SUBROUTINE inibin(nin, ein, nout, eout, start, end, fstart, fend, & z) INTEGER nin, nout INTEGER start(nout), end(nout) REAL ein(0:nin), eout(0:nout), fstart(nout), fend(nout), z c rashafer 1 april 1987 c subroutine to initialize the variable used by EREBIN to rebin c arrays, assuming that the samples are flat topped histograms c from the lower limit to the upper limit of the bin (e.g. photon c arrays) c version 2 6 April 1987 --- include redshift parameter c c Arguments : c nin i I: number of unbinned energy ranges c ein r I: The unbinned boundaries c nout i I: The number of binned ranges c eout r I: The binned boundaries c start i R: The first unbinned point c end i R: The last unbinned point (if <=start(i) c then there is only one point used) c fstart r R: The weighting for the first(or only) point c fend r R: The weighting for the last point. If c end(i)>start(i)+1, then all points between c have a weighting of 1. c z r I: Redshift: The input model is redshifted c by the factor Z, i.e. all input energies c are treated as coming from ranges c divided by (1+z) INTEGER in, out, i REAL zf CHARACTER wrtstr*255 c Initialize the output arrays to give no contributions DO i = 1, nout start(i) = 1 end(i) = 0 fstart(i) = 0. fend(i) = 0. ENDDO c check whether the redshift is reasonable - if not write out a warning c and return IF ( z .NE. -1. ) THEN zf = 1./(1.+z) ELSE CALL xwrite( & ' Redshift is -1 which will lead to a divide by zero', 2) RETURN ENDIF c find the first unbinned boundary below the first binned boundary out = 0 DO WHILE ((out.LT.nout) .AND. (eout(out)*1.000001.LT.zf*ein(0))) out = out + 1 ENDDO out = out + 1 IF ( out .GT. 1 ) THEN CALL xwrite ( & ' No model information is available for observed frame energies', & 15) WRITE (wrtstr, '(a,1pg14.4,a)') & ' below ', eout(out-1), ' so the model is assumed to be zero' CALL xwrite(wrtstr, 15) c No contribution c N.B. In the current implementation, all the output bins c that have any part below the first input bin are set to c zero flux. However, if a bin is partially above the c last input bin, then it is allowed a partial accumulation c (It just was easier to do that one at the time). ENDIF in = 1 DO WHILE ((in.LE.nin) .AND. (zf*ein(in).LT.eout(out-1))) in = in + 1 ENDDO IF ( in .GT. nin ) THEN CALL xwrite( & ' There is no model information available in the requested ', & 5) WRITE(wrtstr, '(a,1pg14.4,a,1pg14.4)') & ' observed frame energy range of ', eout(0), ' to ', eout(nout) CALL xwrite(wrtstr, 5) WRITE(wrtstr, '(a,1pg14.4,a,1pg14.4)') & ' The model rest frame energy range is ', ein(0), ' to ', & ein(nin) CALL xwrite(wrtstr, 5) WRITE(wrtstr, '(a,1pg14.4)') ' and the redshift is ', z CALL xwrite(wrtstr, 5) RETURN ENDIF DO WHILE ( out .LE. nout ) c the output bin is completely within a single input range IF ( eout(out) .LE. zf*ein(in) ) THEN end(out) = 0 start(out) = in fstart(out) = (eout(out)-eout(out-1)) & /(zf*(ein(in)-ein(in-1))) c Exactly finished the bin IF ( eout(out) .EQ. zf*ein(in) ) in = in + 1 out = out + 1 c Now do the case where the output bin overlaps input ranges ELSE start(out) = in fstart(out) = (zf*ein(in)-eout(out-1)) & /(zf*(ein(in)-ein(in-1))) DO WHILE ((in.LE.nin) .AND. (eout(out).GT.zf*ein(in))) in = in + 1 ENDDO IF ( in .GT. nin ) THEN end(out) = nin IF (end(out).NE.start(out)) THEN fend(out) = 1. ELSE end(out) = 0 ENDIF out = out + 1 ELSE end(out) = in fend(out) = (eout(out)-zf*ein(in-1)) & /(zf*(ein(in)-ein(in-1))) IF (zf*ein(in).EQ.eout(out)) in = in + 1 out = out + 1 ENDIF ENDIF c Now check for case that we have run out of input bins IF ( in .GT. nin ) THEN CALL xwrite ( & ' No model information is available for observed frame energies', & 15) WRITE (wrtstr, '(a,1pg14.4,a)') & ' above ', eout(out-2), ' so the model is assumed to be zero' CALL xwrite(wrtstr, 15) c Signal the dowhile loop that we are done out = nout + 1 ENDIF ENDDO RETURN END