SUBROUTINE VFLXPT ( * * inputs * : OFILE, ORDER, NPTS, WFLAG, : COEFFA, CHISQA, COEFFB, CHISQB, : C1, C2, X0, Y0, X0NAME, Y0NAME, APERT, : T1MIN, T1MAX, T2MIN, T2MAX, T1NAME, T2NAME, : EPMIN, EPMAX, * * outputs * : STATUS) * * Module Number: * * Module Name: flex * * Keyphrase: * ---------- * Write the result of VFLEX to output table * * Description: * ------------ * * FORTRAN name: VFLXPT.FOR * * Keywords of accessed files and tables: * -------------------------------------- * Name I/O Description / Comments * * output table column names: * * 'C1, C2' O temperature parameters * 'A0', 'A1', 'A2', 'A3'... * 'B0', 'B1', 'B2', 'B3'... O polynomial coefficients * 'CHISQA' O chi squared of the fit for A coefficients * 'CHISQB' O chi squared of the fit for B coefficients * 'WEIGHT' O weight scheme * 'T1MIN', 'T1MAX' O lower and upper limits of T1 * 'T2MIN', 'T2MAX' O lower and upper limits of T2 * (x0name) O nominal X deflection * (y0name) O nominal Y deflection * 'EPOCHMIN' O lower limit of epoch * 'EPOCHMAX' O upper limit of epoch * 'ORDER' O order of the fit * 'NPOINTS' O number of data points * 'APER_NAME' O aperture name * 'T1NAME' O column name of T1 in input table * 'T2NAME' O column name of T2 in input table * * Subroutines Called: * ------------------- * CDBS: * CDTOUT * SDAS: * UTRPTR, UTRPTI, UTRPTD, UTRPTT, UTTCLO, UMSPUT * Others: * None * * History: * -------- * Version Date Author Description * 1 10-01-88 J.-C. HSU design and coding * *------------------------------------------------------------------------------- * *== input: * --VMS file name of 'OUTTABLE' CHARACTER*(*) OFILE, * --column names of T1 nd T2 : T1NAME, T2NAME, * --column names of X0 and Y0 : X0NAME, Y0NAME * --weighting scheme REAL WFLAG, * --temperature parameters : C1, C2, * --minimum and maximum of T1 and T2 : T1MIN, T1MAX, T2MIN, T2MAX, * --nominal deflection values : X0, Y0 * --minimum, maximum epoch DOUBLE PRECISION EPMIN, EPMAX, * --polynomial coefficients : COEFFA(0:1), COEFFB(0:1), * --chi-squared : CHISQA, CHISQB * --number of input data points INTEGER NPTS, * --order of polynomial fit : ORDER * --aperture name CHARACTER*10 APERT * *== output: * --error status INTEGER STATUS * *== local: * --loop index INTEGER I, NPUT, * --number of existed rows of output * --SDAS table : NROWS, * --number of columns : NCOLS, NC, * --pointer to table descripter : TP, * --column identifiers : COLIDN(100), * --data type : DTYPE(100), * --error status : STAT(20), STATOK * --data buffer REAL CBUFF(100) DOUBLE PRECISION CBUFF2(20) CHARACTER*1 CHAR1 * --column format CHARACTER*8 COLFMT(100) * --output SDAS table names CHARACTER*16 CNAME(100), * --column units : UNIT(100) * --error message context CHARACTER*130 CONTXT *==========================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=========================================== *------------------------------------------------------------------------------ * * specify column names * CNAME(1) = 'C1' CNAME(2) = 'C2' DO 10 I = 1, ORDER+1 WRITE (CHAR1, '(I1)') I-1 CNAME(I+2) = 'A' // CHAR1 CNAME(ORDER+3+I) = 'B' // CHAR1 10 CONTINUE * NC = 2 * (ORDER + 1) + 2 * CNAME(NC+1) = 'CHISQA' CNAME(NC+2) = 'CHISQB' CNAME(NC+3) = 'WEIGHT' CNAME(NC+4) = 'T1MIN' CNAME(NC+5) = 'T1MAX' CNAME(NC+6) = 'T2MIN' CNAME(NC+7) = 'T2MAX' CNAME(NC+8) = X0NAME CNAME(NC+9) = Y0NAME CNAME(NC+10) = 'EPOCHMIN' CNAME(NC+11) = 'EPOCHMAX' * CNAME(NC+12) = 'ORDER' CNAME(NC+13) = 'NPOINTS' CNAME(NC+14) = 'APER_NAME' CNAME(NC+15) = 'T1NAME' CNAME(NC+16) = 'T2NAME' * NCOLS = NC + 16 * * column data type * DO 20 I = 1, NC+9 DTYPE(I) = TYREAL 20 CONTINUE * DO 30 I = NC+10, NC+11 DTYPE(I) = TYDOUB 30 CONTINUE DTYPE(NC+12) = TYINT DTYPE(NC+13) = TYINT DTYPE(NC+14) = -10 DTYPE(NC+15) = -16 DTYPE(NC+16) = -16 * DO 40 I = 1, NCOLS UNIT(I) = ' ' COLFMT(I) = ' ' 40 CONTINUE * * specify buffer contents * CBUFF(1) = C1 CBUFF(2) = C2 * DO 50 I = 1, ORDER+1 CBUFF(I+2) = SNGL(COEFFA(I-1)) CBUFF(ORDER+3+I) = SNGL(COEFFB(I-1)) 50 CONTINUE * CBUFF(NC+1) = SNGL(CHISQA) CBUFF(NC+2) = SNGL(CHISQB) CBUFF(NC+3) = WFLAG CBUFF(NC+4) = T1MIN CBUFF(NC+5) = T1MAX CBUFF(NC+6) = T2MIN CBUFF(NC+7) = T2MAX CBUFF(NC+8) = X0 CBUFF(NC+9) = Y0 CBUFF2(1) = EPMIN CBUFF2(2) = EPMAX * * set up 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+9, NROWS+1, CBUFF, STAT(1)) CALL UTRPTD (TP, COLIDN(NC+10), 2, NROWS+1, CBUFF2, STAT(2)) CALL UTRPTI (TP, COLIDN(NC+12), 1, NROWS+1, ORDER, STAT(3)) CALL UTRPTI (TP, COLIDN(NC+13), 1, NROWS+1, NPTS, STAT(4)) CALL UTRPTT (TP, COLIDN(NC+14), 1, NROWS+1, APERT, STAT(5)) CALL UTRPTT (TP, COLIDN(NC+15), 1, NROWS+1, T1NAME, STAT(6)) CALL UTRPTT (TP, COLIDN(NC+16), 1, NROWS+1, T2NAME, STAT(7)) NPUT = 7 * DO 60 I = 1, NPUT IF (STAT(I) .NE. OK) THEN STATUS = ERRNUM(1) CONTXT = 'cannot write a row to output table' GO TO 999 END IF 60 CONTINUE * 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 CALL UMSPUT ('VFLXPT: ' // CONTXT, DEST, PRIO, STATOK) * 1000 RETURN END