SUBROUTINE VPNPT2 ( * * inputs * : OFILE, IORDER, NPTS, NX, MAMAX, TYPE, : COEFF, COVAR, CHISQ, PROB, X0, XMIN, XMAX, : DETID, APERT, VOLT, GAIN, THRESH, : NATTRB, ATTRB, * * outputs * : STATUS) * * Module Number: * * Module Name: twodpolyfit * * Keyphrase: * ---------- * Write the result of the 2D polynomial fit to the output table * * Description: * ------------ * * FORTRAN name: VPNPT2.FOR * * Keywords of accessed files and tables: * -------------------------------------- * Name I/O Description / Comments * * output table column names: * * 'BASE_VALUE' O base value * 'A00', 'A01', ... 'A10', 'A11'... 'A33' * O polynomial coefficients * 'SIGMA00', 'SIGMA01', ... 'SIGMA10', 'SIGMA11'... 'SIGMA33' * O polynomial coefficients' standard deviation * 'C(10,00)', 'C(20,00)',... O covariances * 'CHISQ' O reduced chi squared of the fit * 'PROBABILITY' O chi-square probability * 'BASE_TEMP' O base temperature * 'TEMPMIN' O lower limit of temperature * 'TEMPMAX' O upper limit of temperature * 'BASE_TIME' O base epoch * 'EPOCHMIN' O lower limit of epoch * 'EPOCHMAX' O upper limit of epoch * 'ORDER1', 'ORDER2' O order of the fit * 'NPOINTS' O number of data points * 'TYPE' O data type * (attribi) O attributes copied from the input table * * Subroutines Called: * ------------------- * CDBS: * CDTOUT * SDAS: * UTRPTR, UTRPTI, UTRPTD, UTRPTT, UTTCLO, UMSPUT * Others: * None * * History: * -------- * Version Date Author Description * 1 12-15-88 J.-C. HSU design and coding *------------------------------------------------------------------------------- * *== input: * --output table name CHARACTER*(*) OFILE, * --data type : TYPE, * --attributes : ATTRB(1) * --number of input data points INTEGER NPTS, * --dimension of X : NX, * --maximum size of the covariance matrix : MAMAX, * --order of polynomial fit : IORDER(*), * --detector ID : DETID, * --number of attributes : NATTRB * --minimum and maximum temperature * --and time range DOUBLE PRECISION XMIN(*), XMAX(*), * --base temperature and time : X0(*), * --polynomial coefficients : COEFF(1), * --covariance matrix : COVAR(MAMAX, MAMAX), * --chi-squared of the fit : CHISQ * --high volatge, gain setting, * --discriminator threshold setting REAL VOLT, GAIN, THRESH, * --chi-square probability : PROB * --aperture name CHARACTER*10 APERT * *== output: * --error status INTEGER STATUS * *== local: * --loop index INTEGER I, J, K, L, M, MA, MM, NPUT, : SIZE, NC1, LARGE * --number of existed rows of output * --table PARAMETER (LARGE = 50) PARAMETER (SIZE = (LARGE*(LARGE+1)/2) + LARGE +20) INTEGER NROWS, * --number of columns : NCOLS, NC, NCO, * --pointer to table descripter : TP, * --column identifiers : COLIDN(SIZE), * --data type : DTYPE(SIZE), * --error status : STAT(20), STATOK * --data buffer REAL CBUFF(SIZE) DOUBLE PRECISION CBUFF2(20) CHARACTER*1 CHARJ, CHARK CHARACTER*2 INDX(LARGE) * --column format CHARACTER*8 COLFMT(SIZE) * --output table names CHARACTER*16 CNAME(SIZE), * --column units : UNIT(SIZE) * --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=========================================== *------------------------------------------------------------------------------ * MA = (IORDER(1)+1) * (IORDER(2)+1) * IF (MA .GT. LARGE) THEN STATUS = ERRNUM(1) CONTXT = 'input orders too large' GO TO 999 END IF * * specify column names of the output table * CNAME(1) = 'BASE_VALUE' * DO 20 J = 0, IORDER(2) WRITE (CHARJ, '(I1)') J DO 10 K = 0, IORDER(1) WRITE (CHARK, '(I1)') K I = (IORDER(1)+1) * J + K + 1 * * column names of the polynomial coefficients and their sigmas, in the order * of A00, A10, A20, A30, A01,... * INDX(I) = CHARK // CHARJ CNAME(I+1) = 'A' // INDX(I) CNAME(I+MA+1) = 'SIGMA' // INDX(I) 10 CONTINUE 20 CONTINUE * * specify column names of the covariance coefficients * NC1 = 2 * MA +1 MM = 0 * DO 40 L = 2, MA DO 30 M = 1, L-1 MM = MM + 1 CNAME(NC1+MM) = 'C(' // INDX(L) // ',' // INDX(M) // ')' 30 CONTINUE 40 CONTINUE * NC = (MA * (MA+1) / 2) + MA + 1 CNAME(NC+1) = 'CHISQ' CNAME(NC+2) = 'PROBABILITY' CNAME(NC+3) = 'BASE_TEMP' CNAME(NC+4) = 'TEMPMIN' CNAME(NC+5) = 'TEMPMAX' CNAME(NC+6) = 'BASE_TIME' CNAME(NC+7) = 'EPOCHMIN' CNAME(NC+8) = 'EPOCHMAX' * * define column data type * DO 50 I = 1, NC+5 DTYPE(I) = TYREAL 50 CONTINUE * DO 60 I = NC+6, NC+8 DTYPE(I) = TYDOUB 60 CONTINUE * CNAME(NC+9) = 'ORDER1' CNAME(NC+10) = 'ORDER2' CNAME(NC+11) = 'NPOINTS' CNAME(NC+12) = 'TYPE' DTYPE(NC+9) = TYINT DTYPE(NC+10) = TYINT DTYPE(NC+11) = TYINT DTYPE(NC+12) = -7 * NCO = NC + 12 * * identify attributes * IF (NATTRB .GT. 0) THEN DO 70 I = 1, NATTRB IF (ATTRB(I) .EQ. 'DETECTOB' .OR. ATTRB(I) .EQ. : 'DET_NUM') THEN CNAME(NCO+I) = 'DET_NUM' DTYPE(NCO+I) = TYINT ELSE IF (ATTRB(I) .EQ. 'APERTOBJ' .OR. ATTRB(I) .EQ. : 'APER_NAME') THEN CNAME(NCO+I) = 'APER_NAME' DTYPE(NCO+I) = -10 ELSE IF (ATTRB(I) .EQ. 'VOLTAGE') THEN CNAME(NCO+I) = 'VOLTAGE' DTYPE(NCO+I) = TYREAL ELSE IF (ATTRB(I) .EQ. 'VGAIND') THEN CNAME(NCO+I) = 'VGAIND' DTYPE(NCO+I) = TYREAL ELSE IF (ATTRB(I) .EQ. 'THRESH') THEN CNAME(NCO+I) = 'THRESH' DTYPE(NCO+I) = TYREAL END IF 70 CONTINUE END IF * NCOLS = NCO + NATTRB * DO 80 I = 1, NCOLS UNIT(I) = ' ' COLFMT(I) = ' ' 80 CONTINUE * * specify the content of each column in the output table * CBUFF(1) = 1.0 DO 90 J = 1, MA CBUFF(1+J) = REAL (COEFF(J)) CBUFF(MA+1+J) = REAL (SQRT(COVAR(J, J))) 90 CONTINUE * * specify covariance coefficients * MM = 0 DO 110 L = 2, MA DO 100 M = 1, L-1 MM = MM + 1 CBUFF(NC1+MM) = REAL (COVAR(L, M)) 100 CONTINUE 110 CONTINUE * * other output columns * CBUFF(NC+1) = REAL (CHISQ) CBUFF(NC+2) = PROB CBUFF(NC+3) = REAL (X0(1)) CBUFF(NC+4) = REAL (XMIN(1)) CBUFF(NC+5) = REAL (XMAX(1)) CBUFF2(1) = X0(2) CBUFF2(2) = XMIN(2) CBUFF2(3) = XMAX(2) * * set up the output table * CALL CDTOUT (OFILE, CNAME, UNIT, COLFMT, DTYPE, NCOLS, : TP, COLIDN, NROWS, STATUS) IF (STATUS .NE. OK) THEN CONTXT = 'error setting up output table' GO TO 999 END IF * * write results to the output table * CALL UTRPTR (TP, COLIDN(1), NC+5, NROWS+1, CBUFF, STAT(1)) CALL UTRPTD (TP, COLIDN(NC+6), 3, NROWS+1, CBUFF2, STAT(2)) CALL UTRPTI (TP, COLIDN(NC+9), 1, NROWS+1, IORDER(1), STAT(3)) CALL UTRPTI (TP, COLIDN(NC+10), 1, NROWS+1, IORDER(2), STAT(4)) CALL UTRPTI (TP, COLIDN(NC+11), 1, NROWS+1, NPTS, STAT(5)) CALL UTRPTT (TP, COLIDN(NC+12), 1, NROWS+1, TYPE, STAT(6)) NPUT = 6 * * write attributes to the output table * IF (NATTRB .NE. 0) THEN DO 120 I = 1, NATTRB IF (ATTRB(I) .EQ. 'DETECTOB' .OR. ATTRB(I) .EQ. : 'DET_NUM') THEN CALL UTRPTI (TP, COLIDN(NCO+I), 1, NROWS+1, DETID, : STAT(NPUT+I)) ELSE IF (ATTRB(I) .EQ. 'APERTOBJ' .OR. ATTRB(I) .EQ. : 'APER_NAME') THEN CALL UTRPTT (TP, COLIDN(NCO+I), 1, NROWS+1, APERT, : STAT(NPUT+I)) ELSE IF (ATTRB(I) .EQ. 'VOLTAGE') THEN CALL UTRPTR (TP, COLIDN(NCO+I), 1, NROWS+1, VOLT, : STAT(NPUT+I)) ELSE IF (ATTRB(I) .EQ. 'VGAIND') THEN CALL UTRPTR (TP, COLIDN(NCO+I), 1, NROWS+1, GAIN, : STAT(NPUT+I)) ELSE IF (ATTRB(I) .EQ. 'THRESH') THEN CALL UTRPTR (TP, COLIDN(NCO+I), 1, NROWS+1, THRESH, : STAT(NPUT+I)) END IF 120 CONTINUE END IF * DO 130 I = 1, NPUT+NATTRB IF (STAT(I) .NE. OK) THEN STATUS = ERRNUM(1) CONTXT = 'cannot write a row to output table' GO TO 999 END IF 130 CONTINUE * * close the output table * CALL UTTCLO (TP, STATUS) IF (STATUS .NE. OK) THEN CONTXT = 'cannot close output table' GO TO 999 END IF * STATUS = OK GO TO 1000 * * write error message * 999 MESS = 'VPNPT2: ' // CONTXT CALL UMSPUT (MESS, DEST, PRIO, STATOK) * 1000 RETURN END