SUBROUTINE VPNGT2 ( * * outputs * : X, Y, YERR, NX, X0, XMIN, XMAX, ORDER, TYPE, : NPTS, SCHEME, PROB0, NATTRB, ATTRB, : DETID, APERT, VOLT, GAIN, THRESH, OFILE, STATUS) * * Module number: * * Module name: twodpolyfit * * Keyphrase: * ---------- * Input parameters and data needed for 2D polynomial fitting * * Description: * ------------ * * FORTRAN name: VPNGT2.FOR * * Keywords of accessed files and tables: * -------------------------------------- * Name I/O Description / Comments * * CL parameters: * * 'intable' I input table name * 'outtable' I output table name * 'scheme' I scheme of executing this task * 'threshold' I minimum probability * 'order1' I maximum order of the fitting polynomial * for the first variable (temperature) * 'order2' I maximum order of the fitting polynomial * for the second variable (time) * 'yname' I column name of the dependent variable * in the input table * 'x1name' I column name of the first independent * variable (temperature) in the input table * 'x2name' I column name of the second independent * variable (time) in the input table * 'base_temp' I base temperature * 'base_time' I base epoch * 'nattrib' I number of attributes to be copied to the * output table * 'attribi' I attributes to be copied to the output * table (max i = 5) * * input table column names: * * (yname) I column name of the dependent variable * as passed from YNAME * (x1name) I column name of the first independent * variable (temperature) as passed from X1NAME * (x2name) I column name of the second independent * variable (time) as passed from X2NAME * (attribi) I attributes to be copied to the output * table as passed from 'ATTRIBi' * * Subroutines Called: * ------------------- * CDBS: * CDTIN * SDAS: * UCLGSI, UCLGST, UCLGSD, UTRGTD, UTRGTT, UTRGTI, UTRGTR, UDMGET, * UTTCLO, UMSPUT * Others: * None * * History: * -------- * Version Date Author Description * 1 12-15-88 J.-C. HSU design and coding *------------------------------------------------------------------------------- * *== output: * --pointers of the dependent variable * --array Y and its standard deviation INTEGER Y, YERR, * --pointers of the independent variable * --array X : X, * --dimension of X : NX, * --total number of valid input data points : NPTS, * --order of fittinf polynomial : ORDER(*), * --detector ID : DETID, * --number of attributes : NATTRB, * --error status : STATUS * --high voltage, gain setting, and * --discriminator threshold setting REAL VOLT, GAIN, THRESH, * --minimum probability : PROB0 * --X offsets and extremes DOUBLE PRECISION X0(*), XMIN(1), XMAX(1) * --attribute names CHARACTER*(*) ATTRB(1), * --scheme of executing this task : SCHEME, * --data type : TYPE, * --output file name : OFILE, * --aperture name : APERT * *== local: * --pointer of table descripter and column * --identifier INTEGER TP, COLIDN(20), * --number of rows in the input table : NROWS, * --loop indices, number of input columns : I, J, NCOLS, NC, NQ, * --index of first valid data : INDEX1, * --status : STAT(30), STATOK * --data buffer DOUBLE PRECISION CBUFF(20), : SUM0(2) * --column names CHARACTER*16 COLNAM(20) * --null flag in UTRGTR LOGICAL NULMSK(30) CHARACTER*1 CHAR1 CHARACTER*5 CHAR5 * --input file name CHARACTER*128 IFILE * --error message context CHARACTER*130 CONTXT, MESS *==========================begin iraf77.inc (without INTEGER*2)================= * Include file for the iraf77 FORTRAN interface to the IRAF VOS * Get IRAF common into main program * LOGICAL MEMB(1) INTEGER MEMI(1) INTEGER MEML(1) REAL MEMR(1) DOUBLE PRECISION MEMD(1) COMPLEX MEMX(1) EQUIVALENCE (MEMB, MEMI, MEML, MEMR, MEMD, MEMX) COMMON /MEM/ MEMD * * File I/O access modes * INTEGER RDONLY PARAMETER (RDONLY = 1) INTEGER RDWRIT PARAMETER (RDWRIT = 2) INTEGER WRONLY PARAMETER (WRONLY = 3) INTEGER APPEND PARAMETER (APPEND = 4) INTEGER NEWFIL PARAMETER (NEWFIL = 5) INTEGER TMPFIL PARAMETER (TMPFIL = 6) INTEGER NEWCPY PARAMETER (NEWCPY = 7) INTEGER NEWIMG PARAMETER (NEWIMG = 5) * * codes for data types * INTEGER TYBOOL PARAMETER (TYBOOL = 1) INTEGER TYCHAR PARAMETER (TYCHAR = 2) INTEGER TYSHOR PARAMETER (TYSHOR = 3) INTEGER TYINT PARAMETER (TYINT = 4) INTEGER TYLONG PARAMETER (TYLONG = 5) INTEGER TYREAL PARAMETER (TYREAL = 6) INTEGER TYDOUB PARAMETER (TYDOUB = 7) INTEGER TYCPLX PARAMETER (TYCPLX = 8) INTEGER TYUSHT PARAMETER (TYUSHT = 11) INTEGER TYUBYT PARAMETER (TYUBYT = 12) * * TYTEXT is a special code for the iraf77 interface; it is not in the VOS * INTEGER TYTEXT PARAMETER (TYTEXT = 13) *========================end iraf77.inc========================================= *=========================begin hsp.inc========================================= * --status return code INTEGER OK, ERRNUM(20) * --message destination and priority INTEGER DEST, PRIO DATA OK /0/ DATA ERRNUM /701, 702, 703, 704, 705, 706, 707, 708, 709, 710, : 711, 712, 713, 714, 715, 716, 717, 718, 719, 720/ DATA DEST, PRIO /1, 0/ *=========================end hsp.inc=========================================== *------------------------------------------------------------------------------ * * input parameters in the parameter file: * CALL UCLGST ('intable', IFILE, STAT(1)) CALL UCLGST ('outtable', OFILE, STAT(2)) CALL UCLGST ('scheme', SCHEME, STAT(3)) CALL UCLGSR ('threshold', PROB0, STAT(4)) CALL UCLGSI ('order1', ORDER(1), STAT(5)) CALL UCLGSI ('order2', ORDER(2), STAT(6)) CALL UCLGST ('yname', COLNAM(1), STAT(7)) CALL UCLGST ('yerrname', COLNAM(2), STAT(8)) CALL UCLGST ('x1name', COLNAM(3), STAT(9)) CALL UCLGST ('x2name', COLNAM(4), STAT(10)) CALL UCLGSI ('nattrib', NATTRB, STAT(11)) * NQ = NATTRB + 11 * DO 10 I = 1, NATTRB WRITE (CHAR1, '(I1)') I CALL UCLGST ('attrib'//CHAR1, ATTRB(I), STAT(11+I)) 10 CONTINUE * DO 20 I = 1, NQ IF (STAT(I) .NE. OK) THEN STATUS = ERRNUM(1) CONTXT = 'can not get CL parameter(s)' GO TO 999 END IF 20 CONTINUE * * determine dimension from input orders * IF (ORDER(2) .NE. 0) THEN IF (ORDER(1) .NE. 0) THEN NX = 2 ELSE CONTXT = '1-D case, set order2 = 0, use order1' STATUS = ERRNUM(1) GO TO 999 END IF ELSE NX = 1 END IF * * get temperature and time offsets, if undefined, use mean X vector * CALL UCLGSD ('base_temp', X0(1), STAT(NQ+1)) CALL UCLGSD ('base_time', X0(2), STAT(NQ+2)) * NC = 2 + NX COLNAM(NC+1) = 'TYPE' * DO 30 I = 1, NATTRB COLNAM(NC+1+I) = ATTRB(I) 30 CONTINUE * NCOLS = NC + 1 + NATTRB * * set up input table * CALL CDTIN (IFILE, COLNAM, NCOLS, : TP, COLIDN, NROWS, STATUS) IF (STATUS .NE. OK) THEN CONTXT = 'error setting up input table' GO TO 999 END IF * * allocate dynamic memory for the input data * CALL UDMGET (NROWS, TYDOUB, Y, STAT(1)) CALL UDMGET (NROWS, TYDOUB, YERR, STAT(2)) CALL UDMGET (NX*NROWS, TYDOUB, X, STAT(3)) * DO 40 I = 1, 3 IF (STAT(I) .NE. OK) THEN STATUS = ERRNUM(2) CONTXT = 'cannot allocate dynamic memory' GO TO 999 END IF 40 CONTINUE * * read data from input table * NPTS = 0 DO 100 I = 1, NROWS * CALL UTRGTD (TP, COLIDN, NC, I, CBUFF(1), NULMSK(1), : STAT(1)) * STATOK = ABS(STAT(1) - OK) + OK DO 50 J = 1, NC IF (NULMSK(J)) THEN STATOK = ERRNUM(2) GO TO 60 END IF 50 CONTINUE * * if error in UTRGT_, put an error message and do NOT increment the data array * index * 60 CONTINUE IF (STATOK .NE. OK) THEN WRITE(CHAR5, '(I5)') I CONTXT = 'can not read input table row #' // CHAR5 CALL UMSPUT (CONTXT, DEST, PRIO, STAT(30)) ELSE NPTS = NPTS + 1 IF (NPTS .EQ. 1) THEN INDEX1 = I DO 70 J = 1, NX XMAX(J) = CBUFF(2+J) XMIN(J) = CBUFF(2+J) SUM0(J) = 0.D0 70 CONTINUE END IF * * look for maximum and minimum * DO 80 J = 1, NX XMAX(J) = MAX (XMAX(J), CBUFF(2+J)) XMIN(J) = MIN (XMIN(J), CBUFF(2+J)) 80 CONTINUE * * put data into dynamic memory * MEMD(Y+NPTS-1) = CBUFF(1) MEMD(YERR+NPTS-1) = CBUFF(2) DO 90 J = 1, NX MEMD(X-1+J+NX*(NPTS-1)) = CBUFF(2+J) SUM0(J) = SUM0(J) + CBUFF(2+J) 90 CONTINUE END IF 100 CONTINUE * * if offset of X is undefined, use mean X of all data points * DO 110 J = 1, NX IF (STAT(NQ+J) .NE. 0) THEN X0(J) = SUM0(J) / DBLE(NPTS) END IF 110 CONTINUE * * read attributes * CALL UTRGTT (TP, COLIDN(NC+1), 1, INDEX1, TYPE, : NULMSK(NC+1), STAT(4)) * IF (NATTRB .GT. 0) THEN DO 120 I = 1, NATTRB IF (ATTRB(I) .EQ. 'DETECTOB' .OR. ATTRB(I) .EQ. : 'DET_NUM') THEN CALL UTRGTI (TP, COLIDN(NC+1+I), 1, INDEX1, : DETID, NULMSK(NC+1+I), STAT(4+I)) ELSE IF (ATTRB(I) .EQ. 'APERTOBJ' .OR. ATTRB(I) : .EQ. 'APER_NAME') THEN CALL UTRGTT (TP, COLIDN(NC+1+I), 1, INDEX1, : APERT, NULMSK(NC+1+I), STAT(4+I)) ELSE IF (ATTRB(I) .EQ. 'VOLTAGE') THEN CALL UTRGTR (TP, COLIDN(NC+1+I), 1, INDEX1, : VOLT, NULMSK(NC+1+I), STAT(4+I)) ELSE IF (ATTRB(I) .EQ. 'VGAIND') THEN CALL UTRGTR (TP, COLIDN(NC+1+I), 1, INDEX1, : GAIN, NULMSK(NC+1+I), STAT(4+I)) ELSE IF (ATTRB(I) .EQ. 'THRESH') THEN CALL UTRGTR (TP, COLIDN(NC+1+I), 1, INDEX1, : THRESH, NULMSK(NC+1+I), STAT(4+I)) ELSE STATUS = ERRNUM(3) CONTXT = 'invalid attribute ' // ATTRB(I) GO TO 999 END IF 120 CONTINUE END IF * * close the input table * CALL UTTCLO (TP, STATUS) IF (STATUS .NE. OK) THEN CONTXT = 'cannot close input table' GO TO 999 END IF * IF (NPTS .LE. 0) THEN STATUS = ERRNUM(4) CONTXT = 'no input data been successfully read' GO TO 999 END IF * STATUS = OK GO TO 1000 * * write error message * 999 MESS = 'VPNGT2: ' // CONTXT CALL UMSPUT (MESS, DEST, PRIO, STATOK) * 1000 RETURN END