!+ADDARF SUBROUTINE ADDARF IMPLICIT NONE ! ! Description: ! Adds ARF files with specified weights, and writes result ! to a single ARF file. The maximum number of input ARFs is defined ! by MXARF in addarf.inc90. ! NOTE - The par file is assumed to have been opened. ! ! Passed Paremeters ! None ! ! User i/ps required (prompted for): ! None here, isolated in GP_CNVOIRSP (see below) ! ! Include/Common blocks files ! common TASK : (FTOOLS) standard fatal error message thingy ! ! Called routines ! subroutine GP_ADDARF : (below) Gets parameters from XPI par file ! subroutine CAL_ADDARF : (below) Does the job ! ! Compilation: ! subroutines require CALLIB, FTOOLS, FITSIO ! ! Origin: ! Original ! ! Authors/Modification History: ! Ken Ebisawa (1.0.0;1995 Oct 16) original ! Ian M George (1.0.1:1995 Oct 27) minor (mainly cosmetic) changes ! ! Banashree M Seifert (1.1.0:1996 Nov26) ! . changes made by Keith A and Ken Ebisawa is put here ! they are as below: ! Banashree M Seifert (1.2.0:1997 March 11) ! . added option for input file list, as below: ! Extra option added so that instead of giving file names, ! user can also input '@filename', where filename is an ascii file ! containing files to be added and factor(weight) ! e.g., if file1, file2 to be added as file1*1 with file2*4, then ! input file should have two lines as: ! file1 1.0 ! file2 4.0 ! ! . for this a new subroutine added to reda the input ascii file ! and parse them (rdlistfile) ! Ning Gan (1.2.1:1998 Aug. 28) ! . changed the dimension of comment array from 10 to 800. ! Ning Gan (1.2.2:1999 Oct 25) ! . Added dynamically allocated arrays of sum_arf, e_high, e_low. ! . Added a routine process_add_arf ! Ning Gan (1.2.3:1999 Nov 27) ! . Changed the read format from '(f)' to '(f22.0)' ! Ning Gan (1.2.4:2000 Mar 01) ! . Find ARF extensions automatically ! Ning Gan (1.2.5:2000 Mar 19) ! . Increase the size of filenames to 255. ! . Increase the total number of arf files from 100 to 2500. ! Ning Gan (1.2.6:2000 May 11) ! . Fixed the write statements for output of error and warning ! strings. ! Bryan Irby (1.2.8:2018 Nov 9) ! Replaced udmget/udmfre calls with allocate/deallocate ! MFC (1.2.9:2020 Apr 16) ! converted to f90 ! !------------------------------------------------------------------------------ character(7) version parameter (version = '1.2.9') !- ! Internals character(511) message, context integer nfile, ierr, chatter include 'addarf.inc90' character(255) arfnames(MXARFS), outarf real weights(MXARFS) logical clobber character(20) taskname integer clenact ! Initization COMMON/task/taskname taskname = 'addarf ' // version ierr = 0 ! User Info message = '** addarf ' // version call fcecho(message) ! Open and read parameter file call gp_addarf(nfile, arfnames, weights, outarf, & clobber, chatter, ierr) if (ierr .ne. 0) go to 999 ! The main part call cal_addarf(nfile, arfnames, weights, outarf, clobber, & chatter, ierr) ! Error handling 999 continue if(ierr.NE.0) then context = 'Incomplete Execution' message = '** addarf ' // version // ' ERROR : '& // context(:clenact(context)) call fcecho(message) call fcerr(context) else message = '** addarf ' // version // ' Finished' call fcecho(message) endif return end ! ----------------------------------------------------------------- !+ GP_ADDARF subroutine gp_addarf(nfile, arfnames, weights, outarf, & clobber, chatter, ierr) integer nfile, ierr, chatter character*(*) arfnames(*), outarf real weights(*) logical clobber ! ! Description: ! Gets the parameters required by ADDARF from the parameter file ! NOTE - The XPI par file is assumed to have been opened. ! ! User i/ps required (prompted for): ! IN_ARFS - string containing list of arf filenames to be added ! WEIGHTS - string containing weighting factors of arfs ! OUT_ARF - O/p filename to be created ! CLOBBER - Falg as to whether overwriting of o/p file allowed ! CHATTER - chattiness flag for o/p (5 quite,9 normal,15 high,>20 silly) ! ! Origin: ! Original ! ! Called Routines ! subroutine FCECHO : (FTOOLS) writes to standard o/p device ! ! Compilation: ! requires XPI/Host interface etc and CALLIB ! ! Authors/Modification History: ! Ken Ebisawa (1.0.0;1995 Oct 16) original ! Ian M George (1.0.1:1995 Oct 27) minor (mainly cosmetic) changes ! ! Banashree M Seifert (1.1.0:1996 Nov 26) ! . message was character(80). it is made character(180) ! Banashree M Seifert (1.2.0:1997 March 11) ! . added option for input file list, as below: ! Extra option added so that instead of giving file names, ! user can also input '@filename', where filename is an ascii file ! containing files to be added and factor(weight) ! e.g., if file1, file2 to be added as file1*1 with file2*4, then ! input file should have two lines as: ! file1 1.0 ! file2 4.0 !------------------------------------------------------------------------------ character(7) version parameter (version = '1.2.1') !- ! Internals include 'addarf.inc90' character(255) context character(1000) wtstring character(20) st_weights(MXARFS) integer i, status, nweights logical flag character(255) errstr, wrnstr, outstr character(511) message character(5000) list character(5000) lstfil integer lstu integer clenact ! Initialize variables status = 0 errstr = '** GP_ADDARF ' // version // ' ERROR: ' wrnstr = '** GP_ADDARF ' // version // ' WARNING: ' ! Get the input list parameter which could be either ! string for the ARF names or @fielname call uclgst('list', list, status) if (status .ne. 0) then context = 'Cannot get the listfile parameter' goto 999 endif call crmvlbk(list) ! if list has '@' as first character, then ! >>1. read list file to load the names of RMF files, their weighting factors ! if not, ! >>1. Parse the string and get RMF names and number of files(fcgcls) ! >>2. Get the weights string(uclgst) ! >>3. Parse the string and get the weights and number of weights(fcgcls) lstu = 8 status = 0 if(list(1:1) .eq. '@') then lstfil = list(2:) CALL rdlistfile(lstfil, lstu, MXARFS, nfile, arfnames, & weights, message, status) IF (status .NE. 0) GOTO 999 else ! Parse the string and get the ARF names and number of files flag = .false. call fcgcls(list, arfnames, nfile, flag) ! Get the weights call uclgst('weights', wtstring, status) if (status .ne. 0) then message = errstr(:clenact(errstr)) // & 'Getting WEIGHTS parameter' call fcecho(message) goto 999 endif ! Parse the string and get the weights and number of weights flag = .false. call fcgcls(wtstring, st_weights, nweights, flag) do i = 1, nweights read(st_weights(i), *) weights(i) enddo if (nweights .ne. nfile) then ierr = 999 message = errstr(:clenact(errstr)) // & 'Incompatible files/weights' call fcecho(message) write(context, '(a,i4,a,i4)')& ' ... Number of files:', nfile, & ', Number of weights:', nweights call fcecho(message) go to 999 endif CALL fcecho('Summing ...') do i = 1, nfile WRITE(outstr(1:13), '(1pe10.3, a3)') weights(i), ' * ' outstr(14:) = arfnames(i) CALL fcecho(outstr) enddo endif ! Get the output arf name call uclgst('out_ARF', outarf, status) if(status.ne.0) then message = errstr(:clenact(errstr)) // & 'Getting OUT_ARF parameter' call fcecho(message) goto 999 endif ! Get the cloober flag call uclgsb('clobber', clobber, status) if(status.ne.0) then message = errstr(:clenact(errstr)) // & 'Getting CLOBBER parameter' call fcecho(message) message = ' ... setting CLOBBER = .false.' clobber = .false. status = 0 endif ! Get the chatter flag call uclgsi('chatter', chatter, status) if (status .ne. 0) then message = errstr(:clenact(errstr)) // & 'Getting CHATTER parameter' call fcecho(message) status = 0 message = ' ... setting CHATTER = 9' call fcecho(message) chatter = 9 endif 999 continue if ((status .ne. 0).OR.(ierr.ne.0)) then ierr = 999 message = ' ... GP_ADDARF ' // version // ' aborting' call fcecho(message) elseif(chatter.GE.20) then message = ' ... using GP_ADDARF ' // version call fcecho(message) endif return end ! ----------------------------------------------------------------- !+ CAL_ADDARF subroutine cal_addarf(nfile, arfnames, weights, outarf, clobber, & chatter, ierr) implicit none integer nfile, ierr, chatter character*(*) arfnames(*), outarf real weights(*) logical clobber ! ! Description: ! Subroutine adds passed list of ARF files with passed weights, and writes ! result to the specified o/p ARF file. ! NOTE: Maximum number of input ARFs is 99. ! Max number of energy bins is currently 2048 ! ! Passed Parameters ! NFILE (i) : Number of ARF files to be added ! ARFNAMES (i) : Names of input ARFs ! WEIGHTS (i) : weights for adding ARFs ! OUTARF (i) : output arfname ! CLOBBER (i) : clobber flag ! CHATTER (i) : chatiness flag (9=normal) ! IERR (r): error flag (zero = successful completion) ! ! User i/ps required (prompted for): ! None ! ! Include/Common blocks files ! common TASK : (FTOOLS) standard fatal error message thingy ! ! Called routines ! subroutine GP_ADDARF : (below) Gets parameters from XPI par file ! subroutine CAL_ADDARF : (below) Does the job ! ! Compilation: ! subroutines require CALLIB, FTOOLS, FITSIO ! ! Origin: ! Original ! ! Authors/Modification History: ! Ken Ebisawa (1.0.0;1995 Oct 16) original ! Ian M George (1.0.1:1995 Oct 27) minor (mainly cosmetic) changes ! ! Banashree M Seifert (1.1.0:1996 Nov26) ! . message was same as wrnstr so was error. It has been ! made character(180) ! Ning Gan (1.1.1:1999 Oct 25) ! . Added dynamically allocated arrays of sum_arf, e_high, e_low. character(7) version parameter (version = '1.1.1') !- include 'addarf.inc90' ! Internals integer i, ii, n_energy_bin, status, clenact character(120) context ! real sum_arf(maxne), e_low(maxne), e_high(maxne) real ftsver integer nk_hist, nk_comm, ounit character(120) hist(10), comment(maxcomm) character(255) errstr, wrnstr character(500) message logical qok integer funit integer sstatus ! initialize character(20) telescop, instrume, detnam, filter, arfversn data telescop/' '/, instrume/' '/, detnam/' '/, & filter/' '/, arfversn/' '/ character(20) taskname COMMON/task/taskname ! dynamic arrays real, allocatable :: psum_arf(:) real, allocatable :: pe_low(:) real, allocatable :: pe_high(:) logical gsum_arf, ge_low, ge_high character(255) arf_name integer arf_extn, ninstr, nsearch, & nfound, next(maxextn), htype character(20) instr(9), outhdu(9, maxextn), outver(9, maxextn), & extnam(maxextn) errstr = '** CAL_ADDARF ' // version // ' ERROR:' wrnstr = '** CAL_ADDARF ' // version // ' WARNING:' ierr = 0 ! Here we go ... if (chatter.ge.20) then message = ' ... using CAL_ADDARF ' // version call fcecho(message) call ftvers(ftsver) write(message, '(a,f6.3)')& ' ... using FITSIO Version ', ftsver call fcecho(message) message = ' ... I/p file summary:' call fcecho(message) do i = 1, nfile write(context, '(a,i4)') ' ...... File No =', i call fcecho(context) context = ' ...... Name =' // arfnames(i) call fcecho(context) write(context, '(a,f7.3)') ' ...... Weight =', weights(i) call fcecho(context) end do end if ! *** Check for an illegal o/p filename call ck_file(outarf, arfnames, nfile, qok, clobber, chatter) if(.not.qok) then ierr = -1 goto 999 endif ! *** parse the filename status = 0 call fcpars(arfnames(1), arf_name, arf_extn, status) if(arf_extn.ge.0) then if(chatter.ge.15) then message = ' ...... ARF name is ' // arf_name call fcecho(message) write(message, '(a, i3)') ' ...... ARF extension is ', & arf_extn call fcecho(message) endif else if (chatter.ge.15) then message = '...... ARF extension is not specified for '& // arfnames(i) call fcecho(message) message = '...... ARF extension will be searched' call fcecho(message) end if arf_extn = -99 endif ! *** open one input file and find out the n_energy_bin status = 0 call ftgiou(funit, status) call ftnopn(funit, arfnames(1), 0, status) if(status.ne.0) then message = 'Error open file: ' // & arfnames(1)(1:clenact(arfnames(1))) call wt_ferrmsg(status, message) goto 999 endif ! Jump to the specified extension or find the ARF extension ! Find the SPECRESP extension in the ARF file ! - Extension number NOT given as part of arexp (search for HDUCLAS/EXTNAM) ! This part was taken from marfrmf by Ian Geroge. if(arf_extn.LT.0) then ninstr = 2 instr(1) = 'RESPONSE' instr(2) = 'SPECRESP' nsearch = maxextn call fndhdu(chatter, funit, ninstr, instr, & nsearch, nfound, next, outhdu, outver, extnam, ierr) if(nfound.lt.0) then ! - check for old-style EXTNAME values if no acceptable HDUCLASn values found message = wrnstr(1:clenact(wrnstr)) // & ' Ext w/ allowed HDUCLASn keywrds not found' call fcecho(message) message = ' ... offending file: ' // & arf_name(:clenact(arf_name)) call fcecho(message) message = & ' .. searching for extnsion with EXTNAME = SPECRESP' call fcecho(message) call fndext(chatter, funit, 'SPECRESP', & nsearch, nfound, next, outhdu, outver, extnam, & ierr) endif if(nfound.ge.1) then ! ARF extension having correct HDUCLASS keywords are found if (nfound.ge.2) then ! Warning if there are two or more ARF extensions if (chatter.gt.0) then message = wrnstr(1:clenact(wrnstr)) // & ' there are more than two ARF extensions' call fcecho(message) message = 'File name: '& // arf_name(1:clenact(arf_name)) call fcecho(message) do ii = 1, nfound write(message, '(a, i3)')& 'ARF extension no :', next(ii) call fcecho(message) end do message = 'The first ARF extension will be used' call fcecho(message) endif endif ! Jump to the first ARF extension if (chatter.ge.10) then message = 'ARF extension is found' call fcecho(message) write(message, '(a,i2)') 'ARF extension number : ', & next(1) call fcecho(message) endif call ftmahd(funit, 1 + next(1), htype, status) message = wrnstr(1:clenact(wrnstr)) // & ' Problem moving to specified xtens' call wt_ferrmsg(status, message) endif else ! - Extension number IS given as part of arexp call ftmahd(funit, arf_extn + 1, htype, status) message = wrnstr(1:clenact(wrnstr)) // & ' Problem moving to specified xtens' call wt_ferrmsg(status, message) endif ! If error, terminate if (status.ne.0) then ierr = 999 message = errstr(:clenact(errstr))& // ' Problem moving to specified xtens' call fcecho(message) go to 999 end if ! Find the total number of bins. status = 0 call ftgkyj(funit, 'NAXIS2', n_energy_bin, message, status) IF (status.NE.0) THEN message = arfnames(1)(1:clenact(arfnames(1)))& // ': reading NAXIS2 value ' call wt_ferrmsg(status, message) goto 999 ENDIF call ftclos(funit, status) call ftfiou(funit, status) status = 0 ! *** allocate the sum_arf, e_low, e_high arrays. gsum_arf = .false. ge_low = .false. ge_high = .false. allocate(psum_arf(n_energy_bin), stat = status) if(status .ne. 0) then message = 'Insufficient memory for the SUM_ARF array' call wt_ferrmsg(status, message) goto 999 endif gsum_arf = .true. allocate(pe_low(n_energy_bin), stat = status) if(status .ne. 0) then message = 'Insufficient memory for the E_LOW array' call wt_ferrmsg(status, message) goto 999 endif ge_low = .true. allocate(pe_high(n_energy_bin), stat = status) if(status .ne. 0) then message = 'Insufficient memory for the E_HIGH array' call wt_ferrmsg(status, message) goto 999 endif ge_high = .true. ! Open input ARFs, check formats, and sum ARFs if ARF extension format is fine. call open_addarf(nfile, arfnames, weights, & nk_comm, comment, telescop, instrume, detnam, filter, & arfversn, n_energy_bin, pe_low, pe_high, psum_arf, & chatter, ierr) if(ierr .ne. 0) goto 999 ! Output the summed ARF (wtarf1 is a CALLIB routine) call ftgiou(ounit, ierr) ! P.array call opnpa(outarf, chatter, ounit, clobber, ierr) if(ierr .ne. 0) goto 999 call FTPKYS(ounit, 'CREATOR', taskname, & 's/w task which wrote this dataset', status) if(status .ne. 0) then message = wrnstr(1:clenact(wrnstr)) // & ' Writing CREATOR keyword' call fcecho(message) status = 0 endif nk_hist = 1 hist(1) = 'This file is made with the ftool ' // taskname ! ARF extension call wtarf1(ounit, chatter, nk_hist, hist, & nk_comm, comment, arfversn(1:clenact(arfversn)), 'UNKNOWN', & telescop, instrume, detnam, filter, & n_energy_bin, n_energy_bin, pe_low, pe_high, psum_arf, ierr) if(ierr .ne. 0) goto 999 call FTPKYS(ounit, 'CREATOR', taskname, & 's/w task which wrote this dataset', status) if(status .ne. 0) then message = wrnstr(1:clenact(wrnstr)) // & ' Writing CREATOR keyword' call fcecho(message) status = 0 endif ! Shut up call ftclos(ounit, status) if(status .ne. 0) then message = errstr(:clenact(errstr)) // ' Closing O/p file' call wt_ferrmsg(status, message) goto 999 endif call ftfiou(ounit, status) 999 continue ! Last check for errors if((status.ne.0).or.(ierr.ne.0)) then message = errstr(:clenact(errstr)) // ' Fatal' call fcecho(message) endif sstatus = 0 if(gsum_arf) deallocate(psum_arf, stat = sstatus) sstatus = 0 if(ge_low) deallocate(pe_low, stat = sstatus) sstatus = 0 if(ge_high) deallocate(pe_high, stat = sstatus) return end ! -------------------------------------------------------------- !+ OPEN_ADDARF subroutine open_addarf(nfile, arfnames, weights, & nk_comm, comment, telescop, instrume, detnam, & filter, arfversn, n_energy_bin, energy_lo, energy_hi, & sum_arf, chatter, ierr) implicit none integer nfile, nk_comm, n_energy_bin, chatter, ierr character(255) arfnames(nfile) character*(*) telescop, instrume, detnam, filter, arfversn character*(*) comment(*) real weights(nfile), energy_lo(*), energy_hi(*), sum_arf(*) ! ! Description: ! Open input ARFs, check formats, and sum ARFs if ARF extension format is fine. ! ! Passed Parameters ! NFILE (i) : Number of ARF files to be added ! ARFNAMES (i) : Names of input ARFs ! WEIGHTS (i) : weights for adding ARFs ! NK_COMM (r): No. comment cards ! COMMENT (r): Array of comment cards ! TELESCOPE (r): Name of TELESCOP from ARF files ! INSTRUME (r): Name of INSTRUME from ARF files ! DETNAM (r): Name of DETNAM from ARF files ! FILTER (r): Name of FILTER from ARF files ! ARFVERSN (r): ARFVERSN keyword value in use ! N_ENERGY_BIN (r): Number of energy bins in ARF array ! ENERG_LO (r): Lower energy bound array ! ENERG_HI (r): Upper energy bound array ! SUM_ARF (r): Summed ARF array ! CHATTER (i) : chatiness flag (9=normal) ! IERR (r): error flag (zero = successful completion) ! ! Called routines ! {incomplete} ! ! Compilation: ! subroutines require CALLIB, FTOOLS, FITSIO ! ! Origin: ! Original ! ! Authors/Modification History: ! Ken Ebisawa (1.0.0;1995 Oct 16) original ! Ian M George (1.0.1:1995 Oct 27) minor (mainly cosmetic) changes ! Ian M George (1.0.2:1995 Nov 21) fixed typo ! Ning Gan (1.0.2:1999 Oct 25) ! . Added dynamically allocated arrays of sum_arf, e_high, e_low. character(7) version parameter (version = '1.0.2') ! - ! Max Array sizes (disable the maxchan, maxne, maxgrp) include "addarf.inc90" character(255) arf_name character(512) message integer i, ii, arf_extn, status, iunit, block, ninstr, nsearch, & nfound, next(maxextn), htype, clenact character(40) errstr, wrnstr character(20) instr(9), outhdu(9, maxextn), outver(9, maxextn), & extnam(maxextn) integer sstatus real, allocatable :: sprsp(:) real, allocatable :: e_lo(:) real, allocatable :: e_hi(:) logical gsprsp, ge_lo, ge_hi gsprsp = .false. ge_lo = .false. ge_hi = .false. ! Initialization ierr = 0 errstr = '** OPEN_ADDARF ' // version // ' ERROR: ' wrnstr = '** OPEN_ADDARF ' // version // ' WARNING: ' telescop = 'UNKNOWN' instrume = 'UNKNOWN' detnam = ' ' filter = 'NONE' nk_comm = 0 ! *** allocate the sprsp, e_lo, e_hi arrays. allocate(sprsp(n_energy_bin), stat = status) if(status .ne. 0) then message = 'Insufficient memory for the SPRSP array' call wt_ferrmsg(status, message) goto 666 endif gsprsp = .true. allocate(e_lo(n_energy_bin), stat = status) if(status .ne. 0) then message = 'Insufficient memory for the E_LO array' call wt_ferrmsg(status, message) goto 666 endif ge_lo = .true. allocate(e_hi(n_energy_bin), stat = status) if(status .ne. 0) then message = 'Insufficient memory for the E_HI array' call wt_ferrmsg(status, message) goto 666 endif ge_hi = .true. ! User Info if(chatter.GE.20) then message = ' ... using OPEN_ADDARF ' // version call fcecho(message) endif if(chatter.GE.9) then message = ' ... processing: ' call fcecho(message) endif do i = 1, nfile nk_comm = nk_comm + 1 write(comment(nk_comm), '(a,i2,a,a)') 'File', i, ' : ', & arfnames(i)(:MIN(clenact(arfnames(i)), & len(comment(nk_comm)) - 9)) nk_comm = nk_comm + 1 write(comment(nk_comm), '(a,f9.4)') 'Weight: ', & weights(i) if (chatter.ge.9) then write(message, '(a, i4)') '...... file number ', i call fcecho(message) endif ! Open the each ARF file call fcpars(arfnames(i), arf_name, arf_extn, status) if(arf_extn.ge.0) then if(chatter.ge.15) then message = ' ...... ARF name is '& // arf_name(1:clenact(arf_name)) call fcecho(message) write(message, '(a, i3)') ' ...... ARF extension is ', & arf_extn call fcecho(message) endif else if (chatter.ge.15) then message = '...... ARF extension is not specified for '& // arfnames(i)(:clenact(arfnames(i))) call fcecho(message) message = '...... ARF extension will be searched' call fcecho(message) end if arf_extn = -99 endif call ftgiou(iunit, status) call ftopen(iunit, arf_name, 0, block, status) if(status.ne.0) then ierr = 999 message = errstr(:clenact(errstr)) // ' Opening ARF ' call fcecho(message) message = '... Offending file: ' // & arf_name(:clenact(arf_name)) call wt_ferrmsg(status, message) go to 666 endif ! Jump to the specified extension or find the ARF extension ! Find the SPECRESP extension in the ARF file ! - Extension number NOT given as part of arexp (search for HDUCLAS/EXTNAM) ! This part was taken from marfrmf by Ian Geroge. if(arf_extn.LT.0) then ninstr = 2 instr(1) = 'RESPONSE' instr(2) = 'SPECRESP' nsearch = maxextn call fndhdu(chatter, iunit, ninstr, instr, & nsearch, nfound, next, outhdu, outver, extnam, ierr) if(nfound.lt.0) then ! - check for old-style EXTNAME values if no acceptable HDUCLASn values found message = wrnstr(1:clenact(wrnstr)) // & ' Ext w/ allowed HDUCLASn keywrds not found' call fcecho(message) message = ' ... offending file: ' // & arf_name(:clenact(arf_name)) call fcecho(message) message = & ' .. searching for extnsion with EXTNAME = SPECRESP' call fcecho(message) call fndext(chatter, iunit, 'SPECRESP', & nsearch, nfound, next, outhdu, outver, extnam, & ierr) endif if(nfound.ge.1) then ! ARF extension having correct HDUCLASS keywords are found if (nfound.ge.2) then ! Warning if there are two or more ARF extensions if (chatter.gt.0) then message = wrnstr(1:clenact(wrnstr)) // & ' there are more than two ARF extensions' call fcecho(message) message = 'File name: ' // & arf_name(:clenact(arf_name)) call fcecho(message) do ii = 1, nfound write(message, '(a, i3)')& 'ARF extension no :', next(ii) call fcecho(message) end do message = 'The first ARF extension will be used' call fcecho(message) endif endif ! Jump to the first ARF extension if (chatter.ge.10) then message = 'ARF extension is found' call fcecho(message) write(message, '(a,i2)') 'ARF extension number : ', & next(1) call fcecho(message) endif call ftmahd(iunit, 1 + next(1), htype, status) message = wrnstr(1:clenact(wrnstr)) // & ' Problem moving to specified xtens' call wt_ferrmsg(status, message) endif else ! - Extension number IS given as part of arexp call ftmahd(iunit, arf_extn + 1, htype, status) message = wrnstr(1:clenact(wrnstr)) // & ' Problem moving to specified xtens' call wt_ferrmsg(status, message) endif ! If error, terminate if (status.ne.0) then ierr = 999 message = errstr(:clenact(errstr)) // & ' Problem moving to specified xtens' call fcecho(message) go to 666 end if call process_add_arf(iunit, i, arfversn, telescop, & instrume, detnam, filter, & n_energy_bin, weights(i), & energy_lo, energy_hi, sum_arf, & e_lo, e_hi, sprsp, & nk_comm, comment, chatter, status) if(status.ne.0) then ierr = 999 goto 666 end if ! Close the fits file call ftclos(iunit, status) if(status.ne.0) then message = wrnstr(1:clenact(wrnstr)) // & ' Problem closing File' call wt_ferrmsg(status, message) status = 0 endif call ftfiou(iunit, status) enddo 666 continue ! Last check for errors if((status.ne.0).or.(ierr.ne.0)) then message = errstr(:clenact(errstr)) // & ' Unable to continue' call fcecho(message) endif sstatus = 0 if(gsprsp) deallocate(sprsp, stat = sstatus) sstatus = 0 if(ge_lo) deallocate(e_lo, stat = sstatus) sstatus = 0 if(ge_hi) deallocate(e_hi, stat = sstatus) return end ! ! Processing each arffile. ! ! Most of the codes are from the OPEN_ADDARF. ! Subroutine process_add_arf(iunit, iarf, arfversn, telescop, & instrume, detnam, filter, & n_energy_bin, weight, & energy_lo, energy_hi, sum_arf, e_lo, e_hi, sprsp, & nk_comm, comment, chatter, status) IMPLICIT NONE ! Ning Gan (1.0.0:1999 Oct 25) ! . Added dynamically allocated arrays of sum_arf, e_high, e_low. ! ! Arguments ! integer iunit, iarf character*(*) telescop, instrume, detnam, filter, arfversn integer n_energy_bin real energy_lo(*), energy_hi(*), sum_arf(*) real e_lo(*), e_hi(*), sprsp(*) real weight integer nk_comm CHARACTER*(*) Comment(*) integer status, chatter integer clenact ! ! Internals ! character(20) t_telescop, t_instrume integer ii, n_energ integer ierr character(255) errstr, wrnstr character(511) message character(7) version parameter (version = '1.0.0') ! Initialize variables status = 0 errstr = '** PROCESS_ADD_ARF ' // version // ' ERROR: ' wrnstr = '** PROCESS_ADD_ARF ' // version // ' WARNING: ' ierr = 0 ! Read the ARF extension call rdarf1(iunit, chatter, t_telescop, t_instrume, detnam, filter, & n_energ, e_lo, e_hi, sprsp, arfversn, ierr) if(ierr.ne.0) then status = ierr message = errstr(1:clenact(errstr)) // & ' RDARF1, Problem reading arf file' call fcecho(message) go to 6666 endif ! Now, we are at the ARF extension of the i-th ARF file. ! Save the n_energy_bin, e_lo and e_hi for the first file, ! and make sure the other files have the same values. ! If not, terminate. ! Also, check the consistency of TELESCOP, INSTRUME nk_comm = nk_comm + 1 write(comment(nk_comm), '(a,a)') 'TELESCOP: ', t_telescop nk_comm = nk_comm + 1 write(comment(nk_comm), '(a,a)') 'INSTRUME: ', t_instrume if (iarf .eq. 1) then n_energy_bin = n_energ telescop = t_telescop instrume = t_instrume do ii = 1, n_energy_bin energy_lo(ii) = e_lo(ii) energy_hi(ii) = e_hi(ii) sum_arf(ii) = weight * sprsp(ii) end do else if (telescop .ne. t_telescop) then message = wrnstr(1:clenact(wrnstr)) // ' TELESCOP mismatch' nk_comm = nk_comm + 1 write(comment(nk_comm), '(a)') message(:clenact(message)) call fcecho(message) write(message, *) ' ... TELESCOP of the first file :', & telescop(1:clenact(telescop)) call fcecho(message) write(message, *) ' ... TELESCOP of this file :', & t_telescop(1:clenact(t_telescop)) call fcecho(message) write(message, '(a)')& ' ... TELESCOP of the first file will be used for o/p.' call fcecho(message) nk_comm = nk_comm + 1 write(comment(nk_comm), '(a)') message(:clenact(message)) end if if (instrume .ne. t_instrume) then message = wrnstr(1:clenact(wrnstr)) // ' INSTRUME mismatch' nk_comm = nk_comm + 1 write(comment(nk_comm), '(a)') message(:clenact(message)) call fcecho(message) write(message, *) ' ... INSTRUME of the first file :', & instrume(:clenact(instrume)) call fcecho(message) write(message, *) ' ... INSTRUME of this file :', & t_instrume(:clenact(t_instrume)) call fcecho(message) write(message, '(a)')& ' ... INSTRUME of the first file will be used for o/p.' call fcecho(message) nk_comm = nk_comm + 1 write(comment(nk_comm), '(a)') message(:clenact(message)) end if if (n_energy_bin .ne. n_energ) then ierr = 999 status = ierr message = errstr(:clenact(errstr)) // & ' Energy bins mismatch' call fcecho(message) go to 6666 endif do ii = 1, n_energy_bin if (energy_lo(ii) .ne. e_lo(ii) .or.& energy_hi(ii) .ne. e_hi(ii)) then ierr = 999 status = ierr message = errstr(:clenact(errstr)) // & ' Different E_LO or E_HI values' call fcecho(message) go to 6666 else sum_arf(ii) = sum_arf(ii) + weight * sprsp(ii) endif end do endif 6666 if((status.ne.0).or.(ierr.ne.0)) then message = errstr(:clenact(errstr)) // & ' Unable to continue' call fcecho(message) endif return end ! ----------------------------------------------------------- !+RDLISTFILE SUBROUTINE rdlistfile(lstfil, lstu, MXARFS, nfiles, & inarfs, infact, contxt, errstat) INTEGER MXARFS REAL infact(*) INTEGER lstu, nfiles CHARACTER*(*) inarfs(*) CHARACTER*(*) lstfil, contxt integer errstat ! Subroutine to read the list file and load the arrays of RMF names and ! weighting factors. ! Arguments : ! lstfil c i: name of file with list of RMFs ! wgtfil c i: name of file with weightings ! lstu i i: I/O unit for above ! MXARFS i i: Max number of RMFs allowed (parameter) ! nfiles i r: Number of RMFs in lstfil ! inarfs c r: Array of RMF names ! infact r r: Array of RMF weighting factors ! contxt c r: error description ! errstatus i r: Status : 0 = OK, !0 = !OK INTEGER ierr, i character(511) instrg, outstr errstat = 0 ! Open the list file OPEN(unit = lstu, file = lstfil, status = 'old') ! Read the lines of the list file, loading the arrays as we go nfiles = 0 READ(lstu, '(a)', iostat = ierr) instrg CALL fcecho('Summing ...') DO WHILE (ierr .EQ. 0) IF (nfiles .EQ. MXARFS) THEN write(contxt, '(a,i4,a)') 'I can only deal with ', & MXARFS, ' files.' CALL fcecho(contxt) errstat = 1 RETURN ENDIF nfiles = nfiles + 1 CALL crmvlbk(instrg) i = 1 DO WHILE (instrg(i:i) .NE. ' ') i = i + 1 ENDDO inarfs(nfiles) = instrg(:i - 1) READ(instrg(i:), '(f22.0)') infact(nfiles) outstr(14:) = inarfs(nfiles) WRITE(outstr(1:13), '(1pe10.3, a3)') infact(nfiles), ' * ' CALL fcecho(outstr) READ(lstu, '(a)', iostat = ierr) instrg ENDDO CLOSE(lstu) IF (nfiles .EQ. 0) THEN contxt = 'Failed to read any input ARFs' CALL fcecho(contxt) errstat = 1 RETURN ENDIF RETURN END