SUBROUTINE VPHAGT ( * * outputs * : X, Y, YERR, TEMP, EPOCH, NPTS, : WTFLAG, ITER, TOLERN, FRAC, : HIVOLT, DETID, TARGET, SCHEME, : OFILE, STATUS) * * Module number: 15.3.1.1 * * Module name: phav * * Keyphrase: * ---------- * Input parameters and data needed for VPHA * * Description: * ------------ * * FORTRAN name: VPHAGT.FOR * * Keywords of accessed files and tables: * -------------------------------------- * Name I/O Description / Comments * * CL parameters: * * 'intable' I SDAS table containing input data * 'outtable' I SDAS table containing result * 'scheme' I scheme of determining the optimum * threshold setting * 'weight' I weighting scheme of count rate * 'dcountname' I column name of the digital count rate * 'dcounterrname' I column name of the standard deviation * of digital count rate * 'itermax' I maximum number of iterations * 'tolerance' I tolerance of sigma-squared difference * during least square iterations * 'fraction' I specified fraction applied to the * coefficients modification * * input table column names: * * (dcountname) I digital count rate as passed from dcountname * (dcounterrname) I standard deviation of digital count rate * as passed from dcounterrname * 'VOLTAGE' I high voltage setting * 'THRESH' I discriminator threshold setting * 'DET_TEMP' I detector temperature * 'DETECTOB' I object detector * 'TRGTNAME' I target name * 'EPOCH' I epoch * * Subroutines Called: * ------------------- * CDBS: * CDTIN * SDAS: * UCLGSR, UCLGST, UTRGTR, UTRGTD, UTRGTT, UTTCLO, UMSPUT * Others: * None * * History: * -------- * Version Date Author Description * 1 11-15-85 J.-C. HSU design and coding * 2 09-20-87 J.-C. HSU F77 standard * *------------------------------------------------------------------------------- * *== output: * --temperature of each observation REAL TEMP(1), * --weighting scheme : WTFLAG(*), * --tolerance of sigma-squared differnce * --during least square iterations : TOLERN, * --specified fraction applied to * --coefficients modification : FRAC, * --high voltage setting : HIVOLT * --Y quantity (digital count rate) and * --its standard deviation DOUBLE PRECISION Y(1), YERR(1), * --X quantity (threshold setting) : X(1), * --epoch : EPOCH(1) * --output file name CHARACTER*(*) OFILE, * --target name : TARGET, * --scheme of determining best threshold * --setting : SCHEME * --total number of valid input data points INTEGER NPTS, * --maximum number of least square iteration : ITER, * --detector ID : DETID, * --error status : STATUS * *== local: * --number of input data points INTEGER NROWS, * --pointer of table descripter and column * --identifier : TP, COLIDN(20), * --loop indices, number of input columns : I, J, NCOLS, * --detector ID : DET, * --status : STAT(20), STATOK * --data buffer REAL COLBUF(20) * --null flag in UTRGTR LOGICAL NULMSK(30) CHARACTER*5 CHAR5 * --column names CHARACTER*16 COLNAM(20) * --target name CHARACTER*20 TRGT * --input file name CHARACTER*128 IFILE * --error message context CHARACTER*130 CONTXT *=========================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: * input and output table names, scheme of determining best threshold setting, * maximum iteration of least square, tolerance of the least square fitting, * farction of coefficients correction, weighting scheme, column names of * digital count rate and its standard deviation * CALL UCLGST ('intable', IFILE, STAT(1)) CALL UCLGST ('outtable', OFILE, STAT(2)) CALL UCLGST ('scheme', SCHEME, STAT(3)) CALL UCLGSR ('weight', WTFLAG(2), STAT(4)) CALL UCLGSI ('itermax', ITER, STAT(5)) CALL UCLGSR ('tolerance', TOLERN, STAT(6)) CALL UCLGSR ('fraction', FRAC, STAT(7)) CALL UCLGST ('dcountname', COLNAM(1), STAT(8)) CALL UCLGST ('dcounterrname', COLNAM(2), STAT(9)) * DO 10 I = 1, 9 IF (STAT(I) .NE. OK) THEN STATUS = ERRNUM(1) CONTXT = 'can not get CL parameter(s)' GO TO 999 END IF 10 CONTINUE * * define the rest of input table column names * WTFLAG(1) = -1000. * COLNAM(3) = 'THRESH' COLNAM(4) = 'DET_TEMP' COLNAM(5) = 'VOLTAGE' COLNAM(6) = 'DETECTOB' COLNAM(7) = 'TRGTNAME' COLNAM(8) = 'EPOCH' NCOLS = 8 * 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 * NPTS = 0 DO 40 I = 1, NROWS CALL UTRGTR (TP, COLIDN, 5, I, : COLBUF, NULMSK, STAT(1)) CALL UTRGTI (TP, COLIDN(6), 1, I, : DET, NULMSK(6), STAT(2)) CALL UTRGTT (TP, COLIDN(7), 1, I, : TRGT, NULMSK(7), STAT(3)) CALL UTRGTD (TP, COLIDN(8), 1, I, : EPOCH(I), NULMSK(8), STAT(4)) * STATOK = ABS(STAT(1) - OK) + ABS(STAT(2) - OK) + : ABS(STAT(3) - OK) + ABS(STAT(4) - OK) + OK DO 20 J = 1, NCOLS IF (NULMSK(J)) THEN STATOK = ERRNUM(2) GO TO 30 END IF 20 CONTINUE * * if error in UTRGTR, put an error message and do NOT increment the data array * index * 30 WRITE(CHAR5, '(I5)') I IF (STATOK .NE. OK) THEN CONTXT = 'can not read input table row #' // CHAR5 CALL UMSPUT (CONTXT, DEST, PRIO, STATOK) ELSE NPTS = NPTS + 1 X(NPTS) = DBLE(COLBUF(3)) Y(NPTS) = DBLE(COLBUF(1)) YERR(NPTS) = DBLE(COLBUF(2)) TEMP(NPTS) = COLBUF(4) EPOCH(NPTS) = EPOCH(I) IF (NPTS .EQ. 1) THEN DETID = DET TARGET = TRGT HIVOLT = COLBUF(5) END IF * * check attributes, skip the data if they are different from the first data point * IF (DET .NE. DETID .OR. COLBUF(5) .NE. HIVOLT .OR. : TRGT .NE. TARGET) THEN CONTXT = 'different attribute(s) in row #' // CHAR5 CALL UMSPUT (CONTXT, DEST, PRIO, STATOK) NPTS = NPTS - 1 END IF END IF 40 CONTINUE * * close 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(3) CONTXT = 'no input data been successfully read' GO TO 999 END IF * STATUS = OK GO TO 1000 * * write error message * 999 CALL UMSPUT ('VPHAGT: ' // CONTXT, DEST, PRIO, STATOK) * 1000 RETURN END