SUBROUTINE VAPER1 * * Module number: 15.11.2.1 * * Module name: apercen * * Keyphrase: * ---------- * Aperture location calibration Phase I. * * Description: * ------------ * Look for the center of the target acquisition aperture by using an extended * target and area scans which cover the aperture's field of view. * Maximum number of points on each side of the area scan is 80. * Maximum number of edge points is 300. * * FORTRAN name: VAPER1.FOR * * Keywords of accessed files and tables: * -------------------------------------- * Name I/O Description / Comments * * Subroutines Called: * ------------------- * CDBS: * VAP1GT, VAP1PT, CDMAP, CDENDS, CDEDGE, CDEGPT, CDCIRC * SDAS: * UIMOPN, UIMGID, UDMGET, UIGL1R, UIGL2R, UIMCLO, UDMFRE, UUFACC, UMSPUT * Others: * None * * History: * -------- * Version Date Author Description * 1 01-20-87 J.-C. HSU design and coding * 2 10-20-87 J.-C. HSU F77 SDAS * 3 08-23-90 J.-C. HSU read VHORIZ,...etc from UDL * 4 09-20-90 J.-C. HSU use sort routine cdends *------------------------------------------------------------------------------- * *== local: * --x and y deflection of the starting point INTEGER H0, V0, * --number of columns and rows of the * --area scan : HPT, VPT, * --horizontal and vertical steps per * --point of the are scan : HSTPT, VSTPT, * --number of integration per point : INTPT, * --data file dimension : NAXIS, * --size of each dimension of data : DIMEN(7), * --loop indices : I, J, K, * --file ID : IP, MP, * --data type : DTYPE, * --file pointer : INFID, INMID * --number of input points INTEGER NPTS, * --number of edge points : NEDGE, * --number of points used in determining * --ceiling and floor levels : NTOP, NFLOOR, * --boundary of selected section : XMIN, XMAX, YMIN, YMAX, * --dimension of COUNT, FLAG, X, AND Y : DIMMAX, : EDGMAX, * --maximum number of iterations of least * --square fitting : ITER, * --number of coefficients and variables : NCOEFF, NVAR, * --dimension of the covariance matrix as * --declared in the calling routine : DIM, : LEN, * --error status : STATUS, STATOK, STAT(20) PARAMETER (DIMMAX = 80) PARAMETER (EDGMAX = 300) * --observed (average) number of counts, * --its mean error, its flag and its * --coordinates of each point of the scan REAL COUNT(DIMMAX, DIMMAX), : DCOUNT(DIMMAX, DIMMAX), : FLAG(DIMMAX, DIMMAX), : X(DIMMAX, DIMMAX), Y(DIMMAX, DIMMAX), * --ceiling and floor count level and * --their mean error : TOP, DTOP, FLOOR, DFLOOR, * --edge count level and its mean error : EDGECT, DEDGE, * --edge coordinates and their mean errors : XEDGE(EDGMAX), YEDGE(EDGMAX), : DX(EDGMAX), DY(EDGMAX), * --weighting schemes : SCHEME(2), * --specified fraction applied to the * --coefficient modification : FRAC, * --tolerance of sigma-squared difference : TOLERN, * --mask value of good data points : OKVAL, * --mask value of particle events : HITVAL, * --ratio between count levels of the edge * --and the maximum : LEVEL PARAMETER (OKVAL = 0.0) * --epoch of the observation DOUBLE PRECISION EPOCH, * --fitting coefficients, covariance * --matrix, and chi-squared : COEFF(10), MATRIX(5, 5), CHISQ * --flag of saving circle contour in a table LOGICAL BORDER, : MASK * --observation ID CHARACTER*10 ROOT, * aperture name : APERT * --contour table column names CHARACTER*12 XNAME, YNAME, DXNAME, DYNAME * --input file and mask names, contour * --coordinate table and output table names CHARACTER*128 IFILE, IMASK, CFILE, OFILE * --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) 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/ * --message destination and priority DATA DEST, PRIO /1, 0/ *=========================end hsp.inc=========================================== *------------------------------------------------------------------------------ * * the size of the covariance matrix * DIM = 5 * HITVAL = OKVAL + 1. EPOCH = 0. * XNAME = 'X' YNAME = 'Y' DXNAME = 'DX' DYNAME = 'DY' FRAC = 1. ROOT = ' ' * * input parameters * CALL VAP1GT ( : H0, V0, HPT, VPT, HSTPT, VSTPT, INTPT, : NTOP, NFLOOR, XMIN, XMAX, YMIN, YMAX, : LEVEL, BORDER, SCHEME, ITER, TOLERN, : IFILE, IMASK, CFILE, OFILE, STATUS) * IF (STATUS .NE. OK) THEN GO TO 999 END IF * * check array size * IF (HPT .GT. DIMMAX .OR. VPT .GT. DIMMAX) THEN STATUS = ERRNUM(1) CONTXT = 'oversized 2-D array' GO TO 999 END IF * * open input file, input mask, and get file information of the input file * CALL UIMOPN (IFILE, RDONLY, INFID, STAT(1)) CALL UIMGID (INFID, DTYPE, NAXIS, DIMEN, STAT(2)) STAT(3) = OK CALL UUFACC (IMASK, MASK, STATOK) IF (MASK) THEN CALL UIMOPN (IMASK, RDONLY, INMID, STAT(3)) ELSE CALL UUSLEN (IMASK, LEN) CALL UMSPUT ('mask file '//IMASK(1:LEN)//' does not exist, ' : //'assume all points are good', DEST, PRIO, : STATOK) END IF * DO 10 J = 1, 3 IF (STAT(J) .NE. OK) THEN CONTXT = 'cannot open input file/mask' STATUS = ERRNUM(2) GO TO 999 END IF 10 CONTINUE * * read input file keywords * CALL UHDGST (INFID, 'ROOTNAME', ROOT, STAT(1)) CALL UHDGST (INFID, 'APERTOBJ', APERT, STAT(2)) DO 20 J = 1, 2 IF (STAT(J) .NE. OK) THEN CONTXT = 'cannot read input file keyword(s)' STATUS = ERRNUM(2) GO TO 999 END IF 20 CONTINUE * * determine the number of data points * IF (NAXIS .EQ. 1) THEN NPTS = DIMEN(1) ELSE IF (NAXIS .EQ. 2) THEN NPTS = DIMEN(1) * DIMEN(2) ELSE STATUS = ERRNUM(3) CONTXT = 'illegal dimension (>2)' GO TO 999 END IF * * allocate dynamic memory for input data array and output mask array * CALL UDMGET (NPTS, TYREAL, IP, STAT(1)) CALL UDMGET (NPTS, TYREAL, MP, STAT(2)) * IF (STAT(1) .NE. OK .OR. STAT(2) .NE. OK) THEN STATUS = ERRNUM(4) CONTXT = 'error allocating dynamic memory' GO TO 999 END IF * * read input data and mask to the dynamic memory * DO 30 K = 1, NPTS/DIMEN(1) IF (NAXIS .EQ. 1 .OR. DIMEN(2) .EQ. 1) THEN CALL UIGL1R (INFID, MEMR(IP), STAT(1)) STAT(2) = OK IF (MASK) CALL UIGL1R (INMID, MEMR(MP), STAT(2)) ELSE J = (K - 1) * DIMEN(1) CALL UIGL2R (INFID, K, MEMR(IP+J), STAT(1)) STAT(2) = OK IF (MASK) CALL UIGL2R (INMID, K, MEMR(MP+J), STAT(2)) END IF * IF (STAT(1) .NE. OK .OR. STAT(2) .NE. OK) THEN STATUS = ERRNUM(5) CONTXT = 'error reading data from input file/mask' GO TO 999 END IF 30 CONTINUE * * if there is no input mask file, assume all points are ok * IF (.NOT. MASK) THEN DO 40 K = 1, NPTS MEMR(MP+K-1) = OKVAL 40 CONTINUE END IF * * if range spec are both zero, full range is assumed * IF (XMIN .EQ. 0 .AND. XMAX .EQ. 0) THEN XMIN = 1 XMAX = DIMEN(1) END IF IF (YMIN .EQ. 0 .AND. YMAX .EQ. 0) THEN YMIN = 1 YMAX = DIMEN(2) END IF * * mask out the section which is excluded * IF (NAXIS .EQ. 1 .OR. DIMEN(2) .EQ. 1) THEN YMIN = 1 YMAX = 1 END IF * DO 44 K = 1, NPTS/DIMEN(1) J = (K - 1) * DIMEN(1) DO 42 I = 1, DIMEN(1) IF (K .LT. YMIN .OR. K .GT. YMAX .OR. I .LT. XMIN .OR. : I .GT. XMAX) MEMR(MP+J+I-1) = HITVAL 42 CONTINUE 44 CONTINUE * * find the ceiling and floor count level * CALL CDENDS (MEMR(IP), MEMR(MP), NPTS, NTOP, NFLOOR, TOP, : FLOOR, DTOP, DFLOOR) * * find out the coordinate of each point of the area scan * CALL CDMAP (NPTS, DIMMAX, MEMR(IP), MEMR(MP), : OKVAL, HITVAL, H0, V0, HPT, VPT, : HSTPT, VSTPT, INTPT, : COUNT, DCOUNT, FLAG, X, Y, STATUS) * IF (STATUS .NE. OK) THEN GO TO 999 END IF * * specify the circle edge level * EDGECT = FLOOR + (TOP - FLOOR) * LEVEL DEDGE = SQRT(((1.-LEVEL)*DFLOOR)**2 + (LEVEL*DTOP)**2) * * locate edge points * CALL CDEDGE (EDGECT, DEDGE, COUNT, DCOUNT, FLAG, X, Y, : OKVAL, HITVAL, DIMMAX, HPT, VPT, : XEDGE, YEDGE, DX, DY, NEDGE, STATUS) * IF (STATUS .NE. OK) THEN GO TO 999 END IF * * check array size * IF (NEDGE .GT. EDGMAX) THEN STATUS = ERRNUM(6) CONTXT = 'oversized edge array' GO TO 999 END IF * * write the edge point coordinates to a table * IF (BORDER) THEN CALL CDEGPT (XEDGE, YEDGE, DX, DY, NEDGE, CFILE, : XNAME, YNAME, DXNAME, DYNAME, STATUS) * IF (STATUS .NE. OK) THEN GO TO 999 END IF END IF * * fit a circle to the contour points * CALL CDCIRC (XEDGE, YEDGE, DX, DY, NEDGE, SCHEME, FRAC, DIM, : ITER, TOLERN, : NCOEFF, NVAR, COEFF, MATRIX, CHISQ, STATUS) IF (STATUS .NE. OK) THEN GO TO 999 END IF * * close input file/mask and free dynamic memory * CALL UIMCLO (INFID, STAT(1)) STAT(2) = OK IF (MASK) CALL UIMCLO (INMID, STAT(2)) * CALL UDMFRE (IP, TYREAL, STAT(3)) CALL UDMFRE (MP, TYREAL, STAT(4)) * DO 50 I = 1, 4 IF (STAT(I) .NE. OK) THEN CONTXT = 'cannot close input file/mask or release ' : // 'dynamic memory' GO TO 999 END IF 50 CONTINUE * * write results to output table * CALL VAP1PT (OFILE, ROOT, APERT, COEFF, MATRIX, CHISQ, : NCOEFF, NVAR, DIM, EDGECT, TOP, FLOOR, NEDGE, : XMIN, XMAX, YMIN, YMAX, SCHEME, TOLERN, : ITER, STATUS) IF (STATUS .NE. OK) THEN GO TO 999 END IF * STATUS = OK GO TO 1000 * * write error message * 999 MESS = 'VAPER1: (' // ROOT // ') ' // CONTXT CALL UMSPUT (MESS, DEST, PRIO, STATOK) * 1000 RETURN END