!+DMPRMF subroutine dmprmf ! ------------------ ! ! --- DESCRIPTION ---------------------------------------------------- ! This is the main program for reading and displaying response data ! from a FITS file. ! -------------------------------------------------------------------- ! --- VARIABLES ------------------------------------------------------ ! IMPLICIT NONE character(80) infile, ebdfile, outfile, imagefile logical dispebd, disprmf, disphd, dispmat integer chatter logical cont, page, dmpimg, primary, killit ! ! --- INTERNALS ------------------------------------------------------ ! character(40) subinfo, termdesc, context ! ! --- VARIABLE DIRECTORY --------------------------------------------- ! ! infile char : Input file name (user defined) ! ebdfile char : File containing Ebounds extension ! dispebd logical: 'Y' if user wants to display EBOUNDS data ! disprmf logical: 'Y' if user wants to display RMF data ! disphd logical: 'Y' if user wants to display full header ! dispmat logical: 'Y' if user wants to display full matrix ! outfile char : Ascii outfile name,default no output file ! imagefile char : Output filename for response stored as image ! chatter int : Chatter flag (<5 quiet,>20 noisy) ! cont logical: True if no error encountered ! ! --- CALLED ROUTINES --- ! ! subroutine RMF_GP : Gets user defined parameters ! subroutine RMF_DISP : Displays Response data, EBOUNDS and ! RMF extensions ! subroutine FCECHO : (FTOOLS) Writes to screen, standalone write ! ! --- LINKING AND COMPILATION ---------------------------------------- ! ! Linking with FTOOLS,FITSIO and CALTOOLS ! ! --- AUTHORS/MODIFICATION HISTORY ----------------------------------- ! ! Rehana Yusaf (March 1993)1.0.0 ! Rehana Yusaf (June 21) 1.0.1; Minor changes made for UNIX compiler, ! replacing ((NOT)) with (.NOT.) ! ! Rehana Yusaf (august 2) 1.0.2; Change to subroutine RMF_RMF, and MAN_KEY ! FCERR used for fatal error ! Rehana Yusaf (Nov 1) 1.0.3; Change to subroutine RMF_GP ! Rehana Yusaf (Nov 15) 1.0.4; Change to RMF_GP ! Rehana Yusaf (1993 Dec 6) 1.0.5; Update RMF_RMF - matvals ! array size is increased. Also minor ! modification to scaler routine ! Rehana Yusaf (1994 12 April) 1.0.6; ! . Add ebdfile parameter, to allow for ! Ebounds extension to be in a ! seperate file ! . Add page parameter, the default is ! true, output can be paged, pagelength ! is 23. ! . response can be written as image ! in prmary array of FITS file ! ! Rehana Yusaf (1994 12 Sept) 1.0.7; . add clobber parameter (killit) ! . update ck_file call to add killit ! Rehana Yusaf (1995 Mar 16) 1.0.8; . Bugfix, imagefile option works correctly ! now, killit passed to rmf_img ! Banashree M Seifert (1996 Oct) 1.1.0: ! . modification in one subroutine par_cmd for LINUX ! ! toliver (1998 01 Jun) 1.1.1; Modify subroutine rmf_rmf to display E_MAX ! and E_MIN values above 99.999999 per thread ! ideas/dmprmf_980424 ! Peter D Wilson (1998 July 01) 1.1.2: ! . Updated for new FCPARS behavior ! kaa (1998 Nov 30) 1.1.3: ! . Removed reference to EFFAREA keyword since it is not part of ! the standard ! ngan (1999 Oct 1) 1.1.4: ! . Corrected the wrong size of the full rmf matrix. ! Ziqin Pan (2004 January 6) 1.1.5: ! . Fix a bug when input file not existing ! B.Irby (2005 August 31) 1.1.6: ! . Removed uninitialized variable "defval" (sent to uclpst as garbage) ! and replaced with the (presumably) intended value of "outfile". ! B.Irby (2018 January 11) 1.2.0: ! . Replaced udmget/udmfre with allocate/deallocate ! MFC (2020 Apr 16) 1.2.1 f90 version; lengthened some truncated strings ! ! --------------------------------------------------------------------- character(5) version parameter (version = '1.2.1') character(40) taskname !cc COMMON/task/taskname taskname = 'DMPRMF ' // version !- ! -------------------------------------------------------------------- ! ! --- GET PARAMETERS --- ! context = 'fatal error' termdesc = ' DMPRMF TERMINATED !' cont = .true. call rmf_gp(infile, ebdfile, dispebd, disprmf, disphd, & dispmat, dmpimg, outfile, imagefile, primary, & page, killit, cont, chatter) IF (.NOT.cont) THEN call fcerr(context) call fcecho(termdesc) return ENDIF If (chatter.GE.1) THEN subinfo = ' Main DMPRMF Ver ' // version call fcecho(subinfo) ENDIF ! ! --- DISPLAY RESPONSE DATA --- ! cont = .true. call rmf_disp(infile, ebdfile, dispebd, disprmf, disphd, & dispmat, primary, outfile, page, killit, & cont, chatter) IF (.NOT.cont) THEN call fcerr(context) call fcecho(termdesc) ENDIF ! ! --- DUMP RESPONSE AS IMAGE IF IMAGE FILENAME ENTERED --- ! IF (dmpimg) THEN call rmf_dmpimg(infile, imagefile, taskname, & killit, cont, chatter) ENDIF IF (.NOT.cont) THEN call fcerr(context) call fcecho(termdesc) ENDIF IF (chatter.GE.1) THEN subinfo = ' Program DMPRMF Ver ' // version // ' COMPLETED' call fcecho(subinfo) ENDIF return end ! ! --- END OF MAIN --- ! !+RMF_GP subroutine rmf_gp(infile, ebdfile, dispebd, disprmf, disphd, & dispmat, dmpimg, outfile, imagefile, primary, & page, killit, cont, chatter) ! --------------------------------------------------------------- ! --- DESCRIPTION ----------------------------------------------------- ! ! This routine obtains the user defined paramters by linking with HOST ! ! --- VARIABLES ------------------------------------------------------- ! IMPLICIT NONE character*(*) infile, outfile, ebdfile, imagefile logical dispebd, disprmf, disphd, dispmat integer chatter logical cont, page, dmpimg, primary, killit ! ! --- INTERNALS ------------------------------------------------------- ! character(80) ill_files(5), rmfilename, ebdfilename character(26) errstr character(70) errinfo integer errflag, n_ill, extnum logical ext, valfil ! ! --- VARIABLE DIRECTORY ---------------------------------------------- ! ! infile char : FITS response filename (user defined) ! outfile char : Output filename (Ascii) ! dispebd char : 'Y' if user wants to display EBOUNDS data ! disprmf char : 'Y' if user wants to display RMF data ! dispmat char : 'Y' if user wants to display full matrix ! disphd char : 'Y' if user wants to display full header ! chatter int : Chattines flag, (<5quiet,>20 noisy) ! errflag int : Error flag ! errstr char : Routine error string ! errinfo char : Information about particular error ! cont logical : True if no error is encountered ! ext logical : True if infile exists ! ! --- CALLED ROUTINES ------------------------------------------------- ! ! subroutine UCLGST : (HOST) Obtains string parameter ! subroutine UCLGSI : (HOST) Obtains integer paramter ! subroutine FCECHO : (FTOOLS) Writes to screen ! subroutine CK_FILE: (FTOOLS) Check outfile validity ! ! --- COMPILATION/LINKING --------------------------------------------- ! ! Link with HOST and FTOOLS ! ! --- AUTHORS/MODIFICATION HISTORY ------------------------------------ ! ! Rehana Yusaf (1993 MARCH) ! Rehana Yusaf (1993 August) 1.0.1: CK_FILE added, to allow overwrite ! of existing file, except infile ! Rehana Yusaf (1993 Nov 1) 1.0.2; If no outfile entered do not call ! CK_FILE ! Rehana Yusaf (1993 Nov 15) 1.0.3; If no input file entered then ! return to main ! Rehana Yusaf (1994 April 12) 1.0.4; ! . Add ebdfile parameter ! . Use fcpars, to allow extension number ! to be specified as part of filename ! . Add page parameter ! . Add imagefile parameter ! . Add primary parameter ! ! Rehana Yusaf (1994 Sept 13) 1.0.5; read clobber (killit) ! Peter Wilson (1998 July 01) 1.0.6: Drop INQUIRE. Use ftrtnm instead of fcpars character(5) version parameter (version = '1.0.6') !- ! --------------------------------------------------------------------- ! ! --- GET FILENAME --- ! errstr = ' ERROR : RMF_GP Ver ' // version errflag = 0 call uclgst('infile', infile, errflag) IF (errflag.NE.0) THEN errinfo = errstr // ' ... getting infile parameter' call fcecho(errinfo) cont = .false. return ENDIF call crmvlbk(infile) IF (infile.EQ.' ') THEN errinfo = errstr // ' input file not entered !' call fcecho(errinfo) cont = .false. return ENDIF ! PDW 7/1/98: Drop INQUIRE. Replace fcpars with ftrtnm ! call fcpars(infile,rmfilename,extnum,errflag) call ftrtnm(infile, rmfilename, errflag) ! INQUIRE(FILE=rmfilename,EXIST=ext) ! IF (.NOT.ext) THEN ! errinfo = errstr//' input file does not exist !' ! call fcecho(errinfo) ! cont = .false. ! return ! ENDIF ill_files(1) = rmfilename n_ill = 1 ! ! --- READ EBDFILENAME --- ! call uclgst('ebdfile', ebdfile, errflag) IF (errflag.NE.0) THEN errinfo = errstr // ' ... getting ebdfile parameter' call fcecho(errinfo) cont = .false. return ENDIF call crmvlbk(ebdfile) ! PDW 7/1/98: Drop INQUIRE. Replace fcpars with ftrtnm ! call fcpars(ebdfile,ebdfilename,extnum,errflag) call ftrtnm(ebdfile, ebdfilename, errflag) IF ((ebdfilename.EQ.'%').OR.(ebdfile.EQ.' ')) THEN ebdfile = rmfilename ELSE ! INQUIRE(FILE=ebdfilename,EXIST=ext) ! IF (.NOT.ext) THEN ! errinfo = errstr//' input file does not exist !' ! call fcecho(errinfo) ! cont = .false. ! return ! ENDIF n_ill = n_ill + 1 ill_files(n_ill) = ebdfilename ENDIF ! ! --- GET CHATTER FLAG --- ! errflag = 0 call uclgsi('chatter', chatter, errflag) IF (errflag.NE.0) THEN errinfo = errstr // ' ... getting chatter parameter' call fcecho(errinfo) cont = .false. return ENDIF ! ! --- GET DISPEBD --- ! errflag = 0 call uclgsb('dispebd', dispebd, errflag) IF (errflag.NE.0) THEN errinfo = errstr // ' ... getting dispebd parameter' call fcecho(errinfo) cont = .false. return ENDIF ! ! --- GET DISPRMF --- ! errflag = 0 call uclgsb('disprmf', disprmf, errflag) IF (errflag.NE.0) THEN errinfo = errstr // ' ... getting disprmf parameter' call fcecho(errinfo) cont = .false. return ENDIF ! ! --- GET DISPHD --- ! errflag = 0 call uclgsb('disphd', disphd, errflag) IF (errflag.NE.0) THEN errinfo = errstr // ' ... getting disphd paramter' call fcecho(errinfo) cont = .false. return ENDIF ! ! --- GET DISPMAT INFO IF DISPRMF = 'Y' --- ! IF (disprmf) THEN errflag = 0 call uclgsb('dispmat', dispmat, errflag) IF (errflag.NE.0) THEN errinfo = errstr // ' ... getting dispmat parameter' call fcecho(errinfo) cont = .false. return ENDIF ENDIF ! ! --- GET CLOBBER --- ! killit = .false. errflag = 0 call uclgsb('clobber', killit, errflag) IF (errflag.NE.0) THEN errinfo = errstr // ' ... getting killit parameter' call fcecho(errinfo) cont = .false. return ENDIF ! ! --- GET IMAGEFILE PARAMETER --- ! errflag = 0 call uclgst('imagefile', imagefile, errflag) IF (errflag.NE.0) THEN errinfo = errstr // ' ... getting imagefile parameter' call fcecho(errinfo) cont = .false. return ENDIF call crmvlbk(imagefile) IF (imagefile.EQ.' ') THEN dmpimg = .false. ELSE dmpimg = .true. call ck_file(imagefile, ill_files, n_ill, valfil, killit, chatter) IF (.NOT.valfil) THEN errinfo = errstr // ' invalid imagefilename !' call fcecho(errinfo) cont = .false. return ENDIF n_ill = n_ill + 1 ill_files(n_ill) = imagefile ENDIF ! ! --- GET OUTPUT FILENAME --- ! errflag = 0 call uclgst('outfile', outfile, errflag) IF (errflag.NE.0) THEN errinfo = errstr // ' ... getting output filename parameter' call fcecho(errinfo) cont = .false. return ENDIF ! ! --- CHECK OUTFILE--- ! call crmvlbk(outfile) valfil = .true. IF (outfile.NE.' ') THEN call ck_file(outfile, ill_files, n_ill, valfil, killit, chatter) IF (dmpimg) THEN IF (outfile.EQ.imagefile) THEN errinfo = errstr // 'outfile name same as imagefile' call fcecho(errinfo) errinfo = ' differant names should be used' call fcecho(errinfo) cont = .false. return ENDIF ENDIF IF (.NOT.valfil) THEN errinfo = errstr // ' invalid outfile name !' call fcecho(errinfo) cont = .false. return ENDIF errflag = 0 call uclpst('outfile', outfile, errflag) IF (errflag.NE.0) THEN errinfo = errstr // '... writing default output filename ' call fcecho(errinfo) cont = .false. return ENDIF n_ill = n_ill + 1 ill_files(n_ill) = outfile ENDIF ! !--- GET PAGE PARAMETER --- ! call uclgsb('page', page, errflag) IF (errflag.NE.0) THEN errinfo = errstr // ' ... getting page parameter' call fcecho(errinfo) cont = .false. return ENDIF call uclpsb('page', .true., errflag) IF (errflag.NE.0) THEN errinfo = errstr // ' ... putting default page parameter' call fcecho(errinfo) cont = .false. return ENDIF call uclgsb('primary', primary, errflag) IF (errflag.NE.0) THEN errinfo = errstr // '... getting primary parameter' call fcecho(errinfo) cont = .false. return ENDIF return end ! ! --- END OF RMF_GP --------------------------------------------------- ! !+RMF_DISP subroutine rmf_disp(infile, ebdfile, dispebd, disprmf, disphd, & dispmat, primary, outfile, page, killit, & cont, chatter) ! ----------------------------------------------------------------- ! --- DESCRIPTION ------------------------------------------------------ ! ! This routine displays the response data, it displays ... ! EBOUNDS extension header, and EBOUNDS data columns, and ! RMF extension header, and RMF data columns. ! ! --- VARIABLES -------------------------------------------------------- ! IMPLICIT NONE character*(*) infile, outfile, ebdfile logical dispebd, disprmf, disphd, dispmat, killit integer chatter logical cont, page, primary ! ! --- INTERNAL VARIABLES --- ! integer status, iunit, ierr, ounit, rw, block, ln_cnt character(30) subinfo character(28) errstr character(50) wrnstr character(70) errinfo logical wtfile ! ! --- VARIABLE DIRECTORY ----------------------------------------------- ! ! Arguments ... ! ! infile char : FITS RMF filename (user defined) ! outfile char : Output filename, ascii ! dispebd char : 'Y' if user wants to display EBOUNDS data ! disprmf char : 'Y' if user wants to display RMF data ! disphd char : 'Y' if user wants to display full header ! dispmat char : 'Y' if user wants to display full matrix ! chatter int : Chattiness flag (>20 noisy) ! cont logical : True if no error encoutered ! ! Internals ... ! ! subinfo char : Routine info for user ! errstr char : Error string for this routine ! wrnstr char : warning string for this routine ! errinfo char : Error info for a particular error ! status int : Error flag ! rw int : Read/Write mode for FITS file, O=readonly ! block int : FITSIO record blocking factor ! iunit int : Fortran i/o unit ! wtfile logical : True if writing to output file ! ! --- CALLED ROUTINES -------------------------------------------------- ! ! subroutine FCECHO : (FTOOLS) Writes string to screen ! subroutine FTOPEN : (FITSIO) Opens FITS file ! subroutine WT_FERRMSG : (CALLIB) Writes FITSIO and routine error messages ! subroutine RMF_PRHD : Prints primary header ! subroutine RMF_EBD : Displays EBOUNDS extension ! subroutine RMF_RMF : Displays RMF extension ! ! --- LINKING/COMPILATION ---------------------------------------------- ! ! Linking with FTOOLS and FITSIO ! ! --- AUTHORS/MODIFICATION --------------------------------------------- ! ! Rehana Yusaf (1993 March) ! Rehana Yusaf (1993 May 3) ! Rehana Yusaf (1994 April 12) ; Add ebdfile parameter and page parameter ! Add primary - only display primary ! header if primary='yes' ! Rehana Yusaf (1994 Sept 13) ; pass in killit character(5) version parameter (version = '1.0.2') !- ! ---------------------------------------------------------------------- ! ! --- USER INFO --- ! IF (chatter.GE.10) THEN subinfo = ' ... using RMF_DISP Ver ' // version call fcecho(subinfo) ENDIF errstr = ' ERROR : RMF_DISP Ver ' // version wrnstr = ' WARNING : RMF_DISP Ver ' // version ! ! --- DISPLAY PRIMARY HEADER IF USER CHOOSES TO DISPLAY IT --- ! IF (primary) THEN status = 0 rw = 0 block = 2880 call cgetlun(iunit) call ftopen(iunit, infile, rw, block, status) errinfo = errstr // ' ... opening RMF file ' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. return ENDIF ENDIF ! ! --- OPEN OUTPUT FILE --- ! IF (outfile.EQ.' ') THEN wtfile = .false. ELSE wtfile = .true. ierr = 0 call cgetlun(ounit) call opasci(ounit, outfile, 2, 80, killit, chatter, ierr) ! open (UNIT=ounit,FILE=outfile,STATUS='new',IOSTAT=ierr) IF (ierr.NE.0) THEN errinfo = errstr // ' ... opening output file' call fcecho(errinfo) cont = .false. return ENDIF ENDIF ! ! --- READ AND DISPLAY PRIMARY HEADER --- ! ln_cnt = 0 IF (primary) THEN call rmf_prhd(iunit, ounit, wtfile, page, ln_cnt, chatter) status = 0 call ftclos(iunit, status) errinfo = errstr // ' ... closing RMF file' call wt_ferrmsg(status, errinfo) ENDIF ! ! --- READING AND DISPLAYING EBOUNDS EXTENSION IF DISPEBD = 'Y'--- ! cont = .true. IF (dispebd) THEN call rmf_ebd(ebdfile, disphd, ounit, wtfile, & page, ln_cnt, cont, chatter) IF (.not.cont) THEN errinfo = errstr // ' EBOUNDS display not completed !' call fcecho(errinfo) cont = .true. ENDIF ENDIF ! ! --- READING AND DISPLAYING RMF EXTENSION IF DISPRMF = 'Y'--- ! cont = .true. IF (disprmf) THEN call rmf_rmf(infile, disphd, dispmat, & ounit, wtfile, page, ln_cnt, & cont, chatter) IF (.NOT.cont) THEN errinfo = errstr // ' RMF display not completed !' call fcecho(errinfo) cont = .true. ENDIF ENDIF ! ! --- CLOSE OUTPUT FILE ! close(ounit, IOSTAT = ierr) return end ! ! --- END OF RMF_DISP ---------------------------------------------- ! !+RMF_PRHD subroutine rmf_prhd(iunit, ounit, wtfile, page, ln_cnt, chatter) ! ---------------------------------------------------------- ! --- DESCRIPTION -------------------------------------------------- ! ! This routine reads and writes the primary header array. It ! displays keywords to the screen ... ! ! SIMPLE : Does the FITS file conform to all FITS standards ! BITPIX : Number of bits per pixel ! NAXIS : Number of data axes ! EXTEND : T, True if there may be extensions following PRIMARY ! DATE : Date ! CONTENT : File contents ! RMFVERSN : OGIP FITS version ! ORIGIN : Place of File creation ! ! --- VARIABLES ---------------------------------------------------- ! IMPLICIT NONE integer iunit, chatter, ounit, ln_cnt logical wtfile, page ! ! --- INTERNALS ---------------------------------------------------- ! integer status, key_no, ierr logical endhead character(80) card, header, line, subinfo, desc character(30) errstr ! ! --- VARIABLE DIRECTORY ------------------------------------------- ! ! Arguments ... ! ! iunit int : Fortran input unit ! ounit int : Fortran output unit ! chatter int : chattiness flag, > 20 verbose ! wtfile logical: True if writing to output file ! ! Internals ... ! ! status int : FITSIO error flag ! key_no int : Record/Card No to be read from file ! card char : Current card ! header char : Used for output purposes ! line char : Used for underline output purposes ! endhead logical: endhead = .true. when end of primary header ! subinfo char : Routine information ! errstr char : Routine Error string ! ! --- CALLED ROUTINES ---------------------------------------------- ! ! subroutine FTGREC : (FITSIO) Routine to read FITS record ! subroutine WT_FERRMSG: (CALTOOLS) Routine to write routine and ! FITSIO error messages ! subroutine FCECHO : (FTOOLS), standalone write to screen ! ! --- LINKING AND COMPILATION -------------------------------------- ! ! FTOOLS, FITSIO and CALTOOLS ! ! --- AUTHORS/MODIFICATION HISTORY --------------------------------- ! ! Rehana Yusaf (1993 March) ! Rehana Yusaf (1994 April 13) 1.0.1; Add page and ln_cnt arguments ! USE pg_fcecho to page output character(5) version parameter (version = '1.0.1') !- ! ------------------------------------------------------------------ ! ! --- USER INFO --- ! IF (chatter.GE.10) THEN subinfo = ' ... using RMF_PRHD Ver ' // version call fcecho(subinfo) ENDIF errstr = ' ERROR : RMF_PRHD Ver ' // version ! ! --- READ AND DISPLAY PRIMARY HEADER --- ! endhead = .false. key_no = 1 line = ' -------------- ' call pg_fcecho(line, page, ln_cnt, status) IF (status.NE.0) THEN return ENDIF IF (wtfile) THEN write(ounit, 100, IOSTAT = ierr) line ENDIF header = ' PRIMARY HEADER ' call pg_fcecho(header, page, ln_cnt, status) IF (status.NE.0) THEN return ENDIF call pg_fcecho(line, page, ln_cnt, status) IF (status.NE.0) THEN return ENDIF IF (wtfile) THEN write(ounit, 100, IOSTAT = ierr) header write(ounit, 100, IOSTAT = ierr) line ENDIF header = ' ' call pg_fcecho(header, page, ln_cnt, status) IF (status.NE.0) THEN return ENDIF IF (wtfile) THEN write(ounit, 100, IOSTAT = ierr) header ENDIF do WHILE (.NOT.endhead) status = 0 call ftgrec(iunit, key_no, card, status) call wt_ferrmsg(status, errstr) IF (status.EQ.0) THEN call pg_fcecho(card, page, ln_cnt, status) IF (status.NE.0) THEN return ENDIF IF (wtfile) THEN write(ounit, 100, IOSTAT = ierr) card ENDIF ELSE desc = errstr // ' invalid record encountered in header' call pg_fcecho(desc, page, ln_cnt, status) IF (wtfile) THEN write(ounit, 100, IOSTAT = ierr) desc ENDIF status = 0 ENDIF IF (card(1:3).EQ.'END') THEN endhead = .true. ENDIF key_no = key_no + 1 enddo 100 format(A80) return end ! ! --- END OF SUBROUTINE RMF_PRHD --------------------------------- ! !+RMF_EBD subroutine rmf_ebd(ebdfile, disphd, ounit, & wtfile, page, ln_cnt, cont, chatter) ! --------------------------------------------------- ! --- DESCRIPTION ------------------------------------------------ ! ! This routine reads,and displays the EBOUNDS header and ! data. If disphd (user defined) is 'Y' then the full header ! is displayed, otherwise only the standard OGIP keywords are ! displayed. ! ! --- VARIABLES -------------------------------------------------- ! IMPLICIT NONE integer iunit, chatter, ounit, ln_cnt logical disphd character*(*) ebdfile logical cont, wtfile, page ! ! --- INTERNALS -------------------------------------------------- ! character(26) errstr character(50) wrnstr character(70) errinfo, subinfo character(70) ebdchan character(80) card, header, data, blank, line character(40) comm integer status, key_no, chancol, emincol, emaxcol integer npha, chanval, ran1, ran2 integer felem, nelems, inull, row, perr, ierr real eminval, emaxval, enull logical endhead, anyflg ! VARIABLES FOR MVEXT integer nsearch, ninstr parameter (nsearch = 50) integer next(nsearch) character(20) extnames(nsearch), outhdu(9, nsearch) character(20) outver(nsearch), instr(9) character(20) extname ! ! --- VARIABLE DIRECTORY ----------------------------------------- ! ! Arguments ... ! ! iunit int : Fortran i/o unit ! disphd char : 'Y' if user wants to display full header ! outfile char : User defined output filename, default to screen ! chatter int : Chattines flag (>20 verbose) ! ounit int : Fortran i/o unit ! ! Internals ... ! ! errstr char : Routine error string ! wrnstr char : Routine warning string ! errinfo char : Additional error information ! blank char : Used for blank line output ! line char : Used for underline output ! card char : FITS record ! header char : Used for output ! data char : Used for outputing data ! comm char : FITSIO comments ! extname char : FITS extension name ! chnum char : Char used for outputing Channel numbers ! cmin char : Char used for outputing E_MIN values ! cmax char : Char used for outputing E_MAX values ! status int : FITSIO error flag ! nhdu int : No. of header unit ! htype int : Header unit type ! key_no int : Record number ! chancol int : "CHANNEL" Column No. ! emincol int : "E_MIN" Column No. ! emaxcol int : "E_MAX" Column No. ! npha int : Counter for number of pha values ! snum int : Start number for reading TTYPEx ,x starts at snum ! ncols int : Number of data columns in extension ! chanval int : Channel value ! eminval real : E_MIN value ! emaxval real : E_MAX value ! felem int : First pixel of vector, for FITSIO read ! nelems int : Number of data items to read ! inull int : Null value ! enull real : real null value ! row int : Row number ! findext logical: TRUE if desired extension found ! endhead logical: TRUE if pointer at end of header ! anyflg logical: TRUE if any returned data values are undefined ! foundcol logical: TRUE if desired column found ! ! --- CALLED ROUTINES -------------------------------------------- ! ! subroutine FTMAHD : (FITSIO) Move to header unit ! subroutine FTGKYx : (FITSIO) To read keyword of type x, ! for example s (string) ! subroutine FTGREC : (FITSIO) Reads FITS record ! subroutine FTGCVx : (FITSIO) Reads data column of type x ! subroutine WT_FERRMSG: (CALTOOLS) Writes FITSIO and routine ! error message if appropriate ! subroutine FCECHO : (FTOOLS) standalone screen write ! subroutine MAN_KEY : Writes mandatory keywords, if necessary ! subroutine MVEXT : (CALLIB) Open infile and move to desired ! extension ! ! --- COMPILATION AND LINKING ------------------------------------ ! ! Link with FTOOLS and FITSIO and CALTOOLS ! ! --- AUTHORS/MODIFICATION HISTORY ------------------------------- ! ! Rehana Yusaf (1993 March 19) ! Rehana Yusaf (1994 April 13) 1.0.1; Add page and ln_cnt arguments ! . Add mvext ! . Use pg_fcecho to page output ! . format for E_MIN E_MAX display ! changed from f10.7 to f12.7 ! to allow more dynamic range ! Rehana Yusaf (1994 May 24) 1.0.2; mvext has an additional passsed ! parameter character(5) version parameter (version = '1.0.2') !- ! ---------------------------------------------------------------- ! ! --- INITIALISATION --- ! errstr = ' ERROR : RMF_EBD Ver ' // version wrnstr = ' WARNING : RMF_EBD Ver ' // version blank = ' ' ! ! --- USER INFO --- ! IF (chatter.GE.10) THEN subinfo = ' ... using RMF_EBD Ver ' // version call fcecho(subinfo) ENDIF ! ! --- MOVE TO EBOUNDS EXTENSION IN FILE --- ! status = 0 ninstr = 2 instr(1) = 'RESPONSE' instr(2) = 'EBOUNDS' extname = 'EBOUNDS' call mvext(0, ebdfile, iunit, ninstr, instr, nsearch, next, outhdu, & extnames, outver, extname, status, chatter) IF (status.NE.0) THEN cont = .false. return ENDIF ! ! --- READ HEADER AND DISPLAY FULL HEADER IF DISPHD = 'Y'--- ! IF (disphd) THEN line = ' ----------------------------- ' IF (wtfile) THEN write(ounit, 400, IOSTAT = ierr) blank write(ounit, 400, IOSTAT = ierr) line ENDIF call pg_fcecho(blank, page, ln_cnt, status) IF (status.NE.0) THEN goto 100 ENDIF call pg_fcecho(line, page, ln_cnt, status) IF (status.NE.0) THEN goto 100 ENDIF header = ' FULL EBOUNDS EXTENSION HEADER ' IF (wtfile) THEN write(ounit, 400, IOSTAT = ierr) header write(ounit, 400, IOSTAT = ierr) line write(ounit, 400, IOSTAT = ierr) blank ENDIF call pg_fcecho(header, page, ln_cnt, status) IF (status.NE.0) THEN goto 100 ENDIF call pg_fcecho(line, page, ln_cnt, status) IF (status.NE.0) THEN goto 100 ENDIF call pg_fcecho(blank, page, ln_cnt, status) IF (status.NE.0) THEN goto 100 ENDIF key_no = 1 endhead = .false. do WHILE (.NOT.endhead) status = 0 call ftgrec(iunit, key_no, card, status) call pg_fcecho(card, page, ln_cnt, status) IF (status.NE.0) THEN goto 100 ENDIF IF (wtfile) THEN write(ounit, 400, IOSTAT = ierr) card endif IF (card(1:3).EQ.'END') THEN endhead = .true. ENDIF key_no = key_no + 1 enddo ELSE ! ! --- READ MANDATORY HEADER KEYWORDS, DISPLAY IF DISPHD = 'N' --- ! call man_key(iunit, extname, ounit, wtfile, & page, ln_cnt, chatter) ENDIF ! ! --- READ AND DISPLAY EBOUNDS DATA, CHAN,E_MIN,E_MAX --- ! status = 0 call ftgkyj(iunit, 'NAXIS2', npha, comm, status) errinfo = errstr // ' ... getting Naxis2 parameter' call wt_ferrmsg(status, errinfo) status = 0 ! ! --- GET RANGE OF CHANNELS TO BE DISPLAYED --- ! call pg_fcecho(blank, page, ln_cnt, status) IF (status.NE.0) THEN goto 100 ENDIF 20 status = 0 call uclgst('ebdchan', ebdchan, status) IF (status.NE.0) THEN errinfo = errstr // ' ... getting ebdchan parameter' call fcecho(errinfo) ENDIF perr = 0 call ftupch(ebdchan) call crmvlbk(ebdchan) IF (ebdchan(1:3).NE.'ALL') THEN call par_cmd(ebdchan, ran1, ran2, perr, npha) IF (perr.NE.0) THEN errinfo = errstr // 'invalid command syntax' call fcecho(errinfo) errinfo = ' SYNTAX : minchan - maxchan ' call fcecho(errinfo) errinfo = ' For example : 1-20' call fcecho(errinfo) errinfo = ' Try Again !' call fcecho(errinfo) goto 20 ENDIF ELSE ran1 = 1 ran2 = npha ENDIF ! ! --- FIND COLUMN NUMBERS FOR CHANNEL,E_MIN and E_MAX --- ! status = 0 call ftgcno(iunit, .FALSE., 'CHANNEL', chancol, status) errinfo = errstr // ' error finding CHANNEL COLUMN !' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. return ENDIF status = 0 call ftgcno(iunit, .FALSE., 'E_MIN', emincol, status) errinfo = errstr // ' error finding E_MIN COLUMN !' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. return ENDIF status = 0 call ftgcno(iunit, .FALSE., 'E_MAX', emaxcol, status) errinfo = errstr // ' error finding E_MAX COLUMN !' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. return ENDIF ! ! --- READ AND DISPLAY DATA ROW AT A TIME --- ! IF (wtfile) THEN write(ounit, 400, IOSTAT = ierr) blank ELSE call pg_fcecho(blank, page, ln_cnt, status) IF (status.NE.0) THEN goto 100 ENDIF ENDIF line = ' ------------------------------------' header = ' CHANNEL E_MIN keV E_MAX keV' IF (wtfile) THEN write(ounit, 400, IOSTAT = ierr) line write(ounit, 400, IOSTAT = ierr) header write(ounit, 400, IOSTAT = ierr) line ELSE call pg_fcecho(line, page, ln_cnt, status) IF (status.NE.0) THEN goto 100 ENDIF call pg_fcecho(header, page, ln_cnt, status) IF (status.NE.0) THEN goto 100 ENDIF call pg_fcecho(line, page, ln_cnt, status) IF (status.NE.0) THEN goto 100 ENDIF ENDIF felem = 1 nelems = 1 do row = ran1, ran2 ! --- READ ROW OF DATA status = 0 inull = 0 call ftgcvj(iunit, chancol, row, felem, nelems, inull, chanval, & anyflg, status) enull = 0 status = 0 call ftgcve(iunit, emincol, row, felem, nelems, enull, eminval, & anyflg, status) enull = 0 status = 0 call ftgcve(iunit, emaxcol, row, felem, nelems, enull, emaxval, & anyflg, status) ! --- DISPLAY ROW OF DATA ierr = 0 write(data, 300, IOSTAT = ierr) chanval, eminval, emaxval IF (ierr.NE.0) THEN errinfo = errstr // ' error writing data row ' call fcecho(errinfo) write(ounit, 400, IOSTAT = ierr) errinfo ELSE IF (.NOT.wtfile) THEN call pg_fcecho(data, page, ln_cnt, status) IF (status.NE.0) THEN goto 100 ENDIF ELSE write(ounit, 400, IOSTAT = ierr) data ENDIF ENDIF enddo 100 status = 0 call ftclos(iunit, status) errinfo = errstr // ' closing EBOUNDS file' call wt_ferrmsg(status, errinfo) ! 200 format(f7.4) 300 format(I4, 6X, f12.7, 3X, f12.7) 400 format(A80) return end ! ! --- END OF SUBROUTINE RMF_EBD ---------------------------------- ! !+MAN_KEY subroutine man_key(iunit, extname, ounit, wtfile, & page, ln_cnt, chatter) ! ------------------------------------------------------ ! --- DESCRIPTION ------------------------------------------------- ! ! This routine reads and displays OGIP mandatory Keywords ... ! ! TELESCOP : Mission/Telescope name ! INSTRUME : Instrument/Detector name ! RMFVER : OGIP FITS version ! FILTER : Filter status ! DETCHANS : No. of PHA entries ! ! --- VARIABLES --------------------------------------------------- ! IMPLICIT NONE integer iunit, chatter, ounit, ln_cnt character(8) extname logical wtfile, page ! ! --- INTERNALS --------------------------------------------------- ! character(26) errstr, comm character(8) telescop, instrume, rmfver, filter character(10) cnum character(80) header, blank, line, subinfo, errinfo integer status, detchans, erange, ierr ! ! --- VARIABLE DIRECTORY ------------------------------------------ ! ! Arguments ... ! ! iunit int : Fortran input unit ! extname char : Character name ! ! Internals ... ! ! telescop char : Mission/Telescope name ! instrume char : Instrument/Detector name ! rmfver char : OGIP version of FITS file ! filter char : Filter, if not present NONE ! detchans int : No. of Pha entries ! cnum char : Character used for output for integer value,detchans ! header char : Used for each line of output, using FCECHO ! blank char : Used for blank line output ! line char : Used for underline output ! status int : FITSIO Error flag ! ! --- CALLED ROUTINES --------------------------------------------- ! ! subroutine FTGKYx : (FITSIO) Reads Keywords of type x ! subroutine FCECHO : (FTOOLS), standalone write to screen ! subroutine WT_FERRMSG : (CALTOOLS), writes routine and FITS error ! message if necessary ! ! --- COMPILATION AND LINKING ------------------------------------- ! ! Link with FTOOLS,FITSIO and CALTOOLS ! ! --- AUTHORS/MODIFICATION HISTORY -------------------------------- ! ! Rehana Yusaf (1993 March 19) ! Rehana Yusaf (1993 August 2) 1.0.1; Minor change to detector/instrume ! display, add space ! Rehana Yusaf (1994 April 13) 1.0.2; Add page and ln_cnt arguments character(5) version parameter (version = '1.0.2') !- ! ----------------------------------------------------------------- ! ! --- USER INFO --- ! IF (chatter.GE.10) THEN subinfo = ' ... using MAN_KEY Ver ' // version call fcecho(subinfo) ENDIF errstr = ' ERROR : MAN_KEY Ver ' // version ! ! --- READ MANDATORY KEYWORDS --- ! blank = ' ' status = 0 call ftgkys(iunit, 'TELESCOP', telescop, comm, status) status = 0 call ftgkys(iunit, 'INSTRUME', instrume, comm, status) status = 0 call ftgkys(iunit, 'FILTER', filter, comm, status) status = 0 call ftgkys(iunit, 'RMFVERSN', rmfver, comm, status) status = 0 call ftgkyj(iunit, 'DETCHANS', detchans, comm, status) IF ((extname.EQ.'SPECRESP').OR.& (extname.EQ.'MATRIX')) THEN status = 0 call ftgkyj(iunit, 'NAXIS2', erange, comm, status) ENDIF ! ! --- DISPLAY MANDATORY HEADER KEYWORDS --- ! call fcecho(blank) IF (wtfile) THEN write(ounit, 300, IOSTAT = ierr) blank ENDIF line = ' ------------------------------------- ' call fcecho(line) IF (wtfile) THEN write(ounit, 300, IOSTAT = ierr) line ENDIF header = ' MANDATORY ' // extname // ' HEADER INFORMATION ' call fcecho(header) call fcecho(line) call fcecho(blank) IF (wtfile) THEN write(ounit, 300, IOSTAT = ierr) header write(ounit, 300, IOSTAT = ierr) line write(ounit, 300, IOSTAT = ierr) blank ENDIF header = ' Detector Identity : ' // telescop // ' '& // instrume call fcecho(header) IF (wtfile) THEN write(ounit, 300, IOSTAT = ierr) header ENDIF ierr = 0 write(cnum, 100, IOSTAT = ierr) detchans call crmvlbk(cnum) IF (ierr.NE.0) THEN errinfo = errstr // ' error writing detchans' call fcecho(errinfo) IF (wtfile) THEN write(ounit, 300, IOSTAT = ierr) errinfo ENDIF ierr = 0 ELSE header = ' No. of PHA Channels : ' // cnum call fcecho(header) IF (wtfile) THEN write(ounit, 300, IOSTAT = ierr) header ENDIF ENDIF call crmvlbk(filter) header = ' Filter : ' // filter call fcecho(header) IF (wtfile) THEN write(ounit, 300, IOSTAT = ierr) header ENDIF IF ((extname.EQ.'SPECRESP').OR.(extname.EQ.'MATRIX')) THEN write(cnum, 100, IOSTAT = ierr) erange call crmvlbk(cnum) IF (ierr.NE.0) THEN errinfo = errstr // ' writing energy ranges' call fcecho(errinfo) IF (wtfile) THEN write(ounit, 300, IOSTAT = ierr) errinfo ENDIF ierr = 0 ELSE header = ' No. of Energy Ranges : ' // cnum call fcecho(header) IF (wtfile) THEN write(ounit, 300, IOSTAT = ierr) header ENDIF ENDIF ENDIF call crmvlbk(rmfver) header = ' OGIP version of FITS : ' // rmfver call fcecho(header) IF (wtfile) THEN write(ounit, 300, IOSTAT = ierr) header ENDIF 100 format(I4) !200 format(f7.4) 300 format(A80) return end ! ! --- END OF SUBROUTINE MAN_KEY ------------------------------------ ! !+GET_NPHA subroutine get_npha(iunit, npha) ! ------------------------------- ! integer iunit, npha character(8) extname integer nhdu, htype, status logical findext character(30) comm ! ! ! !- nhdu = 2 findext = .false. do WHILE(.NOT.findext) status = 0 call ftmahd(iunit, nhdu, htype, status) call ftgkys(iunit, 'EXTNAME', extname, comm, status) IF (extname.EQ.'EBOUNDS'.OR.extname.EQ.'SPECRESP'& .OR.extname.EQ.'MATRIX') THEN findext = .true. ENDIF enddo call ftgkyj(iunit, 'DETCHANS', npha, comm, status) return end !+RMF_RMF subroutine rmf_rmf(infile, disphd, dispmat, & ounit, wtfile, page, & ln_cnt, cont, chatter) ! -------------------------------------------------------- ! --- DESCRIPTION ------------------------------------------------------ ! ! This routine reads and displays the RMF extension of a FITS format ! RESPONSE file. ! ! --- VARIABLES -------------------------------------------------------- ! IMPLICIT NONE integer iunit, chatter, ounit, ln_cnt character*(*) infile logical disphd, dispmat logical cont, wtfile, page ! ! --- INTERNALS -------------------------------------------------------- ! character(30) errstr, wrnstr character(80) errinfo, blank, line, header, card, subinfo character(80) datastr, undline character(70) rmfener character(40) comm character(9) teff, curgrp, cscale character(10) cmin, cmax character(4) cgrp character(5) cresp, cbin1, cbin2 integer felem, nelems, inull, row, fchancol, nchancol, i, k, l integer nrmf, mincol, emaxcol, grpcol, matcol integer maxgrp, maxmat, tempfin parameter (maxgrp = 256) parameter (maxmat = 4096) integer status, key_no, stnum, finum, counter, ran1, ran2 !integer*2 resp, binlo, binhi, st, fin, counter2 integer resp, binlo, binhi, st, fin, counter2 real enull, eminval, emaxval, matvals(maxmat), eff, scale integer grpval, fchans(maxgrp), nchans(maxgrp), perr, ierr logical endhead, anyflg, enddata ! VARIABLES FOR MVEXT integer nsearch, ninstr parameter (nsearch = 50) integer next(nsearch), extnum, htype character(20) extnames(nsearch), outhdu(9, nsearch) character(20) outver(nsearch), instr(9) character(16) extname ! ! --- VARIABLE DIRECTORY ----------------------------------------------- ! ! Arguments ... ! ! iunit int : Fortran input unit ! ounit int : Fortran i/o unit ! chatter int : Chatter flag (>20 verbose) ! outfile char : Output filename, default is no ootput file ! disphd char : 'Y' if user wants to display full header ! dispmat char : 'Y' if user want to display full matrix ! cont logical: True if no error is encountered ! wtfile logical: True if writing to file ! ! Internals ... ! ! subinfo char : User information about routine ! errstr char : Error string for this routine ! wrnstr char : Warning string for this routine ! errinfo char : additional error information ! blank char : Used for blank line output to screen ! line char : Used for underline output to screen ! header char : Used for screen output ! card char : For reading record from FIT file ! datastr char : String containing data for screen output ! undline char : For underline screen output ! comm char : For reading comment field of FITS record ! extname char : FITS extension name ! eminval real : Minimum energy value ! emaxval real : Maximum energy value ! eff real : Sum of Channels for group ! grpval int : No. of groups in energy row ! scale real : Scaling factor used to scale data read from file ! resp int : No. of response values ! binlo int : Lower bin range of a group ! binhi int : Upper bin range of a group ! cmin char : Used for output of eminval ! cmax char : Used for output of emaxval ! teff char : Used for output of eff ! curgrp char : Current group No. ! cgrp char : For output of grpval value ! cresp char : For output of resp value ! cbin1 char : For output of binlo value ! cbin2 char : Used for binhi output ! fchans int : Array of starting channel for each respective group ! nchans int : Array of number of channels in each group ! maxgrp int : Array dimension for fchans and nchans ! maxmat int : Array dimension for matvals ! matvals real : Array of Matrix values for a group ! fchancol int : Column number of fchans ! nchancol int : Column number of nchans ! mincol int : Column number of eminval ! emaxcol int : Column number of emaxval ! grpcol int : Column number of grpval ! matcol int : Column number of matvals ! nrmf int : Counter for number of RMF data rows ! row int : Loop counter ! felem int : First pixel of element vector to be read ! nelems int : Number of elements to be read ! inull int : Null integer value for fitsio ! enull real : Null real value for fitsio ! snum int : Starting number for reading Keywords ! ncols int : Number of columns in extension ! nhdu int : Header number unit ! status int : Error status flag ! htype int : Type of hdu ! key_no int : Sequence number of keyword record ! rmfener char : User command, energy range ! ran1 int : Lower value of range to be displayed ! ran1 int : Upper range value ! findext logical: TRUE when desired extension is found ! endhead logical: True when end of extension header ! anyflg logical: Set to true by fitsio when any of the ! returned data values are undefined ! foundcol logical: True when column found ! enddata logical: True when all the channel in a group have ! been displayed on the screen ! ! ! --- CALLED ROUTINES -------------------------------------------------- ! ! subroutine FTMAHD : (FITSIO) Move to header unit ! subroutine FTGKYx : (FITSIO) To read keyword of type x, ! for example s (string) ! subroutine FTGREC : (FITSIO) Reads FITS record ! subroutine FTGCVx : (FITSIO) Reads data column of type x ! subroutine WT_FERRMSG : (CALTOOLS) Writes FITSIO and routine ! error message if appropriate ! subroutine FCECHO : (FTOOLS) standalone screen write ! subroutine MAN_KEY : Writes mandatory keywords, if necessary ! subroutine MVEXT : (CALLIB) Open infile and move to desired ! extension ! subroutine MVER : (CALLIB) Move to desired extension, assuming ! file is already open ! ! ! --- LINKING/COMPILATION ---------------------------------------------- ! ! Link with FITSIO,FTOOLS and CALTOOLS ! ! --- AUTHORS/MODIFICATION HISTORY ------------------------------------- ! ! Rehana Yusaf (1993 March 19) ! Rehana Yusaf (1993 August 2) 1.0.1; Fix bug, full header is now ! displayed to file, if requested. ! Rehana Yusaf (1993 Dec 6) 1.0.1; Increase matvals array size (should ! be as large as DETCHANS) ! Rehana Yusaf (1994 April 13) 1.0.2; Add page and ln_cnt arguments ! Add mvext ! add pg_fcecho ! Rehana Yusaf (1994 May 24) 1.0.3;MVEXT has an additional passed ! parameter, rwmode ! MVER added to move to MATRIX extension ! if not SPECRESP ext ! DISPMAT no longer redundant, if "N" ! then a concise rmf display ! toliver (1998 01 Jun) 1.0.4; Increased sizes of CMIN and CMAX arrays and ! format field size to allow displaying of E_MAX ! and E_MIN values above 99.999999 per thread ! ideas/dmprmf_980424 ! ! James Peachey (1999 Sep 9) 1.0.5; Increased by one character the ! width of output format in rmf_rmf to accomodate Astro-E rmfs. ! character(5) version parameter (version = '1.0.5') !- ! ---------------------------------------------------------------------- ! ! --- USER INFO --- ! IF (chatter.GE.10) THEN subinfo = ' ... using RMF_RMF Ver ' // version call fcecho(subinfo) ENDIF ! ! --- MOVE TO MATRIX EXTENSION --- ! errstr = ' ERROR : RMF_RMF Ver ' // version wrnstr = ' WARNING : RMF_RMF Ver ' // version blank = ' ' ninstr = 2 instr(1) = 'RESPONSE' instr(2) = 'RSP_MATRIX' status = 0 extname = 'SPECRESP MATRIX' call mvext(0, infile, iunit, ninstr, instr, nsearch, next, & outhdu, extnames, outver, extname, status, chatter) IF(status.eq.1) THEN cont = .false. goto 70 endif IF (status.NE.0) THEN status = 0 call ftmahd(iunit, 1, htype, status) subinfo = errstr // 'moving to primary extension' call wt_ferrmsg(status, subinfo) IF (status.NE.0) THEN goto 70 ENDIF extname = 'MATRIX' extnum = 0 call mver(iunit, extnum, ninstr, instr, nsearch, next, & outhdu, extnames, outver, extname, status, chatter) IF (status.NE.0) THEN cont = .false. goto 70 ENDIF ENDIF ! ! --- READ AND DISPLAY FULL HEADER IF DISPHD = 'Y'--- ! IF (disphd) THEN line = ' ------------------------------------ ' call pg_fcecho(blank, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF call pg_fcecho(line, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) blank write(ounit, 500, IOSTAT = ierr) line ENDIF header = ' FULL SPECRESP/MATRIX EXTENSION HEADER ' call pg_fcecho(header, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF call pg_fcecho(line, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF call pg_fcecho(blank, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) header write(ounit, 500, IOSTAT = ierr) line write(ounit, 500, IOSTAT = ierr) blank ENDIF key_no = 1 endhead = .false. do WHILE (.NOT.endhead) status = 0 call ftgrec(iunit, key_no, card, status) call pg_fcecho(card, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) card ENDIF IF (card(1:3).EQ.'END') THEN endhead = .true. ENDIF key_no = key_no + 1 enddo ELSE ! ! --- READ MANDATORY HEADER KEYWORDS, AND DISPLAY THEM --- ! call man_key(iunit, extname, ounit, wtfile, & page, ln_cnt, chatter) ENDIF ! ! --- GET No. OF ENERGY ROWS ! status = 0 call ftgkyj(iunit, 'NAXIS2', nrmf, comm, status) errinfo = errstr // ' reading No. of energy rows !' call wt_ferrmsg(status, errstr) IF (status.NE.0) THEN cont = .false. goto 70 ENDIF ! ! --- OBTAIN RMFENER, THE RANGE OF ENERGYS TO BE DISPLAYED --- ! IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) blank ENDIF call pg_fcecho(blank, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF 20 status = 0 call uclgst('rmfener', rmfener, status) IF (status.NE.0) THEN errinfo = errstr // ' ... getting rmfener parameter' call fcecho(errinfo) ENDIF call ftupch(rmfener) call crmvlbk(rmfener) IF (rmfener(1:3).NE.'ALL') THEN perr = 0 call par_cmd(rmfener, ran1, ran2, perr, nrmf) IF (perr.NE.0) THEN errinfo = errstr // ' invalid range syntax !' call fcecho(errinfo) errinfo = ' SYNTAX : minchan - maxchan' call fcecho(errinfo) errinfo = ' For example : 1-20' call fcecho(errinfo) errinfo = ' Try Again !' call fcecho(errinfo) goto 20 ENDIF ELSE ran1 = 1 ran2 = nrmf ENDIF ! ! --- READ AND DISPLAY RMF DATA ,THAT IS --- ! --- ENERGY_LO,ENERGY_HI,N_GRP,F_CHAN,N_CHAN AND MATRIX --- ! ! --- FIND COLUMN NUMBERS --- ! status = 0 call ftgcno(iunit, .FALSE., 'ENERG_LO', mincol, status) IF (status.NE.0) THEN errinfo = errstr // ' finding ENERG_LO column' call fcecho(errinfo) cont = .false. return ENDIF status = 0 call ftgcno(iunit, .FALSE., 'ENERG_HI', emaxcol, status) IF (status.NE.0) THEN errinfo = errstr // ' finding ENERG_HI column' call fcecho(errinfo) cont = .false. return ENDIF status = 0 call ftgcno(iunit, .FALSE., 'N_GRP', grpcol, status) IF (status.NE.0) THEN errinfo = errstr // ' finding N_GRP column' call fcecho(errinfo) cont = .false. return ENDIF status = 0 call ftgcno(iunit, .FALSE., 'F_CHAN', fchancol, status) IF (status.NE.0) THEN errinfo = errstr // ' finding F_CHAN column' call fcecho(errinfo) cont = .false. return ENDIF status = 0 call ftgcno(iunit, .FALSE., 'N_CHAN', nchancol, status) IF (status.NE.0) THEN errinfo = errstr // ' finding N_CHAN column' call fcecho(errinfo) cont = .false. return ENDIF status = 0 call ftgcno(iunit, .FALSE., 'MATRIX', matcol, status) IF (status.NE.0) THEN errinfo = errstr // ' finding MATRIX column' call fcecho(errinfo) cont = .false. return ENDIF ! ! --- READ AND DISPLAY DATA --- ! header = ' RMF DATA' line = ' --------' IF (.NOT.wtfile) THEN call pg_fcecho(blank, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF call pg_fcecho(line, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF call pg_fcecho(header, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF call pg_fcecho(line, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF ELSE write(ounit, 500, IOSTAT = ierr) blank write(ounit, 500, IOSTAT = ierr) line write(ounit, 500, IOSTAT = ierr) header write(ounit, 500, IOSTAT = ierr) line ENDIF felem = 1 ! ! --- DISPLAY USER DEFINED RANGE OF ENERGYS --- ! do row = ran1, ran2 felem = 1 nelems = 1 status = 0 enull = 0 call ftgcve(iunit, mincol, row, felem, nelems, enull, eminval, & anyflg, status) errinfo = errstr // ' reading ENERG_LO column' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. return ENDIF enull = 0 status = 0 call ftgcve(iunit, emaxcol, row, felem, nelems, enull, emaxval, & anyflg, status) errinfo = errstr // ' reading ENERG_HI column' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. return ENDIF status = 0 inull = 0 call ftgcvj(iunit, grpcol, row, felem, nelems, inull, grpval, & anyflg, status) errinfo = errstr // ' reading N_GRP column' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. return ENDIF enull = 0 status = 0 inull = 0 IF (grpval.GT.maxgrp) THEN errinfo = wrnstr // ' DMPRMF cannot display >256 groups' call fcecho(errinfo) goto 60 ENDIF nelems = grpval call ftgcvj(iunit, fchancol, row, felem, nelems, inull, & fchans, anyflg, status) errinfo = errstr // ' reading F_CHAN column' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. return ENDIF status = 0 inull = 0 nelems = grpval call ftgcvj(iunit, nchancol, row, felem, nelems, inull, & nchans, anyflg, status) errinfo = errstr // ' reading N_CHAN column' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. return ENDIF ! ! --- DISPLAY CURRENT ROW INFO --- ! write(undline, 80) IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) undline ELSE call pg_fcecho(undline, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF ENDIF ierr = 0 write(cmin, 100, IOSTAT = ierr) eminval write(cmax, 100, IOSTAT = ierr) emaxval write(curgrp, 200, IOSTAT = ierr) row IF (ierr.NE.0) THEN errinfo = errstr // ' writing energy range,e_min,e_max' call pg_fcecho(errinfo, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) errinfo ENDIF ierr = 0 ELSE header = ' Energy Range ' // curgrp // ' E_MIN : ' // cmin& // ' E_MAX : ' // cmax IF (.NOT.wtfile) THEN call pg_fcecho(header, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF ELSE write(ounit, 500, IOSTAT = ierr) header ENDIF ENDIF write(cgrp, 200, IOSTAT = ierr) grpval IF (ierr.EQ.0) THEN header = ' No. of Channel groups : ' // cgrp IF (.NOT.wtfile) THEN call pg_fcecho(header, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF ELSE write(ounit, 500, IOSTAT = ierr) header ENDIF ELSE errinfo = errstr // ' writing channel groups' call fcecho(errinfo) IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) errinfo ENDIF ierr = 0 ENDIF ! ! --- READ AND DISPLAY DATA FOR EACH GROUP RESPECTIVELY FOR THIS ROW --- ! k = 0 do i = 1, grpval binlo = fchans(i) binhi = binlo + nchans(i) - 1 counter = 0 stnum = k + 1 finum = k + nchans(i) tempfin = finum IF (nchans(i).GT.maxmat) THEN errinfo = ' Only first 4096 response values displayed!'& // ' for next group' call fcecho(errinfo) errinfo = errstr // ' Array values too small' finum = k + maxmat - 1 ENDIF k = tempfin eff = 0 do l = stnum, finum status = 0 nelems = 1 felem = l enull = 0 counter = counter + 1 call ftgcve(iunit, matcol, row, felem, nelems, enull, & matvals(counter), anyflg, status) eff = eff + matvals(counter) enddo ierr = 0 write(curgrp, 200, IOSTAT = ierr) i IF (ierr.EQ.0) THEN header = ' GROUP ' // curgrp IF (.NOT.wtfile) THEN call pg_fcecho(header, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF ELSE write(ounit, 500, IOSTAT = ierr) header ENDIF ELSE errinfo = wrnstr // ' cannot write current group number' call fcecho(errinfo) IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) errinfo ENDIF ENDIF ierr = 0 resp = nchans(i) write(cresp, 250, IOSTAT = ierr) resp write(teff, 400, IOSTAT = ierr) eff IF (ierr.EQ.0) THEN header = ' No. of Response Values : ' // cresp& // ' Total Efficiency : ' // teff IF (.NOT.wtfile) THEN call pg_fcecho(header, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF ELSE write(ounit, 500, IOSTAT = ierr) header ENDIF ELSE errinfo = errstr // ' writing response and efficiency' call fcecho(errinfo) IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) errinfo ENDIF ierr = 0 ENDIF IF (dispmat) THEN call scaler(matvals, stnum, finum, scale) write(cbin1, 250, IOSTAT = ierr) binlo write(cbin2, 250, IOSTAT = ierr) binhi write(cscale, 400, IOSTAT = ierr) scale IF (ierr.EQ.0) THEN header = ' Bin Range : ' // cbin1 // ' to' // cbin2& // ' Response Value Scaler : ' // cscale IF (.NOT.wtfile) THEN call pg_fcecho(header, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF ELSE write(ounit, 500, IOSTAT = ierr) header ENDIF ELSE errinfo = errstr // ' writing Bin Range and scaler' call pg_fcecho(errinfo, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) errinfo ENDIF ierr = 0 ENDIF enddata = .false. counter2 = counter st = 1 do WHILE (.NOT.enddata) IF (counter2.LE.6) THEN ierr = 0 write(datastr, 300, IOSTAT = ierr)& (scale * matvals(l), l=st, counter) enddata = .true. IF (ierr.EQ.0) THEN IF (.NOT.wtfile) THEN call pg_fcecho(datastr, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF ELSE write(ounit, 500, IOSTAT = ierr) datastr ENDIF ELSE errinfo = errstr // ' writing data in bin' call fcecho(errinfo) IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) errinfo ENDIF ierr = 0 ENDIF ELSE ierr = 0 fin = st + 5 write(datastr, 300, IOSTAT = ierr)& (scale * matvals(l), l=st, fin) IF (ierr.EQ.0) THEN IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) datastr ELSE call pg_fcecho(datastr, page, ln_cnt, status) IF (status.NE.0) THEN goto 70 ENDIF ENDIF ELSE errinfo = errstr // ' writing data in bin' call fcecho(errinfo) IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) errinfo ENDIF ENDIF counter2 = counter2 - 6 st = fin + 1 ENDIF enddo ENDIF enddo 60 enddo IF (wtfile) THEN write(ounit, 500, IOSTAT = ierr) undline ELSE call fcecho(undline) ENDIF 70 status = 0 call ftclos(iunit, status) errinfo = errstr // ' closing RMF file' call wt_ferrmsg(status, errinfo) 80 format (72('-')) 100 format(f10.6) 200 format(I4) 250 format(I5) 300 format(6(1X, f12.6)) 400 format (1pg9.2) 500 format(A80) return end ! ! --- END OF SUBROUTINE RMF_RMF ---------------------------------------- ! !+SCALER subroutine scaler(matvals, stnum, finum, scale) ! -------------------------------------------- ! --- DESCRIPTION ------------------------------------------------ ! ! This routine calculates a scaling factor for data, by taking ! the maximum value in the data set into account. ! ! --- VARIABLES -------------------------------------------------- ! IMPLICIT NONE real matvals(*), scale integer i, stnum, finum real maxdata ! ! --- VARIABLE DIRECTORY ----------------------------------------- ! ! --- AUTHORS/MODIFICATION HISTORY-------------------------------- ! ! Rehana Yusaf (1993 March 23): Essentially this code is extracted ! from RDRSP (M A Sweeney) and ! minor modifications have been made ! Rehana Yusaf (1993 Dec 7) 1.0.1 ; Change 10** to 10.0 ** the ! prevoius setup caused problems with ! maxdata values <10E-14 character(5) version parameter (version = '1.0.1') !- ! ---------------------------------------------------------------- maxdata = 0 do i = stnum, finum maxdata = max(maxdata, matvals(i)) enddo IF ((0.0.LT.maxdata).AND.(maxdata.LE.1.0)) THEN scale = (10.0)**(-INT(LOG10(maxdata)) + 1) ELSEIF (maxdata.GE.100.0) THEN scale = (10.0)**(1 - INT(LOG10(maxdata))) ELSE scale = 1.0 ENDIF return end ! ! --- END OF SUBROUTINE SCALER ------------------------------------ ! !+PAR_CMD subroutine par_cmd(icmd, ran1, ran2, perr, max) ! ------------------------------------------- ! --- DESCRIPTION ----------------------------------------------------- ! ! This routine parses a user input command string, containing a range. ! Two numbers are extracted from the string, and converted to integer. ! ! --- VARIABLES ------------------------------------------------------- ! character(70) icmd, cmd, desc, odesc character(26) errstr character(4) cran1, cran2 integer ran1, ran2, len, perr, max integer pos, beg, end, ierr ! ! --- VARIABLE DIRECTORY ---------------------------------------------- ! ! Argumnents ... ! ! icmd char : Command string ! ran1 int : lower range ! ran2 int : upper range ! max int : No. of pha values or energy ranges ! perr int : Error flag, perr = 0 okay ! 1 ran1 is invalid number ! 2 ran1<0 or ran1>max ! 3 ran2 is invalid number ! 4 ran2<0 ! 5 ran1>ran2 ! ! Internals ... ! ! cmd char : Command string, after extra spaces removed ! cran1 char : substring of cmd, containing lower range ! cran2 char : substring of cmd, containing upper range ! len int : length of int in cran1, and cran2 ! ! --- CALLED ROUTINES ------------------------------------------------- ! ! FCECHO : (FTOOLS) screen write ! RMVEXSP : Compresses more than one blank to single blank ! ! --- COMPILATION AND LINKING ----------------------------------------- ! ! Link with CALTOOLS ! ! --- AUTHORS/COMPILATION --------------------------------------------- ! ! Rehana Yusaf (1993 March 26) ! Rehana Yusaf (1993 May 4) Update, add error flag ! ! Banashree M Seifert (1996 Oct 11) 1.1.0: ! . format at the end of this subroutine changed from I to i5 ! (LINUX problem) ! --------------------------------------------------------------------- character(5) version parameter (version = '1.1.0') !- ! --------------------------------------------------------------------- ! ! --- EXTRACT LOWER RANGE VALUE --- ! perr = 0 errstr = ' ERROR : PAR_CMD Ver ' // version call rmvexsp(icmd, cmd) pos = index(cmd, '-') end = pos - 1 beg = 1 cran1 = cmd(beg:end) len = end read(cran1(1:len), 100, IOSTAT = ierr) ran1 IF (ierr.NE.0) THEN desc = errstr // ' invalid number :' // cran1 call fcecho(desc) perr = 1 return ENDIF ! Check validity of lower range, must be > 0 and <= maxvalue IF ((ran1.LE.0).OR.(ran1.GT.max)) THEN perr = 2 desc = errstr // ' lower range value outside limits' call rmvexsp(desc, odesc) call fcecho(odesc) return ENDIF ! ! --- EXTRACT UPPER RANGE VALUE --- ! beg = end + 2 pos = index(cmd, ' ') len = pos - beg end = pos - 1 cran2 = cmd(beg:end) read(cran2(1:len), 100, IOSTAT = ierr) ran2 IF (ierr.NE.0) THEN desc = errstr // ' invalid number :' // cran2 call fcecho(desc) perr = 3 return ENDIF ! Check validity of upper range value, >0, and if >max set to max IF (ran2.LE.0) THEN perr = 4 desc = errstr // ' upper range value out of limits' call rmvexsp(desc, odesc) call fcecho(odesc) return ENDIF IF (ran2.GT.max) THEN ran2 = max ENDIF ! ! --- VALIDITY CHECK, MINRANGE => MAXRANGE --- ! IF (ran1.GT.ran2) THEN write(desc, 200, IOSTAT = ierr)ran1, ran2 IF (ierr.EQ.0) THEN call rmvexsp(desc, odesc) call fcecho(odesc) ENDIF perr = 5 ENDIF 100 format(i5) 200 format (' Lower range :', i5, ' is larger than upper range :', i5) return end ! ! --- END OF SUBROUTINE PAR_CMD --------------------------------------- ! !+RMF_DMPIMG ! --------------------------------------------------- subroutine rmf_dmpimg(infile, imagefile, taskname, & killit, cont, chatter) ! --------------------------------------------------- ! --- DESCRIPTION -------------------------------------------------- ! This routine reads a RESPONSE matrix and writes it in the form of ! and image FITS file. ! --- VARIABLES ---------------------------------------------------- ! IMPLICIT NONE character*(*) infile, imagefile, taskname integer chatter logical cont, killit ! ! --- VARIABLE DIRECTORY ------------------------------------------- ! ! infile char : input response filename ! imagefile char : output image filename ! chatter int : verbose if > 20 ! cont logical : false if error detected ! ! --- CALLED ROUTINES ---------------------------------------------- ! ! MVEXT (CALLIB) : Open file and locate desired extension ! RMF_IMG : Reads response matrix then writes it to output ! RMFSZ : Returns the array sizes, maxne, maxgrp, and ! maxelt ! --- AUTHORS/MODIFICATION HISTORY --------------------------------- ! ! Rehana Yusaf (1994 April 15) 1.0.0; ! Alex M. (Feb 1999) 1.1.3: Added new variables maxne, maxgrp, and ! maxelt. Added 'call RMFSZ()'. ! character(5) version parameter (version = '1.0.0') !- ! ------------------------------------------------------------------ ! ! --- LOCALS --- ! character(70) subinfo, errinfo character(30) errstr, comm ! --- Alex --- added new variables maxchan, maxne, maxgrp, and maxelt: ! maxchan - size channel array; ! maxne - size of energy array; ! maxgrp - size of response group array; ! maxelt - size of response matrix. integer iunit, status, ichan, nrmf, maxchan, maxne, maxgrp, maxelt ! VARIABLES FOR MVEXT integer nsearch, ninstr parameter (nsearch = 50) integer next(nsearch), htype, extnum character(20) extnames(nsearch), outhdu(9, nsearch) character(20) outver(nsearch), instr(9) character(20) extname ! ! --- USER INFO --- ! IF (chatter.GE.15) THEN subinfo = ' ... using RMF_DMPIMG Ver ' // version call fcecho(subinfo) ENDIF ! ! --- Move to desired extension --- ! ninstr = 2 instr(1) = 'RESPONSE' instr(2) = 'RSP_MATRIX' status = 0 extname = 'SPECRESP MATRIX' call mvext(0, infile, iunit, ninstr, instr, nsearch, next, & outhdu, extnames, outver, extname, status, chatter) IF (status.eq.1) then cont = .false. goto 70 ENDIF IF (status.NE.0) THEN status = 0 call ftmahd(iunit, 1, htype, status) subinfo = errstr // 'moving to primary extension' call wt_ferrmsg(status, subinfo) IF (status.NE.0) THEN cont = .false. goto 70 ENDIF extname = 'MATRIX' extnum = 0 call mver(iunit, extnum, ninstr, instr, nsearch, next, & outhdu, extnames, outver, extname, status, chatter) IF (status.NE.0) THEN cont = .false. goto 70 ENDIF ENDIF ! --- Alex --- initialize array sizes : maxne = 0 maxgrp = 0 maxelt = 0 maxchan = 0 ! --- Alex --- Get the values of array sizes maxne, maxgrp, and maxelt : status = 0 call rmfsz(iunit, chatter, maxne, maxgrp, maxelt, status) errinfo = errstr // ' reading maxne, maxgrp, and maxelt ' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. goto 70 ENDIF ! ! --- GET NPHA VALUE --- ! status = 0 call ftgkyj(iunit, 'DETCHANS', maxchan, comm, status) errinfo = errstr // ' reading DETCHANS ' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. goto 70 ENDIF ! ! --- CALL RMF_IMG to read and write response matrix --- ! --- Alex --- added two arguments maxgrp and maxelt call rmf_img(iunit, imagefile, maxne, maxchan, maxgrp, maxelt, & taskname, killit, cont, chatter) 70 IF (.NOT.cont) THEN errinfo = errstr // ' incomplete image dump' call fcecho(errinfo) ENDIF status = 0 call ftclos(iunit, status) errinfo = errstr // ' closing RMF file' call wt_ferrmsg(status, errinfo) return end ! --------------------------------------------------------------- ! END OF RMF_DMPIMG ! --------------------------------------------------------------- !+RMF_IMG ! ----------------------------------------------------------- subroutine rmf_img(iunit, imagefile, imaxne, imaxchan, imaxgrp, & imaxelt, taskname, killit, cont, chatter) ! ----------------------------------------------------------- ! --- DESCRIPTION ---------------------------------------------------- ! ! This routine reads a response matrix, and writes it as an image to ! a FITS file ! --------------------------------------------------------------------- ! --- VARIABLES ------------------------------------------------------- ! IMPLICIT NONE character*(*) imagefile, taskname integer iunit, chatter integer imaxne, imaxchan, imaxgrp, imaxelt logical cont, killit ! ! --- CALLED ROUTINES ------------------------------------------------- ! ! RDRMF1 (CALLIB) : Reads OGIP format Response matrix extension ! ! --- AUTHORS/MODIFICATION HISTORY ------------------------------------ ! ! Rehana Yusaf (1994 April 15) 1.0.0; ! Rehana Yusaf (1994 Sept 13) 1.0.1; pass in killit, use opfits ! instead of ftinit ! Banashree M Seifert (Oct 1996) 1.1.0: ! . replaced rdrmf1 by rdrmf3 ! Alex M. (Feb 1999) 1.1.3: Added two more arguments to the subroutine ! RMF_IMG: imaxgrp and imaxelt. Replaced ! RDRMF3 by RDRMF4. ! ngan (1999 Oct 1) 1.1.4: ! . Corrected the wrong size of the full rmf matrix. ! ! ---------------------------------------------------------------------- character(5) version parameter (version = '1.1.4') !- ! --------------------------------------------------------------------- ! --- LOCALS --- ! ! ... pointers to "arrays" to be dynamically allocated ! --- Alex --- added p_order integer, allocatable :: p_ngrp(:), p_order(:) integer, allocatable :: p_F_chan(:), p_N_chan(:) real, allocatable :: p_fmatrix(:) real, allocatable :: p_energ_lo(:), p_energ_hi(:) ! ... "arrays" to be dynamically allocated ! integer ngrp(imaxne) real fmatrix(imaxelt) ! integer F_chan(imaxne,imaxgrp) integer N_chan(imaxne,imaxgrp) ! real energ_lo(imaxne) real energ_hi(imaxne) character(30) errstr character(70) subinfo, message, errinfo character(16) rmftlscop, rmfinstrum, rmffilt, rmfdet character(8) matext, rmfchantype character(5) rsp_rmfversn character(20) hduclas3 real lo_thresh, rmfarea integer frmfchan integer rmfchan, ienerg, block, ounit, bitpix, naxes(2) integer naxis, gcount, pcount, status logical simple, extend, isorder, qorder ! --- DMA --- isorder = .false. qorder = .false. if(imaxelt .lt. imaxne * imaxchan) imaxelt = imaxne * imaxchan ! Allocate dynamic memory status = 0 allocate(p_ngrp(imaxne), stat = status) IF (status.NE.0) THEN goto 50 ENDIF allocate(p_fmatrix(imaxelt), stat = status) IF (status.NE.0) THEN goto 50 ENDIF allocate(p_F_chan(imaxgrp), stat = status) IF (status.NE.0) THEN goto 50 ENDIF allocate(p_N_chan(imaxgrp), stat = status) IF (status.NE.0) THEN goto 50 ENDIF allocate(p_order(imaxgrp), stat = status) IF (status.NE.0) THEN goto 50 ENDIF allocate(p_energ_lo(imaxne), stat = status) IF (status.NE.0) THEN goto 50 ENDIF allocate(p_energ_hi(imaxne), stat = status) IF (status.NE.0) THEN goto 50 ENDIF 50 IF (status.NE.0) then message = errstr // ' Failed to allocate Dynamic Memory' call fcecho(message) status = -1 goto 100 ENDIF ! ! --- READ RESPONSE MATRIX ( RDRMF3 HAS BEEN REPLACED BY RDRM4 --- Alex ) --- ! call rdrmf4(iunit, chatter, qorder, imaxne, imaxgrp, imaxelt, & rsp_rmfversn, hduclas3, rmftlscop, rmfinstrum, rmfdet, & rmffilt, rmfarea, rmfchantype, frmfchan, rmfchan, & ienerg, imaxgrp, imaxelt, p_energ_lo, & p_energ_hi, p_ngrp, p_F_chan, & p_N_chan, isorder, p_order, & p_fmatrix, lo_thresh, status) IF (status.NE.0) THEN cont = .false. goto 100 ENDIF ! ! --- WRITE RESPONSE MATRIX AS AN IMAGE --- ! block = 2880 call cgetlun(ounit) ! call ftinit(ounit,imagefile,block,status) call opfits(ounit, imagefile, killit, chatter, status) errinfo = errstr // ' opening imagefile' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. goto 100 ENDIF simple = .true. bitpix = -32 naxis = 2 naxes(1) = rmfchan naxes(2) = ienerg pcount = 0 gcount = 1 extend = .TRUE. ! --- WRITE MANDATORY PRIMARY ARRAY KEYWORDS --- status = 0 call ftpprh(ounit, simple, bitpix, naxis, naxes, pcount, gcount, & extend, status) errinfo = errstr // ' writing mandatory keywords' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN cont = .false. goto 100 ENDIF ! ! --- TELESCOPE/INSTRUME --- ! status = 0 call ftpkys(ounit, 'TELESCOP', rmftlscop, & 'Mission/Telescope name', status) errinfo = errstr // ' problem writing TELESCOP keyword' call wt_ferrmsg(status, errinfo) status = 0 call ftpkys(ounit, 'INSTRUME', rmfinstrum, & 'Instrument name', status) errinfo = errstr // ' problem writing INSTRUM keyword' call wt_ferrmsg(status, errinfo) ! HDUCLASS and HDUVERS ... status = 0 call ftpkys(ounit, 'HDUCLASS', 'OGIP', & 'format conforms to OGIP standard', status) errinfo = errstr // ' Problem writing HDUCLASS keyword' call wt_ferrmsg(status, errinfo) status = 0 call ftpkys(ounit, 'HDUCLAS1', 'IMAGE', & 'dataset is an image', status) errinfo = errstr // ' problem writing HDUCLAS1 keyword' call wt_ferrmsg(status, errinfo) status = 0 call ftpkys(ounit, 'HDUVERS1', '1.0.0', & 'Version of family of formats', status) errinfo = errstr // ' writing HDUVERS1 keyword' call wt_ferrmsg(status, errinfo) status = 0 call ftpkys(ounit, 'HDUVERS2', '1.0.0', & 'Version of format', status) errinfo = errstr // ' writing HDUVERS2 keyword' call wt_ferrmsg(status, errinfo) status = 0 call ftpdat(ounit, status) status = 0 call FTPKYS(ounit, 'CREATOR', & taskname, & 's/w task which wrote this dataset', & status) errinfo = errstr // ' problem writing CREATOR keyword' IF (chatter.GE.15) THEN call wt_ferrmsg(status, subinfo) ENDIF ! --- DEFINE DATA STRUCTURE --- call ftpdef(ounit, bitpix, naxis, naxes, pcount, gcount, status) errinfo = errstr // ' defining primary data structure' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN status = 2 goto 100 ENDIF IF (chatter.GE.20) THEN subinfo = ' ... data strucure has been defined' call fcecho(subinfo) ENDIF ! --- WRITE DATA --- status = 0 call ftp2de(ounit, 0, rmfchan, naxes(1), naxes(2), & p_fmatrix, status) errinfo = errstr // ' writing primary data ' call wt_ferrmsg(status, errinfo) IF (status.NE.0) THEN status = 3 ENDIF IF (chatter.GE.20) THEN subinfo = ' ... data has been written' call fcecho(subinfo) ENDIF status = 0 call ftclos(ounit, status) errinfo = errstr // ' closing imagefile' call wt_ferrmsg(status, errinfo) ! ***** ! Free the dynamic Memory 100 deallocate(p_ngrp, stat = status) IF (status.NE.0) THEN goto 485 ENDIF deallocate(p_fmatrix, stat = status) IF (status.NE.0) THEN goto 485 ENDIF deallocate(p_F_chan, stat = status) IF (status.NE.0) THEN goto 485 ENDIF deallocate(p_N_chan, stat = status) IF (status.NE.0) THEN goto 485 ENDIF deallocate(p_order, stat = status) IF (status.NE.0) THEN goto 485 ENDIF deallocate(p_energ_lo, stat = status) IF (status.NE.0) THEN goto 485 ENDIF deallocate(p_energ_hi, stat = status) IF (status.NE.0) THEN goto 485 ENDIF 485 IF (status.NE.0) then message = errstr // & ' Failed to deallocate Dynamic Memory' call fcecho(message) status = 99 ENDIF return end ! ------------------------------------------------------------------- ! END OF RMF_IMG ! -------------------------------------------------------------------