SUBROUTINE ZMERG * * Module Number: 13.10.1 * * Module Name: zmerg * * Keyphrase: * ---------- * Merge HRS spectra for absolute sensitivity computation * * Description: * ------------ * Data from different carrousel postions of the same grating mode and * star are merged into equally spaced wavelength intervals. The merged * data can then be input to the zratio routine for computation of the * absolute sensitivity function. * * Fortran Name: zmerg.for * * Keywords of accessed files and tables: * -------------------------------------- * * INPUT input Corrected counts file names * WAVE input wavelength file names * MASK input mask file names * D1 input first diode (main array) to sum * D2 input last diode on main array to sum * TABLE input/output Name of output table * DELW Input Wavelength spacing for output * * Subroutines Called: * ------------------- * CBDS: * ZMERG1, ZMERG2 * SDAS: C uclgs* , umsput C uttinn, utppti, utcdef, utrpt*, utcpt*, uthad*, uttclo, utccre C uimotp, uimxtp, uimctp, uimopn, uimgid, uimclo, uhdgs* uimclo C * * History: * -------- * version date Author Description * 1 02-25-87 D. Lindler Designed and coded * 2 Dec 87 D. Lindler New SDAS I/O and standards * Jan 91 S. Hulbert Get aperture from binid(1) * Dec 91 S. Hulbert Check for input files before * beginning processing * 3 Jan 92 S. Hulbert Modify to use new header * keywords *-------------------------------------------------------------------------- * C INCLUDE FILE FOR THE IRAF77 FORTRAN INTERFACE TO THE IRAF VOS C C C FILE I/O ACCESS MODES C INTEGER RDONLY PARAMETER (RDONLY = 1) INTEGER RDWRIT PARAMETER (RDWRIT = 2) INTEGER WRONLY PARAMETER (WRONLY = 3) INTEGER APPEND PARAMETER (APPEND = 4) C C CODES FOR DATA TYPES C INTEGER TYBOOL PARAMETER (TYBOOL = 1) INTEGER TYCHAR PARAMETER (TYCHAR = 2) INTEGER TYINT PARAMETER (TYINT = 4) INTEGER TYREAL PARAMETER (TYREAL = 6) INTEGER TYDOUB PARAMETER (TYDOUB = 7) C C UMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87 C INTEGER STDOUT PARAMETER (STDOUT = 1) INTEGER STDERR PARAMETER (STDERR = 2) C C UHDAS HEADER PARM TYPES -- CB, DAO, 5-SEP-87 C INTEGER GENHDR PARAMETER (GENHDR = 0) INTEGER IMSPEC PARAMETER (IMSPEC = 1) C C THIS SECTION IS FOR PARAMETERS RELEVANT TO TABLE I/O. C C THESE MAY BE SET BY UTPPTI AND/OR READ BY UTPGTI: C C LENGTH OF ROW (UNIT = SIZE OF REAL) INTEGER TBRLEN PARAMETER (TBRLEN = 1) C INCREASE ROW LENGTH INTEGER TBIRLN PARAMETER (TBIRLN = 2) C NUMBER OF ROWS TO ALLOCATE INTEGER TBALLR PARAMETER (TBALLR = 3) C INCREASE ALLOC NUM OF ROWS INTEGER TBIALR PARAMETER (TBIALR = 4) C WHICH TYPE OF TABLE? (ROW OR COLUMN) INTEGER TBWTYP PARAMETER (TBWTYP = 5) C MAXIMUM NUMBER OF USER PARAMETERS INTEGER TBMXPR PARAMETER (TBMXPR = 6) 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 C END IRAF77.INC C C ERROR PROCESSING PARAMETERS C INTEGER STATUS,ISTAT,ISTATS(10) CHARACTER*130 CONTXT C C INPUT FILE I/O C CHARACTER*130 INPUT,WAVET,MASKT C --->TEMPLATES CHARACTER*64 NAME,WNAME,MNAME C --->FILE NAMES INTEGER IDTEMP,IDTMP2,IDTMP3 C --->TEMPLATE IDS INTEGER IDIN,IDIN2,IDIN3 C --->FILE IDS INTEGER NAXIS,DTYPE,DIMEN(8),NS C --->DATA DESCRIPTIONS DOUBLE PRECISION DATA(2000),WAVE(2000),MASK(2000) C --->DATA BUFFERS C C TABLE PARAMETERS C CHARACTER*64 TABLE CHARACTER*8 COLNAM(4),CUNITS(4),CFORM(4) INTEGER COLIDS(4),IDOUT,CTYPE(4) C C INTERNAL WORK SPACE FOR BINNING MERGED DATA C INTEGER NADDS(5000) DOUBLE PRECISION TOTAL(5000),WAVEL(5000) C C WAVELENGTH RANGES FOR EACH GRATING C CHARACTER*5 GMODES(7) DOUBLE PRECISION WMIN(7),WMAX(7),WFIRST,WLAST C C OTHER LOCAL VARIABLES C INTEGER I,NBINS,NOUT, BINID CHARACTER*5 GRAT1,GRAT C --->GRATING MODE CHARACTER*3 APER,APER1 LOGICAL FIRST C --->FIRST FILE FLAG DOUBLE PRECISION DELW C C DATA DECLARATIONS C DATA COLNAM/'WLOW','WHIGH','FLUX','NPOINTS'/ DATA CUNITS/4*' '/ DATA CFORM/4*' '/ DATA CTYPE/3*TYDOUB,TYINT/ DATA GMODES/'G140M','G160M','G200M','G270M','G140L', $ 'ECH-A','ECH-B'/ DATA WMIN/1000.0,1000.0,1300.0,1800.0,1000.0,1000.0,1600.0/ DATA WMAX/2400.0,2400.0,2700.0,3500.0,2400.0,2400.0,3500.0/ C C---------------------------------------------------------------------------- C C INITIALIZATION C FIRST=.TRUE. DO 1 I=1,2000 MASK(I)=1.0D0 1 CONTINUE C C GET KEYWORD PARAMETERS C CALL UCLGST('input',INPUT,ISTATS(1)) CALL UCLGST('wave',WAVET,ISTATS(2)) CALL UCLGST('mask',MASKT,ISTATS(3)) CALL UCLGST('table',TABLE,ISTATS(4)) CALL UCLGSD('delw',DELW,ISTATS(5)) DO 10 I=1,5 IF(ISTATS(I).NE.0)THEN CONTXT='Error getting CL parameter' GO TO 999 ENDIF 10 CONTINUE C C OPEN TEMPLATES C CALL UIMOTP(INPUT,IDTEMP,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening input filename template '//INPUT GO TO 999 ENDIF CALL UIMOTP(WAVET,IDTMP2,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening wavelength file template '//WAVET GO TO 999 ENDIF IF(MASKT.NE.' ')THEN CALL UIMOTP(MASKT,IDTMP3,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening mask file template '//MASKT GO TO 999 ENDIF ELSE ENDIF C C GET NEXT FILE NAME AND OPEN FILE C 20 CALL UIMXTP(IDTEMP,NAME,ISTAT) IF(ISTAT.LT.0.AND..NOT.FIRST)GO TO 100 IF(ISTAT.NE.0)THEN CONTXT='Error getting filename from template '//INPUT GO TO 999 ENDIF CALL UIMOPN(NAME,RDONLY,IDIN,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening input file '//NAME GO TO 999 ENDIF C C GET NEXT WAVELENGTH FILE NAME AND OPEN C CALL UIMXTP(IDTMP2,WNAME,ISTAT) IF(ISTAT.LT.0)THEN CONTXT='Insufficent wavelength files specified' GO TO 999 ENDIF IF(ISTAT.NE.0)THEN CONTXT='Error getting filename from template '//WAVET GO TO 999 ENDIF CALL UIMOPN(WNAME,RDONLY,IDIN2,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening wavelength file '//WNAME GO TO 999 ENDIF C C GET NEXT MASK FILE NAME AND OPEN C IF(MASKT.NE.' ')THEN CALL UIMXTP(IDTMP3,MNAME,ISTAT) IF(ISTAT.LT.0)THEN CONTXT='Insufficient Mask files supplied' GO TO 999 ENDIF IF(ISTAT.NE.0)THEN CONTXT='Error getting filename from template '//MASKT GO TO 999 ENDIF CALL UIMOPN(MNAME,RDONLY,IDIN3,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error opening mask file '//MNAME GO TO 999 ENDIF 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 CHECK FOR VALID DATA C IF((NAXIS.NE.1).OR.(DIMEN(1).GT.2000))THEN CONTXT='Input data must vector with max of 2000 points' GO TO 999 ENDIF NS=DIMEN(1) C C READ WAVELEGNTH FILE INFO C CALL UIMGID(IDIN2,DTYPE,NAXIS,DIMEN,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading wavelength file '//WNAME GO TO 999 ENDIF C C CHECK FOR VALID DATA C IF((NAXIS.NE.1).OR.(DIMEN(1).NE.NS))THEN CONTXT='Wavelength vector '//WNAME// * ' must match input file-'//NAME GO TO 999 ENDIF C C READ MASK FILE INFO C IF(MASKT.NE.' ')THEN CALL UIMGID(IDIN3,DTYPE,NAXIS,DIMEN,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading mask file '//MNAME GO TO 999 ENDIF C C CHECK FOR VALID DATA C IF((NAXIS.NE.1).OR.(DIMEN(1).NE.NS))THEN CONTXT='Mask vector '//MNAME// * ' must match input file- '//NAME GO TO 999 ENDIF 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 CALL UIGL1D(IDIN2,WAVE,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input file '//WNAME GO TO 999 ENDIF IF(MASKT.NE.' ')THEN CALL UIGL1D(IDIN3,MASK,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading input file '//MNAME GO TO 999 ENDIF ENDIF C C GET KEYWORD PARAMETERS FROM DATA C CALL UHDGST(IDIN,'GRATING',GRAT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error getting GRATING from '//NAME GO TO 999 ENDIF CALL UHDGST(IDIN,'APERTURE',APER,ISTAT) IF(ISTAT.NE.0)THEN CALL UHDGSI(IDIN,'BINID1',BINID,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error determining aperture from '//NAME GO TO 999 ENDIF IF (BINID .EQ. 1) THEN APER = 'LSA' ELSE IF (BINID .EQ. 2) THEN APER = 'SSA' ELSE CONTXT='Error determining aperture from '//NAME GO TO 999 ENDIF ENDIF C C VERIFY GRATING MODE CONSISTENCY C IF(FIRST)THEN GRAT1=GRAT APER1=APER C C DETERMINE WAVELENGTH RANGE FOR GRATING C WFIRST=0.0 DO 101 I=1,7 IF(GMODES(I).EQ.GRAT1)THEN WFIRST=WMIN(I) WLAST=WMAX(I) ENDIF 101 CONTINUE IF(WFIRST.EQ. 0.0)THEN CONTXT='INVALID GRATING MODE IN FILE '//NAME GO TO 999 ENDIF C C COMPUTE NUMBER OF BINS C NBINS=(WLAST-WFIRST)/DELW C C C INITIALIZE BINNED FLUX VECTOR AND NUMBER OF ADDS TO FLUX VECTOR C DO 120 I=1,NBINS NADDS(I)=0 TOTAL(I)=0.0 120 CONTINUE FIRST=.FALSE. ENDIF IF((GRAT.NE.GRAT1).OR.(APER.NE.APER1))THEN CONTXT='All observations not for same grating/aperture' * //' mode' GO TO 999 ENDIF C C CLOSE IMAGES C CALL UIMCLO(IDIN,ISTAT) CALL UIMCLO(IDIN2,ISTAT) IF(MASKT.NE.' ')CALL UIMCLO(IDIN3,ISTAT) C C PLACE MASKED DATA INTO BINS C CALL ZMERG1(DATA,WAVE,MASK,NS, * TOTAL,NADDS,NBINS,WFIRST,DELW,STATUS) IF(STATUS.NE.0)THEN CONTXT='ERROR BINNING DATA' GO TO 999 ENDIF C C GO GET NEXT IMAGE C GO TO 20 100 CONTINUE C C DONE READING INPUT DATA ------------------------------------------------ C C COMPUTE AVERAGES AND DELETE POINTS WITH NO ADDS C NOUT=0 DO 600 I=1,NBINS IF(NADDS(I).GT.0)THEN NOUT=NOUT+1 NADDS(NOUT)=NADDS(I) TOTAL(NOUT)=TOTAL(I)/NADDS(I) WAVEL(NOUT)=WFIRST+I*DELW ENDIF 600 CONTINUE C C CREATE OUTPUT TABLE C CALL UTTINN(TABLE,IDOUT,ISTATS(1)) CALL UTPPTI(IDOUT,TBWTYP,TBTYPC,ISTATS(2)) CALL UTPPTI(IDOUT,TBALLR,NOUT,ISTATS(3)) CALL UTPPTI(IDOUT,TBMXCL,4,ISTATS(4)) CALL UTCDEF(IDOUT,COLNAM,CUNITS,CFORM,CTYPE,4, * COLIDS,ISTATS(5)) CALL UTTCRE(IDOUT,ISTATS(6)) DO 200 I=1,6 IF(ISTATS(I).NE.0)THEN CONTXT='Error creating output table '//TABLE GO TO 999 ENDIF 200 CONTINUE C C COPY RESULTS TO TABLE C CALL UTCPTD(IDOUT,COLIDS(1),1,NOUT,WAVEL,ISTATS(1)) DO 230 I=1,NOUT 230 WAVEL(I)=WAVEL(I)+DELW CALL UTCPTD(IDOUT,COLIDS(2),1,NOUT,WAVEL,ISTATS(2)) CALL UTCPTD(IDOUT,COLIDS(3),1,NOUT,TOTAL,ISTATS(3)) CALL UTCPTI(IDOUT,COLIDS(4),1,NOUT,NADDS,ISTATS(4)) DO 240 I=1,4 IF(ISTATS(I).NE.0)THEN CONTXT='Error writing to output table' GO TO 999 ENDIF 240 CONTINUE C C ADD GRATING MODE AND APERTURE TO TABLE, THEN CLOSE IT C CALL UTHADT(IDOUT,'GRATING',GRAT1,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error adding parameter to output table' GO TO 999 ENDIF CALL UTHADT(IDOUT,'APERTURE',APER1,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error adding parameter to output table' GO TO 999 ENDIF CALL UTTCLO(IDOUT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error closing output table '//TABLE GO TO 999 ENDIF C C DONE C GO TO 1000 999 CALL UMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT) 1000 CALL UIMCTP(IDTEMP,ISTAT) CALL UIMCTP(IDTMP2,ISTAT) IF(MASKT.NE.' ')CALL UIMCTP(IDTMP3,ISTAT) END