!+CMPPHA ! ----------------- subroutine cmppha ! ----------------- ! --- DESCRIPTION ----------------------------------------------------- ! CMPPHA converts a typeII pha file to a type I pha file. ! --- VARIABLES ------------------------------------------------------- ! IMPLICIT NONE character(160) infile, outfile character(80) context, desc, rowexp, dclnam character(80) backfexp, rmfexp, arfexp, corfexp character(40) termdesc character(6) cmpmode integer errflg, chatter logical killit ! ! --- VARIABLE DIRECTORY ---------------------------------------------- ! ! infile char : Input filename ! outfile char : Output filename ! chatter int : Chattiness flag (>20 verbose) ! --- CALLED ROUTINES ------------------------------------------------- ! ! CMP_GP : Gets parameters ! ! --- AUTHORS/MODIFICATION HISTORY ------------------------------------ ! ! Rehana Yusaf (1995 May 8) 1.0.0; ! Peter D Wilson (1998 June 29) 1.0.1: ! . Eliminated INQUIRE call on infile ! Ning Gan (1999 March 22) 1.0.2 ! Expanded the maxchan from 256 to 256*256 ! Ning Gan (1999 March 22) 1.0.3 ! The nchan is changed to be decided by tform of channel instead. ! Koji Mukai (2000 September 18) 1.1 ! Introduced a new hidden parameter, rows, which controls which ! spectra to squish/expand. The default for rows would be "-" ! meaning all rows. ! Koji Mukai (2000 October 17) 1.1.1 ! Introduced a new hidden parameter, datacol, which allows users ! to override the standard Type II PHA file column name (which is ! the default, " ") so it can produce BACKGROUND_UP/DOWN spectra. ! Ken Ebisawa (2003 April 14) 1.2 ! Two bugs were fixed: ! (1) When there is only one spectrum in the input file, and/or ! one spectrum is output, the program fails (blank file is ! written). ! (2) ANCRFILE, RESPFILE etc values in the input spectral columns ! (if any), are not copied to the output file keywords besides ! the first row. ! Bryan Irby (2003 August) 1.3 ! Increased input spectra limit from 256 to 1024 ! Bryan Irby (2009 March) 1.4 ! Increase maxcol to handle more than 20 columns. In cmp_ex_wt: ! When wtpha1 returns an error, set forl=1 so that the output file ! is closed. ! Bryan Irby (2018 December) 1.5 ! Replaced udmget with allocate; added deallocate character(5) version parameter (version = '1.5') character(40) taskname COMMON/task/taskname taskname = 'CMPPHA' // version !- ! --------------------------------------------------------------------- ! ! --- GET PARAMETERS --- ! context = 'fatal error' termdesc = ' CMPPHA Ver ' // version // ' terminated !' errflg = 0 call cmp_gp(infile, outfile, cmpmode, rowexp, dclnam, backfexp, rmfexp, & arfexp, corfexp, killit, errflg, chatter) IF (errflg.NE.0) THEN call fcerr(context) call fcecho(termdesc) return ENDIF ! ! --- USER INFO --- ! IF (chatter.GE.1) THEN desc = ' Main CMPPHA Ver ' // version call fcecho(desc) ENDIF ! ! --- READ INFILE, APPLY CMPMODE AND WRITE OUTFILE --- ! call cmp_dma_rd_wt(infile, outfile, cmpmode, rowexp, dclnam, & backfexp, rmfexp, arfexp, corfexp, taskname, & chatter, killit, errflg) IF (chatter.GE.1) THEN desc = ' Completed CMPPHA Ver ' // version call fcecho(desc) ENDIF return end ! ---------------------------------------------------------------------- ! END OF MAIN CMPPHA ! ---------------------------------------------------------------------- !+CMP_GP ! -------------------------------------------------------- subroutine cmp_gp(infile, outfile, cmpmode, rowexp, dclnam, backfexp, & rmfexp, arfexp, corfexp, killit, errflg, chatter) ! -------------------------------------------------------- ! --- DESCRIPTION ------------------------------------------------------ ! Gets parameters. ! --- VARIABLES -------------------------------------------------------- ! IMPLICIT NONE character*(*) infile, outfile, cmpmode, rowexp, dclnam character*(*) backfexp, rmfexp, arfexp, corfexp logical killit integer errflg, chatter ! ! --- ARGUMENT DIRECTORY --------------------------------------------- ! ! infile char : input file name ! outfile char : Output filename ! cmpmode char : Expansion mode Squish or Expand ! rowexp char : Input rows to squish/expand ! dclnam char : Input data column name to operate on ! backfexp char : Background file name to be written in o/p file keyword ! rmfexp char : RMF file name to be written in o/p file keyword ! arfexp char : ARF file name to be written in o/p file keyword ! corfexp char : Correction file name to be written in o/p file keyword ! killit bool : Overwrite output file if it already exists? ! chatter int : Chattiness flag, >20 verbose ! errflg int : Error flag ! ! --- INTERNAL VARIABLES --------------------------------------------- ! ! character(160) filename character(160) ill_files(5) integer n_ill character(28) errstr, wrnstr integer status character(70) desc logical val_cmp, valfil ! integer ext, extnum, flen, fcstln ! ! --- CALLED ROUTINES ------------------------------------------------- ! ! UCLGST : (HOST) Get string input ! UCLGSI : (HOST) Get integer input ! FCECHO : (FTOOLS) Screen write ! ! --- COMPILATION/LINKING --------------------------------------------- ! ! CALTOOLS, FTOOLS ! ! --- AUTHORS/MODIFICATION HISTORY ------------------------------------ ! ! Rehana Yusaf (1995 May 8) 1.0.0; ! Peter D Wilson (1998 June 29) 1.0.1: ! . Eliminated INQUIRE call on infile ! Koji Mukai (2000 September 18) 1.1.0: ! Added 'rows' parameter, ! Koji Mukai (2000 October 17) 1.1.1: ! Added 'datacol' parameter, character(5) version parameter (version = '1.2') !- ! --------------------------------------------------------------------- ! errstr = ' ERROR : CMPPHA Ver ' // version // ':' wrnstr = ' WARNING : CMPPHA Ver ' // version // ':' ! GET INFILE status = 0 call uclgst('infile', infile, status) IF (status.NE.0) THEN desc = errstr // ' .. getting infile parameter !' call fcecho(desc) errflg = 1 return ENDIF call crmvlbk(infile) IF (infile.EQ.' ') THEN errflg = 1 desc = ' Input PHA file not entered !' call fcecho(desc) return ENDIF ! PDW 6/29/98: Leave it to FTOPEN to determine ! call fcpars(infile,filename,extnum,status) ! ext = .true. ! flen = fcstln(filename) ! INQUIRE(FILE=filename(:flen),EXIST=ext) ! IF (.NOT.ext) THEN ! errflg = 1 ! desc = errstr//' File does not EXIST :'//filename ! call fcecho(desc) ! return ! ENDIF ! GET OUTFILE status = 0 call uclgst('outfile', outfile, status) IF (status.NE.0) THEN desc = errstr // ' .. getting outfile parameter !' call fcecho(desc) errflg = 1 return ENDIF ! GET CLOBBER call uclgsb('clobber', killit, status) IF (status.NE.0) THEN killit = .false. desc = errstr // ' ... getting clobber value ' call fcecho(desc) ENDIF ! OUTFILE VALIDATION call crmvlbk(outfile) IF (outfile.EQ.' ') THEN desc = errstr // ' outfile must be entered !!' call fcecho(desc) errflg = 1 return ENDIF n_ill = 1 ! PDW 6/29/98: Strip off possible extension number first ! ill_files(1) = infile call ftrtnm(infile, ill_files(1), status) call ck_file(outfile, ill_files, n_ill, valfil, & killit, chatter) IF (.NOT.valfil) THEN errflg = 2 return ENDIF ! GET CMPMODE status = 0 call uclgst('cmpmode', cmpmode, status) IF (status.NE.0) THEN desc = errstr // ' .. getting cmpmode parameter !' call fcecho(desc) errflg = 1 return ENDIF ! CHECK CMPMODE VALIDITY call ftupch(cmpmode) call crmvlbk(cmpmode) val_cmp = .false. IF (cmpmode(1:1).EQ.'E') THEN val_cmp = .true. ELSEIF (cmpmode(1:1).EQ.'S') THEN val_cmp = .true. ENDIF IF (.NOT.val_cmp) THEN desc = errstr // ' Invalid CMPMODE !' call fcecho(desc) desc = ' VALID CMPMODES : Squish or Expand' call fcecho(desc) errflg = 1 return ENDIF ! GET ROWEXP status = 0 call uclgst('rows', rowexp, status) IF (status.NE.0) THEN desc = errstr // ' .. getting rows parameter !' call fcecho(desc) errflg = 1 return ENDIF ! GET DCLNAM status = 0 call uclgst('datacol', dclnam, status) IF (status.NE.0) THEN desc = errstr // ' .. getting datacol parameter !' call fcecho(desc) errflg = 1 return ENDIF ! GET BACKFEXP status = 0 call uclgst('backfile', backfexp, status) IF ((status.NE.0).OR.(backfexp.EQ.' ')) THEN desc = errstr // ' Getting BACKFILE Parameter' call fcecho(desc) desc = ' setting BACKFILE to NONE' call fcecho(desc) backfexp = 'NONE' status = 0 ELSEIF ((backfexp.EQ.'none').OR.(backfexp.EQ.'NULL').OR.& (backfexp.EQ.'null')) THEN backfexp = 'NONE' ENDIF ! GET CORFEXP status = 0 call uclgst('corrfile', corfexp, status) IF ((status.NE.0).OR.(corfexp.EQ.' ')) THEN desc = errstr // ' Getting CORFILE Parameter' call fcecho(desc) desc = ' setting CORFILE to NONE' call fcecho(desc) corfexp = 'NONE' status = 0 ELSEIF ((corfexp.EQ.'none').OR.(corfexp.EQ.'NULL').OR.& (corfexp.EQ.'null')) THEN corfexp = 'NONE' ENDIF ! GET ARFEXP status = 0 call uclgst('arfile', arfexp, status) IF ((status.NE.0).OR.(arfexp.EQ.' ')) THEN desc = errstr // ' Getting ARFILE Parameter' call fcecho(desc) desc = ' setting ARFILE to NONE' call fcecho(desc) arfexp = 'NONE' status = 0 ELSEIF ((arfexp.EQ.'none').OR.(arfexp.EQ.'NULL').OR.& (arfexp.EQ.'null')) THEN arfexp = 'NONE' ENDIF ! GET RMFEXP status = 0 call uclgst('rmfile', rmfexp, status) IF ((status.NE.0).OR.(rmfexp.EQ.' ')) THEN desc = errstr // ' Getting RMFEXP Parameter' call fcecho(desc) desc = ' setting RMFEXP to NONE' call fcecho(desc) rmfexp = 'NONE' status = 0 ELSEIF ((rmfexp.EQ.'none').OR.(rmfexp.EQ.'NULL').OR.& (rmfexp.EQ.'null')) THEN rmfexp = 'NONE' ENDIF ! GET CHATTER status = 0 call uclgsi('chatter', chatter, status) IF (status.NE.0) THEN desc = errstr // ' .. getting chatter parameter !' call fcecho(desc) errflg = 1 return ENDIF return end ! --------------------------------------------------------------------- ! END OF CMP_GP ! --------------------------------------------------------------------- !+CMP_DMA_RD_WT ! ------------------------------------------------------------- subroutine cmp_dma_rd_wt(infile, outfile, cmpmode, rowexp, & dclnam, backfexp, rmfexp, arfexp, corfexp, taskname, & chatter, killit, errflg) ! ------------------------------------------------------------- ! --- DESCRIPTION ------------------------------------------------ ! This subroutine reads the input TYPE II phafile row by row and ! applies the cmpmode. Subsequently the output file is written. ! --- VARIABLES -------------------------------------------------- ! IMPLICIT NONE character*(*) infile, outfile, cmpmode, rowexp, dclnam character*(*) backfexp, rmfexp, arfexp, corfexp, taskname integer chatter, errflg logical killit ! ! --- AUTHORS/MODIFICATION HISTORY ------------------------------- ! ! Rehana Yusaf (1995 May 9) 1.0.0; ! ! Koji Mukai (2000 September 18) 1.1.0; ! Now allows processing of selected rows only. ! Koji Mukai (2000 October 17) 1.1.1; ! Now allows using a non-standard column name. ! Bryan Irby (2018 December 14) 1.2.0; ! Replaced udmget with allocate character(6) version parameter (version = '1.2.0') !- ! ---------------------------------------------------------------- ! INTERNALS character(33) errstr, wrnstr character(80) subinfo, subinfo2, message integer iunit integer nsearch, ninstr, status parameter (nsearch = 50) integer next(nsearch) character(20) extnames(nsearch), outhdu(9, nsearch) character(20) outver(nsearch), instr(9) character(8) extname integer maxchan integer, allocatable :: p_channel(:), p_ipha(:) integer, allocatable :: p_qualty(:), p_grping(:) integer, allocatable :: p_sq_chan(:), p_sq_ipha(:) integer, allocatable :: p_sq_qual(:), p_sq_grping(:) real, allocatable :: p_staterr(:), p_sq_staterr(:) real, allocatable :: p_sysfrc(:), p_sq_sysfrc(:) real, allocatable :: p_pha(:), p_sq_pha(:) real, allocatable :: p_areascal(:), p_backscal(:) real, allocatable :: p_corscal(:), p_exposure(:) logical got_p_channel, got_p_ipha, got_p_qualty, got_p_grping logical got_p_sq_chan, got_p_sq_ipha logical got_p_sq_qual, got_p_sq_grping logical got_p_staterr, got_p_sq_staterr logical got_p_sysfrc, got_p_sq_sysfrc logical got_p_pha, got_p_sq_pha logical got_p_areascal, got_p_backscal logical got_p_corscal, got_p_exposure ! ! --- USER INFO --- ! errstr = ' ERROR : CMP_DMA_RD_WT ' // version wrnstr = ' WARNING : CMP_DMA_RD_WT ' // version IF (chatter.GE.10) THEN subinfo = ' using CMP_DMA_RD_WT Ver ' // version call fcecho(subinfo) ENDIF ! ! --- DETERMINE MAXCHAN --- ! errflg = 0 call cgetlun(iunit) ninstr = 1 instr(1) = 'SPECTRUM' call mvext(0, infile, iunit, ninstr, instr, nsearch, next, outhdu, & extnames, outver, extname, errflg, chatter) IF (errflg.NE.0) THEN subinfo = errstr // ' problem moving to SPECTRUM ext' call fcecho(subinfo) return ENDIF maxchan = 1024 * 1024 IF (chatter.GE.30) THEN write(subinfo, '(a,i12)') ' Maximum array size:', maxchan call rmvexsp(subinfo, subinfo2) call fcecho(subinfo2) ENDIF ! ! --- SET DMA ARRAYS --- ! status = 0 allocate(p_channel(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_channel = .true. ENDIF status = 0 allocate(p_ipha(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_ipha = .true. ENDIF status = 0 allocate(p_qualty(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_qualty = .true. ENDIF status = 0 allocate(p_grping(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_grping = .true. ENDIF status = 0 allocate(p_sq_ipha(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_sq_ipha = .true. ENDIF status = 0 allocate(p_sq_grping(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_sq_grping = .true. ENDIF status = 0 allocate(p_sq_qual(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_sq_qual = .true. ENDIF status = 0 allocate(p_sq_chan(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_sq_chan = .true. ENDIF status = 0 allocate(p_staterr(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_staterr = .true. ENDIF status = 0 allocate(p_sysfrc(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_sysfrc = .true. ENDIF status = 0 allocate(p_pha(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_pha = .true. ENDIF status = 0 allocate(p_sq_pha(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_sq_pha = .true. ENDIF status = 0 allocate(p_sq_staterr(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_sq_staterr = .true. ENDIF status = 0 allocate(p_sq_sysfrc(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_sq_sysfrc = .true. ENDIF status = 0 allocate(p_areascal(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_areascal = .true. ENDIF status = 0 allocate(p_backscal(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_backscal = .true. ENDIF status = 0 allocate(p_corscal(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_corscal = .true. ENDIF status = 0 allocate(p_exposure(maxchan), stat = status) IF (status.NE.0) THEN goto 50 ELSE got_p_exposure = .true. ENDIF ! --- READ/SQUISH or EXPAND DATA --- call cmp_rd_wt(iunit, infile, outfile, cmpmode, rowexp, & dclnam, backfexp, rmfexp, arfexp, corfexp, taskname, & p_channel, p_ipha, p_grping, & p_qualty, p_sq_chan, p_sq_ipha, & p_sq_qual, p_sq_grping, p_pha, & p_staterr, p_sysfrc, p_sq_pha, & p_sq_staterr, p_sq_sysfrc, p_areascal, & p_backscal, p_corscal, p_exposure, & maxchan, chatter, killit, errflg) if(errflg.NE.0) then message = errstr // ' Failure in CMP_RD_WT' call fcecho(message) endif 50 if(status.NE.0) then message = errstr // ' Failed to allocate dynamic memory' call fcecho(message) errflg = -1 status = 0 call ftclos(iunit, status) endif IF (got_p_channel) deallocate(p_channel, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_channel') IF (got_p_ipha) deallocate(p_ipha, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_ipha') IF (got_p_qualty) deallocate(p_qualty, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_qualty') IF (got_p_grping) deallocate(p_grping, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_grping') IF (got_p_sq_chan) deallocate(p_sq_chan, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_sq_chan') IF (got_p_sq_ipha) deallocate(p_sq_ipha, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_sq_ipha') IF (got_p_sq_qual) deallocate(p_sq_qual, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_sq_qual') IF (got_p_sq_grping) deallocate(p_sq_grping, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_sq_grping') IF (got_p_staterr) deallocate(p_staterr, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_staterr') IF (got_p_sq_staterr) deallocate(p_sq_staterr, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_sq_staterr') IF (got_p_sysfrc) deallocate(p_sysfrc, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_sysfrc') IF (got_p_sq_sysfrc) deallocate(p_sq_sysfrc, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_sq_sysfrc') IF (got_p_pha) deallocate(p_pha, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_pha') IF (got_p_sq_pha) deallocate(p_sq_pha, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_sq_pha') IF (got_p_areascal) deallocate(p_areascal, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_areascal') IF (got_p_backscal) deallocate(p_backscal, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_backscal') IF (got_p_corscal) deallocate(p_corscal, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_corscal') IF (got_p_exposure) deallocate(p_exposure, stat = status) IF (status .NE. 0)& call fcerr (' Error deallocating p_exposure') return end ! ------------------------------------------------------------------------- ! END OF CMP_DMA_RD_WT ! ------------------------------------------------------------------------- !+CMP_RD_WT ! ------------------------------------------------------------- subroutine cmp_rd_wt(iunit, infile, outfile, cmpmode, rowexp, & dclnam, backfexp, rmfexp, arfexp, corfexp, taskname, & channel, ipha, grping, & qualty, sq_chan, sq_ipha, & sq_qual, sq_grping, pha, & staterr, sysfrc, sq_pha, & sq_staterr, sq_sysfrc, areascal, backscal, corscal, & exposure, maxchan, chatter, killit, errflg) ! ------------------------------------------------------------- ! --- DESCRIPTION ------------------------------------------------ ! This subroutine reads the input TYPE II phafile row by row and ! applies the cmpmode. Subsequently the output file is written. ! --- VARIABLES -------------------------------------------------- ! IMPLICIT NONE integer iunit character*(*) infile, outfile, cmpmode, rowexp, dclnam character*(*) backfexp, rmfexp, arfexp, corfexp, taskname integer channel(*), ipha(*), grping(*) integer qualty(*), sq_chan(*), sq_ipha(*) integer sq_qual(*), sq_grping(*) real pha(*), staterr(*), sysfrc(*), sq_pha(*) real sq_staterr(*), sq_sysfrc(*) real areascal(*), backscal(*), corscal(*) real exposure(*) integer maxchan, chatter, errflg logical killit ! ! --- AUTHORS/MODIFICATION HISTORY ------------------------------- ! ! Rehana Yusaf (1995 May 9) 1.0.0; ! ! Koji Mukai (2000 September 18) 1.1.0; ! Now allows operation on selected rows ! Koji Mukai (2000 October 17) 1.1.1; ! Now allows using a non-standard column name. ! Ken Ebisawa (2003 April 14) ! Fixed two bugs. ! (1) When there is only one spectrum in the input file, and/or ! one spectrum is output, the program fails (blank file is ! written). ! (2) ANCRFILE, RESPFILE etc values in the input spectral columns ! (if any), are not copied to the output file keywords besides ! the first row. character(6) version parameter (version = '1.2') !- ! ---------------------------------------------------------------- ! INTERNALS character(33) errstr, wrnstr, comm character(80) subinfo, subinfo2 integer lenact integer ncol, maxcol parameter (maxcol = 100) character(20) ttype(maxcol), tunit(maxcol) character(5) tform(maxcol) logical anyflg, pois integer i, ivar, nspecs, status, felem, inull, nchan integer fchan, lchan, forl integer chancol, ratecol, ctscol, statcol, syscol, qualcol integer grpcol, dtype integer nranges, frows(15), lrows(15), k real totexp real enull logical qerror, qsys, qqual, qgroup character(16) telescop(1024), instrume(1024), detnam(1024) character(16) filter(1024) character(160) rmfile(1024), arfile(1024), corfile(1024) character(160) backfile(1024) integer detchans character(16) hduclas2, chantype ! ! --- USER INFO --- ! errstr = ' ERROR : CMP_RD_WT Ver ' // version wrnstr = ' WARNING : CMP_RD_WT ' // version IF (chatter.GE.10) THEN subinfo = ' using CMP_RD_WT Ver ' // version call fcecho(subinfo) ENDIF ! ! --- OPEN INFILE --- ! ! call cgetlun(iunit) ! ninstr = 1 ! instr(1) = 'SPECTRUM' ! call mvext(0,infile,iunit,ninstr,instr,nsearch,next,outhdu, ! & extnames,outver,extname,errflg,chatter) ! IF (errflg.NE.0) THEN ! subinfo = errstr//' problem moving to SPECTRUM ext' ! call fcecho(subinfo) ! return ! ENDIF ! ! --- READ NSPEC and DETERMINE/LOCATE COLUMNS --- ! call ftghbn(iunit, maxcol, nspecs, ncol, ttype, tform, tunit, & comm, ivar, errflg) subinfo = errstr // ' reading binary header info' call wt_ferrmsg(errflg, subinfo) IF (errflg.NE.0) THEN errflg = 2 return ENDIF IF (chatter.GE.15) THEN write(subinfo, '(a,i12,a)') ' There are ', nspecs, ' spectra' call rmvexsp(subinfo, subinfo2) call fcecho(subinfo2) ENDIF ! Parse the 'rows' parameter call fcgrgs(rowexp, nspecs, nranges, frows, lrows) IF (nranges.LE.0) THEN errflg = 5 subinfo = errstr // ' parsing the ROWS parameter' call wt_ferrmsg(errflg, subinfo) return END IF ! DETERMINE WHICH COLUMNS ARE PRESENT AND SET LOGICALS ACCORDINGLY dtype = 0 qerror = .false. qsys = .false. qqual = .false. qgroup = .false. totexp = 0.0 do i = 1, ncol IF (ttype(i).EQ.'COUNTS') THEN dtype = 1 call ftgcno(iunit, .false., 'COUNTS', ctscol, errflg) subinfo = errstr // ' finding COUNTS column number' call wt_ferrmsg(errflg, subinfo) IF (errflg.NE.0) THEN return ENDIF ELSEIF (ttype(i).EQ.'RATE') THEN dtype = 2 call ftgcno(iunit, .false., 'RATE', ratecol, errflg) subinfo = errstr // ' finding RATE column number' call wt_ferrmsg(errflg, subinfo) IF (errflg.NE.0) THEN return ENDIF ELSEIF (ttype(i).EQ.'STAT_ERR') THEN qerror = .true. call ftgcno(iunit, .false., 'STAT_ERR', statcol, errflg) subinfo = errstr // ' finding STAT_ERR column number' call wt_ferrmsg(errflg, subinfo) IF (errflg.NE.0) THEN return ENDIF ELSEIF (ttype(i).EQ.'SYS_ERR') THEN qsys = .true. call ftgcno(iunit, .false., 'SYS_ERR', syscol, errflg) subinfo = errstr // ' finding SYS_ERR column number' call wt_ferrmsg(errflg, subinfo) IF (errflg.NE.0) THEN return ENDIF ELSEIF (ttype(i).EQ.'QUALITY') THEN qqual = .true. call ftgcno(iunit, .false., 'QUALITY', qualcol, errflg) subinfo = errstr // ' finding QUALITY column number' call wt_ferrmsg(errflg, subinfo) IF (errflg.NE.0) THEN return ENDIF ELSEIF (ttype(i).EQ.'GROUPING') THEN qgroup = .true. call ftgcno(iunit, .false., 'GROUPING', grpcol, errflg) subinfo = errstr // ' finding GROUPING column number' call wt_ferrmsg(errflg, subinfo) IF (errflg.NE.0) THEN return ENDIF ENDIF enddo IF (dclnam.NE.' ') THEN ! Overriding the default column name --- assume the same type ! (COUNTS or RATE) as the mandatory column IF (dtype.EQ.1) THEN call ftgcno(iunit, .false., dclnam, ctscol, errflg) ELSE call ftgcno(iunit, .false., dclnam, ratecol, errflg) ENDIF subinfo = errstr // ' finding ' // dclnam // ' column number' call wt_ferrmsg(errflg, subinfo) IF (errflg.NE.0) THEN return ENDIF ENDIF call ftgcno(iunit, .false., 'CHANNEL', chancol, errflg) subinfo = errstr // ' finding CHANNEL column number' call wt_ferrmsg(errflg, subinfo) IF (errflg.NE.0) THEN return ENDIF IF (chatter.GE.20) THEN subinfo = ' Columns relevant to outfile :' call fcecho(subinfo) subinfo = ' CHANNEL' IF (dtype.EQ.1) THEN subinfo = subinfo(1:lenact(subinfo)) // ' COUNTS' ELSE subinfo = subinfo(1:lenact(subinfo)) // ' RATE' ENDIF IF (qerror) THEN subinfo = subinfo(1:lenact(subinfo)) // ' STAT_ERR' ENDIF IF (qsys) THEN subinfo = subinfo(1:lenact(subinfo)) // ' SYS_ERR' ENDIF call fcecho(subinfo) IF (qqual) THEN subinfo = ' QUALITY' ENDIF IF (qgroup) THEN subinfo = subinfo(1:lenact(subinfo)) // ' GROUPING' ENDIF IF (qqual.OR.qgroup) THEN call fcecho(subinfo) ENDIF ENDIF ! --- READ PHA COLUMNS/KEYWORDS SUCH AS BACKFILE --- call cmp_phakeys(iunit, ttype, ncol, telescop, instrume, & detnam, filter, nspecs, exposure, areascal, backscal, corscal, & rmfile, arfile, corfile, backfile, rmfexp, arfexp, & corfexp, backfexp, cmpmode, hduclas2, detchans, & nchan, chancol, chantype, fchan, lchan, & pois, dtype, errflg, chatter) IF (fchan.EQ.-99) THEN ! TLMIN not found --- guess. fchan = 1 END IF IF (lchan.EQ.-99) THEN ! TLMAX not found --- calculate. lchan = fchan + nchan - 1 END IF ! --- READ PHA DATA row by row --- do k = 1, nranges do i = frows(k), lrows(k) ! do i=1,nspecs status = 0 ! cmp_sq etc. used to compare i with 1 or nspecs to see whether ! it was the first or last call to it; with the option to run ! on restricted rows, we need to pass a new parameter, forl ! ! 2003-04-13: A bug was found such that cmppha fails when ! there is only a single spectral file (single row). ! nranges is the number of rows selected ! It is possible that frows(k)=lrows(k) ! So i is the actual row number to be extracted ! Ken Ebisawa ! if (i.eq.frows(1)) then if (i.eq.lrows(nranges)) then forl = -2 else forl = -1 endif else if (i.eq.lrows(nranges)) then forl = 1 else forl = 0 end if inull = 0 call ftgcvj(iunit, chancol, i, 1, nchan, inull, channel, & anyflg, status) subinfo = errstr // ' reading CHANNEL column' call wt_ferrmsg(status, subinfo) IF (status.NE.0) THEN errflg = 5 return ENDIF IF (dtype.EQ.1) THEN inull = 0 status = 0 felem = 1 call ftgcvj(iunit, ctscol, i, 1, nchan, inull, ipha, & anyflg, status) subinfo = errstr // ' reading COUNTS column' call wt_ferrmsg(status, subinfo) IF (status.NE.0) THEN errflg = 5 return ENDIF ELSEIF (dtype.EQ.2) THEN status = 0 felem = 1 enull = 0 call ftgcve(iunit, ratecol, i, 1, nchan, enull, pha, & anyflg, status) subinfo = errstr // ' reading RATE column' call wt_ferrmsg(status, subinfo) IF (status.NE.0) THEN errflg = 5 return ENDIF ENDIF IF (qerror) THEN status = 0 felem = 1 enull = 0 call ftgcve(iunit, statcol, i, 1, nchan, enull, staterr, & anyflg, status) ENDIF IF (qsys) THEN status = 0 felem = 0 enull = 0 call ftgcve(iunit, syscol, i, 1, nchan, enull, sysfrc, & anyflg, status) subinfo = errstr // ' reading SYS_ERR column' call wt_ferrmsg(status, subinfo) IF (status.NE.0) THEN errflg = 5 return ENDIF ENDIF IF (qqual) THEN status = 0 felem = 0 inull = 0 call ftgcvj(iunit, qualcol, i, 1, nchan, inull, qualty, & anyflg, status) subinfo = errstr // ' reading QUALITY column' call wt_ferrmsg(status, subinfo) ENDIF IF (qgroup) THEN status = 0 felem = 0 inull = 0 call ftgcvj(iunit, grpcol, i, 1, nchan, inull, grping, & anyflg, status) subinfo = errstr // ' reading GROUPING column' call wt_ferrmsg(status, subinfo) ENDIF IF (cmpmode(1:1).EQ.'S') THEN call cmp_sq(i, forl, channel, fchan, nchan, ipha, pha, dtype, & maxchan, qerror, qsys, staterr, sysfrc, & qqual, qualty, sq_qual, qgroup, grping, sq_grping, & exposure(i), sq_chan, sq_pha, sq_ipha, & sq_staterr, sq_sysfrc, totexp, chatter, errflg) ELSEIF (cmpmode(1:1).EQ.'E') THEN !ebi 2003-04-14 Ken Ebisawa !ebi Originally, (i) in the following sentence were (1), !ebi besides exposure(i). This caused a problem that !ebi correct ANCRFILE, RESPFILE etc values in the existent columns !ebi are not copied to the output file header. call cmp_ex_wt(outfile, infile, i, telescop(i), instrume(i), & detnam(i), filter(i), exposure(i), areascal(i), & backscal(i), corscal(i), backfile(i), rmfile(i), & arfile(i), corfile(i), rowexp, dclnam, & dtype, qerror, qsys, qqual, qualty, qgroup, grping, & channel, pha, ipha, staterr, maxchan, sysfrc, & hduclas2, detchans, nchan, chantype, killit, pois, & fchan, taskname, forl, chatter, errflg) ENDIF enddo enddo IF (cmpmode(1:1).EQ.'S') THEN call cmp_sq_wt(outfile, infile, telescop(1), instrume(1), & detnam(1), filter(1), totexp, areascal(1), & backscal(1), corscal(1), backfile(1), rmfile(1), & arfile(1), corfile(1), rowexp, dclnam, & dtype, qerror, qsys, qqual, sq_qual, qgroup, & sq_grping, sq_chan, sq_pha, sq_ipha, sq_staterr, & maxchan, sq_sysfrc, hduclas2, detchans, nchan, & chantype, killit, pois, fchan, taskname, & chatter, errflg) ENDIF return end ! ------------------------------------------------------------------------ ! END OF CMP_RD_WT ! ------------------------------------------------------------------------ !+ ! -------------------------------------------------------- subroutine cmp_sq_wt(outfile, infile, telescop, instrume, & detnam, filter, exposure, ascal, & bscal, cscal, backfile, respfile, & arfile, corfile, rowexp, dclnam, & dtype, qerror, qsys, qqual, qualty, qgroup, & grping, chan, pha, ipha, staterr, & maxchan, sysfrc, hduclas2, detchans, nchan, & chantype, killit, pois, fchan, & taskname, chatter, errflg) ! -------------------------------------------------------- ! --- DESCRIPTION -------------------------------------------------------- ! This routine opens a new file, writes a null primary array, and an OGIP ! standard FITS PHA extension. ! --- VARIABLES ---------------------------------------------------------- ! IMPLICIT NONE character*(*) outfile, telescop, instrume, detnam, filter character*(*) backfile, respfile, arfile, infile character*(*) rowexp, dclnam character*(*) hduclas2, corfile, chantype, taskname real ascal, bscal, cscal, exposure real pha(*), staterr(*), sysfrc(*) integer maxchan, chan(*), ipha(*), i integer chatter, errflg, detchans, nchan integer dtype, qualty(*), grping(*) integer fchan logical killit, pois, qerror, qsys, qqual, qgroup ! ! --- AUTHORS/MODIFICATION HISTORY --------------------------------------- ! ! Rehana Yusaf (23 May 1995) 1.0.0; character(5) version parameter (version = '1.0.0') ! !- ! ------------------------------------------------------------------------ ! INTERNALS integer ounit, nk_hist, nk_comm, status character(30) errstr, wrnstr, phaversn character(70) subinfo, errinfo, hist(4), comm(4) ! ! --- USER INFO --- ! IF (chatter.GE.15) THEN subinfo = ' ... using CMP_SQ_WT Ver' // version call fcecho(subinfo) ENDIF errstr = ' ERROR: CMP_SQ_WT Ver ' // version wrnstr = ' WARNING: CMP_SQ_WT Ver ' // version ! ! --- OPEN FITS FILE --- ! call cgetlun(ounit) call opnpa(outfile, chatter, ounit, killit, errflg) IF (errflg.NE.0) THEN errinfo = errstr // 'opening and writing primary to outfile' call fcecho(errinfo) goto 100 ENDIF ! ! --- WRITE PHA extension --- ! nk_hist = 1 hist(1) = 'infile: ' // infile IF (rowexp.NE.'-') THEN nk_hist = nk_hist + 1 hist(nk_hist) = 'Rows: ' // rowexp ENDIF IF (dclnam.NE.' ') THEN nk_hist = nk_hist + 1 hist(nk_hist) = 'Data column: ' // dclnam ENDIF nk_comm = 0 phaversn = '1.1.0' IF (dtype.EQ.1) THEN do i = 1, nchan pha(i) = ipha(i) enddo ENDIF call wtpha1(ounit, chatter, nk_hist, hist, nk_comm, & comm, telescop, instrume, detnam, filter, & phaversn, hduclas2, fchan, exposure, ascal, & backfile, bscal, corfile, cscal, respfile, & arfile, detchans, chantype, chan, pha, dtype, & qerror, staterr, qsys, sysfrc, qqual, qualty, qgroup, & grping, nchan, errflg) IF (errflg.NE.0) THEN errinfo = errstr // ' problem writing PHA ext' call fcecho(errinfo) goto 100 ENDIF status = 0 call ftpdat(ounit, status) status = 0 call ftpkys(ounit, 'CREATOR', taskname, & 's/w task which wrote this dataset', status) IF (chatter.GE.10) THEN errinfo = wrnstr // ' writing CREATOR ' call wt_ferrmsg(status, errinfo) ENDIF status = 0 call ftphis(ounit, ' Squish mode of CMPPHA', status) IF (chatter.GE.10) THEN errinfo = wrnstr // ' writing CMPPHA' call wt_ferrmsg(status, errinfo) ENDIF 100 status = 0 call ftclos(ounit, status) return end ! ------------------------------------------------------------------ ! END OF CMP_SQ_WT ! ------------------------------------------------------------------ !+ ! -------------------------------------------------------- subroutine cmp_ex_wt(outfile, infile, specnum, telescop, & instrume, detnam, filter, exposure, ascal, & bscal, cscal, backfile, respfile, & arfile, corfile, rowexp, dclnam, & dtype, qerror, qsys, qqual, qualty, qgroup, & grping, chan, pha, ipha, staterr, & maxchan, sysfrc, hduclas2, detchans, nchan, & chantype, killit, pois, fchan, & taskname, forl, chatter, errflg) ! -------------------------------------------------------- ! --- DESCRIPTION -------------------------------------------------------- ! This routine, if forl is -1, opens a new file, writes a null primary ! array, and an OGIP standard FITS PHA extension. It is used by the expand ! mode of CMPPHA. If forl is 0 or 1 then a new PHA extension is appended, ! and if it is 1, the file is closed. ! --- VARIABLES ---------------------------------------------------------- ! IMPLICIT NONE character*(*) outfile, telescop, instrume, detnam, filter character*(*) backfile, respfile, arfile, infile character*(*) hduclas2, corfile, chantype, taskname character*(*) rowexp, dclnam real ascal, bscal, cscal, exposure real pha(*), staterr(*), sysfrc(*) integer maxchan, chan(*), ipha(*), i, specnum, forl integer chatter, errflg, detchans, nchan integer dtype, qualty(*), grping(*) integer fchan logical killit, pois, qerror, qsys, qqual, qgroup ! ! --- AUTHORS/MODIFICATION HISTORY --------------------------------------- ! ! Rehana Yusaf (28 Aug 1995) 1.0.0; ! ! Koji Mukai (2000 September 20) 1.1.0; ! Now uses 'forl' rather than comparision of specnum with 1 and/or nspecs ! (specnum is now an orphan) ! ! Bryan Irby (2005 June 2) 1.1.1: ! - SAVE ounit to prevent garbled file unit on Mac OS X. ! - initialize detchans to prevent garbled value (on Mac OS X) if it ! isn't found by ftgkyj ! ! Bryan Irby (2009 March 16) 1.1.2: ! - When wtpha1 returns an error, set forl=1 so that the output file ! is closed. ! character(5) version parameter (version = '1.1.2') ! !- ! ------------------------------------------------------------------------ ! INTERNALS integer ounit, nk_hist, nk_comm, status character(30) errstr, wrnstr, phaversn character(70) subinfo, errinfo, hist(4), comm(4) SAVE ounit ! ! --- USER INFO --- ! IF (chatter.GE.15) THEN subinfo = ' ... using CMP_EX_WT Ver' // version call fcecho(subinfo) ENDIF errstr = ' ERROR: CMP_EX_WT Ver ' // version wrnstr = ' WARNING: CMP_EX_WT Ver ' // version ! ! --- OPEN FITS FILE --- ! IF (forl.LT.0) THEN call cgetlun(ounit) call opnpa(outfile, chatter, ounit, killit, errflg) IF (errflg.NE.0) THEN errinfo = errstr // 'opening and writing primary to outfile' call fcecho(errinfo) goto 100 ENDIF ENDIF ! ! --- WRITE PHA extension --- ! nk_hist = 1 hist(1) = 'infile: ' // infile IF (rowexp.NE.'-') THEN nk_hist = nk_hist + 1 hist(nk_hist) = 'Rows: ' // rowexp ENDIF IF (dclnam.NE.' ') THEN nk_hist = nk_hist + 1 hist(nk_hist) = 'Data column: ' // dclnam ENDIF nk_comm = 0 phaversn = '1.1.0' IF (dtype.EQ.1) THEN do i = 1, nchan pha(i) = ipha(i) enddo ENDIF call wtpha1(ounit, chatter, nk_hist, hist, nk_comm, & comm, telescop, instrume, detnam, filter, & phaversn, hduclas2, fchan, exposure, ascal, & backfile, bscal, corfile, cscal, respfile, & arfile, detchans, chantype, chan, pha, dtype, & qerror, staterr, qsys, sysfrc, qqual, qualty, qgroup, & grping, nchan, errflg) IF (errflg.NE.0) THEN errinfo = errstr // ' problem writing PHA ext' call fcecho(errinfo) forl = 1 goto 100 ENDIF status = 0 call ftpdat(ounit, status) status = 0 call ftpkys(ounit, 'CREATOR', taskname, & 's/w task which wrote this dataset', status) IF (chatter.GE.10) THEN errinfo = wrnstr // ' writing CREATOR ' call wt_ferrmsg(status, errinfo) ENDIF status = 0 call ftphis(ounit, ' Expand mode of CMPPHA', status) IF (chatter.GE.10) THEN errinfo = wrnstr // ' writing HISTORY' call wt_ferrmsg(status, errinfo) ENDIF 100 status = 0 IF (forl.EQ.+1.or.forl.EQ.-2) THEN call ftclos(ounit, status) errinfo = errstr // ' closing outfile' call wt_ferrmsg(status, errinfo) ENDIF return end ! ------------------------------------------------------------------ ! END OF CMP_EX_WT ! ------------------------------------------------------------------ !+CMP_SQ ! -------------------------------------------------------- subroutine cmp_sq(nspec, forl, channel, fchan, nchan, ipha, & pha, dtype, maxchan, qerror, qsys, staterr, sysfrc, & qqual, qualty, sq_qual, qgroup, grping, sq_grping, & exposure, sq_chan, sq_pha, sq_ipha, & sq_staterr, sq_sysfrc, totexp, & chatter, errflg) ! -------------------------------------------------------- ! --- DESCRIPTION --------------------------------------------- ! This subroutine compresses (adds) many spectra together. ! Each spectrum should have the same number of channels. ! ------------------------------------------------------------- ! --- VARIABLE DIRECTORY ------------------------------------------ ! IMPLICIT NONE integer errflg, chatter, maxchan, nspec, fchan, nchan integer channel(*), ipha(*), forl, dtype real staterr(*), sysfrc(*), pha(*), exposure integer sq_chan(*), sq_ipha(*) real sq_pha(*), sq_sysfrc(*), sq_staterr(*), totexp integer sq_qual(*), sq_grping(*), qualty(*), grping(*) logical qsys, qerror, qqual, qgroup ! ! --- AUTHORS/MODIFICATION HISTORY -------------------------------- ! ! Rehana Yusaf (1995 May 11) 1.0.0; ! ! Koji Mukai (2000 September 20) 1.1.0; ! now uses value of 'forl' instead of comparison of nspec and 1/nspecs ! to see if this is the first call, the last call, or neither ! character(5) version parameter (version = '1.1.0') !- ! ----------------------------------------------------------------- ! INTERNALS ! character(30) errstr, wrnstr character(132) subinfo, errinfo integer i ! --- USER INFO --- IF (chatter.GE.40) THEN subinfo = ' ... using CMP_SQ Ver ' // version call fcecho(subinfo) ENDIF errstr = ' ERROR: CMP_SQ Ver ' // version wrnstr = ' WARNING: CMP_SQ Ver ' // version ! --- SOME ERROR CHECKS --- ! Ensure that each spectrum has the same starting channel ! IF (nspec.EQ.1) THEN ! fchan = channel(1) ! ENDIF IF (channel(1).NE.fchan) THEN subinfo = errstr& // ' Spectra contain inconsistent starting channels' call fcecho(subinfo) ENDIF ! --- POPULATE SQUISH ARRAYS --- do i = 1, nchan IF (forl.LE.-1) THEN sq_chan(i) = channel(i) ELSEIF (sq_chan(i).NE.channel(i)) THEN write(errinfo, '(a,i12,a)')' Row', nspec, & ' spectrum contains channel numbers that are inconsistent' call fcecho(errinfo) errinfo = ' with previous spectra' call fcecho(errinfo) errflg = 1 return ENDIF IF (dtype.EQ.1) THEN sq_ipha(i) = sq_ipha(i) + ipha(i) ELSEIF (dtype.EQ.2) THEN sq_pha(i) = sq_pha(i) + pha(i) * exposure ENDIF ! This must have been a bug, adding exposure inside the 1-nchan loop. ! There is one statement outside this loop, which is as it should be. ! totexp = totexp + exposure ! commented out, KM, 2000 September 20 IF (qerror) THEN sq_staterr(i) = sq_staterr(i) + staterr(i) * staterr(i) ENDIF IF (qsys) THEN IF (forl.LE.-1) THEN sq_sysfrc(i) = sysfrc(i) ELSE IF (sq_sysfrc(i).NE.sysfrc(i)) THEN qsys = .false. write(errinfo, '(a,a,i12,a)') wrnstr, ' Row ', nspec, & ' spectrum systematic errors are differant to previous spectra' call fcecho(errinfo) errinfo = ' Systematic errors are no longer applied' call fcecho(errinfo) ENDIF ENDIF ENDIF IF (qqual) THEN IF (qualty(i).NE.0) THEN sq_qual(i) = qualty(i) ENDIF ENDIF IF (qgroup) THEN IF (forl.LE.-1) THEN sq_grping(i) = grping(i) ELSEIF (grping(i).NE.sq_grping(i)) THEN write(errinfo, '(a,a,i12,a)')wrnstr, ' Row ', nspec, & ' spectrum grouping is differant to previous spectra' call fcecho(errinfo) errinfo = ' Grouping is no longer applied' call fcecho(errinfo) qgroup = .false. ENDIF ENDIF enddo totexp = totexp + exposure IF ((forl.EQ.-2).OR.(forl.EQ.+1)) THEN IF (dtype.EQ.2) THEN do i = 1, nchan sq_pha(i) = sq_pha(i) / totexp enddo ENDIF IF (qerror) THEN do i = 1, nchan sq_staterr(i) = SQRT(sq_staterr(i)) enddo ENDIF ENDIF return end ! ----------------------------------------------------------------- ! END OF CMP_SQ ! ----------------------------------------------------------------- !+CMP_PHAKEYS ! --------------------------------------------------------------- subroutine cmp_phakeys(iunit, ttype, ncol, telescop, instrume, & detnam, filter, nspecs, exposure, areascal, backscal, corscal, & rmfile, arfile, corfile, backfile, rmfexp, arfexp, & corfexp, backfexp, cmpmode, hduclas2, detchans, nchan, & chancol, chantype, fchan, lchan, & pois, dtype, errflg, chatter) ! --------------------------------------------------------------- ! ! --- VARIABLES --- ! IMPLICIT NONE character*(*) telescop(*), instrume(*), hduclas2 character*(*) detnam(*), filter(*), ttype(*), chantype integer iunit, errflg, chatter, nspecs, ncol, detchans integer chancol, nchan, dtype, fchan, lchan character*(*) cmpmode, rmfexp, arfexp, corfexp, backfexp character*(*) rmfile(*), arfile(*), corfile(*), backfile(*) real exposure(*), areascal(*), backscal(*), corscal(*) logical pois ! ! --- MODIFICATION HISTORY ------------------------------------------ ! ! Rehana Yusaf (May 16 1995) 1.0.0 character(5) version parameter (version = '1.0.0') !- ! ------------------------------------------------------------------ ! ! INTERNALS logical qcol integer i, status character(32) errstr, comm, wrnstr character(96) errinfo, subinfo character(8) tlchar real edefval, err integer datacode, repeat, width ! ! --- USER INFO --- ! errstr = ' ERROR: CMP_PHAKEYS Ver ' // version wrnstr = ' WARNING: CMP_PHAKEYS Ver ' // version IF (chatter.GE.10) THEN subinfo = ' ... using CMP_PHAKEYS Ver ' // version call fcecho(subinfo) ENDIF ! ! --- DETERMINE TELESCOPE VALUE --- ! status = 0 call rdkeycols(iunit, ttype, ncol, nspecs, 'TELESCOP', 'UNKNOWN', & telescop, qcol, status, chatter) IF (cmpmode(1:2).EQ.'SQ') THEN IF (qcol) THEN do i = 2, nspecs IF (telescop(i).NE.telescop(1)) THEN errinfo = errstr // ' File contains spectra'& // ' from differant TELESCOPES' call fcecho(errinfo) errinfo = ' In SQUISH mode this is a problem' call fcecho(errinfo) errflg = 1 return ENDIF enddo ENDIF ENDIF ! ! --- DETERMINE INSTRUME --- ! status = 0 call rdkeycols(iunit, ttype, ncol, nspecs, 'INSTRUME', 'UNKNOWN', & instrume, qcol, status, chatter) IF (cmpmode(1:2).EQ.'SQ') THEN IF (qcol) THEN do i = 2, nspecs IF (instrume(i).NE.instrume(1)) THEN errinfo = errstr // ' File contains spectra'& // ' from differant INSTRUMES' call fcecho(errinfo) errinfo = ' In SQUISH mode this is a problem' call fcecho(errinfo) errflg = 1 return ENDIF enddo ENDIF ENDIF ! ! --- DETERMINE DETNAM VALUE --- ! status = 0 call rdkeycols(iunit, ttype, ncol, nspecs, 'DETNAM', 'UNKNOWN', & detnam, qcol, status, chatter) IF (cmpmode(1:2).EQ.'SQ') THEN IF (qcol) THEN do i = 2, nspecs IF (detnam(i).NE.detnam(1)) THEN errinfo = errstr // ' File contains spectra'& // ' from differant DETECTORS' call fcecho(errinfo) errinfo = ' In SQUISH mode this is a problem' call fcecho(errinfo) errflg = 1 return ENDIF enddo ENDIF ENDIF ! ! --- DETERMINE FILTER VALUE --- ! status = 0 call rdkeycols(iunit, ttype, ncol, nspecs, 'FILTER', 'UNKNOWN', & filter, qcol, status, chatter) IF (cmpmode(1:2).EQ.'SQ') THEN IF (qcol) THEN do i = 2, nspecs IF (detnam(i).NE.detnam(1)) THEN errinfo = errstr // ' File contains spectra'& // ' with differant FILTERS' call fcecho(errinfo) errinfo = ' In SQUISH mode this is a problem' call fcecho(errinfo) errflg = 1 return ENDIF enddo ENDIF ENDIF ! ! --- DETERMINE RESPFILE VALUE --- ! IF (rmfexp(1:1).EQ.'%') THEN status = 0 call rdkeycols(iunit, ttype, ncol, nspecs, 'RESPFILE', 'NONE', & rmfile, qcol, status, chatter) IF (cmpmode(1:2).EQ.'SQ') THEN IF (qcol) THEN do i = 2, nspecs IF (rmfile(i).NE.rmfile(i - 1)) THEN errinfo = errstr // ' File contains spectra'& // ' with differant RESPFILE names' call fcecho(errinfo) errinfo = ' In SQUISH mode this is a problem' call fcecho(errinfo) errinfo = ' RESPFILE is set to NONE' call fcecho(errinfo) rmfile(i) = 'NONE' ENDIF enddo rmfile(1) = rmfile(2) ENDIF ENDIF ELSE do i = 1, nspecs rmfile(i) = rmfexp enddo ENDIF ! ! --- DETERMINE ARFILE VALUE --- ! status = 0 IF (arfexp(1:1).EQ.'%') THEN status = 0 call rdkeycols(iunit, ttype, ncol, nspecs, 'ANCRFILE', 'NONE', & arfile, qcol, status, chatter) IF (cmpmode(1:2).EQ.'SQ') THEN IF (qcol) THEN do i = 2, nspecs IF (arfile(i).NE.arfile(i - 1)) THEN errinfo = errstr // ' File contains spectra'& // ' with differant ANCRFILE names' call fcecho(errinfo) errinfo = ' In SQUISH mode this is a problem' call fcecho(errinfo) errinfo = 'ANCRFILE is set to NONE' arfile(i) = 'NONE' ENDIF enddo arfile(1) = arfile(2) ENDIF ENDIF ELSE do i = 1, nspecs arfile(i) = arfexp enddo ENDIF ! ! --- DETERMINE CORRFILE VALUE --- ! status = 0 IF (corfexp(1:1).EQ.'%') THEN status = 0 call rdkeycols(iunit, ttype, ncol, nspecs, 'CORRFILE', 'NONE', & corfile, qcol, status, chatter) IF (cmpmode(1:2).EQ.'SQ') THEN IF (qcol) THEN do i = 2, nspecs IF (corfile(i).NE.corfile(i - 1)) THEN errinfo = errstr // ' File contains spectra'& // ' with differant CORRFILE names' call fcecho(errinfo) errinfo = ' In SQUISH mode this is a problem' call fcecho(errinfo) errinfo = 'CORRFILE is set to NONE' arfile(i) = 'NONE' ENDIF enddo corfile(1) = corfile(2) ENDIF ENDIF ELSE do i = 1, nspecs corfile(i) = corfexp enddo ENDIF ! ! --- DETERMINE BACKFILE VALUE --- ! status = 0 IF (backfexp(1:1).EQ.'%') THEN status = 0 call rdkeycols(iunit, ttype, ncol, nspecs, 'BACKFILE', 'NONE', & backfile, qcol, status, chatter) IF (cmpmode(1:2).EQ.'SQ') THEN IF (qcol) THEN do i = 2, nspecs IF (backfile(i).NE.backfile(i - 1)) THEN errinfo = errstr // ' File contains spectra'& // ' with differant BACKFILE names' call fcecho(errinfo) errinfo = ' In SQUISH mode this is a problem' call fcecho(errinfo) errinfo = 'BACKFILE is set to NONE' backfile(i) = 'NONE' ENDIF enddo backfile(1) = backfile(2) ENDIF ENDIF ELSE do i = 1, nspecs backfile(i) = backfexp enddo ENDIF ! ! --- DETERMINE AREASCAL VALUE --- ! status = 0 edefval = 1.0 call rdkeycole(iunit, ttype, ncol, nspecs, 'AREASCAL', edefval, & areascal, qcol, status, chatter) IF (cmpmode(1:2).EQ.'SQ') THEN IF (qcol) THEN do i = 2, nspecs err = ABS(areascal(i) - areascal(i - 1)) IF (err.NE.(0.01)) THEN errinfo = wrnstr // ' Differant area scaling factors' call fcecho(errinfo) errinfo = ' The differance is >1%' call fcecho(errinfo) errinfo = ' In SQUISH mode this is a problem' call fcecho(errinfo) errflg = 1 return ENDIF enddo ENDIF ENDIF ! ! --- DETERMINE BACKSCAL VALUE --- ! status = 0 edefval = 1.0 call rdkeycole(iunit, ttype, ncol, nspecs, 'BACKSCAL', edefval, & backscal, qcol, status, chatter) IF (cmpmode(1:2).EQ.'SQ') THEN IF (qcol) THEN do i = 2, nspecs err = ABS(backscal(i) - backscal(i - 1)) IF (err.NE.(0.01)) THEN errinfo = wrnstr // ' Differant area scaling factors' call fcecho(errinfo) errinfo = ' The differance is >1%' call fcecho(errinfo) errinfo = ' In SQUISH mode this is a problem' call fcecho(errinfo) errflg = 1 return ENDIF enddo ENDIF ENDIF ! ! --- DETERMINE CORSCAL VALUE --- ! status = 0 edefval = 1.0 call rdkeycole(iunit, ttype, ncol, nspecs, 'CORRSCAL', edefval, & corscal, qcol, status, chatter) IF (cmpmode(1:2).EQ.'SQ') THEN IF (qcol) THEN do i = 2, nspecs err = ABS(corscal(i) - corscal(i - 1)) IF (err.NE.(0.01)) THEN errinfo = wrnstr // ' Differant area scaling factors' call fcecho(errinfo) errinfo = ' The differance is >1%' call fcecho(errinfo) errinfo = ' In SQUISH mode this is a problem' call fcecho(errinfo) errflg = 1 return ENDIF enddo ENDIF ENDIF ! DETERMINE EXPOSURE VALUE --- status = 0 edefval = 1.0 call rdkeycole(iunit, ttype, ncol, nspecs, 'EXPOSURE', edefval, & exposure, qcol, status, chatter) IF (cmpmode(1:2).EQ.'SQ') THEN IF ((dtype.EQ.2).AND.(status.EQ.1)) THEN errinfo = errstr // ' EXPOSURE value is needed !' call fcecho(errinfo) errflg = 1 ENDIF ENDIF ! READ HDUCLAS2 VALUE status = 0 hduclas2 = ' ' call ftgkys(iunit, 'HDUCLAS2', hduclas2, comm, status) errinfo = wrnstr // ' reading HDUCLAS2' IF (chatter.GE.30) THEN call wt_ferrmsg(status, errinfo) ENDIF ! READ CHANTYPE VALUE status = 0 chantype = 'UNKNOWN' call ftgkys(iunit, 'CHANTYPE', chantype, comm, status) IF (chatter.GE.10) THEN errinfo = wrnstr // ' reading CHANTYPE keyword' call wt_ferrmsg(status, errinfo) ENDIF ! READ DETCHANS VALUE detchans = 0 call ftgkyj(iunit, 'DETCHANS', detchans, comm, status) errinfo = errstr // ' reading DETCHANS' IF (chatter.GE.20) THEN call wt_ferrmsg(status, errinfo) ENDIF ! Read Nchan from the tform keyword instead. status = 0 call ftgtcl(iunit, chancol, datacode, repeat, width, status) IF (chatter.GE.20) THEN call wt_ferrmsg(status, errinfo) ENDIF IF (status.EQ.0) THEN nchan = repeat IF (detchans.EQ.0) THEN detchans = nchan END IF ELSE nchan = detchans ENDIF ! READ NCHAN (TLMIN2 value and TLMAX2 value) IF (chancol.LE.9) THEN write(tlchar, 100) chancol ELSE write(tlchar, 150) chancol ENDIF status = 0 fchan = -99 call ftgkyj(iunit, tlchar, fchan, comm, status) errinfo = errstr // ' reading TLMIN' IF (chatter.GE.20) THEN call wt_ferrmsg(status, errinfo) ENDIF IF (chancol.LE.9) THEN write(tlchar, 200) chancol ELSE write(tlchar, 250) chancol ENDIF lchan = -99 call ftgkyj(iunit, tlchar, lchan, comm, status) errinfo = errstr // ' reading TLMAX' IF (chatter.GE.20) THEN call wt_ferrmsg(status, errinfo) ENDIF ! IF (status.EQ.0) THEN ! nchan = lchan - fchan + 1 ! ELSE ! nchan = detchans ! ENDIF ! POIS ... status = 0 pois = .false. call ftgkyl(iunit, 'POISSERR', pois, comm, status) IF (chatter.GE.15) THEN errinfo = wrnstr // ' reading POISSERR keyword' call wt_ferrmsg(status, errinfo) errinfo = 'POISERR assumed to be false' call fcecho(errinfo) ENDIF 100 FORMAT('TLMIN', I1) 150 FORMAT('TLMIN', I2) 200 FORMAT('TLMAX', I1) 250 FORMAT('TLMAX', I2) return end ! ------------------------------------------------------------------ ! END OF CMP_PHAKEYS ! ------------------------------------------------------------------