SUBROUTINE YBASES C C Module Number: 14.3.2 C C Module Name: YBASE C C Keyphrase: C ---------- C determine FOS y-bases C C Description: C ------------ C Using a verticle scan of an FOS entrance aperture, the data for each C y-position is summed giving a table of total counts versus y-position. C The ybase is determined by finding the two aperture edge locations C where the count rate is 1/2 the (maximum + minimum). The y-base is C then computed as the average of these two positions. The centroid C of the aperture profile is also computed for comparison. C C C FORTRAN Name: ybase.for C C C Keywords of Accessed Files : C -------------------------- C input input input template of yscan C ybasetab output output ybase table C profile output output profile table C bintab output output ybases versus diode C aperpos input aperture position (upper or lower). C applicable to paired apertures only C d1 input First diode to use for profile and ybasetab C d2 input Last diode to use C nbins input Number of bins in BINTAB C y1 input Min. y-position to use C y2 input Max. y-position to use C tabstat input YBASETAB table status (write or append) C C Modules Called: C --------------- C CDBS: C ygmode, yxptrn, zlintp, tabinv C SDAS: * uclgs* , umsput * uttinn, utppti, utcdef, utrpt*, utcpt*, uthad*, uttclo, utccre * uttopn, utpgti, utcfnd, utrgt*, utcgt*, uthgt*, uttclo * uimotp, uimxtp, uimctp, uimopn, uimgid, uimclo, uhdgs* uimclo C C History: C -------- C Version Date Author Description C 1 9/15/86 D. Lindler Designed and coded C 2 Apr 88 D. Lindler New sdas I/O and added d1,d2,y1,y2 C parameters C 3 Oct 88 D. Lindler added bintab table C 3.1 May 94 H. Bushouse Added YBASE,YSPACE to YXPTRN C------------------------------------------------------------------------ C C FILE I/O ACCESS MODES C INTEGER RDONLY PARAMETER (RDONLY = 1) INTEGER RDWRIT PARAMETER (RDWRIT = 2) C C CODES FOR DATA TYPES C INTEGER TYINT PARAMETER (TYINT = 4) INTEGER TYREAL PARAMETER (TYREAL = 6) C C UMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87 C INTEGER STDOUT PARAMETER (STDOUT = 1) INTEGER STDERR PARAMETER (STDERR = 2) INTEGER USRLOG PARAMETER (USRLOG = 4) C C THIS SECTION IS FOR PARAMETERS RELEVANT TO TABLE I/O. C C C LENGTH OF ROW (UNIT = SIZE OF REAL) INTEGER TBRLEN PARAMETER (TBRLEN = 1) C NUMBER OF ROWS TO ALLOCATE INTEGER TBALLR PARAMETER (TBALLR = 3) C WHICH TYPE OF TABLE? (ROW OR COLUMN) INTEGER TBWTYP PARAMETER (TBWTYP = 5) C MAXIMUM NUMBER OF COLUMNS INTEGER TBMXCL PARAMETER (TBMXCL = 7) C TYPE = ROW-ORDERED TABLE INTEGER TBTYPR PARAMETER (TBTYPR = 11) C TYPE = COLUMN-ORDERED TABLE INTEGER TBTYPC PARAMETER (TBTYPC = 12) C C THESE MAY BE READ BY UTPGTI BUT MAY NOT BE SET: C C NUMBER OF ROWS WRITTEN TO INTEGER TBNROW PARAMETER (TBNROW = 21) C END IRAF77.INC C C ERROR PROCESSING PARAMETERS C INTEGER STATUS,ISTATS(20),ISTAT C --->ERROR STATUS CHARACTER*130 CONTXT C --->WHAT HAPPENED C C INPUT KEYWORD PARAMETERS C CHARACTER*64 INPUT,TABLE,PROFIL,BINTAB CHARACTER*6 TBSTAT INTEGER D1,D2,Y1,Y2,TWIDTH,NBINS C C INPUT FILE I/O C CHARACTER*64 NAME INTEGER IDTEMP,IDIN,NAXIS,DTYPE,DIMEN(8) DOUBLE PRECISION DATA(5000) C C TABLE VARIABLES C CHARACTER*8 CNAME1(11),CNAME2(2),CUNITS(11),CFORM1(11), * CFORM2(2),CNAME3(4),CFORM3(4) INTEGER COLIDS(11),IDOUT,CTYPE1(11),CTYPE2(2),NROWS, * CTYPE3(4) C C HEADER PARAMETERS C CHARACTER*5 DET,DET1 CHARACTER*3 FGWAID,APERID,FGWA1,APER1 CHARACTER*6 APERPS,APERP1 CHARACTER*1 POLAR INTEGER PASSDR,FCHNL,NCHNL,XSTEPS,OVRSCN,YBASE,YSPACE DOUBLE PRECISION YPOS C C DEFAULTS FOR D1,D2 C CHARACTER*3 GRATS(10) INTEGER D1RED(10),D2RED(10),D1BLUE(10),D2BLUE(10) C C OTHER LOCAL VARIABLES C CHARACTER*3 PAIRS(4) DOUBLE PRECISION Y(200),TOT(200),INDEX(200),BINTOT(200,50) C --->Y-PROFILE DOUBLE PRECISION CENTER,CENTRD,CCOR,EDGES(2) C --->FOUND LOCATIONS DOUBLE PRECISION BCENT(50),BCNTRD(50),BCCOR(50),BEDGES(2), * BINPOS(50) C --->FOUND LOCATIONS FOR BINS INTEGER NS C --->NUMBER OF POINTS IN DATA INTEGER N C --->NUMBER OF Y-POSITIONS PROCESSED INTEGER I1,I2,I,BIN,BIN1,BIN2 DOUBLE PRECISION DI1,DI2,DY1,DY2,DELY,SUM,BSIZE C C DATA INITIALIZATION C DATA PAIRS/'A-2','A-3','A-4','C-1'/ DATA CNAME1/'DETECTOR','FGWA_ID','APER_ID','APER_POS', * 'POLAR_ID','PASS_DIR','DIODE1','DIODE2', * 'CENTER','CROSSCOR','CENTROID'/ DATA CUNITS/11*' '/ DATA CNAME2/'YPOS','TOTAL'/ DATA CTYPE1/-5,-3,-3,-6,-1,TYINT,5*TYREAL/ DATA CTYPE2/2*TYREAL/ DATA CFORM1/5*' ','I9',2*'F9.0',3*'F8.1'/ DATA CFORM2/'F8.1',' '/ DATA CNAME3/'DIODE','CENTER','CROSSCOR','CENTROID'/ DATA CFORM3/4*'F8.2'/ DATA CTYPE3/4*TYREAL/ DATA GRATS/'CAM','H13','H19','H27','H40','H57','H78','L15', * 'L65','PRI'/ C DATA D1BLUE/230,111,1,1,1,1,1,326,291,26/ C DATA D2BLUE/250,4*512,311,512,512,391,147/ C DATA D1RED/260,5*1,101,1,61,366/ C DATA D2RED/280,512,461,4*512,121,216,496/ DATA D1BLUE/229,110,0,0,0,0,0,325,290,25/ DATA D2BLUE/250,4*511,310,511,511,390,146/ DATA D1RED/259,5*0,100,0,60,365/ DATA D2RED/279,511,460,4*511,120,215,495/ C IDTEMP = -1 C----------------------------------------------------------------- CL PARMS C C GET INPUT CL PARAMETERS C CALL UCLGST('input',INPUT,ISTATS(1)) CALL UCLGST('ybasetab',TABLE,ISTATS(2)) CALL UCLGST('profile',PROFIL,ISTATS(3)) CALL UCLGST('bintable',BINTAB,ISTATS(4)) CALL UCLGSI('d1',D1,ISTATS(5)) CALL UCLGSI('d2',D2,ISTATS(6)) CALL UCLGSI('nbins',NBINS,ISTATS(7)) CALL UCLGSI('y1',Y1,ISTATS(8)) CALL UCLGSI('y2',Y2,ISTATS(9)) CALL UCLGSI('twidth',TWIDTH,ISTATS(10)) CALL UCLGST('tabstat',TBSTAT,ISTATS(11)) DO 10 I=1,11 IF(ISTATS(I).NE.0)THEN CONTXT='Error getting CL parameter value' GO TO 999 ENDIF 10 CONTINUE C C LOOP ON INPUT OBSERVATIONS---------------------------------------- INPUT DATA C N=0 C --->NUMBER OF OBSERVATIONS C C OPEN TEMPALTE C CALL UIMOTP(INPUT,IDTEMP,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening input filename template '//INPUT GO TO 999 ENDIF C C GET NEXT FILE NAME C 20 CALL UIMXTP(IDTEMP,NAME,ISTAT) IF(ISTAT.LT.0)GO TO 100 IF(ISTAT.NE.0)THEN CONTXT='Error getting filename from template '//INPUT GO TO 999 ENDIF C C OPEN INPUT FILE C CALL UIMOPN(NAME,RDONLY,IDIN,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening file '//NAME GO TO 999 ENDIF C C READ IMAGE INFO C CALL UIMGID(IDIN,DTYPE,NAXIS,DIMEN,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input file '//NAME GO TO 999 ENDIF C C GET MODE INFORMATION C CALL YGMODE(IDIN,DET,FGWAID,APERID,APERPS,POLAR,PASSDR,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error getting observation mode information' GO TO 999 ENDIF IF(N.EQ.0)THEN DET1=DET FGWA1=FGWAID APER1=APERID APERP1=APERPS C C SET UP DEFAULT D1 AND D2 IF THEY EQAUL ZERO C IF((D1.LT.0).OR.(D2.LT.0))THEN DO 50 I=1,10 IF(FGWAID.EQ.GRATS(I))GO TO 55 50 CONTINUE CONTXT='ERROR: INVALID FGWA_ID' GO TO 999 55 IF(DET.EQ.'AMBER')THEN IF(D1.EQ.-1)D1=D1RED(I) IF(D2.EQ.-1)D2=D2RED(I) ELSE IF(D1.EQ.-1)D1=D1BLUE(I) IF(D2.EQ.-1)D2=D2BLUE(I) ENDIF ENDIF ENDIF IF((DET.NE.DET1).OR.(FGWA1.NE.FGWAID).OR.(APER1.NE.APERID))THEN CONTXT='Error: all obs. must be same det,aperid,'// * ' and fgwa_id' GO TO 999 ENDIF C C GET PATTERN INFORMATION C CALL YXPTRN(IDIN,FCHNL,NCHNL,XSTEPS,OVRSCN,YBASE,YSPACE, * ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error getting x-pattern information' GO TO 999 ENDIF CALL UHDGSD(IDIN,'YPOS',YPOS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error getting YPOS from input header' GO TO 999 ENDIF C C CHECK FOR VALID DATA C IF((NAXIS.NE.1).OR.(DIMEN(1).GT.5000))THEN CONTXT='Input data must be vectors with 5000 or'// * 'fewer points' GO TO 999 ENDIF NS=(NCHNL+OVRSCN-1)*XSTEPS IF(NS.NE.DIMEN(1))THEN CONTXT='ERROR: vector length not equal to '// * '(nchannels+overscan-1)*nxsteps' GO TO 999 ENDIF C C READ DATA C CALL UIGL1D(IDIN,DATA,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input file '//NAME GO TO 999 ENDIF C C CLOSE IMAGE C CALL UIMCLO(IDIN,ISTAT) C C COMPUTE TOTAL BETWEEN D1 AND D2 ----------------------COMPUTE TOTS C I1=(D1-FCHNL)*XSTEPS+1 I2=(D2-FCHNL+OVRSCN-1)*XSTEPS+1 IF(I1.LT.0) I1=0 IF(I2.GT.NS)I2=NS IF(I1.GT.I2)THEN CONTXT='INVALID D1,D2 SPECFICATION' GO TO 999 ENDIF C C ACCUMALATE TOTAL BETWEEN I1 AND I2 C N=N+1 SUM=0.0D0 Y(N)=YPOS DO 90 I=I1,I2 SUM=SUM+DATA(I) 90 CONTINUE TOT(N)=SUM C C ACCUMULATE TOTALS WITHIN THE BINS C DO 95 BIN=1,NBINS BSIZE=(I2-I1-1.0)/NBINS BIN1=(BIN-1)*BSIZE+I1 BIN2=BIN1+BSIZE BINPOS(BIN)=((BIN1+BIN2)/2.0-1)/XSTEPS + FCHNL SUM=0.0 DO 91 I=BIN1,BIN2 91 SUM=SUM+DATA(I) BINTOT(N,BIN)=SUM 95 CONTINUE C C GO GET NEXT IMAGE C GO TO 20 100 CONTINUE C C DONE READING INPUT DATA --------------------------------------COMPUTE YBASES C IF(N.LT.3)THEN CONTXT='Insufficient observations in input template' GO TO 999 ENDIF C C IS IT A PAIRED APERTURE C APERPS='SINGLE' DO 111 I=1,4 IF(APERID.EQ.PAIRS(I))THEN CALL UCLGST('aper_pos',APERPS,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error getting CL parameter APER_POS' GO TO 999 ENDIF ENDIF 111 CONTINUE C C IS IT A POLARIZER MODE C PASSDR=0 IF((POLAR.EQ.'A').OR.(POLAR.EQ.'B'))THEN CALL UCLGSI('pass_dir',PASSDR,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error getting CL parameter PASS_DIR' GO TO 999 ENDIF ENDIF C C FIND TEMPLATE WIDTH IN INDEX UNITS C DELY=(Y(N)-Y(1))/N C --->AVERAGE DELTA Y IF (DELY.EQ.0) THEN CONTXT='Error: all input data is at same y-position' GO TO 999 ENDIF TWIDTH=TWIDTH/DELY + 0.5 IF ((TWIDTH/2)*2 .EQ. TWIDTH) TWIDTH=TWIDTH+1 C --->MAKE IT ODD C C FIND REGION TO USE (BETWEEN Y1 AND Y2) C DY1=Y1 DY2=Y2 CALL TABINV(Y,N,DY1,DI1) CALL TABINV(Y,N,DY2,DI2) I1=DI1+0.5 I2=DI2+0.5 IF(I1.LT.1)I1=1 IF(I2.GT.N)I2=N IF((I2-I1).LT.3)THEN CONTXT='Insufficient observations between y1 and y2' GO TO 999 ENDIF C C FIND CENTER YBASE, CENTROID AND CROSS CORRELATION CENTER C CALL TAEDGE(TOT,I1,I2,EDGES,CENTER,CENTRD,STATUS) CALL TACCOR(TOT,I1,I2,TWIDTH,CCOR,ISTAT) C C CONVERT TO YBASE UNITS C DO 185 I=1,N 185 INDEX(I)=I IF(CENTER.NE.0.0)CALL ZLINTP(INDEX,Y,N,CENTER,CENTER,1,ISTAT) IF(CENTRD.NE.0.0)CALL ZLINTP(INDEX,Y,N,CENTRD,CENTRD,1,ISTAT) IF(CCOR.NE.0.0)CALL ZLINTP(INDEX,Y,N,CCOR,CCOR,1,ISTAT) C C ----------------------------------------------------COMPUTE YBASES FOR BINS C DO 195 BIN=1,NBINS C C FIND CENTER YBASE, CENTROID AND CROSS CORRELATION CENTER C CALL TAEDGE(BINTOT(1,BIN),I1,I2,BEDGES,BCENT(BIN), * BCNTRD(BIN),STATUS) CALL TACCOR(BINTOT(1,BIN),I1,I2,TWIDTH,BCCOR(BIN), * ISTAT) C C CONVERT TO YBASE UNITS C IF(BCENT(BIN).NE.0.0)CALL ZLINTP(INDEX,Y,N, * BCENT(BIN),BCENT(BIN),1,ISTAT) IF(BCNTRD(BIN).NE.0.0)CALL ZLINTP(INDEX,Y,N, * BCNTRD(BIN),BCNTRD(BIN),1,ISTAT) IF(BCCOR(BIN).NE.0.0)CALL ZLINTP(INDEX,Y,N, * BCCOR(BIN),BCCOR(BIN),1,ISTAT) 195 CONTINUE C C WRITE RESULTS --------------------------------------------------YBASE TABLE C C C CREATE OUTPUT OR APPEND TO EXISTING TABLE YBASE TABLE C IF(TBSTAT.NE.'append')THEN C C CREATE NEW TABLE C CALL UTTINN(TABLE,IDOUT,ISTATS(1)) CALL UTPPTI(IDOUT,TBWTYP,TBTYPR,ISTATS(2)) CALL UTPPTI(IDOUT,TBRLEN,15,ISTATS(3)) CALL UTPPTI(IDOUT,TBMXCL,11,ISTATS(4)) CALL UTCDEF(IDOUT,CNAME1,CUNITS,CFORM1,CTYPE1,11, * COLIDS,ISTATS(5)) CALL UTTCRE(IDOUT,ISTATS(6)) DO 200 I=1,6 IF(ISTATS(I).NE.0)THEN CONTXT='Error opening ybase table '//TABLE GO TO 999 ENDIF 200 CONTINUE NROWS=1 ELSE CALL UTTOPN(TABLE,RDWRIT,IDOUT,ISTATS(1)) CALL UTPGTI(IDOUT,TBNROW,NROWS,ISTATS(2)) CALL UTCFND(IDOUT,CNAME1,11,COLIDS,ISTATS(3)) DO 205 I=1,3 IF(ISTATS(I).NE.0)THEN CONTXT='Error reading ybase table '//NAME GO TO 999 ENDIF 205 CONTINUE NROWS=NROWS+1 ENDIF C C COPY RESULTS TO TABLE C CALL UTRPTT(IDOUT,COLIDS(1),1,NROWS,DET,ISTATS(1)) CALL UTRPTT(IDOUT,COLIDS(2),1,NROWS,FGWAID,ISTATS(2)) CALL UTRPTT(IDOUT,COLIDS(3),1,NROWS,APERID,ISTATS(3)) CALL UTRPTT(IDOUT,COLIDS(4),1,NROWS,APERPS,ISTATS(4)) CALL UTRPTT(IDOUT,COLIDS(5),1,NROWS,POLAR,ISTATS(5)) CALL UTRPTI(IDOUT,COLIDS(6),1,NROWS,PASSDR,ISTATS(6)) CALL UTRPTI(IDOUT,COLIDS(7),1,NROWS,D1,ISTATS(7)) CALL UTRPTI(IDOUT,COLIDS(8),1,NROWS,D2,ISTATS(8)) CALL UTRPTD(IDOUT,COLIDS(9),1,NROWS,CENTER,ISTATS(9)) CALL UTRPTD(IDOUT,COLIDS(10),1,NROWS,CCOR,ISTATS(10)) CALL UTRPTD(IDOUT,COLIDS(11),1,NROWS,CENTRD,ISTATS(11)) DO 210 I=1,11 IF(ISTATS(I).NE.0)THEN CONTXT='Error writing to output ybase table' GO TO 999 ENDIF 210 CONTINUE CALL UTTCLO(IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error closing ybase table '//TABLE GO TO 999 ENDIF C---------------------------------------------------------------PROFILE TABLE C OPEN OUTPUT TABLE TO CONTAIN THE Y-PROFILE C CALL UTTINN(PROFIL,IDOUT,ISTATS(1)) CALL UTPPTI(IDOUT,TBWTYP,TBTYPC,ISTATS(2)) CALL UTPPTI(IDOUT,TBALLR,N,ISTATS(3)) CALL UTPPTI(IDOUT,TBMXCL,2,ISTATS(4)) CALL UTCDEF(IDOUT,CNAME2,CUNITS,CFORM2,CTYPE2,2,COLIDS, * ISTATS(5)) CALL UTTCRE(IDOUT,ISTATS(6)) DO 300 I=1,6 IF(ISTATS(I).NE.0)THEN CONTXT='Error creating output table '//PROFIL GO TO 999 ENDIF 300 CONTINUE C C COPY RESULTS TO TABLE C CALL UTCPTD(IDOUT,COLIDS(1),1,N,Y,ISTATS(1)) CALL UTCPTD(IDOUT,COLIDS(2),1,N,TOT,ISTATS(2)) DO 310 I=1,3 IF(ISTATS(I).NE.0)THEN CONTXT='Error writing to output table '//PROFIL GO TO 999 ENDIF 310 CONTINUE CALL UTTCLO(IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error closing output table '//PROFIL GO TO 999 ENDIF C-------------------------------------------------------------------- BINTABLE C C OPEN OUTPUT TABLE C CALL UTTINN(BINTAB,IDOUT,ISTATS(1)) CALL UTCDEF(IDOUT,CNAME3,CUNITS,CFORM3,CTYPE3,4, * COLIDS,ISTATS(2)) CALL UTTCRE(IDOUT,ISTATS(3)) DO 700 I=1,3 IF(ISTATS(I).NE.0)THEN CONTXT='Error creating output bintable' GO TO 999 ENDIF 700 CONTINUE C C COPY RESULTS TO TABLE C CALL UTCPTD(IDOUT,COLIDS(1),1,NBINS,BINPOS,ISTATS(1)) CALL UTCPTD(IDOUT,COLIDS(2),1,NBINS,BCENT,ISTATS(2)) CALL UTCPTD(IDOUT,COLIDS(3),1,NBINS,BCCOR,ISTATS(3)) CALL UTCPTD(IDOUT,COLIDS(4),1,NBINS,BCNTRD,ISTATS(4)) DO 710 I=1,4 IF(ISTATS(I).NE.0)THEN CONTXT='Error writing to output bintable' GO TO 999 ENDIF 710 CONTINUE CALL UTTCLO(IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error closing output bintable ' GO TO 999 ENDIF C C DONE C GO TO 1000 999 CALL UMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT) 1000 IF (IDTEMP .NE. -1) CALL UIMCTP (IDTEMP, ISTAT) RETURN END