!=== FINAL NAME WILL EVENTUALLY BE Starlight_v06r01.for !! ! s waiting FOCA+FABIO+EDUARDO's TESTS... !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! Starlight_v06r01.for - novelities in the Aug/2017 version !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Starting from PANcMEx_StarlightChains_v04_PHO.for, this new version has ! several novelties, implemented over ~ April--August/2017. The main ones ! are the ESM & CFl, documented below. !!====>>>> NEW ETC-SCALING METHOD (ESM) ! All 5 chi2-functions (namely: SlowF_chi2, FK_chi2, VeryFastF_chi2, ! fun_vd_chi2, and fun_v0_chi2) now return ! ! chi2 = ETC_GlobalChi2ScaleFactor * (chi2_OPTICAL + chi2_ETC) ! ! where chi2_OPTICAL is the traditional sum_l [(Obs_l - Mod_l)/err_l)]**2, ! and chi2_ETC (computed in function ETC_CalcETCchi2) combines the ! FIR/QHR/PHO chi2's and weigths: ! ! chi2_ETC = k_FIR * chi2_FIR + k_QHR * chi2_QHR + k_PHO * chi2_PHO ! ! Each of the chi2_FIR, _QHR & _PHO are traditional chi2's, computed as ! (obs - mod)/err)**2 except for the internal weights [like ! QHR_Chi2ScaleFactor(iY)] given in arq_ETCinfo. ! ! The k_factors combine the user given (in arq_ETCinfo) ! GlobalChi2ScaleFactor with Weight by Number (WbN), Weight by Chi2 ! (WbC) or No Weight (NoW) recipes (as defined in the grid file) as ! follows (example is given for QHR but it's the same for FIR & PHO): ! ! k_QHR = G_QHR * (Np_OPT/Np_QHR)**ETC_alpha * (chi2_OPTICAL/Np_QHR)**ETC_beta ! ! Since (ETC_alpha , ETC_beta) = (0,0) for NoW, (1,0) for WbN and (0,1) ! for WbC, this becomes simply: ! ! k_QHR = G_QHR - NoW ! k_QHR = G_QHR * (Np_OPT/Np_QHR) - Wbn ! k_QHR = G_QHR * (chi2_OPTICAL/Np_QHR) - WbC ! ! where G_QHR = QHR_GlobalChi2ScaleFactor (as given in arq_ETCinfo). ! ! This scheme allow different weighting philosophies to be implemented. ! The ETC_GlobalChi2ScaleFactor does **NOT** affect the relative ! optical/ETC weights. It is introduced to scale the overall chi2 value ! to a ~reasonable scale. STARLIGHT does not really care much about the ! absolute value of chi2, but it is usefull to keep it within reasonable ! bounds, something which we cannot garantee with all ETC-scalings ! discussed above. ! ! ETC_GlobalChi2ScaleFactor = (den/num)**ETC_gamma ! ! where den & num are ! ! num = (Np_OPT + Np_PHO + Np_QHR + Np_FIR) / ! den = G_PHO * Np_OPT**z * Np_PHO**(1 - z) + G_QHR * Np_OPT**z * Np_QHR**(1 - z) + G_FIR * Np_OPT**z * Np_FIR**(1 - z) ! ! and z == (ETC_alpha + ETC_beta) = 0 for Now, or 1 for WbN & WbC. ! ! ETC_gamma (given in the grid file) is used to turn this scaling ON ! (with ETC_gamma = 1) or OFF (with ETC_gamma = 0). ! ! This scaling scheme wors on the assumption that each chi2 should be of ! order of the number of data points, i.e., that one expects chi2_OPT ~ ! Np_OPT, chi2_QHR ~ Np+QHR, etc. ! Cid@UFSC - Aug/2017 !====>>>> GENERALIZED CHARLOT & FALL LAW (CFl) ! ! Using ind_exAV() = -1 in arq_base the ! extra extinction of the ind_exAV(j) = -1 populations is given by ! exAV = a0_CFl + (a1_CFl - 1)* AV. Written in terms of young and ols stars: ! AV_Young = a0_CFl + a1_CFl * AV_Old. This implements 2 extinctions, but only ! one parameter, since the two are tied. The independent term a0_CFl allows for ! some generalization of the original CF-law. a0_CLf & a1_CFl are read from arq_base. ! Changes marked with !CFl! !===>>> !OJO! PHO input change to magnitudes ... FOCA MUST DOC IT!!! !====>>>> Some (relatively) minor changes ! !OJO! & !2BEDONE! mark things to improve in future updates. ! Major changes to output format! !SNmax! Impose S/N = weight_obs(i) * Of_obs(i) <= SNmax_threshold. ! This is done adding (in quadrature) a minimum error to the input Oerr_obs, ! where this minimum error = Signal / SNmax_threshold. While testing MaNGA & ! D3D runs w/Andre et al, we decided to implement this trick. ! SNmax_threshold is read from arq_config. If = 0, nothing is done. ! Changes marked with !SNmax! ! Cid@Lagoa - 09/Aug/2017 ! i_ChangeIdum = 0 bug: I realized that i_ChangeIdum did not really work, as ! sequential calls in a grid file with repeated entries did not repeat the ! sequence of idum's This was due to the way NR's gasdev() is written. I have ! changed it (see gasdev function & common/Init4gasdev/ isetInit4gasdev)so that ! now i_ChangeIdum = 0 is correctly implemented. This was noticed during the ! ESM work, but is unrelated to it. ! Cid@UFSC - 14/Aug/2017 ! Changed ModlogY ==> logY_mod just on output. Also, removed all chi2-%ratios, ! as they now do not (necessarely) make sense w/the new ESM-scheme. ! Some basic renaming of the internal FIR-nomenclature was done for ! elegance/consistency with QHR & PHO: ! Renamed FIRlogLobs_norm, FIRq_norm, FIRModlogLFIR & FIRModlogLBOL ! to ---> FIR_logLobs_norm, FIR_q_norm, FIR_ModlogLFIR, FIR_ModlogLBOL. ! Removed fscale_chi2 altogether! Implies 1 less line in the grid file, and ! changes in the arq_out too. ! F_adev now returns adevS, ie, the adve wrt the synthetic spectrum. ! Introduce a slight/harmless change which seems to allow fits with a ~ fixed ! AV by setting AV_upp = AV_upp + a-little-bit. Lookup !~FixAV! ! Removed power-law stuff. It was already turned off since the 1st MEX versions ! but not completely removed from the code. This changes arq_out. ! New IsReadQHfromBaseFile switch added to config file to decide whether ! to (=1) read QH from an 8th column in arq_base or (=0) to integrate it ! directly from the base spectra. Changes marked with !QHi! ! Minor change: Renamed FIRChi2ScaleFactor --> FIR_GlobalChi2ScaleFactor. ! FIR-nomenclature differes slightly from that in QHR & PHO... :-() ! A sum(x) > 0 sanity check was added to AverageXoverLambda(x,AV_tot,avelamb_x) ! in order to circumvent Herpich's bug! ! Cid@Lagoa - 13/Apr/2017 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Current version: PANcMEx_StarlightChains_v03.for ! BIG/IMPORTANT CHANGE! Optimize fn: I now allow for the scaling (normalization) ! factor to be evaluated ANALITICALY, such that dchi2/dfn = 0. This ! was something which should have been implemented long ago, but I ! never did ... It seems that by letting fn free, as a parameter, most ! pop vectors experimented during the chains had their chain energies ! larger than they could be, just because of a bad/unlucky choice of ! fn! I did not test this thoroughly, but the few tests I did suggest ! this, and it makes perfect sense! With this new option, we may have ! to evaluate many less steps than before! ! ! The changes associated to this are marked by !OPTfn!. Apart from the ! change in arq_config and the common/Optimize_fn_OPT/, the main ! changes are in routines SlowF_chi2, VeryFastF_chi2, and ! MEX_ScubiduCadeVoce. The to-do-it-or-not-to-do-it flag ! IsOptimize_fn_OPT (read from arq_config) is saved (in an odd ! place...) in the output file ! Is1stLineHeader: I also removed the ugly Is1stLineHeader flag from arq_config. Now ! arq_obs can have ANY number of header lines starting with a '#', ! with no need for any previous information on that (as always did ! for base spectra) ! Added i_SaveBestSingleCompFit in this output file to help reading ! macros. This info determines whether a 5th spectral columns is ! saved in the or not. ! Spectral flux format: Relucted to do this, but finally changed spectra ! format in output file. (Sometimes, for crazy spectra, numbers would ! be much larger than 1 (in units of fobs_norm...) and the format ! would go correspondingly crazy. A harmless thing anyway. ! Flagged pix in output weight col: Instead of assigining -2 to every flagged ! pixel, I now keep the values of the input flag (possibly resampled) in ! the output. If the input flag-spec has different values meaning different ! situations (sky lines, hot pix, etc etc), this alows one to identify this ! in the output file itself. A purely cosmetical change! ! ElCid@Sanchhica - 10/Feb/2012 !2BEDONE! Some to-be-done things... (some marked in the code with !2BEDONE!) ! * Implement save chi2_FIR , chi2_QHR... in the PDF-sampling option! (Some comments ! were included in preparation for that.) ! ! * Minimum Nl_eff in clipping in 50 ... should be more smartly scaled! ! ! * ATT: fobs_norm computation IGNORES bad (flaged/masked) pixels!! ! This is dangerous and could/should be changed one day... ! ! * Clean up the f'ing code!! This looks more like a diary! ! ! ElCid@Sanchica - 06--10/Feb/2012 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Was PANcMEx_StarlightChains_v01.for - started to tidy it up in GRX/Aug/2011!! ! ElCid@Sanchica - 15/Ago/2011 ! ! The old compilation warning ! do u=u_low,u_upp,du ! Warning: Deleted feature: Step expression in DO loop at (1) must be integer ! was fixed with a new version of routine GaussSmooth which replaces the ! (real) u-loop by an (integer) i_u-loop. ! ! Some testing was done, but not all things were implemented .... Anyway, decided to ! rename to PANcMEx_StarlightChains_v02.for to start CALIFA work! ! ! ElCid@Sanchica - 08/Oct/2011 !FIX4CALIFA! ATT: In PANcMEx_StarlightChains_v01.for, used for the U/LIRGS work, ! the parameter n_pt_MaxBF = 10000, but this is TOO LARGE if one is dealing ! with just one extinction, as I am now doing for the CALIFA data. In this case ! one has nBF_Dim = 1 and thus ! n_pt_PerDim = (float(n_pt_MaxBF))**(1. / float(nBF_Dim)) = 10000 ! n_pt_BF = n_pt_PerDim**nBF_Dim = 10000 ! For instance, in good-old StarlightChains_v04 the equivalent was NAV_try = 100, ! ie, 100 times less! ! I thus changed it to 100 here.... it's a 1 line change, marked with !FIX4CALIFA! ! If I now try 2 extinctions, then there will be only 100**(1/2) = 10 pts per AV ! Should rethink if this need to go to a config file or set it up on the code depending ! on how many extinction I actually use in the fit... ! ! ElCid@Sanchica - 10/Oct/2011 ! I have relocated the READ MASK FILE block to BEFORE the read-observed-spectrum block, ! and used the masks in the estimation of a S/N in the absence of an error spectrum. ! The motivation is that we are building CALIFA masks for Pre-Processing which mask away ! main bugs, like sky-lines (besides EmLines, of course), and it is unfair to include any ! such "faulty" region in an estimate of the rms which represents the error. ! ! Added more blurb on the chains output headers (at Natalia's & Rafa's request) ! ! Some experiments w/CALIFA suggest that EX0s produce x-solution which are more focused ! than those in the chains... need to understand this better! Is this related to the ! infamous bermuda triangle issue?? Is this a localization onto a local minimum while fine-tuning? ! ! The chains-output contains Mcor_j, NOT Mini_j. I can add that ~ easily, but ! it is also easy to do the transformation using the information already provided in ! the output, so I decided NOT to add more bytes to arq_out. ! ! ElCid@Sanchica - 17/Oct/2011 !FIX-DAE2-BUG! ATT! Found a serious PROBLEM. In dae2.iaa.es, the gfortran version is 4.6.1, ! while here in my humble MacBook it is (thank's god) older: 4.4.1. While doing some ! fits of **horrible** ARP220 CALIFA spectra, the code stopped with a segmentation fault at dae2, ! but not in my MacBook! Furungating in the code I realized that @ dae2 the FUNCTION fun_v0_chi2 ! was being called (from with those dammed NR routines .... mnbrack & golden) ! with completely absurd values... The input crappy-spectrum deserved such a bad treatment, but ! the code should not crash! I have thus changed both fun_v0_chi2 & fun_vd_chi2 FUNCTIONs, ! such that they now return an "infinite" (= 3.0e38) chi2 everytime they are ! called with vd or |v0| > 5000 km/s. For some reason gfortran 4.4.1 can cope with the infinities... ! This should really not make any difference for minimally decent spectra (I've checked it)! ! The changes are marked with !FIX-DAE2-BUG! ! ! BTW, I have also fixed the gfortran (correct!) complaint/warning: ! call HYPERZ_red_spec(l_aux,f_int_aux,1.0,f_obs_aux,1,1,ilaw_rd) 1 ! Warning: Actual argument contains too few elements for dummy argument 'wl' (1/1300) at (1) ! This was a silly and harmless thing. Fix marked with !FIX-DAE2-WARNING-HYPERZ! ! ! ElCid@Sanchica - 21/Oct/2011 !MORE-BUGS: Fixed an un-noticed bug in GaussSmooth (the new version which replaced do u=... ! by do i_u=... to avoid/skip compilation Warnings). See comments on SUBROUTINE GaussSmooth. ! ! ElCid@Sanchica - 05/Nov/2011 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Minor fixes: ! (1) Fixed Z_base format to f8.5 to satisfy Paula Coelho. She says ! this is needed when Z is expressed in log units (eg, -1.5, as in ! Vazdekis models) ! ! (2) Natalia realized that when the SN-window has no info to compute ! SN, then the trick to use all the spectrum to compute a fake SN ! screws up all next galaxies in a grid! This happens because ! llow_SN & llup_SN are read from the grid file, but changed ! forever once this safety-trick is activated... To fix this bug I ! simply renamed llow_SN & llupp_SN in the driver to the main code ! to Ollow_SN & Ollupp_SN, and restore them everytime I call the ! main code. ! ! (3) One thing which alway annoyed me was that when repeating large ! grids using the same grid-file, it took ~ 1 second per run (all in ! the reset-stuff block) to reach the SkipExistingOutFiles-check. For ! large grids, this implies a huge waste of time! I've changed the ! order of things (read input info and test if file exist 1st, and ! only then reset arrays) to fix this "bug". ! ! (4) In Jan/2011 I had the impression the idum_orig = 0 trick was NOT ! working, but now this bug seems to have vanished ! ! MISCELANEOUS: ! ! Shoud re-check PDF option, and maybe save only 1 out of "M" steps ! to avoid huge PDF files with little x-variations.... anyway, re-check it. ! ! IDEA: maybe I can impose limits in, say, EW(G-band) using PHO! .... think about it! ! ! ElCid@Sanchica - 15/Ago/2011 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ************************************************************************* *** PANcMEx_StarlightChains_v01.for *** ************************************************************************* c PANCRHOMATIC-contraints & MULTIPLE EXTINCTION STARLIGHT: c [FIR and/or QHR-ELR and/or PHO-constraints] c ABSTRACT: Expanding upon FIRcMEx_StarlightChains_v02.for [from c ~ Jan-Feb/2010 work], this version now accounts for two other types c of input constraints: ionizing photon rate (QH) Related [hence c "QHR"] stuff and photometric data ("PHO"). Within QHR, one can use c emission line log-luminosities (logY) and/or use an c EmissionLineRatio (eg, Ha/Hb) to constrain the fit! (ELR-fits c should be particularly useful for MEx-fits, and help contraining c young & reddened populations.) The notes below report some of the c things associated w/this new version. c **> NEW ETC-file: The user now provides a **single** separate c input file (arq_ETCinfo) with FIR and/on QHR and/on PHO data. The c file is such that when reading it [in routine Read_ETC_Info] the c code realizes which FIR/QHR/PHO data are available and how to use c them. The scheme is pretty flexible. For instance, you do not need c to specify info for all FIR + QHR + PHO constraints, and even if c you do so, they can be accomodated in any order in arq_ETCinfo. See c comments in routine Read_ETC_Info for more on this. c The GRID FILE now contains IsFIRcOn, IsQHRcOn & IsPHOcOn flags. c These admit 3 options: c c 1 = YES, use info to the constrain the fit. c 0 = NO, do not use the info in arq_ETCinfo at all. c -1 = do not use the ETC-info in the fit, but instead PREDICT IT c c [eg, predict the FIR luminosity even without any FIR-data, or c predict PHOtometric luminosities given some input filters.] c Options 1 & -1 produce FIR/QHR/PHO-related output in arq_out, c while option 0 does not. c **> HANDLING 4 CHI2's! The way the FIR+QHR+PHO-info is actually c used in the fit is identical to that in earlier FIRc-work, ie, via c gaussian-flat-top likelyhood profiles which allow for range c fitting, normal fitting and scaling of the corresponding chi2 wrt c the optical-fit chi2. In practice, we now have c c chi2 = chi2_Opt + chi2_ETC c c where chi2_Opt is the good-old-chi2 of the optical fit (before all c new-stuff/ETC was implemented), and c c chi2_ETC = chi2_FIR + chi2_QHR + chi2_PHO c c The FIR, QHR & PHO-chi2 functions are all called from within the c old-chi2 functions/routines: SlowF_chi2, FK_chi2, VeryFastF_chi2, c fun_vd_chi2 & fun_v0_chi2. [These are the 5 key chi2 routines, as c far as the code is concerned.] In fact, a single FUNCTION c ETC_CalcETCchi2(x,AV_tot,chi2_OPTICAL,WhereFrom) is called, which c joins the chi2's from the new FUNCTIONs FIR_CalcFIRchi2, c QHR_CalcQHRchi2 & PHO_CalcPHOchi2. Besides these functions, there c are initialization SUBROUTINES (FIRInitialization, c QHRInitialization, PHOInitialization, Read_ETCinfo) and a bunch of c commons (eg, QHR_BaseStuff, PHO_DataStuff, FIR_OutputStuff...) c involved in the implementation of these extra-info in the spectral c fits. c c chi2 = chi2_Opt * [1 + chi2_FIR/chi2_Opt + chi2_QHR/chi2_Opt + chi2_PHO/chi2_Opt] c OBS: Curiously, with these changes it became somewhat tricky to c obtain a pure optical chi2... The reason is that all other c chi2-functions need Chi2_Opt for scaling purposes, while the c values returned by the old chi2-functions (eg, FK_chi2) are now c TOTAL chi2's... In the output section of the code there are a few c manouvers which illustrate how to go about this. c c **> FIR/QHR/PHO CHI2-SCALE-FACTORS: FIRc-fits introduce only one c observable, FIR_logLFIR_obs, and thus only one FIR-to-Optical c chi2-scaling factor is needed: FIR_GlobalChi2ScaleFactor. QHRc & PHOc c fits, however, may introduce more than one observable each c QHR_logYobs(iY), iY=1...NQHR_Ys, and PHO_logYobs(iY), c iY=1...NPHO_Ys. Each of this comes with its own scaling factor, c QHR_Chi2ScaleFactor(iY) or PHO_Chi2ScaleFactor(iY), but in order c to attribute a global meaning to these, there is also a c QHR_GlobalChi2ScaleFactor (and similarly for PHO) which says what c is the global weight that the QHR chi2 should have wrt to the c optical one. For instance, if you use two emission lines (Ha and c Hb), each with QHR_Chi2ScaleFactor(iY) = 1, and chose c QHR_GlobalChi2ScaleFactor = 1, in practice each of the lines will c be scaled by 1/2 of the optical chi2. c **> FRAC2MODEL, LOW <= OBS <= UPP - RANGE & FLAT-TOP-GAUSSIAN c LYKELYHOODS: For any of FIR/QHR/PHO, the user inform in c arq_ETCinfo a total luminosity and the fraction of it to be c modeled (a trick to account for, say, aperture effects), and this c defines the observed value used in the fit [eg, QHR_logY_obs(iY) c for the log of the iY emission line luminosity]. Then a RANGE is c specified, from which one defined *_low & *_upp limits for the c observable (eg, logLFIR). If RANGE = 0, then UPP = LOW and the c likelyhood wil be a gaussian with the given input error. If RANGE c NE 0, then we create a flat-top-cored gaussian, with gaussian c wings below *_LOW & above *_UPP, but flat behaviour (corresponding c to chi2 = 0!) in the middle, such that the fit will try to c constrain the value of the observable between *_LOW & *_UPP. For c RANGE > 0, we set *_UPP = *_OBS and *_LOW = *_OBS - RANGE c (suitable for upper-limit fitting), whereas (at Natalia's c suggestion) for RANGE < 0, we do the opposite (ie, *_LOW = *_OBS c & *_UPP = *_OBS + RANGE, suitable for lower limit fitting). c Setting a very small error, these ranges work like chi2 walls c ("likelyhhod abisses"). This scheme works for FIR, QHR & PHO info. c **> LUMINOSITIES & FLUXES: All galaxy-data in arq_ETCinfo is given c in **LUMINOSITIES** (Lsun for FIR-work and also for emission line c luminosities used in QHR-work, or Lsun/Angs), but the optical c spectrum is a flux... The user now inputs LumDistInMpc in the GRID c FILE, and this is used to define Lobs_norm and then scale things c to absolute quantities. c ATT: It is the user's responsability to make sure that the c luminosities in arq_ETCinfo were computed with the SAME c LumDistInMpc informed in the GRID file. Notice that this REVERTS c the double-checking policy in FIRcMEx_StarlightChains_v02.for... c **> NEW GRID-FILE ENTRIES: c c etc_dir = dir where to find arq_ETCinfo c IsFIRcOn = 0/1/-1 = no FIRc-fit/FIRc-fit/only *predict* FIR things. c IsQHRcOn = 0/1/-1 = no QHRc-fit/QHRc-fit/only *predict* QHR things. c IsPHOcOn = 0/1/-1 = no PHOc-fit/PHOc-fit/only *predict* PHO things. c arq_ETCinfo = file where all FIR/QHR/PHO info is provided. c LumDistInMpc = same distance used to compute the luminosities in arq_ETCinfo c **> NEW CONFIG-FILE ENTRIES: If any FIR and/or QHR and/or PHO c stuff is to be used, then read ALL the following, regardless of c which of the ETC-features will be used in practice: c c FIRAV_grid parameters (= PHOAV_grid parameters): NFIR_AV, c FIRAV_low, FIRAV_upp (= NPHO_AV, PHOAV_low, PHOAV_upp), c QHRbeta_I, FIRbeta_I, FIRbeta_D c **> NEW ROUTINES introduced during FIR+QHR+PHO=ETC-implementation: c c SUBROUTINE FIRInitialization(i_verbose,N_base,Nl,l,l_norm,red_law_option,FIRbeta_I,FIRbeta_D) c FUNCTION FIR_CalcFIRchi2(x,AV_tot,chi2_OPTICAL,WhereFrom) c SUBROUTINE AverageXoverLambda(x,AV_tot,avelamb_x) c c SUBROUTINE QHRInitialization(i_verbose,N_base,Nl,l,l_norm,red_law_option) c FUNCTION QHR_CalcQHRchi2(x,AV_tot,chi2_OPTICAL,WhereFrom) c c SUBROUTINE PHOInitialization(PHO_redshift,NPHO_Ys,i_verbose,N_base,NOl_base,Ol_base,l_norm,red_law_option,etc_dir) c FUNCTION PHO_CalcPHOchi2(x,AV_tot,chi2_OPTICAL,WhereFrom) c c SUBROUTINE Read_ETC_Info(i_verbose,arq) c FUNCTION ETC_CalcETCchi2(x,AV_tot,chi2_OPTICAL,WhereFrom) c c OBS: Apart from input & output changes, several changes were c needed in SUBROUTINE MEX_EX0s_Fit_Scubi to store & restore c ETC-related arrays. c **> FIR/QHR/PHO INPUTS in arq_ETCinfo: See also routine Read_ETCinfo. c c FIR_logLFIR_TOT c FIR_LFIRFrac2Model c FIR_ErrlogLFIR c FIR_RangelogLFIR c FIR_GlobalChi2ScaleFactor c c NQHR_Ys = Number of line-luminosities (Y) used for QHRc-fits c QHR_GlobalChi2ScaleFactor = to re-scale each QHR_Chi2ScaleFactor(iY) c ELR-info: IsELROn, ELR_lambdaA & B, ELR_ErrlogR, ELR_RangelogR, ELR_Chi2ScaleFactor. c These info are used inside QHR-routines to predict L_A / L_B and c compare it to the observed value. c QHR_lambda(iY) = line wavelength, in Angs c QHR_frecomb(iY) = # of recombination/line photons from Osterbrock-like theory c QHR_logY_TOT(iY) = observed luminosity [in Lsun] c QHR_YFrac2Model(iY) = fration of Y_TOT which should be considered in fit c QHR_ErrlogY(iY) = Error in logY c QHR_RangelogY(iY) = Range in logY - defines flat-top core in likelyhood c QHR_Chi2ScaleFactor(iY) = weight wrt to optical fit c ...where iY=1,NQHR_Ys c c PHO_redshift = redshift to be applied to a model spectrum such c that the model-filter-luminosities can be compared c with the observed ones (avoids need of K-correcting c data). c NPHO_Ys = # of photoetric data points to be used/considered. c PHO_name(iY) = a char*10 string to identify the filter c PHO_Filter_file(iY) = the transmissin curve file c PHO_logY_TOT(iY) = total luminosity in the filter [Lsun/Angs] c PHO_YFrac2Model(iY) = fraction of Y_TOT to be modeled c PHO_ErrlogY(iY) = error in logY [dex] c PHO_RangelogY(iY) = range in logY [dex] c PHO_Chi2ScaleFactor(iY) = weigth wrt to optical chi2 c ...where iY=1,NPHO_Ys c **> GENERAL NOTES ON QHR-WORK! QHRc-fits denote fits which use c QH-Related constraints, QH being the rate of ionizing photons c predicted by a model. These fits use the observed luminosities of c NQHR_Ys recombination emission lines (e.g., Ha, Hb...) in c conjunction with the QH measured in the base spectra to predict c emission line luminosities and (hopefully) better constrain the c spectral fit. *QHR* marks changes in the code related to c QHRc-modeling. c c See the abstracts to SUBROUTINE QHRInitialization and FUNCTION c QHR_CalcQHRchi2 for details on the modeling of QHR-things. c There is still quite a lot of testing to be done.... In any case, c I expect that by imposing consistency with LHa & LHb, and FIR-data c too, I can get more consistent/reliable resuts for MEx fits... c c NOTE: All QHRelated things rely entirely in the input-base models c for lambda <= 912 Angs. If you do not trust these models, do not c use this code, or else, fiddle the <= 912 Angs base spectra to make c them be more of your likening... This fiddling is enteriely left c for the user... c Within QHRc-fits, we can now fit an EmissionLineRatio (ELR)! This c is very cool, since we may not trust the, say, Hb & Ha c luminosities (due to claibration, apertures & other effects), but c we my still want the model to predict/fit the correct/observed c Ha/Hb! In practice, since the yous pops are the ones whichproduce c ionizing photos, fitting a given Ha/Hb is ~ equivalent of fixing c the AV_tot of these you populations! I always wanted to do this, c and it is now working :-) c **> GENERAL NOTES ON PHO-WORK! !AKI! I just wrote the code, but c had not tested it seriously yet! I'll wait for tests before c writing something here... c Cid@Lagoa - 11/Jan/2011 ************************************************************************* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! The misterious "Illegal Instruction" Bug and how I fixed it ... ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! While implementing PHO-things, suddenly the code would compile ! well but, when running it, this is what happend: ! ! cid@MacBook-de-Roberto-Cid-Fernandes:~/IAA/LIRGS$ ./novo5.exe < qhtest.in5 ! Illegal instruction ! ! It crashed immediately. This happened while I was reseting ! PHO_3Mat(j,iY,i_AV) in SUBROUTINE MEX_EX0s_Fit_Scubi. It had to be ! something about gfortran... Before this I had already written ! notes to myself saying that the FIRAV_grid array was stupidly ! overdimensioned at Nl_max (= 14000) just for lazyness. The same ! thing propagates to FIR (j,i_AV) matrices FIRR_opt, FIRR_Lya ! FIRR_LCE & FIRRmat, to the new PHOAV_grid and ! PHO_3Mat(j,iY,i_IAV). For the default values of Nb_max, ! NPHO_Ys_max and Nl_max, the size of PHO_3Mat was 300 x 100 x 14000 ! = 4.2e8! No wonder it caused gfortran to crash... ! ! The solution was to do what I should have done earlier, ie, ! rationalize the size of AV-grid related arrays. I've introduced a ! new parameter NAVgrid_max = 1001, and used it in the declarations ! of: ! ! FIRAV_grid(NAVgrid_max) , FIRR_opt(Nb_max,NAVgrid_max) , ! FIRR_Lya(Nb_max,NAVgrid_max) , FIRR_LCE(Nb_max,NAVgrid_max) , ! FIRRmat(Nb_max,NAVgrid_max) ! PHOAV_grid(NAVgrid_max) ,PHO_3Mat(Nb_max,NPHO_Ys_max,NAVgrid_max) ! ! and the bug was gone! ! ! Cid@Lagoa - 11/Jan/2011 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ************************************************************************* *** FIRcMEx_StarlightChains_v02.for *** ************************************************************************* ! *ABSTRACT: STARLIGHT + Multiple Extinctions + FIR-constraints! ! This version uses a simple (energy-balance/bolometric) dust model ! to compute the luminosity expected in the FIR due to dust ! reprocessing of extincted stellar radiation. This extinction- and ! pop-vector-dependent prediction is (optionally) compared to the ! observed FIR luminosity (eg, IRAS) to constrain the mixture of ! populations & exctinctions, ie, the solution! Originally developed ! for the U/LIRG work, this version may be useful for other projects ! too. In particular, the changes introduced to account for the ! FIR-constraints (alas "FIRc") are very similar to the ones I'll ! need to introduce to include multi-band photometric constraints! ! The dust reprocessing model is described in routine ! FIRInitialization, and the computation and scaling of the FIR-chi2 ! is explained in the function FIR_CalcFIRchi2 (which allows for ! both classical fitting and range/upper/lower-limit fittings). ! FIR-related routines were basically added to this version of STARLIGHT! ! Nonetheless, a number of adjustments had to be made in other parts ! of the code. The changes are all marked with "*FIR*" and ! commented. A new AverageXoverLambda(x,AV_tot,avelamb_x) routine ! was also included (see below). ! This version is supposed to run as the old one when no FIRc-fit is ! intended, though this has not really been tested thoroughly as ! yet... ! There are IMPORTANT and MAJOR changes in the input grid file, as ! well as minor aditions to arq_config! These were implemented ! because they are needed in FIRc-fits, but they are useful **in ! general**. For instance, the user must now provide the physical ! UNITS of the input f_obs(l_obs) spectrum, and the DISTANCE! With ! these changes the output masses are now in units M_sun! Things ! like the bolometric lum of the model (in L_sun) and the predicted dust ! reprocessed luminosity (also in L_sun) can also be computed. If no ! distance is known (or if distance is irrelevant), the user needs ! to cheat STARLIGHT by providing some entry for it;-) ! An extra option to deal with how-to-EX0 the fit was added. The ! user can now chose to decide which elements of the base are ! excluded on the basis of an Lambda-Averaged pop-vector (LAx). I ! found this useful when working with U/LIRGS, where a component may ! be weak at lambda = l_norm but much stronger (and thus more ! relevant) at other wavelengths. This is presumably a better option ! in general! ! In addition, the user MUST provide an arq_FIRinfo file, which, as ! name suggests, provides the FIR information needed for FIRc ! fits. If no FIRc-fit is intended (and there is an entry in the ! grid file to state this), just set arq_FIRinfo to nodata.stupid, ! or something like that. ! There are also MAJOR changes in the OUTPUT. I tried to change as ! little as possible, but it was not possible to avoid changes which ! imply adaptating the programs & macros which read STARLIGHT's ! output... The two major changes are a new block where ! Lambda-Averaged pop-vectors (LAx*) are reported, and at the very ! end of the file, where the FIR results are outputed. ! ! Notice that correct modeling of the dust-reprocessing REQUIRES ! bases which provide spectra from l << 912 Angs to the optical, ! since ionizing photons and non-ionizing UV light are the major ! contributors to dust emission in the Far IR... At the time of ! writing, only BC03/CB07 provide this info! ! ! Silly bugs in previous versions (like the bug in AV-estimation for ! SSP fits and the saving-in-the-wrong-dir when fobs_norm = 0) were ! also fixed (as in StarlightChains_v05.for). Also added the ! save-best-ssp-spec option from v05. ! ! OBS: There are important differences wrt ! FIRcMEx_StarlightChains_v01.for (which was given a final-looking ! name too early...). ! * NEW GRID-FILE INPUTS: ! ! IsFIRcOn = 0/1/-1 = no FIRc-fit/FIRc-fit/only *predict* FIR lum. ! flux_unit = multiplicative factor to conver f_obs to ergs/s/cm2/A ! LumDistInMpc = luminosity distance in Mpc. ! arq_FIRinfo = file where FIR info is provided. ! ! ! * arq_FIRinfo INPUTS: ! ! FIR_logLFIR_TOT = TOTal log FIR luminosity [Lsun] ! FIR_LFIRFrac2Model = frac of LFIR_TOT to consider in fit ! FIR_ErrlogLFIR = error in log L_FIR [dex] ! FIR_RangelogLFIR = Range in log L_FIR [dex] ! FIR_GlobalChi2ScaleFactor = multiply chi2_FIR by this and by chi2_OPTical! ! ! ! * NEW ROUTINES introduced during FIRc-implementation: ! ! FIRInitialization(N_base,Nl,l,l_norm,..,FIRbeta_I,FIRbeta_D) ! FIR_CalcFIRchi2(x,AV_tot,chi2_OPTICAL,WhereFrom) ! AverageXoverLambda(x,AV_tot,avelamb_x) ! ! * NEW CONFIG-FILE ENTRIES: ! ! > i_SaveBestSingleCompFit = inherited from v05 & MCclusters work: ! = 1/0 = Y/N - save best single component fit on output ! > iEXOs_IsAve_x_of_lambda = 0/1: (0) Make EX0 relevance-decision ! with x(l_norm) or (1) with . The latter is the ! Lambda-Averaged (weighting by weight_obs) pop-vector. ! > FIRc technical parameters (needed to model dust reprocessing): ! FIRbeta_I, FIRbeta_D, NFIR_AV, FIRAV_low & FIRAV_upp ! * ARRAY-RESETINGS: During the implementation of FIR-constraints I ! realized that some arrays were not reset to = 0. This causes a ! harmless population of unused array elements with RAM-garbage. In ! principle this does NOT affect the code, since the elements that ! matter are correctly dealt with, but it is annoying and drove me ! crazy for a few days in January/2010. Because of that I now reset ! ALL output quantities, including ALL Nb_max elements of x() & ! exAV(), among many other arrays. The reseting is done even in ! routines which are called-up all the time, like ! MEX_Unpack_par2xAVYAVfn, but I have verified that this does not ! slow down the code significantly at all. These changes are marked ! with "*FIR*", "Reset" or something similar throughout. ! Cid@Granada+LaLaguna - Jan+Feb/2010 ************************************************************************* ! The StarlightChains_v05.for abstract below was added to explain ! what was introduced/fixed in that version. ! ------------------------------------------------------------------ ! | StarlightChains_v05.for | ! ------------------------------------------------------------------ ! ! !!Found a TRUE & +/- SERIOUS bug in StarlightChains_v04.for:( The ! bug affects ONLY the single-component (SSP) fits carried out at ! the end of each run. It MAY lead to wrong SSP-parameters, ! particularly when they are already bad anyway. The bug was: ! ! call mnbrak(ax,bx,cx,fa,fb,fc,F_SSP_chi2_AV) ! chi2_AV_Gold = golden(ax,bx,cxf,F_SSP_chi2_AV,tol,AV_Gold) ! ! where "cxf", instead of "cx", was passed to golden, leading to a ! (not always) incorrect estimation of AV_Gold. Cid & Rosa noticed ! this bug in the AV_SSP x SSP age curves while fiting star cluster ! spectra. AV_SSP becomes constant at some values of age (but, ! luckly, not in the range of best SSP fits). This version corrects ! this bug. ! ! This version also reads a new i_SaveBestSingleCompFit flag from ! the config file. If = 1, the best fit SSP spectrum is saved as a ! 5th column in arq_out, otherwise the output is as in v04. ! ! Finally, I also take the chance to fix the harmless previously ! knwon bug that when fobs_norm = 0 arq_out is saved in the running ! dir, instead or in out_dir. Now such bugged output-files are saved ! in out_dir. ! ! All changes are marked with "!v05!". ! ! Cid@Lagoa - 10/May/2008 ! ------------------------------------------------------------------ ************************************************************************* * MEX_StarlightChains_v01.for * ************************************************************************* * * This is the 1st "official" version of the Multiple EXtinctions * (a.k.a. "MEX") version of Starlight. Based on * StarlightChains_v04.for, but with MEX-modifications. Except for * output details, the code is exactly = multext_draft9_com_v04.for, * which I used for initial tests. * * There are still a "few" things to tidy up, but this will be left * for later ... Now I will concentrate on running this version for * the VLIRGS project with Rosa. Later on, I should consider making * this version public (in which case I should 1st check that it does * work exactly as the previous one in the simpler case of a single * AV). * * Cid@Lagoa - 30/July/2007 ************************************************************************* * Miscelaneous comments/notes... * Implemented CUMULATIVE AV_tot scheme. Most of what I had to do was * to adapt routine MEX_Update_AV_array(N_par,N_base,AV,exAV,AV_tot) * and a few loose ends. * * eliminated useless input in arq_config: YAV_low & _upp + * PowerLaw-stuff. ! tah indo bem, mas o adaptive-steop pros AV & exAV inda parece ! estranho... Passos em av parecem too large!! eg: ! a*eps_AV=8.25E-01 Sao os "ultimos" !!UEPA!!'s antes de usar pra ! valer com as VLIRGS...ou simuacoes ... ou SDSS galaxies... ! aparentemente i_UpdateAVYAVStepSeparately = 0 dah um jeito... * Cid@Lagoa - 28/May/2007 * Introduced "revert to slow chi2 in case of horror" scheme! * *BUT* It will only be used if NRC_AV_Default < 0 in arq_config!! * Ideally I should make it revert-to-slow-chi2 automathicaly when * the RC-scheme fails.... but I have NOT done it! * Cid@Lagoa - 28/May/2007 c OBS: me dei conta de que ha uma maneira bem + simples de c implementar um EX0s scheme: eh soh definir um array com os indices c das componentes relevantes e soh perturbar elas! :( * ====================================================================== * !!MEX!! Peguei o StarlightChains_v04.for e vou comecar a meter as * multiple extinctions nele... Marcacoes com !!MEX!! (Cid@Lagoa - * 19/April/2007) ! ------------------------------------------------------------------ ! | StarlightChains_v04.for | ! ------------------------------------------------------------------ ! v04 = 1st public version of STARLIGHT! ! This new version is still similar to StarlightChains_v02.for, but ! with a large suite of new features, including some which imply ! changes in the grid file info, base-file (arq_base), config-file ! (arq_config) and output file (arq_out) too! ! ! The ~ minor changes are (some imply changes in the grid, config, ! base & arq_out files): ! ! (01) Fixed the "infinite loop" bug plus the silly i<->j mistake in ! arrays-reseting (found by William). Also, changed Nl_max from 7000 ! to 14000. (Paula's base has ~ 10400 pixels!). ! ! (02) Added some time() & etime() commands to figure how long a run ! takes (useful to test configs). ! ! (03) Added protections against non-increasing l_obs() & l_base(), ! Mstars() <= 0 & idum_orig > 0. ! ! (04) If idum_orig = 0 in the grid.in file, then idum_orig will be ! kept the same for all runs in the grid file. Also added protection ! against idum_orig > 0. ! ! (05) Added a nice & simple feature: If the output file arq_out ! already exists, then we SKIP THE FIT altogether and go to the next ! one on the list! Very useful to run grids in "modo-burro"! At ! William's request, I added a Y/N flag in arq_config which decides ! whether this trick is to be used or not. ! ! (06) In preparation for alpha enhanced bases, I have increased to ! character*15 the size of the component nickname (base_name), and ! introduced a alphaFe_base() arrays which MUST be read from ! arq_base. alphaFe_base() is echoed in the output, along with x & ! etc. ! ! (07) Mask base edges! The first & last dl_cushion Angs in the base ! spectra will be masked to prevent edge effects in the kinematical ! filter! ! ! (08) dl_cushion used to be fixed at 50 Angs in previous ! versions. Now we read it from arq_config! (whose format thus ! changed!) ! ! (09) After STARLIGHT is done (ie, just before output) we now do ! "Single-Component-Fits", where each of the base spectra is ! compares to the data individually. We fit AV and the ! norm. factor. The results are stored along with the main fit pop ! vector (see SSP_* arrays). This may be used to define a "best ! single component" representing a spectrum (potentially usefull for ! star-clusters and elliptical galaxies.) ! ! (10) Now reading fEX0_MinBaseSize from arq_config. This is used ! to define N_base_min = nint(fEX0_MinBaseSize * N_base) in EX0-fit. ! ! (11) Removed unnecessary common/YAV_stuff/ in ConvertLight2Mass. ! ! (12) Now the EX0s routine will NOT be called when NEX0s_loop = 0. ! Part of the output was computed & printed with EX0s* parameters ! (like x, av, v0, vd...), so I had to fix that to allow for the ! NEX0s_loop = 0 case. (changes marked with "!Cid24Mar07-FIX!") ! ! (13) Added "censored weights" (Weight-control-filter-stuff) info ! in the output file just for control-purposes. ! ! (14) Added a scheme to count number of columns in arq_obs to check ! consistency of IsErrSpecAvailable & IsFlagSpecAvailable... ! ! (15) Added protection againts using i_FastBC03_FLAG = 1 and non ! BC03/STELIB models. If this happens, reset i_FastBC03_FLAG to 0. ! ! (16) The grid file now hase obs_dir, mask_dir & out_dir, which are ! dire directorieds whre arq_obs & arq_masks will be read from and ! arq_out will be written to. ! ! (17) Format of l_obs on arq_out changed from i4 to f8.2 to cope ! with IR data and high-res too. ! ! ! The ~ major changes (implying changes in the grid file) are: ! ! (01) grid-file "header" info is now vertical! Ie, the previoulsy ! horribly long 3rd line input is now broken into one thing per ! line. Similarly, the config file has been restructured and ! reordered for clarity! ! ! (02) Introduced Gordon et al (2003) SMC & LMC extinction curves ! (red_law_option = GD1, GD2 & GD3). They are still interpolated ! from a table, but better and different from HyperZ-curves. ! Also, introduced a general "from-a-file" reddening law read from a ! file named ExtinctionLaw.red_law_option! ! ! (03) Now the initial estimates for v0 & vd are read FOR EACH ! GALAXY from the grid file! The previous version all used v0 = 0 & ! vd = 150 km/s as a starting point. This implied a change to the ! format of grid files... ! ! (04) Introduced a new "FXK" option for the FitOrSamplePDF_option ! string, which keeps vd & v0 FIXED throught the fits. In other ! words, kinematics is NOT fitted at all, and v0 & vd are kept = to ! their initial values (now read from the grid file)! The base is ! shifted by v0 & vd before any call to "Scubidu" routines and never ! shifted nor smoothed again. This may be useful in a number of ! cases. This was the major change. Search for "FXK" to find where ! the changes were made. ! ! (05) While writing the manual and checking the code I found an ! invisible bug! In the Refit-after-clipping and Burn-In calls to ! Fit_Scubidu the variable i_RestartChains was UNDEFINED! That means ! it was 0, and neither in the Refit nor Burn-In stages the chains ! were reset to the best parameters... I now set i_RestartChains = ! i_RestartChains_FF in both calls. This was most lilkey harmless, ! though (in general) we should now get slightly better fits (if ! i_RestartChains_FF = 1, of course). ! ! Later (01April07) I found another related bug! The new bug is that ! by setting the last values equal to the best ones (in Fit_Scubi ! with i_RestartChains = 1), if one of these best chain values = the ! global best so far then the trick of resetting the chain with ! worst energy = to the best global model may result in this ! chain-values appearing TWICE!! Ie, 2 of the chains would start ! from IDENTICAL positions.... To see how I fixed this search for ! "Cid01April07-FIX". I also introduce a new option: ! i_RestartChains = 2, which will reset ONLY the worst chain to the ! best model, but leave the others wherever they are. ! ! ! Cid@Lagoa - 07/February/2007 --> 11/April/2007 ! ! **Disorganized list of things to improve** ! -Better/analytical reddening laws for SMC & LMC! & fix minor "step" in CAL law. ! -The i_FastBC03_FLAG for Fast-rebinning should be changed to cope w/other bases... ! -Write robust resampling routine... ! -Option to deal with rectified spectra? Dificult to see how this can be done... ! ------------------------------------------------------------------ ! ------------------------------------------------------------------ ! | StarlightChains_v02.for | ! ------------------------------------------------------------------ ! This version fixes a few minor things in StarlightChains_v01.for. ! Changes are essentially cosmetic or safety-measures. ! ! (1) No 'Running model # ...' screen output anymore. ! ! (2) Introduced Is1stLineHeader flag in config. ! ! (3) If fobs_norm <= 0 the run is aborted. ! ! (4) Added safety-check in the computation of S/N's in the ! llow_SN--lupp_SN window... ! ! (5) Changed a bit the way we constrain initial chain fn, AV & YAV ! values to allow them to be constrained by the low->upp values in ! the config file. ! ! (6) Introduced IsScaleNstepsInEX0sFit flag in config. If turned ! on, the numbers N_sim & Nmax_steps, which control the length of ! Metropolis runs in Scubidu, will be scaled according to the actual ! number of relevant parameters in the EX0s fits. This ONLY changes ! things in the EX0s fits. ! (7) Introduced a IsNoKin4LargeBaseInEX0sFits flag & a ! frac_NoKin4LargeBaseInEX0sFits variable, which, multiplied by ! N_base, defines what is the minimum size of a EX0s-condensed base ! for which we turn-off kinematical fits. (In v01 this was fixed at ! 50 elements). This too ONLY changes things in the EX0s fits. ! ! (8) Introduced the 5 reddening laws of HYPERZ ('HZ1' ... 'HZ5'), ! of which HZ4 is the SMC (which I'd expect to be most relevant) ! ! Only (6) & (7) may have some relevant effect wrt v01, particular ! (6). Setting IsScaleNstepsInEX0sFit = 0 should yield nearly ! identical results, but setting it to 1 will result in shorter ! (faster) EX0s-fits, which may be slightly worse in chi2. ! ! Cid@Lagoa - 09/October/2005 ! ------------------------------------------------------------------ ! This is my "1st-final" version of "ScubiStar" (built upon ! ScubiStar7.for version produced at IAA in May/2005). The main ! difference wrt previous versions of Starlight is that this version ! uses N_chains parallel Markov chains, which run untill a Gelman & ! Rubin-like Burn-In convergence criterion is satisfied. Full ! documentation is not ready yet... ! ! A few other cosmetic changes were made. Base files are now stored ! in a user-defined directory (read from the input file), avoiding ! multiple copies of base-spectra throughout the disk. Another ! change is that now the input file specifies two flags ! (IsErrSpecAvailable & IsFlagSpecAvailable) which define whether ! error & flag-spectra are read from the input file (as for SDSS ! data) or are computed online with the old rms-in-a-window ! method. Yet another change is that now the base, mask and config ! files & extinction curve-option are specified for each galaxy! ! These changes (and others) were made in the sense of having a ! single version of the code useful for different purposes (eg, SDSS ! and my LLAGN data). More details will be added later. ! ! I have not run a full set of tests/simulations of this code... ! However, quick & dirty tests of different configurations show ! that results are very similar for all configurations I ! tried. Hence, I'll distribute the code and see how it ! performs. Changes will be made "on-the-fly", ie, as problems appear. ! ! Sent to Abilio on 30/May/2005 ! ! Cid@IAA - 30/May/2005 c voltei a mexer no codigo - ... abstracts-totalmente desatualizados.... c Cid@IAA - 3/May/2005 c c Tentando botar Scubidu no Starlight05_Fast_v01.for... c melhor seguir testes sem YAV e depois resolver este bug novo... c Cid - 17-2-05 c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ c This is my latest update of the Starlight spectral synthesis code. c BRIEF HISTORY of Starlight: So far there have been 2 main c versions. c (1) Starligh03_v02.for (September/2003) was the original code, c used in the Seyfert 2 paper (CF, Gu, Melnick ... et al 2004; c MNRAS). The same code was used in my LLAGN paper III (CF, Gonzalez c Delgado ... et al 2004; MNRAS), with a base of template c galaxies. Initial experiments with SDSS spectra were also c performed using a slightly modified version of the code c (Starlight03_v04SDSS.for; which dealt with errors and flags). c (2) In Starlight03_v04SDSS_Fast2.for I've introduce the trick of c expanding the extinction term in a truncated series (the c "RapidChi2" or RC-trick), which speeds things up by > 200 times! c That was used in SDSS-Paper-I (CF, Mateus ... et al MNRAS 2005). A c slightly modified version called Starlight03_v04_ind_Fast2.for was c produced to deal with individual spectra (which require galaxy by c galaxy input info); it also introduced the Calzetti reddening-law c option. c NEW FEATURES OF THIS VERSION: The main novelty in this 3rd version c is that we now allow for 2 different extinctions: AV & YAV. Each c population j (j=1...N_base) is reddened by AV_tot(j) = AV + YAV, c and only some of them are allowed to have the extra extinction c YAV. The array ind_YAV(j) says who can have this extra c extinction. The idea is to do something like a Charlot & Fall c (2000) extinction law, which has one (higher) AV for young c populations (<= 10 Myr) and a global AV affecting both young and c old stars. However, the SAME reddening law is assumed for both c populations, otherwise heavy changes would be required in the c RC-chi2 routines... The code was also re-organized, with c improvement structure and comments. Finally, I now read the base c DIRECTORY (string base_dir) from the input/grid file (2nd c line). This avoids duplication of base spectral files. Use "./" c for base_dir if the base files are in the current directory! c Note that symbolic links work:) c Other changes: Allowance for returned-mass in the light-to-mass c fractions conversion was introduced. The conjugate-gradient c routines were removed altogether (they never proved worthy). Both c config & base files now have different formats. The output file c too is now slightly different (so auxiliary table-making & c plotting codes will have to be updated accordingly). c FUTURE CHANGES: There is a major change in progress to make the c whole algorithm more efficient, using the estimates of the c covariance matrix to identify principal directions for movement in c the parameter space. The burn-in phase should also be mapped, and c full error estimates of the parameters will be done. Jean, William c & myself are working on it. c The code is heavily commented, but not yet fully comprehenssible c by people other than myself! Full documentation & tips will be c provided elsewhere, one day... c c Cid@Lagoa - 23/January/2005 c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ c ########################################################################### c # DRIVER FOR MAIN CODE # c ########################################################################### program Starlight_With_MEx_and_FIRc_QHRc_PHOc implicit real (a-h,j-m,o-z) implicit integer (i,n) !ESM! string ETC_ESM now read from grid header character*3 FitOrSamplePDF_option , ETC_ESM character*100 base_dir , obs_dir , mask_dir , out_dir , etc_dir !ESM! Introduced to allow reseting the modified gasdev() when i_ChangeIdum = 0 integer isetInit4gasdev common/Init4gasdev/ isetInit4gasdev isetInit4gasdev = 0 * ........................................................................... c 1st line in input/grid-file is the number of fits to be computed read (*,*) N_models c Input some global grid-parameters here & pass them on to main code read (*,'(a)') base_dir read (*,'(a)') obs_dir read (*,'(a)') mask_dir read (*,'(a)') etc_dir read (*,'(a)') out_dir read (*,*) idum_orig !NAT-SN-BUG! Renamed l*_SN to Ol_*SN - ElCid@Sanchica - 15/Ago/2011 read (*,*) Ollow_SN read (*,*) Olupp_SN read (*,*) Olsyn_ini read (*,*) Olsyn_fin read (*,*) Odl_syn read (*,*) FitOrSamplePDF_option read (*,*) IsErrSpecAvailable read (*,*) IsFlagSpecAvailable *FIR* flux_unit is the factor by which one must multiply the input observed * spectrum to obtain it in ergs/s/cm2/Angs. Knowing the physical units is * ESSENTIAL for FIRc/PHOc/QHRc work (since fluxes at two bands will be * analysed simultaneously), but IRRELEVANT for optical-fits alone! read (*,*) flux_unit !ESM! Read all ETC-related grid entries here. Also, produce some ! old/harm-&-pointless screen blurb... read (*,*) IsFIRcOn , IsQHRcOn , IsPHOcOn , ETC_ESM , ETC_gamma * ........................................................................... * ........................................................................... *FIR* 1/0/-1 = Y/N/Predict-FIR Flag to turn FIRc On/Off/Predict-only. * With -1 FIR-model-related-things are initialized but no actual * FIR-data is read. The purpose is just to predict the FIR * luminosity implied by the optical STARLIGHT-fit. write (*,'(70(a))') ('*',i=1,38) if (IsFIRcOn.EQ.1) then write (*,'(a,a)') '* ATT: You asked for FIRc fits!! *' else if (IsFIRcOn.EQ.0) then write (*,'(a,a)') '* ATT: You asked for NON-FIRc fits!! *' else if (IsFIRcOn.EQ.-1) then write (*,'(a,a)') '* ATT: L_FIR will just be predicted! *' end if write (*,'(70(a))') ('*',i=1,38) *QHR* 1/0/-1 = Y/N/Predict-QHR Flag to turn QHRc On/Off/Predict-only. write (*,'(70(a))') ('*',i=1,38) if (IsQHRcOn.EQ.1) then write (*,'(a,a)') '* ATT: You asked for QHRc fits!!! *' else if (IsQHRcOn.EQ.0) then write (*,'(a,a)') '* ATT: You asked for NON-QHRc fits!! *' else if (IsQHRcOn.EQ.-1) then write (*,'(a,a)') '* ATT: QHR will just be predicted! *' end if write (*,'(70(a))') ('*',i=1,38) *PHO* 1/0/-1 = Y/N/Predict-PHO Flag to turn PHOc On/Off/Predict-only. write (*,'(70(a))') ('*',i=1,38) if (IsPHOcOn.EQ.1) then write (*,'(a,a)') '* ATT: You asked for PHOc fits!!! *' else if (IsPHOcOn.EQ.0) then write (*,'(a,a)') '* ATT: You asked for NON-PHOc fits!! *' else if (IsPHOcOn.EQ.-1) then write (*,'(a,a)') '* ATT: PHO will just be predicted! *' end if write (*,'(70(a))') ('*',i=1,38) c Safety-check on some of the input info... if ((FitOrSamplePDF_option.NE.'PDF').AND. $ (FitOrSamplePDF_option.NE.'FIT').AND. $ (FitOrSamplePDF_option.NE.'FXK')) then write (*,'(a)') ' Problem with your grid file! ' write (*,'(a,a,a)') ' What are you doing? ' , $ FitOrSamplePDF_option ,' should be = FIT or FXK ...' stop end if if ((IsErrSpecAvailable.NE.0).AND.(IsErrSpecAvailable.NE.1)) then write (*,'(a)') ' Problem with your grid file! ' write (*,'(a,a,i3)') ' What are you doing? ' , $ ' IsErrSpecAvailable = ' , IsErrSpecAvailable stop end if if ((IsFlagSpecAvailable.NE.0).AND.(IsFlagSpecAvailable.NE.1))then write (*,'(a)') ' Problem with your grid file! ' write (*,'(a,a,i3)') ' What are you doing? ' , $ ' IsFlagSpecAvailable = ' , IsFlagSpecAvailable stop end if if ((IsErrSpecAvailable.EQ.0).AND.(IsFlagSpecAvailable.EQ.1)) then write (*,'(a)') ' Problem with your grid file! ' write (*,'(a,a,i3,a,i3)') ' What are you doing? ' , $ ' IsFlagSpecAvailable = ' , IsFlagSpecAvailable , $ ' but IsErrSpecAvailable = ' , IsErrSpecAvailable stop end if if ((abs(IsFIRcOn).GT.1).OR.(abs(IsQHRcOn).GT.1).OR. $ (abs(IsPHOcOn).GT.1)) then write (*,*) '* ATT: IsFIR/QHR/PHOcOn should be = -1/0/1: ', $ IsFIRcOn , IsQHRcOn , IsPHOcOn , ' ... :-(' write (*,*) '>> Run aborted:-(' stop end if * ........................................................................... * ........................................................................... !Cid14Jan07-FIX! idum-trick: Sometimes I may want to repeat the run with ! the same idum, but different config, or base, or red-law. To allow ! for this possibility using a single grid-file, just set idum = 0 ! in the grid.in file and all runs will have the same idum:) ! Also, added a protection against idum_orig > 0. i_ChangeIdum = 1 if (idum_orig.EQ.0) then i_ChangeIdum = 0 idum_orig = -123456 end if if (idum_orig.GT.0) idum_orig = -idum_orig c Run grid of N_models spectral fits do i_model=1,N_models !ESM! This re-initializes gasdev() when we want to enforce i_ChangeIdum = 0 if (i_ChangeIdum.EQ.0) isetInit4gasdev = 0 !NAT-SN-BUG! Reset l*_SN = Ol_*SN - ElCid@Sanchica - 15/Ago/2011 llow_SN = Ollow_SN lupp_SN = Olupp_SN *ETC* Added IsFIRcOn, IsQHRcOn, IsPHOcOn flags, flux_unit & etc_dir. call FitSpectrum(idum_orig,llow_SN,lupp_SN $ ,Olsyn_ini,Olsyn_fin,Odl_syn $ ,base_dir,obs_dir,mask_dir,etc_dir,out_dir $ ,FitOrSamplePDF_option,IsErrSpecAvailable $ ,IsFlagSpecAvailable,IsFIRcOn,IsQHRcOn,IsPHOcOn,flux_unit $ ,ETC_ESM,ETC_gamma) c changes idum-seed just to avoid doing always the same sequence of c random numbers. Also, idum-trick: only changes if i_ChangeIdum.NE.0!! if (i_ChangeIdum.NE.0) idum_orig = idum_orig - 1 end do * ........................................................................... end c ########################################################################### c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ c @ MAIN CODE @ c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ! ATT: This is an incomplete & rather disorganized ABSTRACT of the ! code. Full documentation will be produced one day... (yeah, right...) c This code synthesizes a galaxy spectrum f_obs(l_obs) with a base c of N_base spectra f_base(l_base). The base can be made up of c observed template galaxies or theoretical spectra (eg, BC03, c Starburst99, etc). The ouput consists of the population vector c x(i); i=1...N_base, plus the V-band global extinction AV and the c extra-extinction YAV to selected components, plus kinematical c parameters v0 (residual velocity-shift) & vd (velocity c dispersion). c The code seeks to minimize the chi2: c c chi2(x,AV,YAV,v0,vd) = SUM [(f_syn - f_obs) * weight_obs]**2 c c where the sum is over all lambdas, and f_syn = c f_syn(x,AV,YAV,v0,vd) is the model spectrum for the given c parameters: c c f_syn(i) = Sum_j x(j) * f_base(j,i) * 10.**(AV_tot(j) * red_term(i)) c CONVOLVED with G(v0,vd) c c where f_base(j,i) is the base spectrum of component # j at lambda c l_obs(i), convolved with the Gaussian kinematical filter G(v0,vd). c c Masked lambdas are given weight_obs = 0. For other lambdas, c weight_obs = 1 / error_spectrum, or mask_weight times larger if c specified on arq_masks. c * NORMALIZATION: The base spectra f_base are normalized by their c flux at l_norm, while the observed spectrum is normalized by c fobs_norm = the median flux between llow_norm & lupp_norm (which c must bracket l_norm). We do NOT force the population vector to be c normalized to 100%! The returned value of x_j is the flux in the c model spectrum (without convolution by G!) in component j, in unit of c fobs_norm. c * ERROR & FLAG SPECTRA: The input spectrum MUST come with an c associated error spectrum (err_obs) and a flag-spectrum c (flag_obs). The coding for the flag spectrum is like this: flag = c 0 or 1 is OK, while flag > 1 will ignore the points from the fit c (like the masks described below). Flags are useful to identify bad c pixels. If you do NOT have an error spectrum, then invent one, but c beware that the chi2's computed here depend on this error. c * MASKS: The synthesis is carried out in all Nl_obs observed c wavelengths l_obs, but some are "masked out". The user-supplied c file arq_masks indicates which intervals should be excluded from c the modeling (eg, those containing emission lines or bad c pixels). We further impose a limit f_obs >= f_cut (in units of the c normalization flux). Weaker fluxes are masked out assignig c weight_obs = 0 for f_obs <= f_cut. (Just set f_cut = 0 if you do c not want this safety feature.) The file arq_masks can also c specify windows over which we want to give larger weight (for c instance, on key absorption features). The array mask_weight() c decides by how much the weight should be multiplied in a given c window. (Example: mask_weight = 0 ignores the region in the fit c and mask_weight = 2 gives is twice as much weight as it would have c otherwise.) c * SAMPLING: The input spectrum f_obs(l_obs) is resampled/rebinned in c wavelength to lsyn_ini ==> lsyn_fin, in steps of dl_syn c (subroutine RebinSpec). This is the range which will actually be c modeled (but note that we internaly extend the desired fitting c range by 50 Angs on the blue & red edges to circumvent problems in c the kinematical filter). The base spectra f_base are resampled to c the same wavelengths (ie, l_obs = lsyn_ini ==> lsyn_fin in dl_syn c steps). Note that vd depends on dl_syn, as well as on the actual c spectral resolution of the input spectra... To correct vd for the c different resolutions of observed & base spectra do a quadrature c correction. For instance, if your spectra have sigma_inst = 62 c km/s and the base has 86 km/s resolution do: c vd_corrected = sqrt(vd_given_by_the_code**2 + 86.**2 - 62.**2) c ==> It is VERY STRONGLY recommended that you provide both observed c & base spectra already resampled to 1 Angs! (This makes things c easier.) One reason for this is that is that my Rebinning routine c does NOT handle the error spectrum properly. It just resamples c err_obs, whereas it should actually correct for the fact that c going from, say, 1 to 2 Angs sampling the error should be smaller... c * NUMERICAL-SCHEME: I've tried several schemes to estimate the c stellar population (x, AV & YAV) and kinematical parameters (v0 & c vd). c c 1 - Metropolis in the (x,AV,YAV,v0,vd) space - (slow method) c 2 - Metropolis on x,AV followed by Metropolis on (x,AV,YAV,v0,vd). c 3 - Annealing schemes c 4 - etc (in previous versions I tried conjugate gradients, dicrete c grids, combinations of these,...) c c I have settled for an adapted version of stimulated annealing, c which runs a series of Metropolis runs to find the best (x,AV,YAV) c for fixed (v0,vd) and, at each step, re-estimates (v0,vd) for c fixed (x,AV,YAV). [Also, after each Metropolis run (in the c annealing loop) I do a quick search for better AV & YAV for fixed c x, v0 & vd.] c c At each step in the annealing routine (Fit_xAVYAVv0vd) I multiply c the weights (= 1 / error) by a factor wf which runs from wf_low to c wf_upp. The step size (in x & AV) is concomitantly reduced from c eps_upp to eps_low, and the number of steps is adjusted so that a c long Metropolis trip can be made. The last loop is the slowest c one, with more points. The maximum number of steps at any given c annealing interaction is limited by Nmet_max. If you give a very c large number for this parameter then all steps that "should" be c made are actualy made, but it may take a long time to run... c [CLIPPIG & EX0s & etc] The code allows other tricks: c (A) Sigma-Clipping can be made, removing all points with more c than, say, sig_clip_threshold = 3 sigma residuals, and re-doing c the fit. This can be done Nclip_loops_max times. c (B) Quick-Clipping: If Nclip_loops_max < 0 on input, then a "fast" c clipping routine is performed (only once) before going for the c actual fit. This works prettry well and saves time, so we c recommend it. c (C) Condensed-Base-Fitting: Setting NEX0s_llops >= 1 on arq_config c will re-fit the spectrum, taking as initial point the values c obtained in the main call to Fit_xAVYAVv0vd, and reducing the base c just to the N_non_zeros components which have x_j > 0. This speeds c up computations (because of the smaller base), and serves to c refine the fit. c (D) The rebinning of BC03 spectra is now much faster (and less c general, since we assume dlambda = 1). Use i_FastBC03_FLAG = 1 in c arq_config. c (E) WEIGHT-CONTROL-FILTER: I have implemented a "safety-filter" which c prevents any given point from having a weight more than 2 sigma c above the mean weight of unmasked points. I did this after c realizing that some SDSS spectra come with very low errors, which c produce large weight_obs(i) and are thus given too much weight in c the synthesis. ! * RAPID-CHI2 TRICK: This used to be Starlight03_v04SDSS.for, but ! is now VERY different. There were several minor changes and one ! HUGE change. The huge modification is the use of a truncated ! series to represent the extinction term in the model ! spectrum. This simple trick, which works fine as long as AV is not ! too large, allows a MUCH-MUCH faster calculation of the chi2 by ! circumventing the need to sum over all lambdas every time. See ! notes for details! The bottom line is that we can now let the ! Metropolis routine run for MUCH-MUCH longer than before in less ! time! (Indeed, the advantage is only noticeable when we do force ! huge Metropolis runs.) The routines involved are Calc_RC_terms & ! VeryFastF_chi2. The screen output register info on the difference ! between approximate & exact chi2's, but nothing is stored in the ! ouput files! Note that we have not eliminated the full-exact-chi2 ! routines altogether; some are still used (for output, to minimize ! over kinematic parameters v0 & vd, etc). The faster routines are ! used essentially only in the (x,AV,YAV) Metropolis chain... c The RC-scheme involves the computation of 3 terms: RC1, RC2(n,j) c and RC3(n,j,k). RC2 & RC3 involve the base spectra f_base(j,i). My c implementation of this scheme uses f_base(j,i) which are already c convolved with the kinematical filter G(v0,vd). This means that I c first convolve with G and only then apply the extinction c factor. This is slightly different than appliyng the extinction c factor and then convolving correction (the difference is small c because the extinction curve is ~ constant over scales of c vd). This RC-chi2 is inly used in the estimation of x, AV & c YAV. The kinematical fitting of v0 & vd uses a Golden Search c method with a chi2 function which included the extinction term c inside the convolution. This note is just to recall myself that c there are two slightly different chi2's in the code... ! Still to be implemented: ! * A bias-correcting trick... (for the AV-expansion series) ! ! * There might be a reasonable method to define an initial ! annealing weight-factor (<=> Temperature) based on the typical ! value of chi2 for a few random models and what factor ! (Temperature) would it take to make it go to a chi2 ~ 1/N_dof in ! not-too-many steps... Think about it! ! ! * The "MCMC-thing", with ~ 12 paralell chains, mean & std dev ! estimates (with burn-in convergence test) c ATT: This abstract is permanently under construction... c c Cid@Lagoa - 27/Jan/2005 !ESM! Major changes introduced while revamping the ESM scheme.... ! Cid@Lagoa - 21/July/2017 SUBROUTINE FitSpectrum(idum_orig,llow_SN,lupp_SN $ ,Olsyn_ini,Olsyn_fin,Odl_syn $ ,base_dir,obs_dir,mask_dir,etc_dir,out_dir $ ,FitOrSamplePDF_option ,IsErrSpecAvailable $ ,IsFlagSpecAvailable,IsFIRcOn,IsQHRcOn,IsPHOcOn,flux_unit $ ,aux_ETC_ESM,aux_ETC_gamma) c *************************************************************************** c * DEFINITIONS * c *************************************************************************** implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) parameter (Nchains_max = 1000,Npar_max = 601) parameter (NQHR_Ys_max=10, NPHO_Ys_max=100) parameter (NAVgrid_max = 1001) c Spectral quantities: observed, synthetic, mask & auxiliar stuff real l_obs(Nl_max) , f_obs(Nl_max) real err_obs(Nl_max) , weight_obs(Nl_max) real l_syn(Nl_max) , f_syn(Nl_max) real llow_mask(Nl_max) , lupp_mask(Nl_max) real mask_weight(Nl_max) , f_mask(Nl_max) real l_aux(Nl_max) real f_aux1(Nl_max) , f_aux2(Nl_max) , f_aux3(Nl_max) c Base spectra, age, Z & "absolute"-luminosity @ l_norm (= fbase_norm) real f_base(Nb_max,Nl_max) , fbase_norm(Nb_max) real age_base(Nb_max) , Z_base(Nb_max) , alphaFe_base(Nb_max) character*15 base_name(Nb_max) c Population vector arrays in flux (x) & mass (mu_ini) fractions real x(Nb_max) , x_min(Nb_max) , mu_ini(Nb_max) c Auxiliar arrays real aux1(Nb_max) , aux2(Nb_max) , aux3(Nb_max) c Mstars = array which says what fraction of the INITIAL stellar c mass in population # j is still in stars at age(j). The name c "Mstars" is inspired by the bc2003 nomenclature. Mstars(j) is only c used in the flux-to-mass fractions conversions (ie, for output c purposes). mu_cor() are the corrected mass-fractions. real Mstars(Nb_max) , mu_cor(Nb_max) c AV_array: AV_tot(j) = population dependent extinction real AV_tot(Nb_max) c Arrays to store Original (hence the "O") observed & base spectra real Ol_obs(Nl_max) , Of_obs(Nl_max) real Ol_base(Nl_max) , Of_base(Nb_max,Nl_max) real Oerr_obs(Nl_max) , Oflag_obs(Nl_max) c Chain-arrays! real ChainPar(Npar_max,Nchains_max) real Gpar_min(Npar_max) , Gpar_ave(Npar_max) real Cpar_min(Npar_max,Nchains_max) , CEne_min(Nchains_max) real EX0sChainPar(Npar_max,Nchains_max) real EX0sGpar_min(Npar_max) , EX0sGpar_ave(Npar_max) real EX0sCpar_min(Npar_max,Nchains_max) ,EX0sCEne_min(Nchains_max) c file names - including arq_ETCinfo character*100 arq_obs , arq_base , arq_masks , arq_config character*100 arq_out , arq_aux , arq_lix , arq_ETCinfo c Reddening-law option string character*3 red_law_option c Option-String which defines which method will be used to define c who is relevant and who is not in the pop vector x_Test! character*5 EXOs_method_option character*3 EXOs_PopVector_option c Defining base, obs, mask, etc & out directories strings! character*100 base_dir , obs_dir , mask_dir , out_dir , etc_dir c Clipping-Method-opting-string character*6 clip_method_option c Option-string which defines whether we'll fit or sample the PDF character*3 FitOrSamplePDF_option c commons... common/Red_factor/ red_term(Nl_max) common/Obs/ Nl_obs , l_obs , f_obs , weight_obs common/Base/ N_base , f_base common/Obase/ Of_base common/N_Gauss/ N_int_Gauss common/Age_and_Met/ age_base , Z_base common/CalcMass/ q_norm , fbase_norm , fobs_norm common/RC_AV_Stuff/ NRC_AV , i_RC_CRASH_FLAG , NRC_AV_Default c Lower & upper limits on parameters (x,AV,exAV,fn) common/ParLimits/ par_low(Npar_max) , par_upp(Npar_max) c ScubiduCadeVoce Technical Parameters common/Scubi_TechnicalParameters/ alpha , Falpha , IsGRTestHard , $ eff_IDEAL , i_UpdateEps , Feps , i_UpdateAlpha , $ i_MoveOneParOnly , i_HelpParWithMaxR , prob_jRmax , $ Npar4GRtest ,i_UpdateAVYAVStepSeparately , $ ind_HelpParMove2Average(Npar_max) , $ prob_HelpParMove2Average(Npar_max) c Opened file units, for output common/OutputFileUnits/ i_UnitScubi c Willy time functions real willy_tiempo(2) !Cid19Jan07-FIX! Added chi2, AV & norm. factor for best SSP fits! !v05! Array to store best-fit SSP spectrum real SSP_AV(Nb_max) , SSP_x(Nb_max) , SSP_chi2(Nb_max) , $ SSP_adev(Nb_max) real Best_f_SSP(Nl_max) common/SSP_chi2_stuff/ x_SSP , f_SSP(Nl_max) external F_SSP_chi2_AV !Cid14Jan07-FXK! Added FXK = Fixed kinematics option!! common/FXK_fits/ IsThisAnFXKFit !!MEX!! real exAV(Nb_max) real exAV_min(Nb_max) , exAV_low(Nb_max) , exAV_upp(Nb_max) common/exAV_stuff/ N_exAV , ind_exAV(Nb_max) !!MEX!! Introduced flag to use SLOW chi2 always! common/ToRCOrNotToRC_ThatIsTheQuestion/ i_UseSlowChi2Always *ETC* Common to get FIR, QHR & PHO chi2's from function ETC_CalcETCchi2 for output common/ETC_Chi2s/ chi2_FIR , chi2_QHR , chi2_PHO *FIR* Arrays to store Lambda-Averaged pop-vectors: min, ave & * chain-solutions. OBS: They are ONLY used in the output-phase!! real LAx_min(Nb_max) , LAx_ave(Nb_max) , & LAx_chain(Nb_max,Nchains_max) *FIR* Data-info-common for FIR-work common/FIR_DataStuff/ FIR_logLobs_norm , $ FIR_logLFIR_TOT , FIR_LFIRFrac2Model , $ FIR_logLFIR_obs , FIR_ErrlogLFIR , $ FIR_logLFIR_low , FIR_logLFIR_upp , FIR_RangelogLFIR , $ FIR_GlobalChi2ScaleFactor , iFIR_IsFIRcOn *FIR* Base-info-common. * OBS: In the main code (ie here) these stuff (actually just part of * it!) is only used to produce FIR-related output common/FIR_BaseStuff/ NFIR_AV , FIRAV_grid(NAVgrid_max) , $ FIRAV_low , FIRAV_upp , FIRdAV , $ FIRLbol(Nb_max) , FIRFracLion(Nb_max) , FIRBolCor(Nb_max) , $ FIRR_opt(Nb_max,NAVgrid_max) , FIRR_Lya(Nb_max,NAVgrid_max) , $ FIRR_LCE(Nb_max,NAVgrid_max) , $ FIRRmat(Nb_max,NAVgrid_max) , FIR_q_norm , NFIR_base *FIR* Common (used just for output) for predicted L_FIR & x_FIR & x_BOL * pop-vectors common/FIR_OutputStuff/ FIR_ModlogLFIR , FIR_ModlogLBOL , & x_FIR(Nb_max),x_BOL(Nb_max) *QHR* Data-info-common for QHR-work common/QHR_DataStuff/ QHR_lambda(NQHR_Ys_max) , $ QHR_frecomb(NQHR_Ys_max) , $ QHR_logY_TOT(NQHR_Ys_max) , QHR_YFrac2Model(NQHR_Ys_max) , $ QHR_ErrlogY(NQHR_Ys_max) , QHR_RangelogY(NQHR_Ys_max) , $ QHR_Chi2ScaleFactor(NQHR_Ys_max) , $ QHR_logY_obs(NQHR_Ys_max) , $ QHR_logY_upp(NQHR_Ys_max) , QHR_logY_low(NQHR_Ys_max) , $ QHR_qlambda(NQHR_Ys_max) , $ QHR_GlobalChi2ScaleFactor , $ QHR_logLobs_norm , $ NQHR_Ys , iQHR_IsQHRcOn *QHR* Base-info-common. common/QHR_BaseStuff/ QHR_qH40(Nb_max) , QHR_Q2Lnorm40(Nb_max) , $ QHR_q_norm , QHRbeta_I , NQHR_base *QHR* Common (used just for output) for predicted QHR-&-ELR-things common/QHR_OutputStuff/ QHR_x_QH0(Nb_max) , QHR_x_QHeff(Nb_max) , $ QHR_x_Y(Nb_max,NQHR_Ys_max) , QHR_ModlogY(NQHR_Ys_max) , $ QHR_chi2_Y(NQHR_Ys_max) , QHR_log_QH0 , QHR_log_QHeff , $ ELR_chi2_logR , ELR_ModlogR *ELR* Data-info for ELR-work - goes together w/QHR-things! common/ELR_DataStuff/ ELR_lambdaA , ELR_lambdaB , $ ELR_logRint , ELR_logRobs , $ ELR_ErrlogR , ELR_logR_low , ELR_logR_upp , $ ELR_RangelogR , ELR_Chi2ScaleFactor , $ iY_ELR_A , iY_ELR_B , IsELROn , $ IsELRInputInconsistentWarningFlag *PHO* filter name & file name common for PHO-work character*10 PHO_name(NPHO_Ys_max) character*100 PHO_Filter_file(NPHO_Ys_max) common/PHO_NamesStuff/ PHO_name , PHO_Filter_file *PHO* Data-info-common for PHO-work common/PHO_DataStuff/ PHO_logY_TOT(NPHO_Ys_max) , $ PHO_YFrac2Model(NPHO_Ys_max) , PHO_ErrlogY(NPHO_Ys_max) , $ PHO_RangelogY(NPHO_Ys_max) , $ PHO_Chi2ScaleFactor(NPHO_Ys_max) , $ PHO_logY_obs(NPHO_Ys_max) , $ PHO_logY_low(NPHO_Ys_max) , PHO_logY_upp(NPHO_Ys_max) , $ PHO_GlobalChi2ScaleFactor , $ PHO_redshift , PHO_logFobs_norm , NPHO_Ys , iPHO_IsPHOcOn *PHO* Base-info-common. !FOCA!... common/PHO_BaseStuff/ NPHO_AV , PHOAV_grid(NAVgrid_max) , $ PHOAV_low , PHOAV_upp , PHOdAV , $ PHO_MeanLambda(NPHO_Ys_max) , PHO_StdDevLambda(NPHO_Ys_max) , $ PHO_PivotLambda(NPHO_Ys_max) , $ PHO_q_MeanLambda(NPHO_Ys_max) , $ PHO_3Mat(Nb_max,NPHO_Ys_max,NAVgrid_max) , $ PHO_q_norm , NPHO_base *PHO* Common (used just for output) for predicted PHO-things common/PHO_OutputStuff/ PHO_ModlogY(NPHO_Ys_max) , $ PHO_chi2_Y(NPHO_Ys_max) , PHO_x_Y(Nb_max,NPHO_Ys_max) !OPTfn! Optically optimal fn - common. Used to pass IsOptimize_fn_OPT ! from here to where it is needed. common/Optimize_fn_OPT/ IsOptimize_fn_OPT , Optimal_fn_OPT c Implemented more-than-one header-lines - ElCid@Sanchica - 29/Jan/2012 character*1 cerquinha !ESM! Factors involved in the July/2017 recipe for ETC-chi2-scaling character*3 ETC_ESM , aux_ETC_ESM common/ETC_Chi2Scaling/ G_FIR,G_QHR,G_PHO , k_FIR,k_QHR,k_PHO , $ ETC_alpha,ETC_beta,ETC_gamma , $ Np_OPT,Np_FIR,Np_QHR,Np_PHO , ETC_ESM !ESM! chi2_OPTICAL now shared through this common! common/OpticalChi2/chi2_OPTICAL , ETC_GlobalChi2ScaleFactor !CFl! Charlot & Fall law stuff: AV_Young = a0_CFl + a1_CFl * AV_Old common/CFl_stuff/ a0_CFl , a1_CFl , IsCFlawOn c *************************************************************************** c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + INPUT & PRE-PROCESSING STEPS + c + + c + In this part we reset variables, read input data & perform all + c + necessary pre-processing, like re-sampling to a common lambda-scale, + c + normalization, definition of weights, etc. + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c *************************************************************************** c * INPUT INFO * c *************************************************************************** *ATT* This block used to be **after** the reset-things block below, but * I moved it here to force the SkipExistingOutFiles-check to be done * before the slow (~ 1 second) reset-things block. This should speed * up the repetition of large grids ... * * OBS: Note that I still read the do-it-or-not flag i_SkipExistingOutFiles * from arq_config instead of the grid file. This is rather stupid, * but saves me the trouble of adapting files and scripts... * * ElCid@Sanchica - 15/Ago/2011 *ETC* Input observed spectrum, ETCinfo file-name, luminosity-distance * (in Mpc), config-file, base, masks, initial v0 & vd, and output * filename on a galaxy by galaxy basis! * ATT: Provide an arq_ETCinfo filename (eg 'nodata') even if no * ETCc-fit is being attempted. Likewise, if no distance is known, * provide something (e.g., 100 Mpc). write (*,*) write (*,'(a)') '**> ... Reading input from grid file...' read (*,*) arq_obs , arq_ETCinfo , LumDistInMpc , & arq_config , arq_base , arq_masks , red_law_option , & v0_ini , vd_ini , arq_out * Skips runs already made: A 2007-implemented trick now in a new & faster skin:-) * There was a silly bug here, found by FOCA@UFSC - 03/May/2017 * ATT: The do i=1,38 below may vary if arq_config is changed! open (unit=1,file=arq_config,status='old') do i=1,38 read (1,*) end do read (1,*) i_SkipExistingOutFiles close(1) if (i_SkipExistingOutFiles.EQ.1) then iTest = iCheckExistingOutFiles(out_dir,arq_out) if (iTest.NE.0) then write (*,'(a,a)')' OOPS! arq_out already exists!! Skipping ', $ arq_out return end if end if *ETC* Store flags IsFIRcOn, IsQHRcOn & IsPHOcOn into variables * acessibles by the FIR/QHR/PHO routines via the respective * data-commons. iFIR_IsFIRcOn = IsFIRcOn iQHR_IsQHRcOn = IsQHRcOn iPHO_IsPHOcOn = IsPHOcOn *ETC* Added this for a coherent output... if ((iPHO_IsPHOcOn.EQ.0).AND.(iQHR_IsQHRcOn.EQ.0).AND. $ (iFIR_IsFIRcOn.LE.0)) arq_ETCinfo = 'nodata' * Screen check... write (*,'(a,a)') 'arq_obs = ', arq_obs write (*,'(a,a)') 'arq_ETCinfo = ', arq_ETCinfo write (*,'(a,f8.3)') 'LumDistInMpc = ', LumDistInMpc write (*,'(a,a)') 'arq_config = ', arq_config write (*,'(a,a)') 'arq_base = ', arq_base write (*,'(a,a)') 'arq_masks = ', arq_masks write (*,'(a,a)') 'red_law_option = ', red_law_option write (*,'(a,f8.3)') 'v0_ini = ', v0_ini write (*,'(a,f8.3)') 'vd_ini = ', vd_ini write (*,'(a,a)') 'arq_out = ', arq_out *ETC* Set iETC_IsETCcOn = 1 if something needs to be read from * arq_ETCinfo (and/or arq_config), even if only for predictions. iETC_IsETCcOn = 0 if ((iFIR_IsFIRcOn.EQ.1).OR. $ (iQHR_IsQHRcOn.EQ.1).OR. $ (iQHR_IsQHRcOn.EQ.-1).OR. $ (iPHO_IsPHOcOn.EQ.1).OR. $ (iPHO_IsPHOcOn.EQ.-1)) then iETC_IsETCcOn = 1 end if c *************************************************************************** c *************************************************************************** c * RESET STUFF * c *************************************************************************** !Cid01Apr07-FIX! Reseting all time counters (just in case) i_ini_time = 0 w_ini_TotTime = 0 w_ini_UsrTime = 0 w_ini_SysTime = 0 i_fin_time = 0 w_fin_TotTime = 0 w_fin_UsrTime = 0 w_fin_SysTime = 0 i_ini_time_FF = 0 w_ini_FF_TotTime = 0 w_ini_FF_UsrTime = 0 w_ini_FF_SysTime = 0 i_fin_time_FF = 0 w_fin_FF_TotTime = 0 w_fin_FF_UsrTime = 0 w_fin_FF_SysTime = 0 i_ini_time_RF = 0 w_ini_RF_TotTime = 0 w_ini_RF_UsrTime = 0 w_ini_RF_SysTime = 0 i_fin_time_RF = 0 w_fin_RF_TotTime = 0 w_fin_RF_UsrTime = 0 w_fin_RF_SysTime = 0 i_ini_time_BI = 0 w_ini_BI_TotTime = 0 w_ini_BI_UsrTime = 0 w_ini_BI_SysTime = 0 i_fin_time_BI = 0 w_fin_BI_TotTime = 0 w_fin_BI_UsrTime = 0 w_fin_BI_SysTime = 0 i_ini_time_EX0 = 0 w_ini_EX0_TotTime = 0 w_ini_EX0_UsrTime = 0 w_ini_EX0_SysTime = 0 i_fin_time_EX0 = 0 w_fin_EX0_TotTime = 0 w_fin_EX0_UsrTime = 0 w_fin_EX0_SysTime = 0 !Cid29Dec06-FIX! Introduced time-counters (to help in config-tests) i_ini_time = time() w_ini_TotTime = etime(willy_tiempo) w_ini_UsrTime = willy_tiempo(1) w_ini_SysTime = willy_tiempo(2) c Reset All arrays do i=1,Nl_max f_aux1(i) = 0. f_aux2(i) = 0. f_aux3(i) = 0. l_obs(i) = 0. f_obs(i) = 0. l_syn(i) = 0. f_syn(i) = 0. err_obs(i) = 0. weight_obs(i) = 0. llow_mask(i) = 0. lupp_mask(i) = 0. mask_weight(i) = 0. f_mask(i) = 0. Ol_obs(i) = 0. Of_obs(i) = 0. Oerr_obs(i) = 0. Oflag_obs(i) = 0. Ol_base(i) = 0. do j=1,Nb_max f_base(j,i) = 0. Of_base(j,i) = 0. end do Best_f_SSP(i) = 0. !v05! f_SSP(i) = 0. !v05! end do !Cid29Dec06-FIX! Fixed silly i->j bug found by William on Dec/23/2006! do j=1,Nb_max age_base(j) = 0. Z_base(j) = 0. fbase_norm(j) = 0. x(j) = 0. x_min(j) = 0. AV_tot(j) = 0. mu_ini(j) = 0. mu_cor(j) = 0. Mstars(j) = 0. base_name(j) = 'none' SSP_AV(j) = 0. SSP_x(j) = 0. SSP_chi2(j) = 0. SSP_adev(j) = 0. end do * !!MEX Reset AV & exAV estimates (Cid/Apr/19/2007) do j=1,Nb_max exAV_min(j) = 0. exAV(j) = 0. exAV_low(j) = 0. exAV_upp(j) = 0. ind_exAV(j) = 0 aux1(j) = 0. aux2(j) = 0. aux3(j) = 0. end do AV_min = 0. N_exAV = 0 c Reset clip-bug flag & CRASH flag for RC-scheme (RC = Rapid Chi2) iCLIPBUG_flag = 0 i_RC_CRASH_FLAG = 0 c Reset sigma-clipping & global step counters i_clip_loop = 0 Ntot_cliped = 0 Nglobal_steps = 0 c Set idum = seed for random-#-generator. idum_orig is preserved for output idum = idum_orig c Reset arrays ind_ & prob_HelpParMove2Average arrays do j=1,Npar_max ind_HelpParMove2Average(j) = 0 prob_HelpParMove2Average(j) = 0.0 end do c Reset Chain-arrays! do j=1,Npar_max Gpar_min(j) = 0 Gpar_ave(j) = 0 EX0sGpar_min(j) = 0 EX0sGpar_ave(j) = 0 do i_chain=1,Nchains_max ChainPar(j,i_chain) = 0 Cpar_min(j,i_chain) = 0 EX0sCpar_min(j,i_chain) = 0 CEne_min(i_chain) = 0 EX0sCEne_min(i_chain) = 0 end do end do c Reset SaveStep-flag = file unit! i_UnitScubi = 0 * !!MEX!! Reset desperate use-only-slow-chi2 option! i_UseSlowChi2Always = 0 *FIR* Reset FIR_BaseStuff arrays & other things for safety! do j=1,Nb_max x_FIR(j) = 0. x_BOL(j) = 0. FIRLbol(j) = 0. FIRFracLion(j) = 0. FIRBolCor(j) = 0. do i_AV=1,NAVgrid_max FIRR_opt(j,i_AV) = 0. FIRR_Lya(j,i_AV) = 0. FIRR_LCE(j,i_AV) = 0. FIRRmat(j,i_AV) = 0. end do LAx_min(j) = 0. LAx_ave(j) = 0. do i_chain=1,Nchains_max LAx_chain(j,i_chain) = 0. end do end do FIRfobs_norm = 0. FIR_logLobs_norm = 0. FIR_q_norm = 0. NFIR_base = 0 FITRbeta_D = 0. FITRbeta_I = 0. FIR_logLFIR_TOT = 0. FIR_logLFIR_obs = 0. FIR_LFIRFrac2Model = 0. FIR_ErrlogLFIR = 99. FIR_RangelogLFIR = 0. FIR_GlobalChi2ScaleFactor = 0. FIR_logLFIR_low = -99. FIR_logLFIR_upp = 99. NFIR_AV = 0 FIRAV_low = 0. FIRAV_upp = 0. FIRdAV = 0. do i_AV=1,NAVgrid_max FIRAV_grid(i_AV) = 0. end do *FIR* OBS: The 99's above are just to avoid inf's & nan's if I decide to * call FIR-routines in non-FIRc fits (ie, when IsFIRcOn = 0)! *QHR* Reset all QHR stuff for safety! QHR_GlobalChi2ScaleFactor = 0. QHR_q_norm = 0. QHRbeta_I = 0. NQHR_base = 0 QHR_logLobs_norm = 0. NQHR_Ys = 0 QHR_log_QH0 = 0. QHR_log_QHeff = 0. do iY=1,NQHR_Ys_max QHR_lambda(iY) = 0. QHR_frecomb(iY) = 0. QHR_logY_TOT(iY) = 0. QHR_YFrac2Model(iY) = 0. QHR_ErrlogY(iY) = 0. QHR_RangelogY(iY) = 0. QHR_Chi2ScaleFactor(iY) = 0. QHR_logY_obs(iY) = 0. QHR_logY_upp(iY) = 0. QHR_logY_low(iY) = 0. QHR_qlambda(iY) = 0. QHR_ModlogY(iY) = 0. QHR_chi2_Y(iY) = 0. end do do j=1,Nb_max QHR_qH40(j) = 0. QHR_Q2Lnorm40(j) = 0. QHR_x_QH0(j) = 0. QHR_x_QHeff(j) = 0. do iY=1,NQHR_Ys_max QHR_x_Y(j,iY) = 0. end do end do *ELR* reset ELR-things ELR_lambdaA = 0. ELR_lambdaB = 0. ELR_logRint = 0. ELR_logRobs = 0. ELR_ErrlogR = 0. ELR_logR_low = 0. ELR_logR_upp = 0. ELR_RangelogR = 0. ELR_Chi2ScaleFactor = 0. iY_ELR_A = 0 iY_ELR_B = 0 IsELROn = 0 ELR_chi2_logR = 0. ELR_ModlogR = 0. IsELRInputInconsistent = 0 *PHO* Reset all PHO-stuff for safety! PHO_GlobalChi2ScaleFactor = 0. NPHO_Ys = 0 PHO_redshift = 0. PHO_logFobs_norm = 0. PHO_q_norm = 0. NPHO_base = 0 do iY=1,NPHO_Ys_max PHO_name(iY) = 'none' PHO_Filter_file(iY) = 'none' PHO_logY_TOT(iY) = 0. PHO_YFrac2Model(iY) = 0. PHO_ErrlogY(iY) = 0. PHO_RangelogY(iY) = 0. PHO_Chi2ScaleFactor(iY) = 0. PHO_logY_obs(iY) = 0. PHO_logY_upp(iY) = 0. PHO_logY_low(iY) = 0. PHO_MeanLambda(iY) = 0. PHO_StdDevLambda(iY) = 0. PHO_ModlogY(iY) = 0. PHO_chi2_Y(iY) = 0. do j=1,Nb_max PHO_x_Y(j,iY) = 0. end do end do NPHO_AV = 0 PHOAV_low = 0. PHOAV_upp = 0. PHOdAV = 0. do i_AV=1,NAVgrid_max PHOAV_grid(i_AV) = 0. end do do j=1,Nb_max do iY=1,NPHO_Ys_max do i_AV=1,NAVgrid_max PHO_3Mat(j,iY,i_AV) = 0. end do end do end do Best_SSP_chi2 = 1.e36 !v05! *ESM* Reset things introduced during the July/2017 ESM revamp of ETC-chi2-scaling k_FIR = 0. k_QHR = 0. k_PHO = 0. G_FIR = 0. G_QHR = 0. G_PHO = 0. Np_OPT = 0 Np_FIR = 0 Np_QHR = 0 Np_PHO = 0 chi2_OPTICAL = 0. ETC_GlobalChi2ScaleFactor = 0. !CFl! Reset CF-law things IsCFlawOn = 0 a0_CFl = 0. a1_CFl = 0. !ESM! Set ETC _ESM, _gamma, _alpha & _beta. ETC_ESM = aux_ETC_ESM ETC_gamma = aux_ETC_gamma if (ETC_ESM.EQ.'NoW') then ETC_alpha = 0 ETC_beta = 0 else if (ETC_ESM.EQ.'WbN') then ETC_alpha = 1 ETC_beta = 0 else if (ETC_ESM.EQ.'WbC') then ETC_alpha = 0 ETC_beta = 1 else ETC_alpha = 0 ETC_beta = 0 iLix = abs(IsFIRcOn) + abs(IsQHRcOn) + abs(IsPHOcOn) if (iLix.GT.0) then write (*,*) '* Invalid ETC-chi2-scaling method (ESM) ...', $ '* It should be either NoW, WbN, or WbC, but it is ', $ ETC_ESM write (*,*) '>> Run aborted:-(' stop end if end if !OPTfn! Probably unnecessary ... (Cid@UFSC - 14/Aug/2017) Optimal_fn_OPT = 1. c *************************************************************************** c *************************************************************************** c * READ "TECHNICAL-PARAMETERS" FROM CONFIGURATION FILE * c *************************************************************************** write (*,'(a,a)') '**> ... Reading arq_config = ',arq_config open (unit=1,file=arq_config,status='old') read (1,*) read (1,*) read (1,*) read (1,*) read (1,*) c Set normalization wavelength (for base & synthetic spectra) & c window limits for normalization of observed spectrum. Make sure c that llow_norm <= l_norm <= lupp_norm! read (1,*) l_norm read (1,*) llow_norm read (1,*) lupp_norm if ((l_norm.LT.llow_norm).OR.(l_norm.GT.lupp_norm)) then write (*,*) '[MAIN] l_norm outside llow_norm ==> lupp_norm!' write (*,*) llow_norm , l_norm , lupp_norm stop end if c Set a priori limits on extinction (AV), extra-extinction (YAV), c normalization factor (fn) and kinematical parameters (v0 & vd). read (1,*) read (1,*) read (1,*) read (1,*) read (1,*) AV_low read (1,*) AV_upp !!MEX!! REMOVED YAV_low & _upp from arq_config!! Meaningless in MEX-fits! read (1,*) fn_low read (1,*) fn_upp read (1,*) v0_low read (1,*) v0_upp read (1,*) vd_low read (1,*) vd_upp c Set clip_method_option-string & sigma-clipping threshold read (1,*) read (1,*) read (1,*) read (1,*) read (1,*) clip_method_option read (1,*) sig_clip_threshold c Set weight control filter ... Points with weights larger than c wei_ave + wei_nsig_threshold * wei_sig will be "censored". c wei_nsig_threshold <= 0 means that no weight filter will be applied. read (1,*) wei_nsig_threshold !SNmax! Points where the S/N exceeds SNmax_threshold will have their error ! ajusted to err = sqrt[err**2 + (flux / SNmax_threshold)**2]. ! This should help circumventing excessive clipping in high S/N spectra. ! Cid@UFSC - 09/Aug/2017 read (1,*) SNmax_threshold !Cid20Jan07-FIX! Set safety margin cushion (in Angs). Previoulsy = 50 Angs. read (1,*) read (1,*) read (1,*) read (1,*) read (1,*) dl_cushion c Set minimum flux (in units of fobs_norm) to be modeled. Points c with f_obs < f_cut are masked out! read (1,*) f_cut c Set # of points in the brute-force convolution in GaussSmooth. c (Smarter integrators did not prove worthy!) read (1,*) N_int_Gauss c Set verbose... (i_verbose = 0 gives silent output) c iMassAgeZ_verbose lists estimates of Mass & Z just just for control... read (1,*) i_verbose read (1,*) i_verbose_anneal iMassAgeZ_verbose = i_verbose_anneal c Read fast-BC03-rebining option read (1,*) i_FastBC03_FLAG !Cid08Fev07-FIX! Set if an existing arq_out file should be skiped (1) c or if the fit should be redone and the file overwriten (0). c (Added this at William's request) c ATT: IRRELEVANT: It's been read above to speed up this trick! read (1,*) i_SkipExistingOutFiles !v05! Decide whether or not to save the best fit SSP spectrum on arq_out read (1,*) i_SaveBestSingleCompFit c Read # of chains & max(x_j) for initial random chain pop-vectors. read (1,*) read (1,*) read (1,*) read (1,*) read (1,*) N_chains read (1,*) xinit_max c Read a bunch of technical parameters... read (1,*) i_UpdateEps read (1,*) i_UpdateAlpha read (1,*) Falpha read (1,*) i_MoveOneParOnly read (1,*) i_UpdateAVYAVStepSeparately read (1,*) i_HelpParWithMaxR read (1,*) prob_jRmax read (1,*) i_HelpPopVectorMove2Average read (1,*) prob_HelpPopVectorMove2Average read (1,*) i_HelpAVYAVMove2Average read (1,*) prob_HelpAVYAVMove2Average c Set NRC_AV_Default = initial # of terms in the RC AV-series read (1,*) NRC_AV_Default * !!MEX!! Quick & Dirty way to turn-on use-only-slow-chi2 option! if (NRC_AV_Default.LT.0) then NRC_AV_Default = abs(NRC_AV_Default) i_UseSlowChi2Always = 1 write (*,*) write (*,'(a)') '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@' write (*,'(a)') '@@> ATT: Will use only SLOW chi2!! @@' write (*,'(a)') '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@' write (*,*) end if !OPTfn! Read choice of whether to (= 1) optimize fn or else (!= 1) fit ! it as another par (ie, via Metropolis & Chains). A VERY important change!! ! ElCid@Sanchica - 28/Jan/2012 read (1,*) IsOptimize_fn_OPT c Read First-Fits (FF) technical parameters... read (1,*) read (1,*) read (1,*) read (1,*) read (1,*) Temp_ini_FF read (1,*) Temp_fin_FF read (1,*) fini_eps_FF read (1,*) ffin_eps_FF read (1,*) R_ini_FF read (1,*) R_fin_FF read (1,*) IsGRTestHard_FF read (1,*) N_loops_FF read (1,*) i_RestartChains_FF read (1,*) fN_sim_FF read (1,*) fNmax_steps_FF read (1,*) eff_IDEAL_FF c Read Burn-In stage technical parameters... read (1,*) read (1,*) read (1,*) read (1,*) read (1,*) R_BurnIn read (1,*) IsGRTestHard_BurnIn c Read EX0s-Fit (EX0s) technical parameters... read (1,*) read (1,*) read (1,*) read (1,*) read (1,*) EXOs_PopVector_option read (1,*) EXOs_method_option *FIR* Added iEXOs_IsAve_x_of_lambda entry... * OBS: Motivated by, but independent of FIRc-stuff (Cid@IAA, 31/01/10) read (1,*) iEXOs_IsAve_x_of_lambda read (1,*) EX0s_Threshold read (1,*) Temp_ini_EX0s read (1,*) Temp_fin_EX0s read (1,*) fini_eps_EX0s read (1,*) ffin_eps_EX0s read (1,*) R_ini_EX0s read (1,*) R_fin_EX0s read (1,*) IsGRTestHard_EX0s read (1,*) N_loops_EX0s read (1,*) i_RestartChains_EX0s read (1,*) fN_sim_EX0s read (1,*) fNmax_steps_EX0s read (1,*) eff_IDEAL_EX0s ! New stuff in v02! read (1,*) IsScaleNstepsInEX0sFits read (1,*) IsNoKin4LargeBaseInEX0sFits read (1,*) frac_NoKin4LargeBaseInEX0sFits !Cid18Feb07-FIX! Define maximal base reduction factor for EX0-fits ! such that at least NEX0s_base >= N_base * fEX0_MinBaseSize ! (In previous versions this was fixed at 10%) read (1,*) fEX0_MinBaseSize * --------------------------------------------------------------------------- *ETC* If FIR and/or QHR and/or PHO stuff is to be used (either fits or * just predictions), then read ALL the following, regardless of * which of the ETC-features will be used in practice! This allows me * to keep arq_config with a rigid (yet general) format. * * Cid@Lagoa - 09/Jan/2011 [+ added iFIR_IsFIRcOn.EQ.-1 on 30/Aug/2017] if ((iETC_IsETCcOn.EQ.1).OR.(iFIR_IsFIRcOn.EQ.-1)) then do i_skip_12_lines=1,12 read (1,*) end do * FIRAV_grid parameters = PHOAV_grid parameters! read (1,*) NFIR_AV read (1,*) FIRAV_low read (1,*) FIRAV_upp NPHO_AV = NFIR_AV PHOAV_low = FIRAV_low PHOAV_upp = FIRAV_upp read (1,*) read (1,*) read (1,*) read (1,*) !QHi! New switch to decide whether to (=1) read QH from arq_base !QHi! or (=0) to integrate it directly from the base spectra (to be used !QHi! in routine QHRInitialization) !QHi! Cid@UFSC - 03/July/2017 read (1,*) IsReadQHfromBaseFile read (1,*) QHRbeta_I read (1,*) FIRbeta_I read (1,*) FIRbeta_D * Basic sanity checks on ETC-things read from arq_config... if ((NFIR_AV.LT.10).OR.(FIRAV_low.LT.0.0).OR.(FIRAV_upp.LT.3.0) $ .OR.(FIRbeta_D.LT.0.0).OR.(FIRbeta_D.GT.1.0) $ .OR.(FIRbeta_I.LT.0.0).OR.(FIRbeta_I.GT.1.0) $ .OR.(QHRbeta_I.LT.0.).OR.(QHRbeta_I.GT.1.)) then write (*,'(a,a)') '[ETC]>> Something wrong with the input', & ' read from arq_config = ',arq_config write (*,*) ' FIRbeta_I=',FIRbeta_I,' FIRbeta_D=',FIRbeta_D $ ,' | QHRbeta_I = ', QHRbeta_I write (*,*) ' NFIR_AV=',NFIR_AV,' FIRAV_low=',FIRAV_low, & ' FIRAV_upp=',FIRAV_upp stop end if * Reset things which won't be really used! (just for the sake of a * fully consistent output) if (iFIR_IsFIRcOn.EQ.0) then NFIR_AV = 0 FIRAV_low = 0. FIRAV_upp = 0. FIRbeta_I = 0. FIRbeta_D = 0. end if if (iQHR_IsQHRcOn.EQ.0) QHRbeta_I = 0. if (iPHO_IsPHOcOn.EQ.0) then NPHO_AV = 0 PHOAV_low = 0. PHOAV_upp = 0. end if end if * --------------------------------------------------------------------------- close(1) write (*,'(a)') '**> ... finished reading arq_config!' if (i_verbose.GT.0) then write (*,*) write (*,'(a,a)') '**> Welcome to Starlight v06r01 - Aug/2017', $ ' Keep your fingers crossed...' write (*,*) do i=1,10 write (*,'(20x,a)') ' >>>>>>>>> FORA TEMER! <<<<<<<<<' end do write (*,*) write (*,'(a,a)') '**> Read config file: ' , arq_config end if ! Check some of the input quantities... if ((EXOs_method_option.NE.'CUMUL').AND.(EXOs_method_option.NE. $ 'SMALL')) then write (*,'(a,a)') ' [MAIN] OOPS! Bad EXOs_method_option ' , $ EXOs_method_option stop end if if ((i_HelpPopVectorMove2Average.NE.0).AND. $ (i_HelpPopVectorMove2Average.NE.1)) then write (*,*) '[MAIN] Bad i_HelpPopVectorMove2Average! ' , $ i_HelpPopVectorMove2Average stop end if if ((i_HelpAVYAVMove2Average.NE.0).AND. $ (i_HelpAVYAVMove2Average.NE.1)) then write (*,*) '[MAIN] Bad i_HelpAVYAVMove2Average! ' , $ i_HelpAVYAVMove2Average stop end if if ((EXOs_PopVector_option.NE.'AVE').AND. $ (EXOs_PopVector_option.NE.'MIN')) then write (*,*) '[MAIN] Bad EXOs_PopVector_option! ' , $ EXOs_PopVector_option stop end if if (i_MoveOneParOnly.NE.1) then write (*,*) '[MAIN] Bad i_MoveOneParOnly: ',i_MoveOneParOnly stop end if if ((clip_method_option.NE.'NOCLIP').AND. $ (clip_method_option.NE.'NSIGMA').AND. $ (clip_method_option.NE.'RELRES').AND. $ (clip_method_option.NE.'ABSRES')) then write (*,*) '[MAIN] Bad clip_method_option ', $ clip_method_option stop end if c Initialize # of terms in RC-AV series (passed by common) NRC_AV = NRC_AV_Default c Reset alpha to 1. alpha = 1.0 c *************************************************************************** c *************************************************************************** c * READ MASK FILE * c *************************************************************************** !CALIFA! This part used to be located some ~ 400 lines below, after the ETC block. ! I am now reading the mask-file here, BEFORE the observed spectrum. The reason ! is that in this way I can disconsider masked-regions in the computation of a ! pseudo-error when the input spectra come with NO errors and thus STARLIGHT needs ! to guess one from a "S/N window". If this is not done then a S/N window informed ! in a grid file may inadvertedly include emission lines or sky-lines or other ! things, leading to an overestimation of the actual rms in the S/N window. i_last_non_blank_char = 0 do i=1,99 if ((mask_dir(i:i+1).EQ.' ').AND.(i_last_non_blank_char.EQ.0)) & i_last_non_blank_char = i - 1 end do arq_aux = mask_dir(1:i_last_non_blank_char) // arq_masks c Read MASK intervals: The array mask_weight() is used like this: c * mask_weight <= 0 on unwanted windows (eg emission lines) c * mask_weight > 0 is the factor by which we multiply the weight of the c points within llow_mask ==> lupp_mask. This may be c used to give more weight to key absorption features. c OBS: If any of the intervals overlap, then the one further down c the list will take precedence over the other, so be careful when c defining the intervals in arq_masks! write (*,'(a,a)') '**> ... Reading arq_masks = ',arq_aux open (unit=1,file=arq_aux,status='old') read (1,*) N_masks do i=1,N_masks read (1,*) llow_mask(i) , lupp_mask(i) , mask_weight(i) end do close(1) ! Screen output if (i_verbose.GT.0) then write (*,'(a,a45,a,i3)') '**> Read masks file: ' , arq_masks , & ' N_masks = ' , N_masks write (*,'(a,a)') ' from dir = ' , & mask_dir(1:i_last_non_blank_char) end if c *************************************************************************** c *************************************************************************** c * READ OBSERVED SPECTRUM * c *************************************************************************** c OBS: The "O" arrays (where "O" stands for "Original") defined here c are renamed without the "O" later on, after pre-processing steps. c c Implemented more-than-one header-lines - ElCid@Sanchica - 29/Jan/2012 i_last_non_blank_char = 0 do i=1,99 if ((obs_dir(i:i+1).EQ.' ').AND.(i_last_non_blank_char.EQ.0)) & i_last_non_blank_char = i - 1 end do arq_aux = obs_dir(1:i_last_non_blank_char) // arq_obs write (*,'(a,a)') '**> ... Reading arq_obs = ',arq_aux c First find-out how many header lines (those which start with '#') to skip open (unit=1,file=arq_aux,status='old') N_skip_arq_obs_header = 0 do i=1,Nl_max read (1,'(a1)') cerquinha if (cerquinha.EQ.'#') then N_skip_arq_obs_header = N_skip_arq_obs_header + 1 else goto 2901 end if end do 2901 close(1) !Cid24Mar07-FIX! Try to figure how many columns are in arq_obs to check ! consistency of IsErrSpecAvailable & IsFlagSpecAvailable info given... ! If a problem is detected issue a warning, but do NOT stop!! ! OBS: Does NOT work if columns are separated by tabs or commas! open (unit=1,file=arq_aux,status='old') do i=1,N_skip_arq_obs_header read (1,*) end do read (1,*) read (1,'(a)') arq_lix close(1) icol = 0 do i=1,99 if ((arq_lix(i:i).EQ.' ').AND.(arq_lix(i+1:i+1).NE.' ')) $ icol = icol + 1 end do if (arq_lix(1:1).EQ.' ') icol = icol - 1 if ((IsErrSpecAvailable.EQ.1).AND.(IsFlagSpecAvailable.EQ.1) $ .AND.(icol.NE.3)) then 189 format(67('?')) write (*,189) write (*,'(a,a,a)') 'ATT: You said there are error & flag ' , $ 'columns in ' , arq_obs write (*,'(a,i3,a)') ' but I counted only ', icol + 1 , $ ' columns!!' write (*,'(a)') ' Hope you know what you are doing...' write (*,189) else if ((IsErrSpecAvailable.EQ.1).AND.(IsFlagSpecAvailable.EQ.0) $ .AND.(icol.LT.2)) then write (*,189) write (*,'(a,a,a)') 'ATT: You said there is an error ' , $ 'column in ' , arq_obs write (*,'(a,i3,a)') ' but I counted ', icol + 1 , $ ' columns!!' write (*,'(a)') ' Hope you know what you are doing...' write (*,189) end if c Read original/observed galaxy flux, error & flag spectra: c Of_obs(Ol_obs) , Oerr_obs(Ol_obs) & Oflag_obs(Ol_obs) c ATT: Implemented no error/flag-available possibilities... c Cid@IAA - 29/May/2005 open (unit=1,file=arq_aux,status='old') do i=1,N_skip_arq_obs_header read (1,*) end do do i=1,Nl_max if ((IsErrSpecAvailable.EQ.1).AND.(IsFlagSpecAvailable.EQ.1)) then read (1,*,END=20) Ol_obs(i) , Of_obs(i) , Oerr_obs(i) , $ Oflag_obs(i) else if ((IsErrSpecAvailable.EQ.1).AND.(IsFlagSpecAvailable.EQ.0)) $ then read (1,*,END=20) Ol_obs(i) , Of_obs(i) , Oerr_obs(i) Oflag_obs(i) = 0 else if ((IsErrSpecAvailable.EQ.0).AND.(IsFlagSpecAvailable.EQ.0)) $ then read (1,*,END=20) Ol_obs(i) , Of_obs(i) Oflag_obs(i) = 0 end if end do write (*,*) ' [MAIN] BUG reading input spectrum! N > Nl_max!! ' , & Nl_max stop 20 NOl_obs = i - 1 close(1) !Cid07Feb07+Cid25Jan2010-FIX! Screen output if (i_verbose.GT.0) then write (*,'(a,a30)') '**> Read data file: ',arq_obs write (*,'(a,a)') ' from dir = ' , & obs_dir(1:i_last_non_blank_char) write (*,'(4x,a,2(2x,f6.1,a),i5,a)') 'Data goes from: ' , $ Ol_obs(1) , ' --> ' , Ol_obs(NOl_obs) , $ ' Angs with N = ' , NOl_obs , ' pixels' if (IsErrSpecAvailable.EQ.1) write (*,'(4x,a,a)') $ 'STARLIGHT has read an ERROR (column 3) from ' , arq_obs if (IsFlagSpecAvailable.EQ.1) write (*,'(4x,a,a)') $ 'STARLIGHT has read an FLAG (column 4) from ' , arq_obs end if !Cid14Jan07-FIX! Check if Ol_obs is given in increasing order. do i=1,NOl_obs-1 if (Ol_obs(i+1).LE.Ol_obs(i)) then write (*,*) ' [MAIN] PROBLEM w/spectrum: ', $ 'lambda should be given in increasing order! : ' , i , $ Ol_obs(i) , Ol_obs(i+1) stop end if end do c In the absence of a proper error spectrum, define Oerr_obs() using c the old method of rms in a window... (f_aux1 is just a c tmp-fake-weight-array to fool Stats4SN...). if (IsErrSpecAvailable.EQ.0) then do i=1,NOl_obs f_aux1(i) = 100. if (Of_obs(i).LE.0.) f_aux1(i) = -100. !CALIFA! f_aux1 now EXCLUDES windows masked away in the mask file ! so not to overestimate the cooked-up error estimated here! do j=1,N_masks if ((Ol_obs(i).GE.llow_mask(j)).AND. & (Ol_obs(i).LE.lupp_mask(j)).AND. & (mask_weight(j).LE.0.)) f_aux1(i) = -100. end do end do call Stats4SN(NOl_obs,Ol_obs,Of_obs,f_aux1,llow_SN,lupp_SN $ ,aux_ave,aux_sig) c ATT: For safety, if the rms in the llow_SN -> lupp_SN is 0 c (god-knows-why...) then recompute it using ALL the spectrum! if (aux_sig.LE.0.) then llow_SN = Ol_obs(1) lupp_SN = Ol_obs(NOl_obs) call Stats4SN(NOl_obs,Ol_obs,Of_obs,f_aux1,llow_SN,lupp_SN $ ,aux_ave,aux_sig) end if do i=1,NOl_obs Oerr_obs(i) = aux_sig end do if (i_verbose.GT.0) then write (*,'(a,a,f9.3)') $ '**> ATT: Defined error & flag spectra the old way!', $ ' S/N =' , aux_ave / aux_sig end if end if c *************************************************************************** c *************************************************************************** c * READ BASE MASTER-FILE & BASE SPECTRA * c *************************************************************************** c Read base spectra: Of_base(i_base,Ol_base) (later renamed to c f_base). Notice that I'm now also reading Mstars & ind_exAV & c alphaFe_base from the base-file!! c ATT: All base spectra are read from base_dir, so we first find the c last non empty bit in string base_dir (to concatenate names below) i_last_non_blank_char = 0 do i=1,99 if ((base_dir(i:i+1).EQ.' ').AND.(i_last_non_blank_char.EQ.0)) & i_last_non_blank_char = i - 1 end do write (*,'(a,a)') '**> ... Reading arq_base = ',arq_base open (unit=3,file=arq_base,status='old') read (3,*) N_base if (N_base.GT.Nb_max) then write (*,*) ' [MAIN] OOPS! N_base > Nb_max: ' , N_base , Nb_max write (*,*) ' [MAIN] Run aborted!' stop end if do j=1,N_base c Read base-info: filename, age, Z, code-name, Mstars, ind_exAV & c alphaFe_base read (3,*) arq_aux , age_base(j) , Z_base(j) , base_name(j) , & Mstars(j) , ind_exAV(j) , alphaFe_base(j) c Concatenate base spectrum filename with base directory & read it! arq_aux = base_dir(1:i_last_non_blank_char) // arq_aux call ReadSpecWithHeader(arq_aux,Nl_max,NOl_base,Ol_base,f_aux1) !Cid29Mar07-FIX! Introduced tests to check if i_FastBC03_FLAG = 1 is ! being used with the original BC03/STELIB models. If not, I issue a ! warning and revert i_FastBC03_FLAG to 0. if (i_FastBC03_FLAG.EQ.1) then i_shit = 0 if (NOl_base.NE.6900) i_shit = 1 if (int(Ol_base(1)).NE.91) i_shit = 1 if (int(Ol_base(1000)).NE.3974) i_shit = 1 if (int(Ol_base(2000)).NE.4974) i_shit = 1 if (int(Ol_base(3000)).NE.5974) i_shit = 1 if (int(Ol_base(4738)).NE.7712) i_shit = 1 if (int(Ol_base(6361)).NE.9990) i_shit = 1 if (int(Ol_base(6900)).NE.1600000) i_shit = 1 if (i_shit.EQ.1) then 188 format(80('?')) write (*,188) write (*,'(a,a)') 'OOPS! You have specified ' , $ 'i_FastBC03_FLAG = 1 (in arq_config) but the file: ' write (*,'(a)') arq_aux write (*,'(a,a)') 'does NOT match the lambdas of ', $ 'BC03/STELIB!! Reverting to i_FastBC03_FLAG = 0!' i_FastBC03_FLAG = 0 write (*,188) end if end if do i=1,NOl_base Of_base(j,i) = f_aux1(i) end do !Cid14Jan07-FIX! Check if Ol_base is given in increasing order. do i=1,NOl_base-1 if (Ol_base(i+1).LE.Ol_base(i)) then write (*,*) ' [MAIN] PROBLEM w/base spectrum: ', $ 'lambda should be given in increasing order! : ',i $ , Ol_base(i) , Ol_base(i+1) write (*,*) ' [MAIN] base-file = ', arq_aux stop end if end do end do close(3) !Cid14Jan07-FIX! Warn if Mstars(j) <= 0, but only fixes it if ALL are <= 0. IsAtLeastOneMstarsOk = 0 do j=1,N_base if ((Mstars(j).GT.0.).AND.(IsAtLeastOneMstarsOk.EQ.0)) $ IsAtLeastOneMstarsOk = 1 if (Mstars(j).LE.0.) then write (*,*) ' [MAIN] ATT: Mstars <= 0!! ', $ 'Fix it or disregard mass fractions on output...' , j end if end do if (IsAtLeastOneMstarsOk.EQ.0) then write (*,*) ' [MAIN] ATT: ALL Mstars <= 0!! WILL SET IT TO 1!' do j=1,N_base Mstars(j) = 1. end do end if ! Screen output if (i_verbose.GT.0) then write (*,'(a,a45,a,i3)') '**> Read base files: ' , arq_base , & ' N_base = ' , N_base write (*,'(a,a)') ' from dir = ' , & base_dir(1:i_last_non_blank_char) end if c *************************************************************************** c *************************************************************************** c * !!MEX!! SET UP EXTRA-EXTINCTIONS SCHEME (*exAV*) * c *************************************************************************** !CFl! Several modification added to implement CFl_stuff - Cid@Lagoa-03/Aug/2017 * Find Number of different extinctions to be fitted & Number of * components which will be allowed to have the extra-extinction exAV * (passed elsewhere by the common/exAV_stuff/). !CFl! Set IsCFlawOn = 1 if at least one ind_exAV(j) = -1. N_exAV = 0 N_exAV_components = 0 do j=1,N_base if (ind_exAV(j).EQ.-1) IsCFlawOn = 1 if (abs(ind_exAV(j)).GT.N_exAV) N_exAV = abs(ind_exAV(j)) if (ind_exAV(j).NE.0) N_exAV_components=N_exAV_components + 1 end do !CFl! Only one exAV componet is allowed in CFl-fits, ie, ind_exAV(j) must be ! = -1 or 0. Test this! Also, force N_exAV = 1 just in case... if (IsCFlawOn.EQ.1) then N_exAV = 1 do j=1,N_base if ((ind_exAV(j).NE.0).AND.(ind_exAV(j).NE.-1)) then write (*,*) '[MAIN] OOPS! If an ind_exAV=-1 then you can', $ ' only have ind_exAV = -1 or 0! ', j,ind_exAV(j) write (*,*) '[MAIN] Run aborted :(' stop end if end do end if * Check whether there are gaps in the ind_exAV array. It must be = * 0, 1, 2, 3... with NO GAPS! Unnecessary test in CFl-fits! if (IsCFlawOn.NE.1) then do i_aux=1,N_exAV n_aux = 0 do j=1,N_base if (ind_exAV(j).EQ.i_aux) n_aux = n_aux + 1 end do if (n_aux.EQ.0) then write (*,*) '[MAIN] OOPS! Problem with ind_exAV array' write (*,*) '[MAIN] N_exAV = ', N_exAV , $ ' but there is no pop with ind_exAV = ' , i_aux write (*,*) '[MAIN] The ind_exAV array must be = ', $ '0, 1, ... N_exAV, WITHOUT GAPS!' write (*,*) '[MAIN] Run aborted :(' stop end if end do end if * Now read LIMITS to exAV from arq_base. These should be located at * the BOTTOM of the base file and AFTER 2 lines of comments... !CFl! In the case of a CF-law we read the coefficients a0 & a1 in the equation ! AV_Young = a0 + a1 * AV_Old. if (N_exAV.GT.0) then open (unit=3,file=arq_base,status='old') do i_skip=1,N_base+3 read (3,*) end do if (IsCFlawOn.EQ.1) then read (3,*) i_lix , a0_CFl , a1_CFl !CFl! The exAV_low & _upp limits set below are probably unnecessary... exAV_low(1) = a0_CFl + (a1_CFl - 1.) * AV_low exAV_upp(1) = a0_CFl + (a1_CFl - 1.) * AV_upp !CFl! The safety-fix below is necessary to avoid exAV = 0 always, which drives ! the Markov-chains GR-test nuts! By setting a1_CFl1 slightly different ! from 1 exAV will vary a tiny little bit, and the Gelman-&-Rubin ! within-chain variance (GR_W) will not be == 0. ! Cid@Lagoa - 07/Aug/2017 if ((a0_CFl.EQ.0).AND.(a1_CFl.EQ.1)) a1_CFl = 1.00001 else do i_aux=1,N_exAV read (3,*) i_exAV , z1 , z2 exAV_low(i_exAV) = z1 exAV_upp(i_exAV) = z2 end do end if close(3) end if !CFl! While CFl-testing, I realized it's a bad idea to let exAV_low = exAV _upp, ! which might be done even in non-CFl-fits. My "solution" here is to just ! say exAV_upop is a tiny bit larger than exAV_low... (nearly, but not ! exactly equal). ! Cid@Lagoa - 06/Aug/2017 do i_exAV=1,N_exAV if (exAV_low(i_exAV).eq.exAV_upp(i_exAV)) then write (*,*) '##>WARNING: you chose exAV_low = exAV_upp' , $ i_exAV , exAV_low(i_exAV) , exAV_low(i_exAV) exAV_upp(i_exAV) = exAV_low(i_exAV) + 0.0001 write (*,*) ' but i changed it to ' , $ i_exAV , exAV_low(i_exAV) , exAV_upp(i_exAV) end if end do c Screen check exAV-stuff... if (i_verbose.GT.0) then write (*,'(a,i3)') $ '**> Number of components with different extinction = ', $ N_exAV_components write (*,'(a,i3)') ' Number of extra extinctions = ' , $ N_exAV if (IsCFlawOn.EQ.1) then write (*,'(a,2(1x,f8.3))') $ ' * ATT: IsCFlawOn = 1! a0 & a1 = ' , a0_CFl , a1_CFl else do i_exAV=1,N_exAV write (*,'(a,i3,2x,a,f5.2,2x,a,f5.2)') $ ' * ind_exAV= ',i_exAV , $ ' exAV_low= ', exAV_low(i_exAV) , $ ' exAV_upp= ', exAV_upp(i_exAV) end do end if end if c *************************************************************************** c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC READ ETC-info & initialize some ETC-stuff ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c Read ETC-data file, assumed to be in etc_dir if (iETC_IsETCcOn.EQ.1) then i_last_non_blank_char = 0 do i=1,99 if ((etc_dir(i:i+1).EQ.' ').AND.(i_last_non_blank_char.EQ.0)) & i_last_non_blank_char = i - 1 end do arq_aux = etc_dir(1:i_last_non_blank_char) // arq_ETCinfo call Read_ETC_Info(i_verbose,arq_aux) end if *FIR* Initialize model-related things: R-matrix, Lbol, & etc. * OBS1: This is done here because we need the full and original * Of_base spectra, which is chopped and changed below! * OBS2: This initialization is also necessary if we only want to * PREDICT the FIR-luminosity (iFIR_IsFIRcOn option = -1) if ((iFIR_IsFIRcOn.EQ.1).OR.(iFIR_IsFIRcOn.EQ.-1)) then call FIRInitialization(i_verbose,N_base,NOl_base,Ol_base, & l_norm,red_law_option,FIRbeta_I,FIRbeta_D) end if *QRH* Initialize QHR-related things if ((iQHR_IsQHRcOn.EQ.1).OR.(iQHR_IsQHRcOn.EQ.-1)) then *QHR* Recover QHR_qlambda(iY) = A(lambda(iY)) / AV from a fake 1-element * red_term array... [just a trick] n_aux = 1 do iY=1,NQHR_Ys l_aux(1) = QHR_lambda(iY) call Calc_red_term(red_law_option,l_norm,n_aux,l_aux, $ f_aux3,qaux_norm) QHR_qlambda(iY) = qaux_norm - 2.5 * f_aux3(1) end do *QHR* Initialize QHR-base-related things: QHR_qH40(), QHR_Q2Lnorm40(), * QHR_q_norm & NQHR_base, all in common/QHR_BaseStuff/. !QHi! Added IsReadQHfromBaseFile - Cid@UFSC - 03/July/2017 call QHRInitialization(i_verbose,N_base,NOl_base,Ol_base, $ l_norm,red_law_option,IsReadQHfromBaseFile,arq_base) end if *PHO* Initialize PHO-related things: PHO_MeanLambda(,), PHO_3Mat(,,), * etc, all in common/PHO_BaseStuff/ if ((iPHO_IsPHOcOn.EQ.1).OR.(iPHO_IsPHOcOn.EQ.-1)) then call PHOInitialization(PHO_redshift,NPHO_Ys,i_verbose,N_base $ ,NOl_base,Ol_base,l_norm,red_law_option,etc_dir) end if c ETC -ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c *************************************************************************** c * .................. * c *************************************************************************** !CALIFA! The mask-file used to be read here, but not any more. See above. ! Screen output if (i_verbose.GT.0) then write (*,'(a,a30,a,a)') '**> Modeling ',arq_obs,' ==> ', & arq_out write (*,'(4x,3(a,f6.1),a)') 'Sampling: ',Olsyn_ini, & ' ==> ' , Olsyn_fin , ' with dl =' , Odl_syn , ' Angs' write (*,'(a,f6.1)') ' dl_cushion (A) = ' , dl_cushion write (*,'(a,a)') ' Extinction Law = ' , red_law_option write (*,'(3x,a,f6.1,a,f6.1,a)') $ ' Initial kinematical parameters: v0 = ' , v0_ini , $ ' & vd = ', vd_ini , ' km/s' if (FitOrSamplePDF_option.EQ.'PDF') then write (*,'(a)') $ ' We are going to SAMPLE THE PDF for this galaxy' else if (FitOrSamplePDF_option.EQ.'FIT') then write (*,'(a)') $ ' We are going to FIT the spectrum of this galaxy' else if (FitOrSamplePDF_option.EQ.'FXK') then write (*,'(a,a)') $ ' We are going to FIT the spectrum of this galaxy', $ ' with FIXED KINEMATICAL PARAMETERS!' end if end if c *************************************************************************** c *************************************************************************** c * PRE-PROCESSING I: RESAMPLING OBSERVED, BASE & WEIGHT/FLAG/MASK SPECTRA * c *************************************************************************** c Here I introduce the following trick: The wanted range is really c from Olsyn_ini ==> Olsyn_fin. I extend this range by ~ dl_cushion c Angstroms in both blue & red edges, but force the mask f_mask to c be = zero outside the Olsyn_ini ==> Olsyn_fin interval. Therefore c these extra points will NOT be synthesized. However, these c "safety" cushion will help minimizing edge effects in the c Gauss_smooth routine. In fact, these extra points are useful only c in the convolution of the synthetic spectrum with the kinematical c filter (in Gauss_smooth). c Extend wavelength range by dl_cushion Angs to blue & red. !Cid20Jan07-FIX! dl_cushion used to be = 50 Angs. Now it is read from arq_config! n_extra = dl_cushion / Odl_syn lsyn_ini = Olsyn_ini - n_extra * Odl_syn lsyn_fin = Olsyn_fin + n_extra * Odl_syn dl_syn = Odl_syn c Define lambda grid for spectral synthesis, l_syn (later renamed l_obs!) Nl_syn = (lsyn_fin - lsyn_ini) / dl_syn + 1 if (Nl_syn.GT.Nl_max) then write (*,*) ' [MAIN] OOPS! Nl_syn > Nl_max: ' , Nl_syn,Nl_max stop end if do i=1,Nl_syn l_syn(i) = lsyn_ini + (i - 1) * dl_syn end do c Rebin observed spectra. I STRONGLY suggest you rebin your spectra c externally (eg, with IRAF's dispcor) and use Odl_syn = original c dl. The RebinSpec routine would then keep the spectrum untouched! call RebinSpec(0,NOl_obs,Ol_obs,Of_obs,Nl_syn,l_syn,f_aux1) c Rebin error & flag spectra too. c **> ATT: THE REBINNING OF THE ERROR SPECTRUM SHOULD BE RE-THOUGHT! c (Binning adjacent pixels should reduce the noise, but my rebinning c routine simply "averages" it...). This is why I do NOT recommend c rebinning at all! c Rebinning the flag also changes the integer-flags to real c numbers... This, however, is not a problem: We simply flag-away c points with flag > 1. !2BEDONE! ATT: Change here when/if flag-value-meaning is defined in arq_config! call RebinSpec(0,NOl_obs,Ol_obs,Oerr_obs,Nl_syn,l_syn,f_aux2) call RebinSpec(0,NOl_obs,Ol_obs,Oflag_obs,Nl_syn,l_syn,f_aux3) c OBS: This next step REDEFINES NOl_obs, Ol_obs(), Of_obs(), c Oerr_obs() & Oflag_obs()!! NOl_obs = Nl_syn do i=1,NOl_obs ! write (*,'(i4,2x,4(1x,f8.3),10x,4(1x,f8.3))') i , ! & Ol_obs(i) , Of_obs(i) , Oerr_obs(i) , Oflag_obs(i) , ! & l_syn(i) , f_aux1(i) , f_aux2(i) , f_aux3(i) Ol_obs(i) = l_syn(i) Of_obs(i) = f_aux1(i) Oerr_obs(i) = f_aux2(i) Oflag_obs(i) = f_aux3(i) c Mask/flag out points outside desired Olsyn_ini ==> Olsyn_fin range. c Also mask/flag out points with error <= 0! (Just a safety measure...) if ((Ol_obs(i).LT.Olsyn_ini).OR. & (Ol_obs(i).GT.Olsyn_fin).OR. & (Oerr_obs(i).LE.0.)) Oflag_obs(i) = 99. end do c Resample/Rebin base spectra to l_obs wavelength-scale. I've c introduced a i_FastBC03_FLAG which greatly speeds up rebinning for c a BC03 base and dl = 1 and Ol_obs is within 3322-->9300 Angs. c i_FastBC03_FLAG is read from config file. c OBS: This step REDEFINES the Of_base() matrix!! ! ! ATT: I've adapted the fast-rebin trick to work with Base-Rosa ! spectra (br04*spec files), which cover the 3001 --> 6996 Angs ! range. To use use fast-rebin with BR04 you must set ! i_FastBC03_FLAG = 2! This trick should be generalized in a more ! elegant manner... (Cid@IAA - 30/May/2005) !OJO! THIS SHOULD BE IMPROVED! do j=1,N_base do i=1,NOl_base f_aux1(i) = Of_base(j,i) end do call RebinSpec(i_FastBC03_FLAG,NOl_base,Ol_base,f_aux1, & NOl_obs,Ol_obs,f_aux2) do i=1,NOl_obs Of_base(j,i) = f_aux2(i) end do end do !Cid20Jan07-FIX! WARN if we will need to mask base edges to be safe ! against edge effects in the kinematical filter! if ((Ol_base(1).GT.lsyn_ini).OR.(Ol_base(NOl_base).LT.lsyn_fin)) $ then write (*,'(a,a)') '@@@@@@@@@@@@@@@@@@@@@@@@@@@@> BASE ' , $ 'LIMITS WARNING <@@@@@@@@@@@@@@@@@@@@@@@@@@@@@' write (*,'(2(a,f9.1),a)') '@ Your base goes from lambda = ', $ Ol_base(1) ,' to ' , Ol_base(NOl_base) , ' Angs ' write (*,'(2(a,f9.1),a)') '@ but the fit will run from ' , $ lsyn_ini , ' to ' , lsyn_fin , $ ' Angs ' write (*,'(a,f5.1,a)') '@ (including a +/-', dl_cushion , $ ' Angs cushion for the kinematical filter)' write (*,'(2(a,f9.1),a)') $ '@ STARLIGHT will flag-out lambdas outside the ' , $ Ol_base(1) + dl_cushion , ' to ' , $ Ol_base(NOl_base) - dl_cushion , ' Angs range!' write (*,'(a,a)') '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@' $ ,'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@' end if c Define a MASK-SPECTRUM f_mask() in the Ol_obs wavelength-scale. c The mask_weight array should be = 0 on the N_mask llow_mask ==> c lupp_mask windows which we do NOT want to model. If mask_weight > c 0, this sets different/special weight for the corresponding c llow_mask ==> lupp_mask interval. We also force the mask to be c zero outside the Olsyn_ini ==> Olsyn_fin interval. Finally, we c mask-out points for which the (SDSS-inspired) quality flag is > 1. c These points are marked with f_mask = -2. do i=1,NOl_obs f_mask(i) = 1. do j=1,N_masks if ((Ol_obs(i).GE.llow_mask(j)).AND. & (Ol_obs(i).LE.lupp_mask(j))) f_mask(i) = mask_weight(j) end do if ((Ol_obs(i).LT.Olsyn_ini).OR. & (Ol_obs(i).GT.Olsyn_fin)) f_mask(i) = 0. !Cid20Jan07-FIX! Introduced safety against people trying to fit data ! within dl_cushion Angs of the base edges. The if below will ! mask the first and last dl_cushon Angs from the base edges. ! OBS: The possible/likely overlap with the if above is harmless! if ((Ol_obs(i).LT.(Ol_base(1)+dl_cushion)).OR. $ (Ol_obs(i).GT.(Ol_base(NOl_base)-dl_cushion))) then f_mask(i) = 0. end if c Accept points with flag <= 1! This means that we INCLUDE things c SDSS people call "emission lines" (flag = 1), but we've verified c these are not always real emission lines! c Cid&Jean@UFSC - 20/Nov/2003 !KEEP-FLAG-VALUES! This next line used to be: if (Oflag_obs(i).GT.1.) f_mask(i) = -2. ! I now keep the flag>1 values in f_mask. This is just to aid the identification ! of flagged points (which can mean sky-lines, hot pix, etc) in the output of ! STARLIGHT. Nothing else changes! But note that f_mask keeps the resampled ! flag, which will not be equal to the original when the data is rebinnedd.. ! ElCid@Sanchhica - 10/Feb/2012 if (Oflag_obs(i).GT.1.) f_mask(i) = -Oflag_obs(i) end do c OBS: After the steps above all arrays (Of_obs, Of_base & f_mask) c are sampled at Ol_obs. (Ol_base is not used anymore). c *************************************************************************** c *************************************************************************** c * PRE-PROCESSING II: NORMALIZATION * c *************************************************************************** c Renormalize the observed spectrum by the MEDIAN flux between c llow_norm & lupp_norm, but the base spectra are normalized just by c the flux at l_norm! Normalizing the base at a single wavelength is c better (eg, it preserves normalization when applying the reddening c term to synthetic spectra) and should be Ok since the base has "no c noise". The observed spectrum, however, has noise, so it is c better to normalize it by the mean or median flux in a window. c Normalize Of_obs to MEDIAN flux between llow_norm & lupp_norm c Re-Normalize Oerr_obs too. ATT: the median is computed regardless c of whether points are flagged or masked!! ! ATT: NEW-Safety: If fobs_norm <= 0 then produce a silly output ! file & abort the run!! The user should fix this before running. !OJO! !2BEDONE! ATT: fobs_norm computation IGNORES bad (flaged/masked) pixels!! ! This is dangerous and could/should be changed one day... call Stats_F(NOl_obs,Ol_obs,Of_obs,llow_norm,lupp_norm, & Of_ave,Of_sig,Of_med) fobs_norm = Of_med if (fobs_norm.LE.0.) then write (*,'(a,1p,e12.3)') '## ATT: fobs_norm = ' , fobs_norm write (*,'(a,a)') '## arq_obs = ' , arq_obs write (*,'(a)') '## Run aborted & silly file produced :(' i_last_non_blank_char = 0 do i=1,99 if ((out_dir(i:i+1).EQ.' ').AND. & (i_last_non_blank_char.EQ.0)) i_last_non_blank_char=i-1 end do arq_aux = out_dir(1:i_last_non_blank_char) // arq_out open (unit=2,file=arq_aux,status='unknown') write (2,'(a,1p,e12.3)') '## ATT: fobs_norm = ' , fobs_norm write (2,'(a,a)') '## arq_obs = ' , arq_obs write (2,'(a)') '## Run aborted:(' close(2) return end if do i=1,NOl_obs Of_obs(i) = Of_obs(i) / fobs_norm Oerr_obs(i) = Oerr_obs(i) / fobs_norm end do c Normalize base spectra to their flux at l_norm. c OBS1: fbase_norm(j) is saved to compute M/L's & mass-fractions... do j=1,N_base do i=1,NOl_obs f_aux1(i) = Of_base(j,i) end do call calc_Fnorm(NOl_obs,Ol_obs,f_aux1,l_norm,fbase_norm(j)) do i=1,NOl_obs Of_base(j,i) = f_aux1(i) / fbase_norm(j) end do end do c *************************************************************************** c ETC -ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC DEFINE Lobs_norm (Cid@Lagoa - 07/Jan/2011) ETC c ETC -ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c Compute the log(monochromatic-luminosity-@l_norm): Lobs_norm and c its log. The units are expected to be L_sun/Angs, as long as the c entries **flux_unit** and **LumDistInMpc** are Ok. This was c introduced during the FIR-work, but is needed for any ETC-like c fit. The physical flux-scale MUST be right for FIR/QHR/PHO-fits c (this is assumed in the related-routines), but is COMPLETELY c IRRELEVANT for the optical spectral fit itself! In fact, up until c the very final output phase, ONLY the FIR/QHR/PHO routines know c and use the actual units of the observed optical spectrum. logLobs_norm = log10(fobs_norm * flux_unit) + & log10(4. * (4.*atan(1.))) + & 2. * log10(LumDistInMpc * 1.e6 * 3.086e18) - log10(3.826e33) Lobs_norm = 10.**logLobs_norm c Store logLobs_norm into variables * acessibles by the FIR/QHR/PHO c routines via the respective * data-commons. FIR_logLobs_norm = logLobs_norm QHR_logLobs_norm = logLobs_norm ! PHO_logLobs_norm = logLobs_norm ! Foca@ufsc May 2017: Trying to change normalization to switch Starlight ! to magnitudes... ! It worked!!! <3 <3 <3 PHO_logFobs_norm = log10(fobs_norm * flux_unit) c ETC -ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c *************************************************************************** c * PRE-PROCESSING III: DEFINITION OF ERRORS/WEIGHTS & S/N ratios * c *************************************************************************** c Define errors & weights! Weight = 0 if f_mask <= 0 OR f_obs <= c f_cut. These points will thus be excluded from the synthesis. For c other points, use INPUT error flux! Points with mask_weight > 0 c are given extra weight (= f_mask). c Nl_eff = the number of non-zero-weight points, ie, the effective c number of lambdas synthesized. ! !SNmax! S/N <= SNmax_threshold quadrature correction trick implemented. ! Cid@Lagoa - 09/Aug/2017 Nl_eff = 0 do i=1,NOl_obs if ((f_mask(i).LE.0.).OR.(Of_obs(i).LE.f_cut).OR. & (Oerr_obs(i).LE.0.)) then err_obs(i) = -99. weight_obs(i) = 0. else err_obs(i) = Oerr_obs(i) / f_mask(i) if (SNmax_threshold.GT.0.) then err_min = Of_obs(i) / SNmax_threshold err_obs(i) = sqrt(Oerr_obs(i)**2 + err_min**2) / f_mask(i) end if weight_obs(i) = 1. / err_obs(i) Nl_eff = Nl_eff + 1 end if end do c Store Nl_eff onto NOl_eff ("Original Nl_eff"), since Nl_eff will c be modified if clipping is turned on. NOl_eff = Nl_eff c Apply a "WEIGHT-CONTROL-FILTER"! Compute mean and std dev of c weight_obs for the NOl_eff unmasked lambdas, and reset all weights c 2-sigma above mean to weigh_obs = mean + 2 sigma! I've decided to c apply this "filter" as some of the SDSS spectra have very-low c errors on some lambdas, and these are then given a c disproportionately large weight in the synthesis. c Cid@lynx - 17/March/2004 c c I later realized that it is desirable to have more control over c this option. For instance, when err_obs() = constant (as in Joao's c data) but we want (through the mask file) to give more weight to a c particular window (say, Ca II K), we'd have wei_sig(i) = 0, which c would result in weight_obs(i) = wei_ave all accross the c spectrum... Hence, I introduced the parameter wei_nsig_threshold c in arq_config. Setting wei_nsig_threshold <= 0 will turn OFF the c weight filter. Otherwise, we censor points whose weights are >= c wei_nsig_threshold times larger than wei_sig. c Cid@Lagoa - 24/March/2005 !Cid24Mar07-FIX! Added counter of censored weights just for output purposes. n_censored_weights = 0 wei_limit = 0 if (wei_nsig_threshold.GT.0.) then N_aux = 0 do i=1,NOl_obs if (weight_obs(i).GT.0.) then N_aux = N_aux + 1 f_aux1(N_aux) = weight_obs(i) end if end do call avevar(f_aux1,N_aux,wei_ave,wei_var) wei_sig = sqrt(wei_var) wei_limit = wei_ave + wei_nsig_threshold * wei_sig do i=1,NOl_obs if (weight_obs(i).GT.wei_limit) then weight_obs(i) = wei_limit n_censored_weights = n_censored_weights + 1 end if end do end if c Compute the S/N ratio in the SN & normalization windows from the c the average-flux/rms-flux ratios (excluding masked points). Then c re-estimate these quantities using the average-error instead of c the rm-flux in the denominator ("SNerr_*"). The S/N in the c normalization window is just 1 over the noise flux in the c SN-window (a sensible, albeit silly, definition). c OBS: ALL these S/N's are IRRELEVANT since we use an input error c spectrum! They are ONLY used for output purposes! call Stats4SN(NOl_obs,Ol_obs,Of_obs,weight_obs, & llow_SN,lupp_SN,ave1,sig1) c ATT: For safety, if the rms in the llow_SN -> lupp_SN is 0 c (god-knows-why...) then recompute it using ALL the spectrum! This c is just to avoid stupid NaN's in the output file! c Cid@Lagoa - 08/Oct/2005 if (sig1.LE.0.) then llow_SN = Ol_obs(1) lupp_SN = Ol_obs(NOl_obs) call Stats4SN(NOl_obs,Ol_obs,Of_obs,weight_obs,llow_SN,lupp_SN $ ,ave1,sig1) end if call Stats4SN(NOl_obs,Ol_obs,Oerr_obs,weight_obs, & llow_SN,lupp_SN,ave2,sig2) SN_snwin = ave1 / sig1 SN_normwin = 1. / sig1 SNerr_snwin = ave1 / ave2 SNerr_normwin = 1. / ave2 if (i_verbose.GT.0) then write (*,'(a,f8.3,2x,f8.3,a)')' S/N = ', & SN_snwin , SN_normwin ,' in S/N & norm. windows' write (*,'(a,f8.3,2x,f8.3,a)')' S/N_err = ', & SNerr_snwin , SNerr_normwin ,' in S/N & norm. windows' end if c *************************************************************************** c *************************************************************************** c * PRE-PROCESSING IV: SET EXTINCTION LAW & FINAL DETAILS * c *************************************************************************** c Define reddening term = -0.4 * (A(lambda)/AV - A(l_norm)/AV). c The array red_term is passed by the common/Red_factor/ to routines c which need it! c OBS1: The user should apply his own correction for Galactic c extinction to the input observed spectrum before-hand... ! (Removed the obsolete R_V parameter - Cid@Granada - 24/Jan/2010) call Calc_red_term(red_law_option,l_norm,NOl_obs,Ol_obs, $ red_term,q_norm) c Store O* variables onto proper names, passed by commons to other c routines. Nl_obs = NOl_obs do i=1,Nl_obs l_obs(i) = Ol_obs(i) f_obs(i) = Of_obs(i) do j=1,N_base f_base(j,i) = Of_base(j,i) end do end do c *************************************************************************** c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC ESM: ETC_GlobalChi2ScaleFactor ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC !ESM! For a description of all involved in the ETC-Scaling-Method (ESM) ! see the ESM "abstract" @ the top of the code! !ESM! Define Np_OPT as the original (prior to clipping!) number of lambdas ! used in the (optical) spectral fit. Np_OPT = NOl_eff !ESM! With Np_OPT (just defined) and previoulsy defined other stuff, compute ! ETC_GlobalChi2ScaleFactor z0 = float(Np_OPT + Np_PHO + Np_QHR + Np_FIR) z = (ETC_alpha + ETC_beta) z1 = PHO_GlobalChi2ScaleFactor * Np_OPT**z * Np_PHO**(1 - z) z2 = QHR_GlobalChi2ScaleFactor * Np_OPT**z * Np_QHR**(1 - z) z3 = FIR_GlobalChi2ScaleFactor * Np_OPT**z * Np_FIR**(1 - z) zz = z0 / (Np_OPT + z1 + z2 + z3) ETC_GlobalChi2ScaleFactor = zz**ETC_gamma if ((iETC_IsETCcOn.NE.0).AND.(i_verbose.GE.1)) then write (*,'(a)') '**> Some info on the ETC constraints' write (*,'(a,4(i5,1x))') ' Np_ OPT FIR QHR PHO = ', $ Np_OPT , Np_FIR , Np_QHR , Np_PHO write (*,'(a,1p,3(e9.3,2x))') $ ' FIR_ QHR_ PHO_ GlobalChi2ScaleFactor = ', $ FIR_GlobalChi2ScaleFactor , QHR_GlobalChi2ScaleFactor , $ PHO_GlobalChi2ScaleFactor write (*,'(a,1p,e9.3)') ' ETC_GlobalChi2ScaleFactor = ', $ ETC_GlobalChi2ScaleFactor write (*,'(a,a,3(2x,f6.3))') $ ' ETC_ESM alpha beta gamma = ' , $ ETC_ESM , ETC_alpha , ETC_beta , ETC_gamma end if c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + DONE WITH INPUT & PRE-PROCESSING STEPS:) + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + SPECTRAL FIT + c + + c + + c + The pre-processing steps above produced the following main + c + variables: l_obs() , f_obs() , weight_obs(), Of_base(,), + c + f_base(,), age_base(), Z_base(), red_term(), N_base , Nl_obs, + c + ind_YAV(), N_YAV_components. These are used in the spectral fit, + c + which produces estimates of the following output variables: x(), + c + AV_tot() [= AV + YAV], v0 & vd. + c + + c + In this part we do the actual spectral fit. The steps are: + c + (1) Initialize chains & set-up several details c + (2) First-Fits (FF), to make chains converge to a reasonable zone of + c + parameter space. N_loops_FF annealing loops are done. c + (3) Identify & clip outliers. c + (4) Re-fit clipped spectrum. Only 1 loop. c + (5) Re-fit once more, this time with a more rigorous Burn-In c + criterion. The chain & global-best parameters after this step c + are stored for output... c + (6) Do a "Fine-tuning"-annealing-fit with a condense base. c + c + OBS: The code below also allows for sampling of the PDF, but this part c + part is not really optimized/organizwed properly c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c *************************************************************************** c * Initialize Kinematical Parameters v0 & vd (Cid/FXK@Lagoa - 14/Jan/2007) * c *************************************************************************** c Set initial values for kinematical parameters v0 & vd (in km/s). c These are now read from the input for each galaxy!! c (Life would be much easier if we knew these beforehand...) v0_min = v0_ini vd_min = vd_ini c IsKinFixed = 0 allows v0 & vd to be fitted. IsKinFixed = 1 keep c them fixed. IsThisAnFXKFit is an auxiliar flag (associated to c common/FXK_fits/ which indicates that this is an FXK fit, so v0 & c vd will NEVER be changed wrt the input values, so the base c smoothing can be done only once! (In this case, I smooth both c f_base & Of_base). IsThisAnFXKFit = 0 IsKinFixed = 0 if (FitOrSamplePDF_option.EQ.'FXK') then IsKinFixed = 1 IsThisAnFXKFit = 1 if (i_verbose.GT.0) write (*,'(a,2(a,f9.3),a)') $ '[MAIN] FXK-fit: Smoothing base to' ,' v0 = ' , v0_min , $ ' & vd = ' , vd_min , ' km/s... once and for all!' do i=1,Nl_obs l_aux(i) = l_obs(i) end do Nl_aux = Nl_obs do j=1,N_base do i=1,Nl_obs f_aux1(i) = f_base(j,i) end do call GaussSmooth(Nl_aux,l_aux,f_aux1,v0_min,vd_min, & N_int_Gauss,Nl_obs,l_obs,f_aux2) do i=1,Nl_obs f_base(j,i) = f_aux2(i) Of_base(j,i) = f_aux2(i) end do end do if (i_verbose.GT.0) write (*,'(a)') '[MAIN] FXK-fit: ...done!' end if c Sanity check: Warn if initial v0 & vd are not within low->upp bounds! if ((v0_min.LT.v0_low).OR.(v0_min.GT.v0_upp).OR. $ (vd_min.LT.vd_low).OR.(vd_min.GT.vd_upp)) then write (*,*) ' [MAIN] Your initial v0/vd values exceed the' , $ '_low -> _upp values in the config file!! ' write (*,*) ' I hope you know what you are doing!' end if c *************************************************************************** c *************************************************************************** c * !!MEX!! Initialize Chains * c *************************************************************************** c Define par_low & par_upp limits, where par =(x,AV,exAV,fn), in this c order! Also define j_AV, j_exAV & j_fn indices used throughout! c OBS: If no extra AVs are being used (N_exAV = 0) then j_exAV = j_fn! N_par = N_base + 1 + N_exAV + 1 j_AV = N_base + 1 j_exAV = N_base + 2 j_fn = N_par do j=1,N_base par_low(j) = 0. par_upp(j) = fn_upp end do par_low(j_AV) = AV_low par_upp(j_AV) = AV_upp do j=j_exAV,j_fn-1 !OBS: This loop only runs if Nex_AV > 0! j_aux = (j - j_exAV) + 1 par_low(j) = exAV_low(j_aux) par_upp(j) = exAV_upp(j_aux) end do par_low(j_fn) = fn_low par_upp(j_fn) = fn_upp c Initialize N_chains with RANDOM initial parameters: c (x,AV,exAV,fn). Store them onto ChainPar-matrix. Note also that c Generate_PopVector returns a pop-vector normalized to unit sum, so c we renormalize it to Sum{x_j} = fn a posteriori. ! ATT: To decrease initial chain energies, I'm using a more ! constrained range for fn, AV & exAV so that chains do not start ! from completely crazy positions allowed in the low ==> upp ranges! ! Also, I force the 1st chain to start from x_j = 1/N_base, AV = exAV = 0. ! ATT! Whereas in StarlightChains_v01.for the z*_low & *_upp values ! for fn, AV & exAV were fixed, I now set them equal to the ! corresponding input *_low & *_upp values and restrict to narrower ! ranges them only if they exceed certain limits (0.9 -> 1.1 for fn; ! 0 -> 1 for AV). The exAV values are generated in a compressed range. zfn_low = fn_low zfn_upp = fn_upp if (fn_low.LT.0.9) zfn_low = 0.9 if (fn_upp.GT.1.1) zfn_upp = 1.1 zAV_low = AV_low zAV_upp = AV_upp if (AV_low.LT.0.0) zAV_low = 0.0 if (AV_upp.GT.1.0) zAV_upp = 1.0 ! 1st chain ChainPar(j_fn,1) = 1.0 do j=1,N_base ChainPar(j,1) = 1.0 / float(N_base) end do ChainPar(j_AV,1) = 0.0 !~FixAV! This trick seems to make it possible to ~ fix AV by setting AV_upp only ! slightly larger than AV_low (say, 0.500 & 0.501 to fix AV at 0.5) in the ! config file. May be useful one day... Cid@Lagoa - 19/Aug/2017 if (AV_low.GT.0) then ChainPar(j_AV,1) = AV_low zAV_low = AV_low zAV_upp = AV_upp end if if (IsCFlawOn.NE.1) then do j=j_exAV,j_fn-1 !OBS: This loop only runs if Nex_AV > 0! ChainPar(j,1) = 0.0 end do else !CFl! This is probably unnecessary... ChainPar(j_exAV,1) = a0_CFl + (a1_CFl - 1.) * ChainPar(j_AV,1) end if ! Other chains (2,3,...N_chains) do i_chain=2,N_chains ChainPar(j_fn,i_chain) = zfn_low + (zfn_upp - zfn_low) $ * ran2(idum) call Generate_PopVector(idum,N_base,xinit_max,x) do j=1,N_base ChainPar(j,i_chain) = x(j) * ChainPar(j_fn,i_chain) end do ChainPar(j_AV,i_chain) = zAV_low + (zAV_upp - zAV_low) $ * ran2(idum) if (IsCFlawOn.NE.1) then * ATT: Here I compress the initial exAV range to 1/3 of its allowed * range to avoid too crazy initial chain values... do j=j_exAV,j_fn-1 !OBS: This loop only runs if Nex_AV > 0! ChainPar(j,i_chain) = (par_low(j) + par_upp(j)) / 2. + $ (par_upp(j) - par_low(j)) * (ran2(idum) - 0.5) * 2./3. end do else !CFl! Again, probably unnecessary... ChainPar(j_exAV,i_chain) = $ a0_CFl + (a1_CFl - 1.) * ChainPar(j_AV,i_chain) end if * Done with this chain. Now initialize next chain end do * Screen check if (i_verbose_anneal.GT.1) then write (*,'(150a)') ('-',j=1,120) write (*,'(45x,a)') '- Initial Chain Parameters -' write (*,'(150a)') ('-',j=1,120) write (*,'(a,200(1x,i6))') 'Chain # | par#',(j,j=1,N_par) do i_chain=1,N_chains write (*,'(a,i2,a,200(1x,f6.2))') 'Ch-Init ',i_chain , $ ' | par=', (100*ChainPar(j,i_chain),j =1,N_base) , $ (ChainPar(jj,i_chain),jj=j_AV,j_fn) end do write (*,'(150a)') ('-',j=1,120) end if c *************************************************************************** c *************************************************************************** c * !!MEX!! Initialize help-arrays & other stuff * c *************************************************************************** c Define arrays which say which component will be given an extra c help to converge and with what probability. Things are done c separately for the pop-vector & extinction parameters. These c arrays are passed by the /Scubi_TechnicalParameters/ common. do j=1,N_par ind_HelpParMove2Average(j) = i_HelpPopVectorMove2Average prob_HelpParMove2Average(j) = prob_HelpPopVectorMove2Average if ((j.GE.j_AV).AND.(j.LT.j_fn)) then ind_HelpParMove2Average(j) = i_HelpAVYAVMove2Average prob_HelpParMove2Average(j) = prob_HelpAVYAVMove2Average end if end do c Define Npar4GRtest = # of parameters used in the GR-convergence c (burn-in) test. The "- 1" is to exclude fn (the last entry in c the par vector) Npar4GRtest = N_par - 1 c Set probability of picking the par_j with largest GR_R (used if c sampling is one-par-per-move), to help it move more & thus c hopefully converge faster... To turn-on this trick you must set c i_HelpParWithMaxR = 1. The value of prob_jRmax requires some c experimentation... Note that prob_jRmax is actually set on the c input file. Here I just adjust it in the case of small N_par... * prob_jRmax = max((5.0 / float(Npar4GRtest)),prob_jRmax) * !!MEX!! Adjusted!! (Cid@Lagoa - 20/April/2007) z1 = max((5.0 / float(Npar4GRtest)),prob_jRmax) if ((z1.LE.0.5).AND.(prob_jRmax.LT.0.5)) prob_jRmax = z1 if (prob_jRmax.GT.0.9) prob_jRmax = 0.5 c *************************************************************************** c *************************************************************************** c * FF: First Fits (w/full base) * c *************************************************************************** c Here we perform the "First Fits" (FF). The goal is to take all c chains to a reasonable region of parameter space, using simulated c annealing plus a Gelman & Rubin burn-in verification criterion. c Set eff_IDEAL & IsGRTestHard (passed by common), N_sim & c Nmax_steps for First-Fits. eff_IDEAL = eff_IDEAL_FF IsGRTestHard = IsGRTestHard_FF N_sim_FF = fN_sim_FF * N_par Nmax_steps_FF = fNmax_steps_FF * N_par ! Screen output if (i_verbose.GT.0) then write (*,'(80a)') ('*',j=1,80) write (*,'(a)') '* STARTING FIRST FITS ...' write (*,'(a,i3)') '* N_loops = ' , N_loops_FF write (*,'(a,i3)') '* N_chains = ' , N_chains write (*,'(a,1p,e8.2,a,e8.2)') '* Temp = ', Temp_ini_FF, $ ' ==> ' , Temp_fin_FF write (*,'(a,1p,e8.2,a,e8.2,0p,a,i2,a)') '* GR-R = ' , $ R_ini_FF ,' ==> ' , R_fin_FF , ' Method = ' , $ IsGRTestHard , ' (0/1=Soft/Hard)' write (*,'(80a)') ('*',j=1,80) end if !Cid29Dec06-FIX! Introduced time-counters (to help in config-tests) i_ini_time_FF = time() w_ini_FF_TotTime = etime(willy_tiempo) w_ini_FF_UsrTime = willy_tiempo(1) w_ini_FF_SysTime = willy_tiempo(2) c Go for First Fits... call MEX_Fit_Scubidu(i_verbose_anneal,idum,N_loops_FF,v0_low $ ,v0_upp,vd_low,vd_upp,x_min,AV_min,exAV_min,v0_min,vd_min $ ,Ntot_FF,eff_FF,Nl_eff,iMassAgeZ_verbose,N_par,ChainPar $ ,N_chains,Temp_ini_FF,Temp_fin_FF,fini_eps_FF,ffin_eps_FF $ ,R_ini_FF,R_fin_FF,N_sim_FF,Nmax_steps_FF,i_RestartChains_FF $ ,Gpar_min,GE_min,Gpar_ave,Cpar_min,CEne_min,IsKinFixed $ ,IsBurInOver_FF) !Cid29Dec06-FIX! Introduced time-counters (to help in config-tests) i_fin_time_FF = time() w_fin_FF_TotTime = etime(willy_tiempo) w_fin_FF_UsrTime = willy_tiempo(1) w_fin_FF_SysTime = willy_tiempo(2) c Update global steps counter Nglobal_steps = Nglobal_steps + Ntot_FF c *************************************************************************** c *************************************************************************** c * Clip-outliers & Re-Fit * c *************************************************************************** c Clip deviant points in the spectrum! Use best model to compute c residuals... call MEX_Update_AV_array(N_base,AV_min,exAV_min,AV_tot) call Kcalc_Fsyn(Nl_obs,x_min,AV_tot,v0_min,vd_min,f_syn) call Clip_Spectrum(clip_method_option,f_syn,sig_clip_threshold $ ,f_mask,NOl_eff,Nl_eff,Ntot_cliped,iCLIPBUG_flag) c If clipping actually cliped something, then run a single re-fit c with the SAME conditions as in the last loop above. Otherwise c no-refitting is done! if (Ntot_cliped.LE.0) then if (i_verbose.GT.0) then write (*,'(a,i5,a,f3.1,a,a,a)') '* CLIP> Clipped ' , $ Ntot_cliped,' points with > ' , sig_clip_threshold $ ,' sigma residuals with method = ' , clip_method_option $ , '. No re-fitting needed!' end if else Temp_ini = Temp_fin_FF Temp_fin = Temp_fin_FF fini_eps = ffin_eps_FF ffin_eps = ffin_eps_FF R_ini = R_fin_FF R_fin = R_fin_FF N_sim = N_sim_FF Nmax_steps = Nmax_steps_FF N_loops = 1 IsGRTestHard = IsGRTestHard_FF !Cid22Jan07-FIX! i_RestartChains was UNDEFINED here! (The ! implication is that chains where not restarted to their best ! values before going to the next stage). i_RestartChains = i_RestartChains_FF ! Screen output if (i_verbose.GT.0) then write (*,'(80a)') ('*',j=1,80) write (*,'(a)') '* STARTING RE-FIT AFTER CLIPPING ...' write (*,'(a,i5,a,f3.1,a,a)') '* Cliped ' , Ntot_cliped $ ,' points with > ' , sig_clip_threshold $ ,' sigma residuals with method = ' , clip_method_option write (*,'(a,i3)') '* N_loops = ' , N_loops write (*,'(a,1p,e8.2,a,e8.2)') '* Temp = ' , Temp_ini , $ ' ==> ' , Temp_fin write (*,'(a,1p,e8.2,a,e8.2,0p,a,i2,a)') '* GR-R = ' , $ R_ini ,' ==> ' , R_fin , ' Method = ' , IsGRTestHard , $ ' (0/1=Soft/Hard)' write (*,'(80a)') ('*',j=1,80) end if !Cid29Dec06-FIX! Introduced time-counters (to help in config-tests) i_ini_time_RF = time() w_ini_RF_TotTime = etime(willy_tiempo) w_ini_RF_UsrTime = willy_tiempo(1) w_ini_RF_SysTime = willy_tiempo(2) c Go for re-fit call MEX_Fit_Scubidu(i_verbose_anneal,idum,N_loops,v0_low $ ,v0_upp,vd_low,vd_upp,x_min,AV_min,exAV_min,v0_min,vd_min $ ,Ntot_ClipReFit,eff_ClipReFit,Nl_eff,iMassAgeZ_verbose $ ,N_par,ChainPar,N_chains,Temp_ini,Temp_fin,fini_eps $ ,ffin_eps,R_ini,R_fin,N_sim,Nmax_steps,i_RestartChains $ ,Gpar_min,GE_min,Gpar_ave,Cpar_min,CEne_min,IsKinFixed $ ,IsBurInOver_ClipReFit) !Cid29Dec06-FIX! Introduced time-counters (to help in config-tests) i_fin_time_RF = time() w_fin_RF_TotTime = etime(willy_tiempo) w_fin_RF_UsrTime = willy_tiempo(1) w_fin_RF_SysTime = willy_tiempo(2) c Update global steps counter Nglobal_steps = Nglobal_steps + Ntot_ClipReFit end if c *************************************************************************** c *************************************************************************** c * Burn-In Re-fit * c *************************************************************************** c Re-fit (clipped) spectrum using the T = 1 & IsGRTestHard = 1 c (meaning that every individual parameter must satisfy the GR-test) c & GR_R-limit <= 1.2. This is to ensure we're over the BURN-IN c phase before proceeding to further sampling or minimization. c (OBS: Actually, the Hard/Soft GR-test and the R-Threshold used here c are define by the config values of IsGRTestHard_BurnIn & c R_BurnIn!) c If T = 1 & IsGRTestHard = 1 in the last loop above, then this c refit is unnecessary. if ((Temp_fin.LE.1.).AND.(IsGRTestHard.EQ.1).AND.(R_fin.LE. $ R_BurnIn)) then IsBurInOver_BurnIn = 1 if (i_verbose.GT.0) then write (*,'(a,a)') '* No T = 1 & Hard-GR-test refit needed.' $ , ' Burn-in is already over!' end if else !Cid11Feb07-FIX! Previsouly (StarlightChains_v02) I did the Burn-In ! at T = 1, seting Temp_ini = Temp_fin = 1.0. Now I do it at T = ! Temp_fin_FF to be more general. All my fits with ! StarlightChains_v02 used Temp_fin_FF = 1, so results should be ! identical. Temp_ini = Temp_fin_FF Temp_fin = Temp_fin_FF fini_eps = ffin_eps_FF ffin_eps = ffin_eps_FF R_ini = R_BurnIn R_fin = R_BurnIn N_sim = N_sim_FF Nmax_steps = Nmax_steps_FF N_loops = 1 IsGRTestHard = IsGRTestHard_BurnIn !Cid22Jan07-FIX! i_RestartChains was UNDEFINED here! (The ! implication is that chains where not restarted to their best ! values before going to the next stage). i_RestartChains = i_RestartChains_FF ! Screen output if (i_verbose.GT.0) then write (*,'(80a)') ('*',j=1,80) write (*,'(a)') '* STARTING FINAL BURN-IN LOOP...' write (*,'(a,i3)') '* N_loops = ' , N_loops write (*,'(a,1p,e8.2,a,e8.2)') '* Temp = ' , Temp_ini , $ ' ==> ' , Temp_fin write (*,'(a,1p,e8.2,a,e8.2,0p,a,i2,a)') '* GR-R = ' , $ R_ini ,' ==> ' , R_fin , ' Method = ' , IsGRTestHard , $ ' (0/1=Soft/Hard)' write (*,'(80a)') ('*',j=1,80) end if !Cid29Dec06-FIX! Introduced time-counters (to help in config-tests) i_ini_time_BI = time() w_ini_BI_TotTime = etime(willy_tiempo) w_ini_BI_UsrTime = willy_tiempo(1) w_ini_BI_SysTime = willy_tiempo(2) c Go for it call MEX_Fit_Scubidu(i_verbose_anneal,idum,N_loops,v0_low $ ,v0_upp,vd_low,vd_upp,x_min,AV_min,exAV_min,v0_min,vd_min $ ,Ntot_BurnIn,eff_BurnIn,Nl_eff,iMassAgeZ_verbose,N_par $ ,ChainPar,N_chains,Temp_ini,Temp_fin,fini_eps,ffin_eps $ ,R_ini,R_fin,N_sim,Nmax_steps,i_RestartChains,Gpar_min $ ,GE_min,Gpar_ave,Cpar_min,CEne_min,IsKinFixed $ ,IsBurInOver_BurnIn) !Cid29Dec06-FIX! Introduced time-counters (to help in config-tests) i_fin_time_BI = time() w_fin_BI_TotTime = etime(willy_tiempo) w_fin_BI_UsrTime = willy_tiempo(1) w_fin_BI_SysTime = willy_tiempo(2) c Update global steps counter Nglobal_steps = Nglobal_steps + Ntot_BurnIn end if c *************************************************************************** c *************************************************************************** c * Sample PDF option (4 Jean but never used...) * c *************************************************************************** c If FitOrSamplePDF_option = 'PDF', we'll sample the Probability c Distribution Function (PDF), otherwise proceed to optimization c with a shortened base. Instead of sampling the PDF of the actual c synthesis parameters we store in arq_out the values of some c "condensed-parameters" (such as mean age, mean Z, etc) for every c step of every chain. if (FitOrSamplePDF_option.EQ.'PDF') then c To sample the PDF it is first necessary to fix all technical c sampling knobs/tricks, such that the proposal distribution does c NOT vary while sampling. In other words, stop helping parameters c move towards convergence, stop adjusting step-size to achieve c desired efficiency, etc. (All MCMC stuff I´ve read says that c changing/adapting the proposal distribution "on-the-fly" is no c good while sampling the PDF.) do j=1,N_par ind_HelpParMove2Average(j) = 0. prob_HelpParMove2Average(j) = 0. end do i_HelpParWithMaxR = 0 prob_jRmax = 0. i_UpdateAVYAVStepSeparately = 0 i_UpdateEps = 0 i_UpdateAlpha = 0 Falpha = 1.0 i_MoveOneParOnly = 1 i_HelpAVYAVMove2Average = 0 prob_HelpAVYAVMove2Average = 0 i_RestartChains = 0 c Now fix, kinematics, T = 1 & step-sizes. IsKinFixed = 1 Temp_ini = 1.0 Temp_fin = 1.0 fini_eps = ffin_eps_FF ffin_eps = ffin_eps_FF N_loops = 1 c To determine the number of samples, we first run Fit_Scubidu until c a Freeze-In condition is fullfilled, and figure out the number of c steps from the length of the Freeze-In period. Here we define the c GR-R criterion for the Freeze-in loop. R_ini = R_BurnIn R_fin = R_BurnIn IsGRTestHard = 1 N_sim = N_sim_FF Nmax_steps = 2.e6 ! Screen output if (i_verbose.GT.0) then write (*,'(80a)') ('*',j=1,80) write (*,'(a)') '* STARTING FREEZE-IN LOOP...' write (*,'(a,1p,e9.3)') '* alpha = ' , alpha write (*,'(a,i9)') '* N_sim = ' , N_sim write (*,'(a,i9)') '* Nmax_steps = ' , Nmax_steps write (*,'(a,1p,e8.2,a,e8.2,0p,a,i2,a)') '* GR-R = ', $ R_ini ,'==> ' , R_fin , ' Method = ' , IsGRTestHard , $ ' (0/1=Soft/Hard)' write (*,'(80a)') ('*',j=1,80) end if c Initial sampling to define Freeze-in length: N_steps_FreezeIn call MEX_Fit_Scubidu(i_verbose_anneal,idum,N_loops,v0_low $ ,v0_upp,vd_low,vd_upp,x_min,AV_min,exAV_min,v0_min,vd_min $ ,Ntot_FreezeIn,eff_FreezeIn,Nl_eff,iMassAgeZ_verbose,N_par $ ,ChainPar,N_chains,Temp_ini,Temp_fin,fini_eps,ffin_eps $ ,R_ini,R_fin,N_sim,Nmax_steps,i_RestartChains,Gpar_min $ ,GE_min,Gpar_ave,Cpar_min,CEne_min,IsKinFixed $ ,IsBurInOver_FreezeIn) N_steps_FreezeIn = float(Ntot_FreezeIn) / float(N_chains) c Now set a ridiculously small value for GR-R, such that we control c the number of steps by Nmax_steps, which is defined as twice c the freeze in length (or 1e5, whichever is smaller). R_ini = 0.1 R_fin = 0.1 Nmax_steps = min((2. * N_steps_FreezeIn),1.e5) !JEAN: Limit/Define limit file-sizes here! !JEAN: You may try 2, 3...10 times the ! Freeze in length! ! Screen output if (i_verbose.GT.0) then write (*,'(80a)') ('*',j=1,80) write (*,'(a)') '* STARTING PDF SAMPLING...' write (*,'(a,i9)') '* N_FreezeIn = ' , N_steps_FreezeIn write (*,'(a,i9)') '* Nmax_steps = ' , Nmax_steps write (*,'(a,a)') '* Steps saved in ' , arq_out write (*,'(80a)') ('*',j=1,80) end if c Open output steps-file (communicated though i_UnitScubi to actual c sampling routine) & Go for it: sample PDF! i_last_non_blank_char = 0 do i=1,99 if ((out_dir(i:i+1).EQ.' ').AND. & (i_last_non_blank_char.EQ.0)) & i_last_non_blank_char = i - 1 end do arq_aux = out_dir(1:i_last_non_blank_char) // arq_out i_UnitScubi = 2 open (unit=i_UnitScubi,file=arq_aux,status='unknown') write (2,'(93(a1))') ('#',j=1,62) write (2,'(a,a)') '## OUTPUT of Starlight version v06r01 ', & ' - SAMPLE-PDF option! ##' write (2,'(93(a1))') ('#',j=1,62) write (2,'(a)') '#' write (2,'(a,a)') '# arq_obs ' , arq_obs write (2,'(a,a)') '# arq_base ' , arq_base write (2,'(a,a)') '# arq_config ' , arq_config write (2,'(a,a)') '# red_law ' , red_law_option write (2,'(a,i8)') '# N_base ' , N_base write (2,'(a,i8)') '# N_par ' , N_par write (2,'(a,i8)') '# N_chains ' , N_chains write (2,'(a,i8)') '# N_sim ' , N_sim write (2,'(a,i8)') '# N_FreezeIn ' , N_steps_FreezeIn write (2,'(a,i8)') '# Nmax_steps ' , Nmax_steps write (2,'(a)') '#' write (2,'(a,a)') '# i_chain chi2 & 100 X par(1)...par(N_par)' call MEX_Fit_Scubidu(i_verbose_anneal,idum,N_loops,v0_low $ ,v0_upp,vd_low,vd_upp,x_min,AV_min,exAV_min,v0_min,vd_min $ ,Ntot_SamplePDF,eff_SamplePDF,Nl_eff,iMassAgeZ_verbose $ ,N_par,ChainPar,N_chains,Temp_ini,Temp_fin,fini_eps $ ,ffin_eps,R_ini,R_fin,N_sim,Nmax_steps,i_RestartChains $ ,Gpar_min,GE_min,Gpar_ave,Cpar_min,CEne_min,IsKinFixed $ ,IsBurInOver_SamplePDF) close (i_UnitScubi) i_UnitScubi = 0 c We'll not optimize the solution, since the goal here was to Sample c the PDF). Hence we're done! return end if c *************************************************************************** c *************************************************************************** c * Condensed-Base Fits * c *************************************************************************** c If FitOrSamplePDF_option is not = 'PDF' we're thrown here, where c we'll try to find an "optimal" solution by (1) condensing the base c to "relevant" elements and (2) annealing down to low T to find a c best-chi2 solution. !Cid24Mar07-FIX! In previous versions, EX0s would run even with ! N_loops_EX0s = 0! This is fixed now. But then I need to reset the ! things below, just in case N_loops_EX0s = 0. NEX0s_base = N_base do j=1,N_par EX0sGpar_min(j) = Gpar_min(j) end do EX0sv0_min = v0_min EX0svd_min = vd_min v0_min_BeforeEX0s = v0_min vd_min_BeforeEX0s = vd_min idt_EX0 = 0 wdt_EX0_TotTime = 0 wdt_EX0_UsrTime = 0 wdt_EX0_SysTime = 0 if (N_loops_EX0s.GE.1) then c Store initial Chain-positions in EX0sChainPar (since I may want to c save the last ChainPar from the Burn-In loop above) do i_chain=1,N_chains do j=1,N_par EX0sChainPar(j,i_chain) = ChainPar(j,i_chain) end do end do c --------------------------------------------------------------------------- c Define "x_Test". This is the pop-vector which will be used to c decide who stays in the condensed base and who is eliminated! If c EXOs_PopVector_option = 'AVE' we'll use x_Test = global average c pop-vector, which is a CONSERVATIVE strategy, since it has less c x_j = 0 components than any best-solution pop vector. For c EXOs_PopVector_option = 'MIN' we'll use x_Test = global best x so c far, which may be a better thing to do if we wanna refine this c minimum (This option should also produce shorter bases). *FIR* (OBS: Done while implementing FIRc-stuff, but independent from it!) * Input flag (read from arq_config) iEXOs_IsAve_x_of_lambda decides * whether the "x_Test" above (which is either the AVE or the MIN * pop-vector) is maintained at l_norm (iEXOs_IsAve_x_of_lambda = 0) * or averaged over all lambdas (iEXOs_IsAve_x_of_lambda) before * calling the EXO-routine. Notice that x is just used to decide who * is relevant or not. Using iEXOs_IsAve_x_of_lambda = 0 you will * base this decision on the l_norm pop-fractions, whereas with * iEXOs_IsAve_x_of_lambda = 1 all lambdas in the fit (weigthing by * weight_obs(lambda)) will be considered. The latter option sounds * better, **specially for MEx-fits** (where one component can contribute * little at l_norm but much more in other lambdas). * * Cid@Granada - 31/Jan/2010 * *FIX* There were 2 BUGs here: (1) The iEXOs_IsAve_x_of_lambda used x_min, even if * EXOs_PopVector_option = 'AVE'. (2) The AV_tot array needed in AverageXoverLambda * was NOT defined! I have now fixed both bugs and reorganized this part more compactly. * * ElCid@Sanchica - 17/Oct/2011 if (EXOs_PopVector_option.EQ.'AVE') then call MEX_Unpack_par2xAVYAVfn(N_par,N_base,Gpar_ave, & x,AV,exAV,fn) else if (EXOs_PopVector_option.EQ.'MIN') then call MEX_Unpack_par2xAVYAVfn(N_par,N_base,Gpar_min, & x,AV,exAV,fn) end if call MEX_Update_AV_array(N_base,AV,exAV,AV_tot) if (iEXOs_IsAve_x_of_lambda.EQ.1) then call AverageXoverLambda(x,AV_tot,aux3) do j=1,N_base x(j) = aux3(j) end do end if c --------------------------------------------------------------------------- c Set eff_IDEAL & IsGRTestHard (passed by common), N_sim & c Nmax_steps for EX0s-Fits eff_IDEAL = eff_IDEAL_EX0s IsGRTestHard = IsGRTestHard_EX0s N_sim_EX0s = fN_sim_EX0s * N_par Nmax_steps_EX0s = fNmax_steps_EX0s * N_par ! Screen output if (i_verbose.GT.0) then write (*,'(80a)') ('*',j=1,80) write (*,'(a)') '* STARTING EX0s FITS ...' write (*,'(a,a)') $ '* EX0_method = ', EXOs_method_option if (iEXOs_IsAve_x_of_lambda.EQ.1) then write (*,'(a)') & '* x-vector for EX0s will be !' else if (iEXOs_IsAve_x_of_lambda.EQ.0) then write (*,'(a,a,f10.2)') & '* x-vector for EX0s will be ,' , & ' with l_norm = ',l_norm end if write (*,'(a,f7.3)') $ '* EX0s_Threshold = ' , EX0s_Threshold write (*,'(a,a)') $ '* EXOs_PopVector = ' , EXOs_PopVector_option write (*,'(a,i3)') '* N_loops = ' , N_loops_EX0s write (*,'(a,1p,e8.2,a,e8.2)') '* Temp = ' , $ Temp_ini_EX0s , ' ==> ' , Temp_fin_EX0s write (*,'(a,1p,e8.2,a,e8.2,0p,a,i2,a)') '* GR-R = ' , $ R_ini_EX0s ,' ==> ' , R_fin_EX0s , ' Method = ' , $ IsGRTestHard , ' (0/1=Soft/Hard)' write (*,'(80a)') ('*',j=1,80) end if !Cid18Feb07-FIX! Define minimum acceptable base-size! N_base_min = nint(fEX0_MinBaseSize * N_base) if (N_base_min.LT.3) N_base_min = 3 !Cid29Dec06-FIX! Introduced time-counters (to help in config-tests) i_ini_time_EX0 = time() w_ini_EX0_TotTime = etime(willy_tiempo) w_ini_EX0_UsrTime = willy_tiempo(1) w_ini_EX0_SysTime = willy_tiempo(2) c Go for it! call MEX_EX0s_Fit_Scubi(i_verbose_anneal,idum,N_loops_EX0s $ ,v0_low,v0_upp,vd_low,vd_upp,x_min,AV_min,exAV_min $ ,EX0sv0_min,EX0svd_min,Ntot_EX0s,eff_NEX0s,Nl_eff $ ,iMassAgeZ_verbose,N_par,EX0sChainPar,N_chains $ ,Temp_ini_EX0s,Temp_fin_EX0s,fini_eps_EX0s,ffin_eps_EX0s $ ,R_ini_EX0s,R_fin_EX0s,N_sim_EX0s,Nmax_steps_EX0s $ ,i_RestartChains_EX0s,EX0sGpar_min,EX0sGE_min $ ,EX0sGpar_ave,EX0sCpar_min,EX0sCEne_min,x $ ,EXOs_method_option,EX0s_Threshold,N_base_min,IsKinFixed $ ,IsBurInOver_EX0s,NEX0s_base,IsScaleNstepsInEX0sFits $ ,IsNoKin4LargeBaseInEX0sFits $ ,frac_NoKin4LargeBaseInEX0sFits) !Cid24Mar07-FIX! Store EX0s_v0 & vd on v0_min & vd_min. v0_min = EX0sv0_min vd_min = EX0svd_min !Cid29Dec06-FIX! Introduced time-counters (to help in config-tests) i_fin_time_EX0 = time() w_fin_EX0_TotTime = etime(willy_tiempo) w_fin_EX0_UsrTime = willy_tiempo(1) w_fin_EX0_SysTime = willy_tiempo(2) c Update global steps counter Nglobal_steps = Nglobal_steps + Ntot_EX0s end if c *************************************************************************** c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + DONE WITH SPECTRAL FITTING:) + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + FITS WITH JUST ONE COMPONENT + c + + c + ~Quick fits with individual f_base spectra to see which individual + c + base component would best fit the observed spectrum! + c + (These fits do NOT interfere with the composite fits done above!) + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c *************************************************************************** c * Single-Component-fits - Cid@Lagoa - 20/Jan/2007 * c *************************************************************************** c Just for the "fun" of it, before closing STARLIGHT will now fit c f_obs with each of the N_base individual SSPs in the base. With c just one component, there are only 2 parameters: AV and the c normalizatior factor. The best fit values are saved as SSP_AV() c and x_SSP() arrays, along with the corresponding SSP_chi2() and c SSP_adev() arrays. Minimization in SSP_AV is done with a Golden c Search, using FUNCTION F_SSP_chi2_AV(AV_SSP), and SSP_x is fitted c analytically inside that function. c The kinematical parameters used are the best ones at this stage, c and not changed from SSP to SSP fit. This exercise may prove c useful for, say, elliptical galaxies, to find the best c single-population fit. (Indeed, this option was inspired during c Ignacio de la Rosa's visit to Florianopolis on Jan/2007.) c Also useful to fit star-clusters, in which case it's a good idea c to chose an FXK fit and config parameters which minimize the time c spent on the fit-pop-mixtures part of the code (like N_loops_FF = c 1 at high temperature, R-limits, no clipping , etc...), such that c the code gets to this point ASAP. c Cid@Lagoa - 20/Jan/2007 *ETC* ATT: These SSP-fits do NOT include FIR/QHR/PHO info, but that's Ok! do j=1,N_base c Apply kinematical filter to the j'th SSP, unless this is a FXK fit c (in which case f_base is already smoothed & shifted). The c resulting spectrum is stored in f_SSP(). if (FitOrSamplePDF_option.EQ.'FXK') then do i=1,Nl_obs f_SSP(i) = f_base(j,i) end do else Nl_aux = Nl_obs do i=1,Nl_obs l_aux(i) = l_obs(i) f_aux1(i) = f_base(j,i) end do call GaussSmooth(Nl_aux,l_aux,f_aux1,v0_min,vd_min, & N_int_Gauss,Nl_obs,l_obs,f_SSP) end if c Golden Search for best SSP_AV (best norm. factor x_SSP computed c analytically in F_SSP_chi2_AV and returned via common). Notice c tolerance = 1/1000, more than enough for this purpose! ax = AV_low bx = AV_upp tol = 1.e-3 call mnbrak(ax,bx,cx,fa,fb,fc,F_SSP_chi2_AV) !v05! ATT! "cfx" BUG-DETECTED BY CID&ROSA@Lagoa - 10/May/2008!! !was this: chi2_AV_Gold = golden(ax,bx,cxf,F_SSP_chi2_AV,tol,AV_Gold) chi2_AV_Gold = golden(ax,bx,cx,F_SSP_chi2_AV,tol,AV_Gold) c Do not allow SSP_AV outside the AV_low --> AV_upp limits. if (AV_Gold.LT.AV_low) AV_Gold = AV_low if (AV_Gold.GT.AV_upp) AV_Gold = AV_upp SSP_chi2(j) = F_SSP_chi2_AV(AV_Gold) SSP_x(j) = x_SSP SSP_AV(j) = AV_Gold do i=1,Nl_obs f_SSP(i) = 10.**(AV_Gold * red_term(i)) * x_SSP * f_SSP(i) end do SSP_adev(j) = F_adev(f_SSP) !v05! Storing best-fit SSP spectrum if (j.EQ.1) Best_SSP_chi2 = SSP_chi2(j) if (SSP_chi2(j).LE.Best_SSP_chi2) then Best_SSP_chi2 = SSP_chi2(j) index_Best_SSP = j do i=1,Nl_obs Best_f_SSP(i) = f_SSP(i) end do end if end do c *************************************************************************** c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + POST-PROCESSING & OUTPUT + c + + c + Now that we have the final model, do a few final post-processing + c + (like converting flux to mass fractions) & produce output file arq_out. + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c *************************************************************************** c * OUTPUT * c *************************************************************************** !Cid29Dec06-FIX! Introduced time-counters (to help in config-tests) i_fin_time = time() idt_all = i_fin_time - i_ini_time idt_FF = i_fin_time_FF - i_ini_time_FF idt_RF = i_fin_time_RF - i_ini_time_RF idt_BI = i_fin_time_BI - i_ini_time_BI idt_EX0 = i_fin_time_EX0 - i_ini_time_EX0 w_fin_TotTime = etime(willy_tiempo) w_fin_UsrTime = willy_tiempo(1) w_fin_SysTime = willy_tiempo(2) wdt_TotTime = w_fin_TotTime - w_ini_TotTime wdt_UsrTime = w_fin_UsrTime - w_ini_UsrTime wdt_SysTime = w_fin_SysTime - w_ini_SysTime wdt_FF_TotTime = w_fin_FF_TotTime - w_ini_FF_TotTime wdt_FF_UsrTime = w_fin_FF_UsrTime - w_ini_FF_UsrTime wdt_FF_SysTime = w_fin_FF_SysTime - w_ini_FF_SysTime wdt_RF_TotTime = w_fin_RF_TotTime - w_ini_RF_TotTime wdt_RF_UsrTime = w_fin_RF_UsrTime - w_ini_RF_UsrTime wdt_RF_SysTime = w_fin_RF_SysTime - w_ini_RF_SysTime wdt_BI_TotTime = w_fin_BI_TotTime - w_ini_BI_TotTime wdt_BI_UsrTime = w_fin_BI_UsrTime - w_ini_BI_UsrTime wdt_BI_SysTime = w_fin_BI_SysTime - w_ini_BI_SysTime wdt_EX0_TotTime = w_fin_EX0_TotTime - w_ini_EX0_TotTime wdt_EX0_UsrTime = w_fin_EX0_UsrTime - w_ini_EX0_UsrTime wdt_EX0_SysTime = w_fin_EX0_SysTime - w_ini_EX0_SysTime *ETC* Now that the fit is over, I can inform the actual flux units used * and convert distance dependent quantities (like Mcor_tot masses) * to absolute ones using the input entries flux_unit and * LumDistInMpc. fobs_norm = fobs_norm * flux_unit !ESM! Update best model... The call to FK_chi2 below updates chi2_OPTICAL ! & chi2_FIR/PHO/QHR & k_FIR/PHO/QHR factors!! call MEX_Update_AV_array(N_base,AV_min,exAV_min,AV_tot) call Kcalc_Fsyn(Nl_obs,x_min,AV_tot,v0_min,vd_min,f_syn) chi2_tot = FK_chi2(x_min,AV_tot,v0_min,vd_min) chi2_min = chi2_tot / float(Nl_eff) adev = F_adev(f_syn) sum_x = 100. * Sum_of_x(x_min,N_base) call ConvertLight2Mass(N_base,x_min,AV_tot,q_norm,Lobs_norm $ ,fbase_norm,Mstars,Lum_tot,Mini_tot,Mcor_tot,mu_ini,mu_cor) !Cid29Mar07-FIX! Now write arq_out to out_dir, so figure what is the first ! blank char in out_dir & concatenate it: arq_out --> arq_aux i_last_non_blank_char = 0 do i=1,99 if ((out_dir(i:i+1).EQ.' ').AND.(i_last_non_blank_char.EQ.0)) & i_last_non_blank_char = i - 1 end do arq_aux = out_dir(1:i_last_non_blank_char) // arq_out c Open output file & write header open (unit=2,file=arq_aux,status='unknown') write (2,190) 190 format(69('#')) write (2,'(a,3x,a)') & '## OUTPUT of Starlight version v06r01 ', & ' [Cid@UFSC - 18/Aug/2017] ##' write (2,190) * ..... output input, resampling, normalization, S/N & Miscelaneous info .... write (2,*) write (2,'(a)') '## Some input info' i_last_non_blank_char = 0 do i=1,99 if ((obs_dir(i:i+1).EQ.' ').AND.(i_last_non_blank_char.EQ.0)) & i_last_non_blank_char = i - 1 end do write (2,'(a40,a,a)') arq_obs , ' [arq_obs] from ' , & obs_dir(1:i_last_non_blank_char) write (2,'(a40,a)') arq_base , ' [arq_base]' write (2,'(a40,a)') arq_masks , ' [arq_masks]' write (2,'(a40,a)') arq_config , ' [arq_config]' write (2,'(i4,36x,a)') N_base , ' [N_base]' !CFl! Re-organized IsFIR/QHR/PHO & IsOptimize_fn_OPT flags, and ! added CFl-fit info to output! write (2,'(2(i4,3x),2x,i2,2(1x,f8.3),4x,a)') & N_exAV_components , N_exAV , IsCFlawOn , a0_CFl , a1_CFl , & ' [N_exAV_components N_exAV ; IsCFlawOn a0_CFl a1_CFl]' write (2,'(2x,3(i2,5x),7x,i2,8x,a)') $ IsFIRcOn , IsQHRcOn , IsPHOcOn , IsOptimize_fn_OPT , $ ' [IsFIRcOn IsQHRcOn IsPHOcOn ; IsOptimize_fn_OPT] ' write (2,'(a3,2x,f4.1,8x,3(3x,i2),8x,a)') & ETC_ESM , ETC_gamma , Np_PHO , Np_QHR , Np_FIR , & ' [ETC_ESM ETC_gamma ; Np_PHO Np_QHR Np_FIR]' write (2,'(a3,37x,a)') red_law_option , ' [red_law_option]' write (2,'(f9.6,5x,1p,e12.6,0p,14x,a)') q_norm , flux_unit , & ' [q_norm = A(l_norm)/A(V) & flux_unit]' write (2,*) write (2,'(a)') '## (Re)Sampling Parameters' write (2,'(f8.2,32x,a)') Olsyn_ini , ' [l_ini (A)]' write (2,'(f8.2,32x,a)') Olsyn_fin , ' [l_fin (A)]' write (2,'(f8.2,2x,f8.2,22x,a)') Odl_syn , dl_cushion , $ ' [dl & dl_cushion (A)]' write (2,*) write (2,'(a)') '## Normalization info' write (2,'(f8.2,32x,a)') l_norm ,' [l_norm (A) - for base]' write (2,'(f8.2,32x,a)') llow_norm , & ' [llow_norm (A) - window for f_obs]' write (2,'(f8.2,32x,a)') lupp_norm , & ' [lupp_norm (A) - window for f_obs]' write (2,'(1p,2(e12.6,2x),0p,f8.3,4x,a)') & fobs_norm , Lobs_norm , LumDistInMpc , & ' [fobs_norm & Lobs_norm & LumDistInMpc]' write (2,*) write (2,'(a)') '## S/N' write (2,'(f8.2,32x,a)') llow_SN,' [llow_SN (A) - window for S/N]' write (2,'(f8.2,32x,a)') lupp_SN,' [lupp_SN (A) - window for S/N]' write (2,'(f8.3,32x,a)') SN_snwin ,' [S/N in S/N window]' write (2,'(f8.3,32x,a)') SN_normwin ,' [S/N in norm. window]' write (2,'(f8.3,32x,a)')SNerr_snwin ,' [S/N_err in S/N window]' write (2,'(f8.3,32x,a)')SNerr_normwin,' [S/N_err in norm. window]' write (2,*) write (2,'(a)') '## Miscelaneous' write (2,'(i12,28x,a)') idum_orig , ' [idum_orig]' write (2,'(i6,34x,a)') NOl_eff , ' [NOl_eff]' write (2,'(i6,34x,a)') Nl_eff , ' [Nl_eff]' !SNmax! Added SNmax_threshold to output write (2,'(i6,4x,a6,6x,f7.2,3x,9x,a)') $ Ntot_cliped , clip_method_option , SNmax_threshold , $ '[Ntot_clipped & clip_method ; SNmax_threshold]' write (2,'(i9,31x,a)') Nglobal_steps , ' [Nglobal_steps]' write (2,'(i4,36x,a)') N_chains , ' [N_chains]' write (2,'(i4,36x,a)') NEX0s_base , $ ' [NEX0s_base = N_base in EX0s-fits]' !Cid24Mar07-FIX! Added censored weights info here write (2,'(3(i2,2x),2x,i5,2x,f4.1,2x,1p,e12.5,1x,a,a)') $ iCLIPBUG_flag ,i_RC_CRASH_FLAG, IsBurInOver_BurnIn , $ n_censored_weights , wei_nsig_threshold , wei_limit , $ ' [Clip-Bug, RC-Crash & Burn-In warning-flags,' , $ ' n_censored_weights, wei_nsig_threshold & wei_limit]' !Cid29Dec06-FIX! Write time-counters info! write (2,'(i7,3(1x,f10.3),a)') $ idt_all , wdt_TotTime , wdt_UsrTime , wdt_SysTime , $ ' [idt_all, wdt_TotTime, wdt_UsrTime & wdt_SysTime (sec)]' * ........................................................................... * ............. output chi2, adev, v0, vd, masses, AV & exAV's............... c Synthesis results - Global Minimum! write (2,*) write (2,*) write (2,'(a)') '## Synthesis Results - Best model ##' write (2,*) *ETC* Added total chi2 to output write (2,'(1p,e12.5,5x,e12.5,38x,a)') chi2_min , & chi2_tot , ' [chi2/Nl_eff & chi2 (total)]' write (2,'(f12.5,55x,a)') adev , ' [adevS (%) (wrt f_syn)]' write (2,'(f12.5,55x,a)') sum_x , ' [sum-of-x (%)]' *ETC* OBS: If the base spectra are in Lsun/Angs/Msun and proper flux * units were given for the observed spectrum, this Lum_tot should be * in Lsun/Angs and the Mcor_tot and Mini_tot masses should be in Msun... write (2,'(1p,e12.5,55x,a)') Lum_tot , & ' [Lum_tot (Lsun/A if distance & flux_unit are Ok...)]' write (2,'(1p,e12.5,55x,a)') Mini_tot , & ' [Mini_tot (Msun if distance & flux_unit are Ok...)]' write (2,'(1p,e12.5,55x,a)') Mcor_tot , & ' [Mcor_tot (Msun if distance & flux_unit are Ok...)]' write (2,*) *ETC* Added warnings to signal when vd/v0 are = initial values... if ((abs(v0_min-v0_ini).LT.0.01).AND. $ (FitOrSamplePDF_option.NE.'FXK')) then write (2,'(f7.2,34x,a,f7.2,a)') v0_min , $ '[v0_min (km/s)] ... suspiciously close to v0_ini=' , $ v0_ini , ' ... ?!' else write (2,'(f7.2,61x,a)') v0_min ,'[v0_min (km/s)]' end if if ((abs(vd_min-vd_ini).LT.0.01).AND. $ (FitOrSamplePDF_option.NE.'FXK')) then write (2,'(f7.2,34x,a,f7.2,a)') vd_min , $ '[vd_min (km/s)] ... suspiciously close to vd_ini=' , $ vd_ini , ' ... ?!' else write (2,'(f7.2,61x,a)') vd_min ,'[vd_min (km/s)]' end if write (2,'(f7.4,61x,a)') AV_min ,'[AV_min (mag)]' !18/Aug/2017! Added this x% in all exAV elements just for Q&D visual checks xALL_exAV = 0. do j=1,N_base if (ind_exAV(j).NE.0) xALL_exAV = xALL_exAV + x_min(j) end do write (2,'(9(1x,f6.3),5x,a,i1,a,f6.2,a)') (exAV_min(j),j=1,9), $ '[exAV_min (mag)] 1...9 of N_exAV = ', N_exAV , $ ' | x(exAV>0) =' , 100.*xALL_exAV , '%' write (2,*) * ........................................................................... * ............... ETC-related info: ScaleFactors and chi2's ................. !ESM! Major changes to output format! ETC-shit now saved here. Cid@Lagoa-18/Aug/2017 !ESM! ATT: chi2_min & chi2_tot are on the "scaled" units used within the code, ! while chi2_OPTICAL, _FIR, _QHR, &_PHO are pure/mathematical chi2's! write (2,'(1p,4(e12.5,1x),16x,a)') $ FIR_GlobalChi2ScaleFactor , QHR_GlobalChi2ScaleFactor , $ PHO_GlobalChi2ScaleFactor , ETC_GlobalChi2ScaleFactor , $ '[*ETC> FIR_ QHR_ PHO_ & ETC_ GlobalChi2ScaleFactors]' write (2,'(1p,3(e12.5,1x),29x,a)') $ k_FIR , k_QHR , k_PHO , $ '[*ETC> k_FIR k_QHR k_PHO factors]' write (2,'(1p,3(e12.5,1x),29x,a)') $ k_FIR * chi2_FIR / chi2_OPTICAL , $ k_QHR * chi2_QHR / chi2_OPTICAL , $ k_PHO * chi2_PHO / chi2_OPTICAL , $ '[*ETC> FIR QHR PHO weights wrt to OPT: k_* chi2_* / chi2_OPT]' write (2,'(1p,4(e12.5,1x),16x,a)') $ chi2_FIR , chi2_QHR , chi2_PHO , chi2_OPTICAL , $ '[*ETC> chi2_FIR chi2_QHR chi2_PHO chi2_OPT]' write (2,*) * ........................................................................... * ................... output population & AV vectors & etc .................. !Cid20Jan07-FIX! included an alpha/Fe array in pop-vector table, as well as ! new single component fits SSP_* arrays! *ETC* Added yet another column (after AV_tot) to report LAx_min(j) = the * best pop-vector (x_min) averaged over all lambdas in the fit * (weighting by weight_obs), ie, _j. This is just an ouput thing! * Cid@Granada - 31/Jan/2010 .... call AverageXoverLambda(x_min,AV_tot,LAx_min) write (2,191) 191 format ('# j x_j(%) Mini_j(%) Mcor_j(%)' , & ' age_j(yr) Z_j (L/M)_j exAV? Mstars', & ' component_j a/Fe...', & ' | SSP_chi2r SSP_adev(%) SSP_AV SSP_x(%)', & ' | AV_tot _j(%)') do j=1,N_base write (2,192) j , (100.*x_min(j)) , & (100.*mu_ini(j)) , (100.*mu_cor(j)) , & age_base(j) , Z_base(j) , fbase_norm(j) , & ind_exAV(j) , Mstars(j) , base_name(j) , alphaFe_base(j) , & SSP_chi2(j) / float(Nl_eff) , SSP_adev(j) , & SSP_AV(j) , 100. * SSP_x(j) , & AV_tot(j) , 100. * LAx_min(j) end do 192 format (i3,2x,f10.4,3x, & 1p,e12.4,2x,e12.4,4x, & e12.6,1x,0p,f8.5,2x,1p,e9.3,3x, & 0p,i2,3x,f6.4,3x,a15,4x,f9.4,4x, & 1p,e11.4,0p,3x,f8.4,2x, & f7.4,2x,f9.3,6x, & f7.4,2x,f10.4) ! Screen output Best model results if (i_verbose.GT.0) then write (*,*) write (*,'(a,a)') '**> RESULTS for ' , arq_out write (*,812) N_base 812 format (' N_tot chi2/Nl_eff adev | v0 vd | ', & 'sum A_V | x_j... [%], j = 1 ...',i3) write (*,813) Nglobal_steps , chi2_min , adev , & v0_min , vd_min , sum_x , AV_min , & (100.*x_min(j),j=1,min(10,N_base)) 813 format (i8,1x,1p,e10.4,0p,2x,f7.4,' | ' , & f6.1,1x,f5.1,' | ',f7.3,1x,f5.2,' | ',10(1x,f6.2)) do j_out=2,int(N_base/10)+1 j1 = (j_out - 1) * 10 + 1 j2 = min(j1+9,N_base) write (*,'(62x,10(1x,f6.2))') (100.*x_min(j),j=j1,j2) end do if (N_exAV.GT.0) then write (*,'(62x,a)') ' AV_j... [mag]' do j_out=1,int(N_base/10)+1 j1 = (j_out - 1) * 10 + 1 j2 = min(j1+9,N_base) write (*,'(62x,10(1x,f6.2))') (AV_tot(j),j=j1,j2) end do end if write (*,'(70x,a,1p,e12.4,a,0p,i6,a)') 'Total chi2 = ' , $ chi2_min*Nl_eff , ' for Nl_eff =' , Nl_eff ,' lambdas!' write (*,*) end if * ........................................................................... * ............................ output chains ................................ c Now output results for best (repeated), average & last-chain c parameters after Burn-In loop! (This should give us an idea of the c errors, and in any case it'd be a waste to throw all these numbers away!) write (2,*) write (2,*) write (2,'(a)') '## Synthesis Results - Average & Chains ##' write (2,*) c Store chi2 for each chain in f_aux3(), chain-mass fractions in the c EX0sChainPar(,) array (not used anymore), & chain-masses in aux2(), c LAx vectors in LAx_chain(,). Also, compute, store & save results for c the average solution in chi2_ave, Mcor_tot_ave LAx_ave(). ! ATT: The best fit AV_tot array is replaced with chain-solutions below, ! and so needs to be restored further down the output!! Same ! to ETC-related chi2's, screwed up in the calls to FK_chi2 below. c Untidy, but working! (Reviewed by Cid@Lagoa-19/Aug/2017) do i_chain=1,N_chains do j=1,N_par f_aux1(j) = ChainPar(j,i_chain) end do call MEX_Unpack_par2xAVYAVfn(N_par,N_base,f_aux1,x,AV,exAV,fn) call MEX_Update_AV_array(N_base,AV,exAV,AV_tot) chi2_red = FK_chi2(x,AV_tot,v0_min,vd_min) / float(Nl_eff) f_aux3(i_chain) = chi2_red *ETC* Changed fobs_norm -> Lobs_norm & Flux_tot->Lum_tot call ConvertLight2Mass(N_base,x,AV_tot,q_norm,Lobs_norm $ ,fbase_norm,Mstars,Lum_tot,chain_Mini_tot $ ,chain_Mcor_tot,mu_ini,aux1) do j=1,N_base EX0sChainPar(j,i_chain) = aux1(j) end do aux2(i_chain) = chain_Mcor_tot call AverageXoverLambda(x,AV_tot,aux3) do j=1,N_base LAx_chain(j,i_chain) = aux3(j) end do end do c Now compute things for average solution call MEX_Unpack_par2xAVYAVfn(N_par,N_base,Gpar_ave,x,AV,exAV,fn) call MEX_Update_AV_array(N_base,AV,exAV,AV_tot) chi2_ave = FK_chi2(x,AV_tot,v0_min,vd_min) / float(Nl_eff) *ETC* Changed fobs_norm -> Lobs_norm & Flux_tot->Lum_tot. call ConvertLight2Mass(N_base,x,AV_tot,q_norm,Lobs_norm $ ,fbase_norm,Mstars,Lum_tot,Mini_tot_ave $ ,Mcor_tot_ave,mu_ini,aux3) call AverageXoverLambda(x,AV_tot,LAx_ave) c Print out x, mu, AV, chi2 & Masses for ave & chain-solutions ieAVl = N_base + 2 ieAVu = N_par - 1 if (N_exAV.LE.0.) then ieAVl = -0 ieAVu = -0 endif write (2,'(a,i3,a,5(a,i3))') $ '# j par_j: min, ave & last-chain-values for 1 ...' $ , N_chains , ' chains.' $ ,' x: 1 -> ',N_base, ' ; AV: ',N_base+1 $ ,' ; exAV (if any): ',ieAVl,' -> ',ieAVu,' ; fn:',N_par do j=1,N_par aux = 100. if ((j.GT.N_base).AND.(j.NE.N_par)) aux = 1. write (2,'(i3,40(2x,f10.4))') j , aux*EX0sGpar_min(j) , $ aux*Gpar_ave(j) , ((aux*ChainPar(j,i_chain)),i_chain=1 $ ,N_chains) end do *ETC* Print out the LAx* Lambda-Averaged pop vector: min (repeated from above), * average and chain-results. write (2,*) write (2,'(a,a,i3,a)') $ '# j Lambda-Averaged pop-vectors _j: ', $ 'min, ave & last-chain-values for 1 ...',N_chains,' chains' do j=1,N_base write (2,'(i3,40(2x,f10.4))') j , 100.*LAx_min(j) , $ 100.*LAx_ave(j) , ((100.*LAx_chain(j,i_chain)),i_chain=1 $ ,N_chains) end do * Now print mass-fraction vectors for the min, ave & chain-solutions. write (2,*) write (2,'(a,i3,a)') $ '# j Mcor_j: min, ave & last-chain-values for 1 ...' $ ,N_chains , ' chains' do j=1,N_base write (2,'(i3,1p,40(2x,e10.4))') j , 100.*mu_cor(j) , 100. $ *aux3(j), ((100.*EX0sChainPar(j,i_chain)),i_chain=1 $ ,N_chains) end do * Finally, print chi2 & masses for min, ave & chain-solutions. write (2,*) write (2,'(a,a,i3,a)') '# chi2/Nl_eff & Mass for min, <> & ' , $ 'i_chain = 1 ...', N_chains , ' solutions' write (2,'(a5,1p,40(e10.4,2x))') 'chi2 ', chi2_min , chi2_ave , $ (f_aux3(i_chain),i_chain=1,N_chains) write (2,'(a5,1p,40(e10.4,2x))') 'Mass ' , Mcor_tot , $ Mcor_tot_ave ,(aux2(i_chain),i_chain=1,N_chains) write (2,'(f7.2,34x,a)') v0_min_BeforeEX0s , $ '[v0_min (km/s) before EX0s...]' write (2,'(f7.2,34x,a)') vd_min_BeforeEX0s , $ '[vd_min (km/s) before EX0s...]' write (2,*) * ........................................................................... * ............ output spectra: obs syn wei & Best_f_SSP spectra ............ c Observed, Synthetic & Weight Spectra: Save f_obs, f_syn & weight_obs. c Save only points inside originally input range: c Olsyn_ini ==> Olsyn_fin! Points which have been clipped (those with c f_mask < 0) are saved with -1 in the weight_obs column just for control. Nl_obs_save = 0 do i=1,Nl_obs if ((l_obs(i).GE.Olsyn_ini).AND.(l_obs(i).LE.Olsyn_fin)) $ Nl_obs_save = Nl_obs_save + 1 end do !v05! Saving Best_f_SSP() too (if wanted) write (2,*) write (2,*) if (i_SaveBestSingleCompFit.EQ.0) then write (2,'(a,a)') '## Synthetic spectrum (Best Model) ##', & 'l_obs f_obs f_syn wei' else write (2,'(a,a)') '## Synthetic spectrum (Best Model) ##', & 'l_obs f_obs f_syn wei Best_f_SSP' end if ! Added i_SaveBestSingleCompFit in this line to help reading macros.... ! ElCid@Sanchica - 29/Jan/2012 write (2,'(i5,4x,i5,4x,i5,4x,a)') $ Nl_obs_save , index_Best_SSP , i_SaveBestSingleCompFit , $ '[Nl_obs & index_Best_SSP & i_SaveBestSingleCompFit]' do i=1,Nl_obs if ((l_obs(i).GE.Olsyn_ini).AND.(l_obs(i).LE.Olsyn_fin)) then aux = weight_obs(i) if (f_mask(i).LT.0.) aux = f_mask(i) if (i_SaveBestSingleCompFit.EQ.0) then write (2,'(f8.2,1p,3(1x,e12.5))') & l_obs(i) , f_obs(i) , f_syn(i) , aux else write (2,'(f8.2,1p,4(1x,e12.5))') & l_obs(i) , f_obs(i) , f_syn(i) , aux , Best_f_SSP(i) end if end if end do * ........................................................................... c Standard output ends here. ETC-related output follows below. c *************************************************************************** * *************************************************************************** * Preparations for ETC [= FIR & QHR & PHO] output * * *************************************************************************** *ETC* I have overwritten the best-fit AV_tot above (while saving * chains-results), so lets first restore it in case there is FIR * and/or QHR output to be saved below. call MEX_Update_AV_array(N_base,AV_min,exAV_min,AV_tot) * Every time any chi2 function [like FK_chi2, ...] is called, the * FIR_, QHR_ & PHO_Calc*Chi2 functions are also called upp, and new * values are computed for things like FIR_ModlogLFIR and * QHR_chi2_Y(). In the savings above I have called up FK_chi2 with * Chain & Average parameters, and this screwed up these ETC * output quantities! This is why I recompute them below. Also, I use * the 'OUT' string to compute some final stuff for output. lix = ETC_CalcETCchi2(x_min,AV_tot,'OUT') * *************************************************************************** c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR FIR-RELATED OUTPUT . FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR *FIR* Produce/re-compute/compile FIR-related things for output * The if just below skips FIRc-output for non-FIRc fits (IsFIRcOn = * 0). Note that for IsFIRcOn = -1 the predicted FIR luminosity is * given, even if no FIR-data was provided! if ((iFIR_IsFIRcOn.EQ.1).OR.(iFIR_IsFIRcOn.EQ.-1)) then write (2,*) write (2,*) write (2,*) write (2,'(35(a))') ('#',j=1,35) if (IsFIRcOn.EQ.-1) then write (2,'(a,a)') '## FIRc-FIT RELATED OUTPUT ##' , & ' (Predicted things only!) ' else write (2,'(a)') '## FIRc-FIT RELATED OUTPUT ##' end if write (2,'(35(a))') ('#',j=1,35) write (2,*) write (2,'(a)') '## FIR: Input info' write (2,'(a40,a)') arq_ETCinfo , ' [arq_ETCinfo]' * OBS: Redundant LumDistInMpc included here just for backwards compatibility... write (2,'(f9.4,31x,a)') LumDistInMpc , & ' [LumDist (Mpc)]' write (2,'(f9.4,31x,a)') FIR_logLFIR_TOT , & ' [FIR_logLFIR_TOT (Lsun)]' write (2,'(f9.4,31x,a)') FIR_LFIRFrac2Model , & ' [FIR_LFIRFrac2Model]' write (2,'(f9.4,31x,a)') FIR_logLFIR_obs , & ' [FIR_logLFIR_obs (Lsun)]' write (2,'(f9.4,31x,a)') FIR_ErrlogLFIR , & ' [FIR_ErrlogLFIR (dex)]' write (2,'(f9.4,31x,a)') FIR_RangelogLFIR , & ' [FIR_RangelogLFIR (dex)]' write (2,'(f9.4,31x,a)') FIR_GlobalChi2ScaleFactor , & ' [FIR_GlobalChi2ScaleFactor]' write (2,'(2(f9.4,2x),18x,a)') FIR_logLFIR_low,FIR_logLFIR_upp, & ' [FIR_logLFIR_low -> FIR_logLFIR_upp (Lsun)]' write (2,'(2(f9.4,2x),18x,a)') FIRbeta_D , FIRbeta_I , & ' [FIRbeta_D & FIRbeta_I]' * Extra: Output a rough FIR/Optical "color" for Q&D analysis obs_FIR2Opt_ratio = 0. if (IsFIRcOn.EQ.1) obs_FIR2Opt_ratio = FIR_logLFIR_obs - & (log10(l_norm) + FIR_logLobs_norm) write (2,'(f9.4,31x,a)') obs_FIR2Opt_ratio , & ' [log L_FIR/(l_norm * Lobs_norm) - a rough FIR/Opt ratio]' write (2,*) * Compute the predicted log LFIR, the FIR-population vector * (x_FIR) & chi2_FIR for the best model (x_min & AV_tot) by calling * the FIR_CalcFIRchi2 function with WhereFrom = 'OUT'. The predicted * bolometric luminosity and bolometric pop-vector are also computed * and outputed. !ESM! Now that ETC_CalcETCchi2 only runs FIR-shit when Np_FIR.GT.0, I need to ! call FIR_CalcFIRchi2 to generate the predicted FIR output! (Thisfake-call ! to the chi2-function is not needed for QHR nor PHO predictions because of ! the way Read_ETC_Info handles them ... FIR-predictions require no input ! info, but QHR & PHO do need some input reading) ! Cid@Lagoa - 17/Aug/2017 if (IsFIRcOn.EQ.-1) lix = FIR_CalcFIRchi2(x_min,AV_tot,'OUT`') write (2,'(a)') '## FIR: Results for best model' z1 = 0. if (IsFIRcOn.EQ.1) z1 = 10.**(FIR_ModlogLFIR - FIR_logLFIR_obs) !ESM! Changed notation (only on output!) for elegance/consistency/taste: ! FIR_ModlogLFIR --> FIR_logLFIR_mod ! FIR_ModlogLBOL --> FIR_logLBOL_mod write (2,'(f11.5,5x,1p,e9.3,0p,15x,a)') FIR_ModlogLFIR , z1 , $ ' [FIR_logLFIR_mod (Lsun) & Mod/Obs ratio]' z1 = 10.**(FIR_ModlogLFIR - FIR_ModlogLBOL) write (2,'(f11.5,5x,1p,e9.3,0p,15x,a)') FIR_ModlogLBOL , z1 , $ ' [FIR_logLBOL_mod (Lsun) & FIR/BOL ratio]' write (2,'(1p,e11.5,5x,e11.5,0p,13x,a)') $ chi2_FIR , chi2_OPTICAL , ' [chi2_FIR & chi2_OPT]' write (2,*) * Screen output of FIR-results if (i_verbose.GT.0) then write (*,*) write (*,*) write (*,'(a)') '## FIR: Results for best model' z1 = 0. if (IsFIRcOn.EQ.1) z1=10.**(FIR_ModlogLFIR - FIR_logLFIR_obs) write (*,'(f11.5,5x,1p,e9.3,0p,15x,a)') FIR_ModlogLFIR , z1 , $ ' [FIR_logLFIR_mod (Lsun) & Mod/Obs ratio]' z1 = 10.**(FIR_ModlogLFIR - FIR_ModlogLBOL) write (*,'(f11.5,5x,1p,e9.3,0p,15x,a)') FIR_ModlogLBOL , z1 , $ ' [FIR_logLBOL_mod (Lsun) & FIR/BOL ratio]' write (*,'(1p,e11.5,5x,e11.5,0p,13x,a)') $ chi2_FIR , chi2_OPTICAL , ' [chi2_FIR & chi2_OPT]' write (*,*) write (*,1191) end if * OBS: Lbol(j) is the base-original per unit initial mass value! write (2,1191) 1191 format ('# j age_j(yr) Z_j exAV? ', & ' x_j(%) AV_tot | ', & ' x_FIR(%) x_BOL(%) ', & ' BolCor FracLion Lbol/M ', & ' Rmat R_opt R_Lya R_LCE') do j=1,N_base ind_FIRAV = int(0.5 + (AV_tot(j) - FIRAV_low) / FIRdAV) + 1 if (ind_FIRAV.LT.1) ind_FIRAV = 1 if (ind_FIRAV.GT.NFIR_AV) ind_FIRAV = NFIR_AV write (2,1192) j , age_base(j) , Z_base(j) , ind_exAV(j) , & (100.*x_min(j)) , AV_tot(j) , & (100.*x_FIR(j)) , (100.*x_BOL(j)) , & FIRBolCor(j) , FIRFracLion(j) , FIRLbol(j) , & FIRRmat(j,ind_FIRAV) , FIRR_opt(j,ind_FIRAV) , & FIRR_Lya(j,ind_FIRAV) , FIRR_LCE(j,ind_FIRAV) if (i_verbose.GT.0) then write (*,1192) j , age_base(j) , Z_base(j) , ind_exAV(j) , & (100.*x_min(j)) , AV_tot(j) , & (100.*x_FIR(j)) , (100.*x_BOL(j)) , & FIRBolCor(j) , FIRFracLion(j) , FIRLbol(j) , & FIRRmat(j,ind_FIRAV) , FIRR_opt(j,ind_FIRAV) , & FIRR_Lya(j,ind_FIRAV) , FIRR_LCE(j,ind_FIRAV) end if end do 1192 format (i3,2x,1p,e12.6,2x,0p,f7.5,2x,i3,2x, & f10.4,2x,f7.4,2x, & 2(f10.4,2x),1p, & 3(2x,e9.3),1x, & 4(2x,e9.3)) end if c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR QHR-RELATED OUTPUT . QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR *QHR* Produce/re-compute/compile QHR-related things for output * The loong if just below skips QHRc-output for non-QHRc fits (IsQHRcOn = * 0). Note that for IsQHRcOn = -1 predicted QHR things are saved, * even though no actual QHR-data was used. if ((iQHR_IsQHRcOn.EQ.1).OR.(iQHR_IsQHRcOn.EQ.-1)) then write (2,*) write (2,*) write (2,*) write (2,'(35(a))') ('#',j=1,35) if (IsQHRcOn.EQ.-1) then write (2,'(a,a)') '## QHRc-FIT RELATED OUTPUT ##' , $ ' (Predicted things only!) ' else write (2,'(a)') '## QHRc-FIT RELATED OUTPUT ##' end if write (2,'(35(a))') ('#',j=1,35) write (2,*) write (2,'(a)') '## QHR: Input info' !QHi! Added IsReadQHfromBaseFile on 04/July/2017 write (2,'(f6.4,5x,i2,42x,a)') QHRbeta_I, IsReadQHfromBaseFile, & ' [QHRbeta_I & IsReadQHfromBaseFile]' write (2,'(a55,a)') arq_ETCinfo , ' [arq_ETCinfo]' write (2,'(f9.4,46x,a)') LumDistInMpc , ' [LumDist (Mpc)]' write (2,'(f9.4,46x,a)') QHR_GlobalChi2ScaleFactor , $ ' [QHR_GlobalChi2ScaleFactor]' write (2,'(i3,3x,i3,46x,a,a)') NQHR_Ys , Np_QHR , $ ' [NQHR_Ys & Np_QHR = # of em-lines included in', $ ' fit & # of QHR constraints]' write (2,*) write (2,'(a,a,a,a)') '# lambda[A] frecomb logY_TOT' , $ ' YFrac2Model ErrlogY RangelogY' , $ ' Chi2ScaleFactor' , $ ' logY_obs logY_low logY_upp' do iY=1,NQHR_Ys write (2,'(i2,1x,f8.2,9(3x,f10.4))') iY , QHR_lambda(iY) , $ QHR_frecomb(iY) ,QHR_logY_TOT(iY) , QHR_YFrac2Model(iY) $ ,QHR_ErrlogY(iY) , QHR_RangelogY(iY) $ ,QHR_Chi2ScaleFactor(iY) , QHR_logY_obs(iY) $ ,QHR_logY_low(iY) , QHR_logY_upp(iY) end do *ELR* ....................................................................... write (2,*) if (IsELRInputInconsistentWarningFlag.EQ.0) then write (2,'(a,a)') '## ELR input & results. ' , $ ' OBS: chi2_ELR is **included** in chi2_QHR!' else write (2,'(4(a))') '## ELR input & results. ' , $ ' OBS: chi2_ELR is **included** in chi2_QHR! ' , $ 'ATT: YOUR INPUT DATA IMPLY AV_neb(A,B) < 0 (!) ' , $ 'SO I **MODIFIED** IT!!!!! BEWARE!!! <===' end if c predicted AV_neb from ELR_lambdas A & B, & its error z1 = 0. z2 = 0. if ((iY_ELR_A.GT.0).AND.(iY_ELR_B.GT.0)) then z1 = -(2.5 / (QHR_qlambda(iY_ELR_A) - $ QHR_qlambda(iY_ELR_B))) * (ELR_logRobs - ELR_logRint) z2 = abs(2.5 / (QHR_qlambda(iY_ELR_A) - $ QHR_qlambda(iY_ELR_B))) * ELR_ErrlogR end if write (2,1357) $ IsELROn , ELR_lambdaA, ELR_lambdaB , iY_ELR_A , iY_ELR_B , $ ELR_logRint , z1 , z2 , $ ' [IsELROn lambda_A lambda_B ind_A ind_B' , $ ' logRint AV_neb(A/B) +/- its error]' 1357 format (i1,1x,f8.2,3x,f8.2,5x,i1,4x,i1,4x,f9.4,3x,2(1x,f9.4), $ 1x,a,a) write (2,'(1x,2(f9.4,2x),3(f9.4,4x),7x,a,a)') $ ELR_ErrlogR , ELR_RangelogR , $ ELR_logR_low , ELR_logR_upp , ELR_Chi2ScaleFactor , $ ' [Err_logR RangelogR logR_low logR_upp' , $ ' Chi2ScaleFactor]' write (2,'(1x,2(f9.4,2x),1p,1x,e12.4,0p,33x,a)') $ ELR_logRobs , ELR_ModlogR , ELR_chi2_logR , $ ' [logR_obs logR_mod chi2_ELR]' !ATT! Order of ELR_logRobs & ELR_ModlogR was wrong! Fixed it. Cid@UFSC - 19/June/2017 ! Also, changed notation (4 output only!): logRobs-->logR_obs & ModlogR-->logR_mod *ELR* ....................................................................... write (2,*) write (2,'(a)') '## QHR: Results for best model' write (2,'(2(f10.5,2x),16x,a)') $ QHR_log_QH0 , QHR_log_QHeff , $ ' [log_QH0 & log_QHeff - in photons/sec]' write (2,'(1p,2(e11.5,2x),0p,14x,a)') $ chi2_QHR , chi2_OPTICAL , ' [chi2_QHR chi2_OPT]' write (2,*) write (2,'(a,a)') '# lambda[A] q_lambda logY_obs ', $ 'logY_mod chi2_Y' do iY=1,NQHR_Ys write (2,2011) iY , QHR_lambda(iY) , QHR_qlambda(iY) , $ QHR_logY_obs(iY) , QHR_ModlogY(iY) , QHR_chi2_Y(iY) end do 2011 format (i2,1x,f8.2,3x,f8.4, $ 2(3x,f10.4),3x,1p,e12.4, $ 2x,e12.4,5x,e12.4) write (2,*) * Repeat base info (age, Z, AV...) now with QHR-stuff too: * qH = 1e40 photons/sec/initial solar mass * QH/Lnorm = 1e40 photons/sec per Lsun/Angs * x_QH0() = %-contributions to total QH0 * x_QHeff() = %-contributions to total QHeff * x_Y() = %-contributions to each emission line write (2,2012) (int(QHR_lambda(iY)),iY=1,NQHR_Ys) 2012 format ('# j age_j(yr) Z_j exAV? ', & ' x_j(%) AV_tot | ', & ' qH__40 QH2Lnorm__40 ', & ' %-QH0 %-QHeff |', & ' %-Y:',10(i6)) do j=1,N_base write (2,2013) j , age_base(j) , Z_base(j) , ind_exAV(j) , & (100.*x_min(j)) , AV_tot(j) , & QHR_qH40(j) , QHR_Q2Lnorm40(j), & (100.*QHR_x_QH0(j)) , (100.*QHR_x_QHeff(j)) , & (100.*QHR_x_Y(j,iY),iY=1,NQHR_Ys) end do 2013 format (i3,2x,1p,e12.6,2x,0p,f7.5,2x,i3, & 2x,f10.4,2x,f7.4, & 2x,1p,2(2x,e12.4),0p, & 2x,f6.2,2x,f6.2, & 9x,10(f5.1,1x)) * Screen output of QHR-results if (i_verbose.GT.0) then *ELR* ....................................................................... write (*,*) write (*,*) if (IsELRInputInconsistentWarningFlag.EQ.0) then write (*,'(a,a)') '## ELR input & results. ' , $ ' OBS: chi2_ELR is **included** in chi2_QHR!' else write (*,'(4(a))') '## ELR input & results. ' , $ ' OBS: chi2_ELR is **included** in chi2_QHR! ' , $ 'ATT: YOUR INPUT DATA IMPLY AV_neb(A,B) < 0 (!) ' , $ 'SO I **MODIFIED** IT!!!!! BEWARE!!! <===' end if z1 = 0. z2 = 0. if ((iY_ELR_A.GT.0).AND.(iY_ELR_B.GT.0)) then z1 = -(2.5 / (QHR_qlambda(iY_ELR_A) - $ QHR_qlambda(iY_ELR_B))) * (ELR_logRobs - ELR_logRint) z2 = abs(2.5 / (QHR_qlambda(iY_ELR_A) - $ QHR_qlambda(iY_ELR_B))) * ELR_ErrlogR end if write (*,1357) $ IsELROn , ELR_lambdaA,ELR_lambdaB , iY_ELR_A,iY_ELR_B , $ ELR_logRint , z1 , z2 , $ ' [IsELROn lambda_A lambda_B ind_A ind_B' , $ ' logRint AV_neb(A/B) +/- its error]' write (*,'(1x,2(f9.4,2x),3(f9.4,4x),7x,a,a)') $ ELR_ErrlogR , ELR_RangelogR, $ ELR_logR_low , ELR_logR_upp , ELR_Chi2ScaleFactor , $ ' [Err_logR RangelogR logR_low logR_upp' , $ ' Chi2ScaleFactor]' write (*,'(1x,2(f9.4,2x),1p,1x,e12.4,0p,33x,a)') $ ELR_logRobs , ELR_ModlogR , ELR_chi2_logR , $ ' [logR_obs logR_mod chi2_ELR]' !ATT! Order of ELR_logRobs & ELR_ModlogR was wrong! Fixed it. Cid@UFSC - 19/June/2017 *ELR* ....................................................................... write (*,*) write (*,*) write (*,'(a)') '## QHR: Results for best model' write (*,'(f9.4,3x,f9.4,19x,a)') $ QHR_log_QH0 , QHR_log_QHeff , $ ' [log_QH0 & log_QHeff - in photons/sec]' write (*,'(1p,2(e11.5,2x),0p,14x,a)') $ chi2_QHR , chi2_OPTICAL , ' [chi2_QHR chi2_OPT]' write (*,*) write (*,'(a,a)') '# lambda[A] q_lambda logY_obs ', $ 'logY_mod chi2_Y' do iY=1,NQHR_Ys write (*,2011) iY , QHR_lambda(iY) , QHR_qlambda(iY) , $ QHR_logY_obs(iY) , QHR_ModlogY(iY) , QHR_chi2_Y(iY) end do write (*,*) write (*,2012) (int(QHR_lambda(iY)),iY=1,NQHR_Ys) do j=1,N_base write (*,2013) j , age_base(j), Z_base(j), ind_exAV(j), & (100.*x_min(j)) , AV_tot(j) , & QHR_qH40(j) , QHR_Q2Lnorm40(j), & (100.*QHR_x_QH0(j)) , (100.*QHR_x_QHeff(j)) , & (100.*QHR_x_Y(j,iY),iY=1,NQHR_Ys) end do end if end if c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO PHO-RELATED OUTPUT . PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO *PHO* Produce/re-compute/compile PHO-related things for output * The if just below skips PHOc-output for non-PHOc fits (IsPHOcOn = * 0). Note that for IsPHOcOn = -1 predicted PHO things are saved, * even though no actual PHO-data was used. if ((iPHO_IsPHOcOn.EQ.1).OR.(iPHO_IsPHOcOn.EQ.-1)) then write (2,*) write (2,*) write (2,*) write (2,'(35(a))') ('#',j=1,35) if (IsPHOcOn.EQ.-1) then write (2,'(a,a)') '## PHOc-FIT RELATED OUTPUT ##' , $ ' (Predicted things only!) ' else write (2,'(a)') '## PHOc-FIT RELATED OUTPUT ##' end if write (2,'(35(a))') ('#',j=1,35) c Foca: Changing output notation to magY, variable names in the code c are still in logY notation. write (2,*) write (2,'(a)') '## PHO: Input info' write (2,'(a40,a)') arq_ETCinfo , ' [arq_ETCinfo]' write (2,'(f9.4,31x,a)') LumDistInMpc , ' [LumDist (Mpc)]' write (2,'(f9.6,31x,a)') PHO_redshift , ' [PHO_redshift]' write (2,'(f9.4,31x,a)') PHO_GlobalChi2ScaleFactor , $ ' [PHO_GlobalChi2ScaleFactor]' write (2,'(i3,37x,a)') NPHO_Ys , $ ' [NPHO_Ys = number of PHO-bands included in fit]' write (2,*) write (2,'(a,4x,a,a,a)') '#name/code filter_file' , $ ' magY_TOT YFrac2Model magYErr magYRange' , $ ' Chi2ScaleFactor magY_obs magY_low magY_upp' 2020 format(a10,2x,a15,5(f9.4,2x),3(2x,f9.4,2x)) do iY=1,NPHO_Ys write (2,2020) PHO_name(iY) , $ PHO_Filter_file(iY) , $ PHO_logY_TOT(iY) , PHO_YFrac2Model(iY) , $ PHO_ErrlogY(iY) , PHO_RangelogY(iY) , $ PHO_Chi2ScaleFactor(iY) , PHO_logY_obs(iY) , $ PHO_logY_low(iY) , PHO_logY_upp(iY) end do write (2,*) write (2,'(a)') '## PHO: Results for best model' write (2,'(1p,2(e11.5,2x),0p,14x,a)') $ chi2_PHO , chi2_OPTICAL , ' [chi2_PHO chi2_OPT]' c Foca@ufsc june 7, 2017: c Now writing output magnitudes, fluxes and pivot wavelength c to output files write (2,*) write (2,'(a,a,a,a)') '# name/code', $ ' MeanLamb PivotLamb StdDevLamb q_MeanLamb ', $ ' magY_obs magY_mod ' , $ ' fY_obs fY_mod chi2_Y' do iY=1,NPHO_Ys ! Foca: Calculating fluxes from the fitted magnitudes: tmp = (3631./3.34e4) / PHO_PivotLambda(iY)**2 fYobs = tmp * 10.**(-0.4 * PHO_logY_obs(iY)) fYmod = tmp * 10.**(-0.4 * PHO_ModlogY(iY)) write (2,2021) iY , PHO_name(iY) , $ PHO_MeanLambda(iY), PHO_PivotLambda(iY), $ PHO_StdDevLambda(iY) , $ PHO_q_MeanLambda(iY) , $ PHO_logY_obs(iY) , PHO_ModlogY(iY) , $ fYobs , fYmod , PHO_chi2_Y(iY) end do 2021 format (i2,1x,a10,1x,3(f8.2,3x),f7.4, $ 2(3x,f10.4),3x,1p,2(e12.3,2x),e12.4) * Repeat base info (age, Z, AV...) now with the PHO_x_Y pop vector: * PHO_x_Y(j,iY) = %-contribution of j-th component to filter iY write (2,*) write (2,2022) (iY,iY=1,NPHO_Ys) 2022 format ('# j age_j(yr) Z_j exAV? ', & ' x_j(%) AV_tot |', & ' %-Y:',100(i5,1x)) do j=1,N_base write (2,2023) j , age_base(j) , Z_base(j) , ind_exAV(j) , & (100.*x_min(j)) , AV_tot(j) , & (100.*PHO_x_Y(j,iY),iY=1,NPHO_Ys) end do 2023 format (i3,2x,1p,e12.6,2x,0p,f7.5,2x,i3, & 2x,f10.4,2x,f7.4, & 8x,100(f5.1,1x)) * Screen output of PHO-results if (i_verbose.GT.0) then write (*,*) write (*,*) write (*,'(a)') '## PHO: Results for best model' write (*,'(1p,2(e11.5,2x),0p,14x,a)') $ chi2_PHO , chi2_OPTICAL , ' [chi2_PHO chi2_OPT]' write (*,*) write (*,'(a,a,a,a,a)') '# name/code', $ ' MeanLamb PivotLamb StdDevLamb q_MeanLamb ', $ ' magY_obs magY_mod ' , $ ' fY_obs fY_mod chi2_Y' do iY=1,NPHO_Ys tmp = (3631./3.34e4) / PHO_PivotLambda(iY)**2 fYobs = tmp * 10.**(-0.4 * PHO_logY_obs(iY)) fYmod = tmp * 10.**(-0.4 * PHO_ModlogY(iY)) write (*,2021) iY , PHO_name(iY) , $ PHO_MeanLambda(iY), PHO_PivotLambda(iY), $ PHO_StdDevLambda(iY) , $ PHO_q_MeanLambda(iY) , $ PHO_logY_obs(iY) , PHO_ModlogY(iY) , $ fYobs , fYmod , PHO_chi2_Y(iY) end do write (*,*) write (*,2022) (iY,iY=1,NPHO_Ys) do j=1,N_base write (*,2023) j , age_base(j) , Z_base(j) , ind_exAV(j), & (100.*x_min(j)) , AV_tot(j) , & (100.*PHO_x_Y(j,iY),iY=1,NPHO_Ys) end do end if end if c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c Done with output :) close(2) * Moved this time-counters blablabla to the very end (= here!) if (i_verbose.GT.0) then write (*,*) write (*,'(5(a,i8,2x),a,a50)') $ '*CidTIME> FF= ' , idt_FF , $ ' RF= ' , idt_RF , ' BI= ' , idt_BI , $ ' EX0= ', idt_EX0 , ' ALL= ', idt_all , $ ' sec - fit = ' , arq_out ! write (*,'(5(a,f8.3,2x),a,a50)') ! $ '*TotTIME> FF= ' , wdt_FF_TotTime , ! $ ' RF= ' , wdt_RF_TotTime , ' BI= ' , wdt_BI_TotTime , ! $ ' EX0= ', wdt_EX0_TotTime , ' ALL= ', wdt_TotTime , ! $ ' sec - fit = ' , arq_out ! write (*,'(5(a,f8.3,2x),a,a50)') ! $ '*UsrTIME> FF= ' , wdt_FF_UsrTime , ! $ ' RF= ' , wdt_RF_UsrTime , ' BI= ' , wdt_BI_UsrTime , ! $ ' EX0= ', wdt_EX0_UsrTime , ' ALL= ', wdt_UsrTime , ! $ ' sec - fit = ' , arq_out ! write (*,'(5(a,f8.3,2x),a,a50)') ! $ '*SysTIME> FF= ' , wdt_FF_SysTime , ! $ ' RF= ' , wdt_RF_SysTime , ' BI= ' , wdt_BI_SysTime , ! $ ' EX0= ', wdt_EX0_SysTime , ' ALL= ', wdt_SysTime , ! $ ' sec - fit = ' , arq_out ! write (*,*) end if c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + DONE WITH POST-PROCESSING & OUTPUT:) + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ end c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ c @ END OF MAIN CODE @ c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + A BUNCH OF SIMPLE ROUTINES + c + + c + iCheckExistingOutFiles - added by ElCid@Sanchica - 15/Ago/2011 + c + ReadSpecWithHeader + c + calc_Fnorm + c + Stats_F + c + Sum_of_x + c + F_adev + c + Interpol_Spec + c + RebinSpec + c + GaussSmooth + c + Calc_Mean_Age_and_Z + c + ConvertLight2Mass + c + Clip_Spectrum + c + F_SSP_chi2_AV (added on 20/Jan/2007) + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c ########################################################################### c Checks if file out_dir/arq_out already exists (ih which case the c function returns 1), or not (function returns 0). c If the file does not exist them create a tmp one. c c ElCid@Sanchica - 15/Ago/2011 c c Here is the old comment/abstract about this bit: ! !Cid08Fev07-FIX! Skip runs already made! New trick: Figure out if ! arq_out already exists. If so, abort run & go to next one! Useful ! to run grids in "modo-burro". If arq_out does NOT exit, then write ! a tmp arq_out (to be overwritten at the end of the run) just to ! avoid that another CPU takes this same job while the code is ! running. ! OBS: Flag i_SkipExistingOutFile decides whether this test is done. FUNCTION iCheckExistingOutFiles(out_dir,arq_out) implicit real (a-h,j-m,o-z) implicit integer (i,n) character*100 out_dir , arq_out , arq_aux i_last_non_blank_char = 0 do i=1,99 if ((out_dir(i:i+1).EQ.' ').AND.(i_last_non_blank_char.EQ.0)) & i_last_non_blank_char = i - 1 end do arq_aux = out_dir(1:i_last_non_blank_char) // arq_out open (unit=2,file=arq_aux,status='old',err=500) close(2) iCheckExistingOutFiles = 1 return 500 iCheckExistingOutFiles = 0 open (unit=2,file=arq_aux,status='unknown') write (2,'(a)') $ 'This file will be overwritten in a few minutes...' close(2) return end c ########################################################################### c ########################################################################### c Reads a spectrum, but skips first N_skip lines if they start with a '#'. c OBS: '#' must be in the 1st column!! c Cid@lynx - 15/Aug/2003 SUBROUTINE ReadSpecWithHeader(arq,N_max,N,l,f) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) real l(N_max) , f(N_max) character*100 arq character*1 cerquinha c ** First find-out how many header lines (those which start with '#') to skip N_skip = 0 open (unit=1,file=arq,status='old') do i=1,N_max read (1,'(a1)') cerquinha if (cerquinha.EQ.'#') then N_skip = N_skip + 1 else goto 10 end if end do 10 close(1) c ** Now reads spectrum, skiping 1st N_skip lines open (unit=1,file=arq,status='old') do i=1,N_skip read (1,*) end do do i=1,N_max read (1,*,END=20) l(i) , f(i) end do write (*,*) ' [ReadSpecWithHeader] BUG! N > Nl_max!! ' , N_max 20 close(1) N = i - 1 end c ########################################################################### c ########################################################################### c Interpolates flux at l_norm Angstrons in a f(l) flux vector. c Used for normalization purposes. c Cid@Lynx - Aug/09/2003 SUBROUTINE calc_Fnorm(N,l,f,l_norm,f_norm) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) real l(N) , f(N) do i=1,N-1 if ((l(i).LE.l_norm).AND.(l(i+1).GE.l_norm)) then a = (f(i+1) - f(i)) / (l(i+1) - l(i)) f_norm = a * (l_norm - l(i+1)) + f(i+1) return end if end do write (*,'(3(a,f7.1))') $ '[calc_Fnorm] Spectrum does NOT contain l_norm = ' , l_norm , $ ' l goes from ' , l(1) , ' -> ' , l(N) stop end c ########################################################################### c ########################################################################### c Compute average, sigma & median flux between l1 & l2. c Cid@Lynx - Aug/24/2003 c Added safety-check when i_tot < 2. Cid@Lagoa - 08/Oct/2005 SUBROUTINE Stats_F(N,l,f,l1,l2,f_ave,f_sig,f_med) parameter (Nl_max = 20000) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) real l(N) , f(N) , f_aux(Nl_max) i_tot = 0 do i=1,N if ((l(i).GE.l1).AND.(l(i).LE.l2)) then i_tot = i_tot + 1 f_aux(i_tot) = f(i) end if end do f_ave = 0. f_sig = 0. f_med = 0. if (i_tot.GT.1) then call avevar(f_aux,i_tot,f_ave,f_var) f_sig = sqrt(f_var) call MDIAN1(f_aux,i_tot,f_med) end if end c ########################################################################### c ########################################################################### c Compute average & sigma of f(l) between l1 & l2 but considering only c points with w(l) > 0. Silly routine used in the computation of S/N c ratios (for output purposes only!). c Cid@Lynx - Jan/27/2005 c Added safety-check when i_tot < 2. Cid@Lagoa - 08/Oct/2005 SUBROUTINE Stats4SN(N,l,f,w,l1,l2,f_ave,f_sig) parameter (Nl_max = 20000) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) real l(N) , f(N) , w(N) , f_aux(Nl_max) i_tot = 0 do i=1,N if ((l(i).GE.l1).AND.(l(i).LE.l2).AND.(w(i).GT.0.)) then i_tot = i_tot + 1 f_aux(i_tot) = f(i) end if end do f_ave = 0. f_sig = 0. if (i_tot.GT.1) then call avevar(f_aux,i_tot,f_ave,f_var) f_sig = sqrt(f_var) end if end c ########################################################################### c ########################################################################### c # Returns the sum of x c # Cid@Lynx - Feb/21/2005 FUNCTION Sum_of_x(x,N) parameter (Nb_max = 300) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) real x(Nb_max) sum_x = 0. do j=1,N sum_x = sum_x + abs(x(j)) end do Sum_of_x = sum_x end c ########################################################################### c ########################################################################### c # Compute mean absolute relative deviation, in percent. c # OBS: only for the Nl_eff points actually used in the synthesis! c # Note that most of the stuff is passed by a common! c # Cid@Lynx - Mar/16/2003 c # Minor change: Nl_eff is now computed here. c # Cid@Lynx - Aug/17/2003 !ESM! Major change: we now compute adevS, i.e., the percentual difference ! wrt the **synthetic** spectrum, not the observed one. In practice, this ! circumvents those few cases of large adev because of a single very low ! (but not masker not flagged) f_obs. ! Cid@UFSC - 09/Aug/2017 FUNCTION F_adev(f_syn) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000) real l_obs(Nl_max) , f_obs(Nl_max) , weight_obs(Nl_max) real f_syn(Nl_max) common/Obs/ Nl_obs , l_obs , f_obs , weight_obs adev = 0. Nl_eff = 0 do i=1,Nl_obs if (weight_obs(i).GT.0.) then adev = adev + abs((f_obs(i) - f_syn(i)) / f_syn(i)) Nl_eff = Nl_eff + 1 end if end do F_adev = 100. * adev / float(Nl_eff) return end c ########################################################################### c ########################################################################### c # Simple linear interpolation of an input spectrum fo(lo) on to fs(ls), c # where ls is given by the user. c # Cid@Lynx - 03/Jan/2003 *PHO* Finally using this routine! I changed it to return a zero when ls * is outside the lo range! * Cid@Lagoa - 08/Jan/2011 SUBROUTINE Interpol_Spec(No,lo,fo,Ns,ls,fs) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) real lo(No) , fo(No) , ls(Ns) , fs(Ns) do is=1,Ns fs(is) = 0. do io=1,No-1 if ((ls(is).GE.lo(io)).AND.(ls(is).LE.lo(io+1))) then a = (fo(io+1) - fo(io)) / (lo(io+1) - lo(io)) b = fo(io) - a * lo(io) fs(is) = a * ls(is) + b goto 10 end if end do ! write (*,*) ' [Interpol_Spec] BUG! ' , is , ls(is) ! stop 10 do_nothing_on_this_silly_line = 0. end do end c ########################################################################### c ########################################################################### c # Rebin an input spectrum fo(lo) on to fs(ls) by direct integration... c # Both lo & ls MUST BE sorted in increasing order. c # This routine treats a spectrum as a "histogram": c # fo(lo) is taken as constant within the lo bin c # lo(i) represents a bin from [lo(i-1)+lo(i)]/2 ==> [lo(i)+lo(i+1)]/2 c # Note that lo (nor ls) does not need to be uniformily spaced. c # Flux density is preserved. c # Cid@Lynx - 24/Aug/2003 c # I've introduced a i_FastBC03_FLAG which greatly speeds up rebinning c # for a BC03 base and when dl = 1 and Ol_obs is within 3322-->9300 Angs. c # In this case no interpolation is needed! I just cut-out the piece of the c # BC03 spectrum which matches the desired ls lambdas (assumed to be spaced c # by 1 Angs, as the BC03 files). c # Cid@Lagoa - 7/May/2004 c I now test whether dls = ls(2) - ls(1) = 1 Angs, the BC03 sampling c in the high resolution optical range. If this is not 1 Angs, the c FastBC03 rebinning-trick should not be aplied! c Cid@Lagoa - 28/Jan/2005 c I've adapted the fast-rebin trick to work with Base-Rosa spectra c (br04*spec files), which cover the 3001 --> 6996 Angs range. To c use fast-rebin with BR04 you must set i_FastBC03_FLAG = 2. c c Cid@IAA - 27/May/2005 SUBROUTINE RebinSpec(i_FastBC03_FLAG,No,lo,fo,Ns,ls,fs) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) real lo(No) , fo(No) , ls(Ns) , fs(Ns) if ((i_FastBC03_FLAG.GE.1).AND.((ls(2) - ls(1)).NE.1.0)) then write (*,'(a,a,i4,f8.3)') ' [RebinSpec] Tried FastBC03-' , & 'rebinning but dl NE 1 Angs. Going for slow rebinning!' , & i_FastBC03_FLAG , ls(2) - ls(1) end if if ((i_FastBC03_FLAG.EQ.1).AND.((ls(2) - ls(1)).EQ.1.0).AND. $ (int(ls(1)).GE.3222).AND.(int(ls(Ns)).LE.9300)) then c ** Just cut-out a BC03 spectrum to ls. See notes above. do is=1,Ns ind_in_BC03 = int(ls(is)) - 3322 + 348 fs(is) = fo(ind_in_BC03) c ** Paranoid check... if (int(ls(is)).NE.int(lo(ind_in_BC03))) then write (*,*) ' [RebinSpec] BUG in FastBC03 scheme! ' , & is , ls(is) , ind_in_BC03 , lo(ind_in_BC03) write (*,*) ' [RebinSpec] Try setting', $ ' i_FastBC03_FLAG = 0 in arq_config' stop end if end do ! Same thing but for br04*spec, which cover 3001-->6996 Angs. else if ((i_FastBC03_FLAG.EQ.2).AND.((ls(2) - ls(1)).EQ.1.0).AND. $ (int(ls(1)).GE.3001).AND.(int(ls(2)).LE.6996)) then c ** Just cut-out a BR04spectrum to ls. See notes above. do is=1,Ns ind_in_BR04 = int(ls(is)) - 3001 + 1 fs(is) = fo(ind_in_BR04) c ** Paranoid check... if (int(ls(is)).NE.int(lo(ind_in_BR04))) then write (*,*) ' [RebinSpec] BUG in FastBR04 scheme! ' , & is , ls(is) , ind_in_BR04 , lo(ind_in_BR04) write (*,*) ' [RebinSpec] Try setting', $ ' i_FastBC03_FLAG = 0 in arq_config' stop end if end do ! Slow-rebinning. else c ** Loop over ls-bins do is=1,Ns c ** Define bin limits corresponding to ls(is) c ** (1st & last bins are forced to be simmetric) if (is.EQ.1) then ls_low = ls(is) - (ls(is+1) - ls(is)) / 2. else ls_low = (ls(is) + ls(is-1)) / 2. end if if (is.EQ.Ns) then ls_upp = ls(is) + (ls(is) - ls(is-1)) / 2. else ls_upp = (ls(is) + ls(is+1)) / 2. end if c ** Find lo points within current ls bin & integrate flux sum_bin = 0. do io=1,No c ** Define bin limits corresponding to lo(io) c ** (1st & last bins are forced to be simmetric) if (io.EQ.1) then lo_low = lo(io) - (lo(io+1) - lo(io)) / 2. else lo_low = (lo(io) + lo(io-1)) / 2. end if if (io.EQ.No) then lo_upp = lo(io) + (lo(io) - lo(io-1)) / 2. else lo_upp = (lo(io) + lo(io+1)) / 2. end if c ** Check if ls & lo bins overlap. If not, skip this lo-bin. c ** If yes, integrate fo(lo) contribution to current ls bin. if ((ls_upp.LE.lo_low).OR.(ls_low.GE.lo_upp)) then ls_bin_does_not_overlap_with_current_lo_bin = 0. else c ** set l_inf = MAX(lo_low,ls_low) and l_sup = MIN(lo_upp,ls_upp) l_inf = lo_low if (ls_low.GT.lo_low) l_inf = ls_low l_sup = lo_upp if (ls_upp.LT.lo_upp) l_sup = ls_upp sum_bin= sum_bin+ fo(io) * (l_sup - l_inf) end if end do c ** sum_bin= integrated flux in ls-bin & fs = sum_bin per delta-ls fs(is) = sum_bin / (ls_upp - ls_low) c ** Screen check... ! write (*,11) 'Rebin> ' , is , ls_low,ls(is),ls_upp,fs(is),sum ! 11 format (a,i5,2x,3(2x,f7.2),1p,2(2x,e9.3)) end do end if end c ########################################################################### c ########################################################################### c # Smooth an input spectrum fo(lo) with a Gaussian centered at velocity c # v = v0 and with sig as velocity dispersion. The output is fs(ls). c # The convolution is done with a BRUTE FORCE integration of n_u points c # from u = -n_sig to u = +n_sig, where u = (v - v0) / sig. c # OBS: Assumes original spectrum fo(lo) is EQUALLY SPACED in lambda!! C # Units of v0 & sig = km/s c # Cid@Lynx - 05/Dec/2002 c # Added n_u as a parameter! c # Cid@Lynx - 16/Mar/2003 *ETC* !AKI! gfortran does not like do u=u_low,u_upp,du! But works! Fix * after other tests are done! Cid@Lagoa - 11/Jan/2011 * This version of GaussSmooth replaces the u-loop by one in an * integer index i_u. The differences wrt are minute (< 1e-5) and due * to precision... * * ElCid@Sanchica - 16/Ago/2011 *ATT* Promoted to new oficial GaussSmooth without much testing! * Previous version removed to skip compilation warnings... * ElCid@Sanchica - 08/Oct/2011 *ATT* Found an array bounds-bug when compiling with gfortran ... -fbounds-check * Ex: Fortran runtime error: Index '3402' of dimension 1 of array 'fo' above upper bound of 3401 * Happens only when sig is very large. The old routine is kept below, and documents the bug briefly. * ElCid@Sanchica - 05/Nov/2011 SUBROUTINE GaussSmooth(No,lo,fo,v0,sig,n_u,Ns,ls,fs) ** Definitions implicit real (a-h,k-m,o-z) implicit integer (i,j,n) real lo(No) , fo(No) , ls(Ns) , fs(Ns) pi = 4. * atan(1.) c = 2.997925e5 c ** Check n_u if (n_u.LT.5) then write (*,*) ' [GaussSmooth] nu too small! ' , n_u stop end if c ** Parameters for the brute-force integration in velocity n_sig = 6 u_low = -n_sig u_upp = n_sig du = (u_upp - u_low) / float(n_u - 1) d_lo = lo(2) - lo(1) c ** loop over ls, convolving fo(lo) with a gaussian do is=1,Ns c ** reset integral of {fo[ll = ls/(1+v/c)] * Gaussian} & start integration sum_fg = 0. do i_u=1,n_u c ** define velocity & lambda corresponding to u u = u_low + float(i_u - 1) * du v = v0 + abs(sig) * u ll = ls(is) / (1. + v/c) c ** find fo flux for lambda = ll ind = (ll - lo(1)) / d_lo + 1 if (ind.LE.1) then ff = fo(1) else if (ind.GE.No) then ff = fo(No) else a = (fo(ind+1) - fo(ind)) / (lo(ind+1) - lo(ind)) b = fo(ind) - a * lo(ind) ff = a * ll + b end if c ** smoothed spectrum sum_fg = sum_fg + ff * exp(-(u**2/2.)) fs(is) = sum_fg * du / sqrt(2. * pi) end do end do end c ########################################################################### c ########################################################################### c Silly mean age & Z - just for screen output/check purposes c Cid@lynx - 04/Feb/04 SUBROUTINE Calc_Mean_Age_and_Z(N_base,x,a_age,s_age,a_met,s_met) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nb_max = 300) real x(Nb_max) , age_base(Nb_max) , Z_base(Nb_max) common/Age_and_Met/ age_base , Z_base sum_t = 0. sum_t2 = 0. sum_z = 0. sum_z2 = 0. sum_x = 0. do i=1,N_base sum_t = sum_t + x(i) * log10(age_base(i) + 1.) sum_t2 = sum_t2 + x(i) * (log10(age_base(i) + 1.))**2 sum_z = sum_z + x(i) * Z_base(i) sum_z2 = sum_z2 + x(i) * (Z_base(i))**2 sum_x = sum_x + x(i) end do a_age = sum_t / sum_x s_age = sqrt(abs((sum_t2/sum_x) - a_age**2)) a_met = sum_z / sum_x s_met = sqrt(abs((sum_z2/sum_x) - a_met**2)) end c ########################################################################### c ########################################################################### c # COMPUTE "TOTAL MASS" & MASS FRACTIONS IN COMPONENTS j=1...N_base # c ########################################################################### c Flux_tot is the total **dereddened** synthetic (WITHOUT c kinematics!) flux at l_norm, in the same units as in the input c spectrum. Mass_tot is the total stellar mass. It's units must be c fixed by the user a posteriori! For instance, if (a) the input c spectrum comes in units of 1e-17 erg/s/cm2/A, (2) the distance to c the galaxy (in cm) is d, and (3) the base spectra were given in c units of L_sun/A/M_sun (as is the case for the BC03 spectra), then c the actual mass is given by Mass_tot * 1e-17 * 4 * pi * d**2 / c 3.826e33. c c ATT: There are 2 versions of Mass_tot: Mini_tot & Mcor_tot! Why? c The original BC03 SSP spectra come normalized to a total INITIAL c mass of 1 M_sun. As time goes by, however, part of this stellar c mass goes back to the ISM. This implies that the mass (Mini_tot) c and mass-fractions (mu_ini(j)) are NOT the current ones! To c correct for the returned mass, I use the array Mstars (read fron c the base file), which says what fraction of the initial mass in c population # j is still in stars at the age of this same c component. The corrected total mass and mass-fractions are given c in Mcor_tot & mu_cor(j). c c OBS1: Note that a Power-Law component (which, if present, is c component # N_base) is excluded from the mass calculations (for c obvious reasons)! c OBS2: Masses & mass fractions may not make any sense at all if, c for instance, the base is made of template galaxies or normalized c models... c OBS3: Note that now AV is population dependent: AV_tot = AV + exAV! c c Cid@Lagoa - 21/April/2007 ! Removed power-law stuff. ! Cid@Lagoa - 08/Aug/2017 SUBROUTINE ConvertLight2Mass(N_base,x,AV_tot,q_norm,fobs_norm $ ,fbase_norm,Mstars,Flux_tot,Mini_tot,Mcor_tot,mu_ini,mu_cor) c Definitions implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nb_max = 300) c L2Mass (@ l_norm) in the base real fbase_norm(Nb_max) c Population vector arrays in flux (x) & mass (mu_ini) fractions real x(Nb_max) , mu_ini(Nb_max) c Mstars = array which says what fraction of the INITIAL stellar c mass in population # j is still in stars at age(j). mu_cor() are c the corrected mass-fractions. real Mstars(Nb_max) , mu_cor(Nb_max) c AV_array: AV_tot(j) = population dependent extinction real AV_tot(Nb_max) c Computes Flux_tot & total initial & actual (corrected) masses. Flux_tot = 0. Mini_tot = 0. Mcor_tot = 0. do j=1,N_base flux_j = x(j) * fobs_norm * 10.**(0.4 * AV_tot(j) * q_norm) mini_j = flux_j / fbase_norm(j) mcor_j = flux_j / fbase_norm(j) * Mstars(j) Flux_tot = Flux_tot + flux_j Mini_tot = Mini_tot + mini_j Mcor_tot = Mcor_tot + mcor_j end do c Compute mass fractions (mu_ini & mu_cor) associated with each base c component. do j=1,N_base flux_j = x(j) * fobs_norm * 10.**(0.4 * AV_tot(j) * q_norm) mini_j = flux_j / fbase_norm(j) mcor_j = flux_j / fbase_norm(j) * Mstars(j) mu_ini(j) = mini_j / Mini_tot mu_cor(j) = mcor_j / Mcor_tot end do end c ########################################################################### c ########################################################################### c # SIGMA-CLIPPING (excluding outliers) # c ########################################################################### c Given an observed (f_obs) and a model spectrum (f_syn) c mask-out/clip points with large residuals. 3 clipping methods are c offered: clip_method_option = "ABSRES", "RELRES" & "NSIGMA". In c the ABSRES method we clip points with |f_obs-f_syn| "ABSOLUTE" c residuals > sig_clip_threshold X the rms (f_obs - f_syn) over all c (non-masked) lambdas. [This was the only option in STARLIGHT up to c March/2005]. "RELRES" clipping consists of excluding points whose c RELATIVE residual |f_obs-f_syn|/error deviates by more than c sig_clip_threshold X the rms of this same quantity over all non c masked points. Finally, "NSIGMA" clipping consists of excluding c points whose |f_obs-f_syn| residual deviates by more than c sig_clip_threshold X the LOCAL error in f_obs. This scheme should c clip less points than ABSRES, since it may allow points with large c errors to be kept in f_obs for fitting. In all cases, exclusions c are added to weight_obs array, and clipped points are flaged as c f_mask(i) = -1 (just to mark them for output/control purposes). c c Cid@Lagoa - 24/Mar/2005 SUBROUTINE Clip_Spectrum(clip_method_option,f_syn $ ,sig_clip_threshold,f_mask,NOl_eff,Nl_eff,Ntot_cliped $ ,iCLIPBUG_flag) c Definitions implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) real l_obs(Nl_max) , f_obs(Nl_max) , weight_obs(Nl_max) real f_syn(Nl_max) , f_mask(Nl_max) , f_aux1(Nl_max) common/Obs/ Nl_obs , l_obs , f_obs , weight_obs character*6 clip_method_option c Clip-spectrum according to clip_method_option. if (clip_method_option.EQ.'NSIGMA') then c "NSIGMA" clipping! Compute # of points to be clipped, assign zero c weight & flag cliped points with f_mask = -1. Corrects c Nl_eff. Store original weight temporarely in f_aux1 (in case I c have to undo it below!) Ntot_cliped = 0 do i=1,Nl_obs f_aux1(i) = weight_obs(i) if (weight_obs(i).GT.0.) then rel_resid = (f_syn(i) - f_obs(i)) * weight_obs(i) if (abs(rel_resid).GT.sig_clip_threshold) then weight_obs(i) = 0. f_mask(i) = -1. Ntot_cliped = Ntot_cliped + 1 Nl_eff = Nl_eff - 1 end if end if end do else if (clip_method_option.EQ.'RELRES') then c "RELRES" clipping! Store RELATIVE residuals (= residue/error for c each lambda) in f_aux1. Compute mean & std dev of relative c residuals (only for non masked points). i_aux = 0 do i=1,Nl_obs if (weight_obs(i).GT.0.) then i_aux = i_aux + 1 f_aux1(i_aux) = (f_syn(i) - f_obs(i)) * weight_obs(i) end if end do call avevar(f_aux1,i_aux,ave_rel_resid,var_rel_resid) sig_rel_resid = sqrt(var_rel_resid) c Compute # of points to be clipped, assign zero weight & flag c cliped points with f_mask = -1. Corrects Nl_eff. Store original c weight temporarely in f_aux1 (in case I have to undo it below!) Ntot_cliped = 0 do i=1,Nl_obs f_aux1(i) = weight_obs(i) if (weight_obs(i).GT.0.) then rel_resid = (f_syn(i) - f_obs(i)) * weight_obs(i) if (abs(rel_resid).GT.(sig_clip_threshold*sig_rel_resid)) $ then weight_obs(i) = 0. f_mask(i) = -1. Ntot_cliped = Ntot_cliped + 1 Nl_eff = Nl_eff - 1 end if end if end do else if (clip_method_option.EQ.'ABSRES') then c "ABSRES" clipping! Store residuals in f_aux1. Compute mean & std c dev of residuals (only for non masked points). i_aux = 0 do i=1,Nl_obs if (weight_obs(i).GT.0.) then i_aux = i_aux + 1 f_aux1(i_aux) = f_syn(i) - f_obs(i) end if end do call avevar(f_aux1,i_aux,ave_resid,var_resid) sig_resid = sqrt(var_resid) c Compute # of points to be clipped, assign zero weight & flag c cliped points with f_mask = -1. Corrects Nl_eff. Store original c weight temporarely in f_aux1 (in case I have to undo it below!) Ntot_cliped = 0 do i=1,Nl_obs f_aux1(i) = weight_obs(i) if (weight_obs(i).GT.0.) then resid = f_syn(i) - f_obs(i) if (abs(resid).GT.(sig_clip_threshold*sig_resid)) then weight_obs(i) = 0. f_mask(i) = -1. Ntot_cliped = Ntot_cliped + 1 Nl_eff = Nl_eff - 1 end if end if end do else if (clip_method_option.NE.'NOCLIP') then write (*,'(a,a)') '[Clip_Spectrum] Bad clip_method_option: ' $ ,clip_method_option write (*,'(a)') '[Clip_Spectrum] Assuming method = NOCLIP' clip_method_option = 'NOCLIP' end if end if c For safety, I first test whether Nl_eff has not become c ridiculously small due to excessive clipping. If that happens, c clipping is aborted (ie, I restore weight_obs & Nl_eff) and a c clip-bug-flag is turned on! !2BEDONE! ATT: This minimum Nl_eff could be more smartly scaled ... if (Nl_eff.LT.50) then write (*,'(a,a,i5)') '[Clip_Spectrum] Too few points to model!' $ ,' clipping aborted ' , Nl_eff do i=1,Nl_obs weight_obs(i) = f_aux1(i) end do Nl_eff = NOl_eff Ntot_cliped = 0 iCLIPBUG_flag = 1 end if c Warn if > 20% of the data is being clipped... if (Ntot_cliped.GT.(0.2*NOl_eff)) then write (*,'(a,a,i5,3x,i5)') $ '[Clip_Spectrum] WARNING ! > 20% of original data', $ ' are being clipped-out... ' , Ntot_cliped , NOl_eff end if end c ########################################################################### c ########################################################################### c Compute the chi2 between a spectrum in f_SSP (passed via common!) c and an observed spectrum f_obs, as a function of the c extinction. The normalization x_SSP of the fitted-spectrum is c computed analyticaly (it's the one satisfying dchi2/dx = 0 for the c given AV), and returned via common). Useful to fit single c population spectra. c c Cid@Lagoa - 20/Jan/2007 *ETC* ATT: These SSP-fits do NOT include ETC-constraints! * Cid@Lagoa - 06/Jan/2011 FUNCTION F_SSP_chi2_AV(AV_SSP) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000) real l_obs(Nl_max) , f_obs(Nl_max) , weight_obs(Nl_max) common/Obs/ Nl_obs , l_obs , f_obs , weight_obs common/Red_factor/ red_term(Nl_max) common/SSP_chi2_stuff/ x_SSP , f_SSP(Nl_max) sum1 = 0. sum2 = 0. do i=1,Nl_obs if (weight_obs(i).GT.0.) then z1 = weight_obs(i)**2 z2 = 10.**(AV_SSP * red_term(i)) * f_SSP(i) sum1 = sum1 + z1 * z2 * f_obs(i) sum2 = sum2 + z1 * z2 * z2 end if end do x_SSP = sum1 / sum2 chi2_SSP = 0. do i=1,Nl_obs if (weight_obs(i).GT.0.) then z1 = 10.**(AV_SSP * red_term(i)) * x_SSP * f_SSP(i) chi2_SSP = chi2_SSP + (weight_obs(i) * (f_obs(i) - z1))**2 end if end do F_SSP_chi2_AV = chi2_SSP return end c ########################################################################### c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + ROUTINES FROM NUMERICAL-RECIPES + c + + c + avevar, mdian1, sort, ran2, golden, mnbrak, gasdev, indexx + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE avevar(data,n,ave,var) INTEGER n REAL ave,var,data(n) INTEGER j REAL s,ep ave=0.0 do 11 j=1,n ave=ave+data(j) 11 continue ave=ave/n var=0.0 ep=0.0 do 12 j=1,n s=data(j)-ave ep=ep+s var=var+s*s 12 continue var=(var-ep**2/n)/(n-1) return END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE MDIAN1(X,N,XMED) DIMENSION X(N) CALL SORT(N,X) N2=N/2 IF(2*N2.EQ.N)THEN XMED=0.5*(X(N2)+X(N2+1)) ELSE XMED=X(N2+1) ENDIF RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE SORT(N,RA) DIMENSION RA(N) L=N/2+1 IR=N 10 CONTINUE IF(L.GT.1)THEN L=L-1 RRA=RA(L) ELSE RRA=RA(IR) RA(IR)=RA(1) IR=IR-1 IF(IR.EQ.1)THEN RA(1)=RRA RETURN ENDIF ENDIF I=L J=L+L 20 IF(J.LE.IR)THEN IF(J.LT.IR)THEN IF(RA(J).LT.RA(J+1))J=J+1 ENDIF IF(RRA.LT.RA(J))THEN RA(I)=RA(J) I=J J=J+J ELSE J=IR+1 ENDIF GO TO 20 ENDIF RA(I)=RRA GO TO 10 END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC FUNCTION ran2(idum) INTEGER idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV REAL ran2,AM,EPS,RNMX PARAMETER (IM1=2147483563,IM2=2147483399,AM=1./IM1,IMM1=IM1-1, *IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791, *NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2e-7,RNMX=1.-EPS) INTEGER idum2,j,k,iv(NTAB),iy SAVE iv,iy,idum2 DATA idum2/123456789/, iv/NTAB*0/, iy/0/ if (idum.le.0) then idum=max(-idum,1) idum2=idum do 11 j=NTAB+8,1,-1 k=idum/IQ1 idum=IA1*(idum-k*IQ1)-k*IR1 if (idum.lt.0) idum=idum+IM1 if (j.le.NTAB) iv(j)=idum 11 continue iy=iv(1) endif k=idum/IQ1 idum=IA1*(idum-k*IQ1)-k*IR1 if (idum.lt.0) idum=idum+IM1 k=idum2/IQ2 idum2=IA2*(idum2-k*IQ2)-k*IR2 if (idum2.lt.0) idum2=idum2+IM2 j=1+iy/NDIV iy=iv(j)-idum2 iv(j)=idum if(iy.lt.1)iy=iy+IMM1 ran2=min(AM*iy,RNMX) return END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC FUNCTION golden(ax,bx,cx,f,tol,xmin) REAL golden,ax,bx,cx,tol,xmin,f,R,C EXTERNAL f PARAMETER (R=.61803399,C=1.-R) REAL f1,f2,x0,x1,x2,x3 x0=ax x3=cx if(abs(cx-bx).gt.abs(bx-ax))then x1=bx x2=bx+C*(cx-bx) else x2=bx x1=bx-C*(bx-ax) endif f1=f(x1) f2=f(x2) 1 if(abs(x3-x0).gt.tol*(abs(x1)+abs(x2)))then if(f2.lt.f1)then x0=x1 x1=x2 x2=R*x1+C*x3 f1=f2 f2=f(x2) else x3=x2 x2=x1 x1=R*x2+C*x0 f2=f1 f1=f(x1) endif goto 1 endif if(f1.lt.f2)then golden=f1 xmin=x1 else golden=f2 xmin=x2 endif return END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func) REAL ax,bx,cx,fa,fb,fc,func,GOLD,GLIMIT,TINY EXTERNAL func PARAMETER (GOLD=1.618034, GLIMIT=100., TINY=1.e-20) REAL dum,fu,q,r,u,ulim fa=func(ax) fb=func(bx) if(fb.gt.fa)then dum=ax ax=bx bx=dum dum=fb fb=fa fa=dum endif cx=bx+GOLD*(bx-ax) fc=func(cx) 1 if(fb.ge.fc)then r=(bx-ax)*(fb-fc) q=(bx-cx)*(fb-fa) u=bx-((bx-cx)*q-(bx-ax)*r)/(2.*sign(max(abs(q-r),TINY),q-r)) ulim=bx+GLIMIT*(cx-bx) if((bx-u)*(u-cx).gt.0.)then fu=func(u) if(fu.lt.fc)then ax=bx fa=fb bx=u fb=fu return else if(fu.gt.fb)then cx=u fc=fu return endif u=cx+GOLD*(cx-bx) fu=func(u) else if((cx-u)*(u-ulim).gt.0.)then fu=func(u) if(fu.lt.fc)then bx=cx cx=u u=cx+GOLD*(cx-bx) fb=fc fc=fu fu=func(u) endif else if((u-ulim)*(ulim-cx).ge.0.)then u=ulim fu=func(u) else u=cx+GOLD*(cx-bx) fu=func(u) endif ax=bx bx=cx cx=u fa=fb fb=fc fc=fu goto 1 endif return END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC !ESM! Obs: Modified to enforce the i_ChangeIdum = 0 option! ! This has nothing to do with ESM, but I found this bug while implementing it. ! Cid@UFSC - 14/Aug/2017 FUNCTION gasdev(idum) INTEGER idum REAL gasdev CU USES ran2! INTEGER iset REAL fac,gset,rsq,v1,v2,ran2 SAVE iset,gset !ESM! DATA iset/0/ !ESM! Introduced to allow reseting the modified gasdev() when i_ChangeIdum = 0 integer isetInit4gasdev common/Init4gasdev/ isetInit4gasdev iset = isetInit4gasdev if (iset.eq.0) then 1 v1=2.*ran2(idum)-1. v2=2.*ran2(idum)-1. rsq=v1**2+v2**2 if(rsq.ge.1..or.rsq.eq.0.)goto 1 fac=sqrt(-2.*log(rsq)/rsq) gset=v1*fac gasdev=v2*fac iset=1 else gasdev=gset iset=0 endif !ESM! isetInit4gasdev = iset return END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE indexx(n,arr,indx) INTEGER n,indx(n),M,NSTACK REAL arr(n) PARAMETER (M=7,NSTACK=50) INTEGER i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) REAL a do 11 j=1,n indx(j)=j 11 continue jstack=0 l=1 ir=n 1 if(ir-l.lt.M)then do 13 j=l+1,ir indxt=indx(j) a=arr(indxt) do 12 i=j-1,1,-1 if(arr(indx(i)).le.a)goto 2 indx(i+1)=indx(i) 12 continue i=0 2 indx(i+1)=indxt 13 continue if(jstack.eq.0)return ir=istack(jstack) l=istack(jstack-1) jstack=jstack-2 else k=(l+ir)/2 itemp=indx(k) indx(k)=indx(l+1) indx(l+1)=itemp if(arr(indx(l+1)).gt.arr(indx(ir)))then itemp=indx(l+1) indx(l+1)=indx(ir) indx(ir)=itemp endif if(arr(indx(l)).gt.arr(indx(ir)))then itemp=indx(l) indx(l)=indx(ir) indx(ir)=itemp endif if(arr(indx(l+1)).gt.arr(indx(l)))then itemp=indx(l+1) indx(l+1)=indx(l) indx(l)=itemp endif i=l+1 j=ir indxt=indx(l) a=arr(indxt) 3 continue i=i+1 if(arr(indx(i)).lt.a)goto 3 4 continue j=j-1 if(arr(indx(j)).gt.a)goto 4 if(j.lt.i)goto 5 itemp=indx(i) indx(i)=indx(j) indx(j)=itemp goto 3 5 indx(l)=indx(j) indx(j)=indxt jstack=jstack+2 !MODIFIED-by-ElCid@Sanchica - 16/Ago/2011: "pause" causes silly compilation warnings... ! if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' if(jstack.gt.NSTACK) then write (*,*) '[indexx] NSTACK too small in indexx... ' write (*,*) '[indexx] run aborted :-( !!' stop end if if(ir-i+1.ge.j-l)then istack(jstack)=ir istack(jstack-1)=i ir=j-1 else istack(jstack)=j-1 istack(jstack-1)=l l=i endif endif goto 1 END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + REDDENING-RELATED ROUTINES + c + + c + Calc_red_term - computes -0.4 * (A(lambda)/A_V - A(l_norm)/A_V) + c + Cardelli_RedLaw, Calzetti_RedLaw & HYPERZ_RedLaw + c + + c + To use HYPERZ_RedLaw use red_law_option = 'HZ1' ...'HZ5', where the + c + number = 1 for Allen 76 MW, = 2 for Seaton 79 + Fitzpatrick 86 MW, + c + = 3 for Fitzpatrick 86 LMC, = 4 for Prevot et al 84 and Bouchet et al + c + 85 SMC & = 5 for Calzetti (astro-ph/9911459). + c + + c + For Gordon et al (2003, ApJ, 594, 279, Table 4), use red_law_option = + c + 'GD1' => SMC Bar, 'GD2' => LMC2 SuperShell, 'GD3' => LMC Average + c + + c + The HZ1...HZ5 options are new to v02. (Cid@Lagoa - 14/Oct/2005) + c + And the GD1...GD3 options are new to v03. (Cid@Lagoa - 20/Jan/2007) + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c ########################################################################### c Routine Calc_red_term computes the "reddening term", defined by c c red_term(lambda) = -0.4 * (A(lambda) / A_V - A(l_norm) / A_V) c c such that to redden a flux at a certain lambda and keep the c normalization at l_norm all we need to do is to multiply the c reddening-free flux by c c 10**(A_V * red_term(lambda)) c c The A(lambda) / A_V (== q) law is from of Cardelli et al (1989) or c Calzetti et al. (according to red_law_option) c c Cid@INAOE - July/06/2004 c c + Force red_term = 0 at l_norm (it may be NE 0 due to precision c issues...) c Cid@Lagoa - 06/Jan/2005 c c Introduced HYPERZ laws (red_law_option = 'HZ1' ... 'HZ5') c OBS: I didn't quite like their sloppy interpolation at optical c wavelengths of the SMC law (eg, a straight line between 5291 c & 12500 Angs), bur could find nothing better! c c Cid@Lagoa - 14/October/2005 c Introduced Gordon SMC & LMC extinction curves, plus a general c "from-a-file" reddening law read from a file named c ExtinctionLaw.red_law_option! (Not fully tested yet!!) The c power-law option was included and then removed after implementing c the from-a-file option. c c Cid@Lagoa - 07/February/2007 *FIR* Added CCC law (Calzetti + Claus + Cid). Better than CAL at UV and IR * Cid@Granada - 22/January/2010 SUBROUTINE Calc_red_term(red_law_option,l_norm,nobs,lambda, & red_term,q_norm) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_FromFileMax = 100000) real l_FromFile(Nl_FromFileMax) , q_FromFile(Nl_FromFileMax) real lambda(nobs) , red_term(nobs) real l_norm ,q_norm , R_V , q character*3 red_law_option if (red_law_option.EQ.'CCM') then ! (Removed the obsolete R_V parameter - Cid@Granada - 24/Jan/2010) R_V = 3.1 q_norm = Cardelli_RedLaw(l_norm,R_V) do i=1,nobs q = Cardelli_RedLaw(lambda(i),R_V) red_term(i) = -0.4 * (q - q_norm) if (lambda(i).EQ.l_norm) red_term(i) = 0. end do else if (red_law_option.EQ.'CAL') then q_norm = Calzetti_RedLaw(l_norm) do i=1,nobs q = Calzetti_RedLaw(lambda(i)) red_term(i) = -0.4 * (q - q_norm) if (lambda(i).EQ.l_norm) red_term(i) = 0. end do else if (red_law_option.EQ.'CCC') then q_norm = CCC_RedLaw(l_norm) do i=1,nobs q = CCC_RedLaw(lambda(i)) red_term(i) = -0.4 * (q - q_norm) if (lambda(i).EQ.l_norm) red_term(i) = 0. end do else if (red_law_option.EQ.'HZ1') then q_norm = HYPERZ_RedLaw(l_norm,1) do i=1,nobs q = HYPERZ_RedLaw(lambda(i),1) red_term(i) = -0.4 * (q - q_norm) if (lambda(i).EQ.l_norm) red_term(i) = 0. end do else if (red_law_option.EQ.'HZ2') then q_norm = HYPERZ_RedLaw(l_norm,2) do i=1,nobs q = HYPERZ_RedLaw(lambda(i),2) red_term(i) = -0.4 * (q - q_norm) if (lambda(i).EQ.l_norm) red_term(i) = 0. end do else if (red_law_option.EQ.'HZ3') then q_norm = HYPERZ_RedLaw(l_norm,3) do i=1,nobs q = HYPERZ_RedLaw(lambda(i),3) red_term(i) = -0.4 * (q - q_norm) if (lambda(i).EQ.l_norm) red_term(i) = 0. end do else if (red_law_option.EQ.'HZ4') then q_norm = HYPERZ_RedLaw(l_norm,4) do i=1,nobs q = HYPERZ_RedLaw(lambda(i),4) red_term(i) = -0.4 * (q - q_norm) if (lambda(i).EQ.l_norm) red_term(i) = 0. end do else if (red_law_option.EQ.'HZ5') then q_norm = HYPERZ_RedLaw(l_norm,5) do i=1,nobs q = HYPERZ_RedLaw(lambda(i),5) red_term(i) = -0.4 * (q - q_norm) if (lambda(i).EQ.l_norm) red_term(i) = 0. end do !Cid29Dec06-FIX! Introduced Gordon SMC & LMC extinction curves else if ((red_law_option.EQ.'GD1').OR. $ (red_law_option.EQ.'GD2').OR. $ (red_law_option.EQ.'GD3')) then q_norm = GordonTab4_RedLaw(l_norm,red_law_option) do i=1,nobs q = GordonTab4_RedLaw(lambda(i),red_law_option) red_term(i) = -0.4 * (q - q_norm) if (lambda(i).EQ.l_norm) red_term(i) = 0. end do else !Cid01Feb07-FIX! If none of the red_law_options above worked, then we'll ! try reading a lambda q_lambda table from a file called: ! 'ExtinctionLaw'.red_law_option and interpolate from it! If that ! fails, stop run! The interpolation is in x = 10000 / lambda, and ! done in a very non-elegant fashion! write (*,'(a,a,a,a)') $ '[Calc_red_term] --> Will try reading extinction law ' , $ 'from file ExtinctionLaw.' , red_law_option , ' ... ' open (unit=1,file='ExtinctionLaw.'//red_law_option, $ status='old',err=501) do j=1,Nl_FromFileMax read (1,*,END=502) l_FromFile(j) , q_FromFile(j) end do close(1) write (*,'(a)') '[Calc_red_term] OOOPS! Should not be here!' write (*,'(a,a)') '[Calc_red_term] ' , $ 'Too many points in your ExtinctionLaw file? Run aborted!' stop 501 write (*,'(a,a)') '[Calc_red_term] OOPS! Bad red_law_option: ', $ red_law_option write (*,'(a,a,a)') '[Calc_red_term] File ExtinctionLaw.' , $ red_law_option , ' does not exist either!' write (*,'(a,a,a)') '[Calc_red_term] Run aborted!' stop 502 Nl_FromFile = j - 1 close(1) q_norm = 0. do j=1,Nl_FromFile-1 if ((l_FromFile(j).LE.l_norm).AND. $ (l_norm.LE.l_FromFile(j+1))) then x = 10000. / l_norm x1 = 10000. / l_FromFile(j) x2 = 10000. / l_FromFile(j+1) y1 = q_FromFile(j) y2 = q_FromFile(j+1) q_norm = y1 + (y2 - y1) / (x2 - x1) * (x - x1) end if end do do i=1,nobs q = 0. do j=1,Nl_FromFile-1 if ((l_FromFile(j).LE.lambda(i)).AND. $ (lambda(i).LE.l_FromFile(j+1))) then x = 10000. / lambda(i) x1 = 10000. / l_FromFile(j) x2 = 10000. / l_FromFile(j+1) y1 = q_FromFile(j) y2 = q_FromFile(j+1) q = y1 + (y2 - y1) / (x2 - x1) * (x - x1) end if end do red_term(i) = -0.4 * (q - q_norm) if (lambda(i).EQ.l_norm) red_term(i) = 0. end do write (*,'(a,a)') '[Calc_red_term] --> ' , $ 'Ok! Read Extinction Law file!' end if end c ########################################################################### c ########################################################################### c q = A_lambda / A_V for Cardelli et al reddening law c l = lambda, in Angstrons c x = 1 / lambda in 1/microns c q = a + b / R_V; where a = a(x) & b = b(x) c Cid@INAOE - 6/July/2004 FUNCTION Cardelli_RedLaw(l,R_V) real l , a , b , F_a , F_b , x , y , R_V , q a = 0. b = 0. x = 10000. / l c Far-Ultraviolet: 8 <= x <= 10 ; 1000 -> 1250 Angs if ((x.GE.8.).AND.(x.LE.10.)) then a = -1.073 - 0.628 * (x - 8.) + 0.137 * (x - 8.)**2 - & 0.070 * (x - 8.)**3 b = 13.670 + 4.257 * (x - 8.) - 0.420 * (x - 8.)**2 + & 0.374 * (x - 8.)**3 c Ultraviolet: 3.3 <= x <= 8 ; 1250 -> 3030 Angs else if ((x.GE.3.3).AND.(x.LE.8.)) then F_a = 0 F_b = 0 if ((x.GE.5.9).AND.(x.LE.8)) then F_a = -0.04473 * (x - 5.9)**2 - 0.009779 * (x - 5.9)**3 F_b = 0.2130 * (x - 5.9)**2 + 0.1207 * (x - 5.9)**3 end if a = 1.752 - 0.316 * x - 0.104 / ((x - 4.67)**2 + 0.341) + F_a b = -3.090 + 1.825 * x + 1.206 / ((x - 4.62)**2 + 0.263) + F_b c Optical/NIR: 1.1 <= x <= 3.3 ; 3030 -> 9091 Angs ; else if ((x.GE.1.1).AND.(x.LE.3.3)) then y = 10000. / l - 1.82 a = 1.+ 0.17699 * y - 0.50447 * y**2 - 0.02427 * y**3 + & 0.72085 * y**4 + 0.01979 * y**5 - 0.77530 * y**6 + & 0.32999 * y**7 b = 1.41338 * y + 2.28305 * y**2 + 1.07233 * y**3 - & 5.38434 * y**4 - 0.62251 * y**5 + 5.30260 * y**6 - & 2.09002 * y**7 c Infrared: 0.3 <= x <= 1.1 ; 9091 -> 33333 Angs ; else if ((x.GE.0.3).AND.(x.LE.1.1)) then a = 0.574 * x**1.61 b = -0.527 * x**1.61 end if q = a + b / R_V c Issue a warning if lambda falls outside 1000 -> 33333 Angs range of CCM89 if ((x.LT.0.3).OR.(x.GT.10.)) then q = 0. ! write (*,*) '[Cardelli_RedLaw] WARNING! ' , ! & 'lambda outside valid range: ' , l , x end if Cardelli_RedLaw = q return end c ########################################################################### c ########################################################################### c q = A_lambda / A_V for Calzetti et al reddening law (formula from c hyperz-manual). c l = lambda, in Angstrons c x = 1 / lambda in 1/microns c Cid@INAOE - 6/July/2004 FUNCTION Calzetti_RedLaw(l) real l , x , R_V , q x = 10000. / l R_V = 4.05 c UV -> Optical: 1200 -> 6300 Angs if ((l.GE.1200.).AND.(l.LE.6300.)) then q = (2.659 / R_V) * (-2.156 + 1.509 * x - 0.198 * x**2 + & 0.011 * x**3) + 1. c Red -> Infrared else if ((l.GE.6300.).AND.(l.LE.22000.)) then q = (2.659 / R_V) * (-1.857 + 1.040 * x) + 1. c Issue a warning if lambda falls outside 1200->22000 Angs range else q = 0. ! write (*,*) '[Calzetti_RedLaw] WARNING! ' , ! & 'lambda outside valid range: ' , l , x end if Calzetti_RedLaw = q return end c ########################################################################### c ########################################################################### c CCC = "Calzetti + Claus + Cid" - law: Returns $2 = q(l) = A(l) / AV; for c given l = (in Angs). Strictly valid from 970 to 22000, but c extrapolated to 912 -> 31149 Angs. UV: I switch from the c Leitherer to the Calzetti law at 1846 Angs. This is a bit longer c than the nominal limit of the Leitherer law, but is is where the c two equations meet and so the transition is smooth. In the IR, c extrapolating the Calzetti law to l > 22000 we find that it c becomes = 0 at 31149.77 Angs. I thus set q = 0 for l > 3149. c c Cid@Granada - 22/Jan/2010 FUNCTION CCC_RedLaw(l) real l , x , R_V , q x = 10000. / l R_V = 4.05 c FUV: 912 -> 1846. Leitherer et al 2002 (ApJS, 140, 303), eq 14, c valid from 970 to 1800 Angs, but extended to 912 -> 1846. OBS: c They use E(B_V)_stars in their eq, so I divide by R_V, assumed to c be the same as for the Calzetti-law. if ((l.GE.912.).AND.(l.LE.1846.)) then q = (5.472 + 0.671 * x - 9.218e-3 * x**2 + 2.620e-3 * x**3)/R_V c UV -> optical: 1846 -> 6300. Calzetti law. else if ((l.GT.1846.).AND.(l.LE.6300.)) then q = (2.659 / R_V) * (-2.156 + 1.509 * x - 0.198 * x**2 + & 0.011 * x**3) + 1. c Red -> Infrared: 6300 -> 31149. Calzetti law, originally valid up c to 22000 Angs, but stretched up to 31149 Angs, where it becomes c zero. else if ((l.GT.6300.).AND.(l.LE.31149.)) then q = (2.659 / R_V) * (-1.857 + 1.040 * x) + 1. c q = ZERO for l < 912 & l > 31149 Angs. else q = 0. end if CCC_RedLaw = q return end c ########################################################################### c ########################################################################### c q = A_lambda / A_V for one of the 5 reddening laws in HYPERZ. c This is just a sloppy DRIVER for the HYPERZ fortran routine red_spec! c I call their routine with a wavelength array containing just one c lambda (l_aux(1) = l), and tell it to return me the reddened c spectrum f_obs_aux(1) for an intrinsic spectrum f_int_aux(1) = 1.0 c and A_V = 1. From this we derive q = -2.5 * log10(f_obs_aux(1)). c c l = lambda, in Angstrons c ilaw_rd=1 : the standard variation of absorption with wavelength c is used (Allen, 76) - MW c ilaw_rd=2 : the analytic fit of Seaton (79) curve by c Fitzpatrick (86) - MW c ilaw_rd=3 : Fitzpatrick (86) - LMC c ilaw_rd=4 : Prevot et al. (1984) and Bouchet et al. (1985) - SMC c ilaw_rd=5 : Calzetti (astro-ph/9911459) - SB c c Cid@Lagoa - 14/October/2005 !FIX-DAE2-WARNING-HYPERZ! ! To avoid the compilation warning (and potential BUGS, like those reported ! by Marianne Takamiya on her Wed, Jun 8, 2011 at 2:32 AM mail, ! I've changed ! real l_aux(1) , f_int_aux(1) , f_obs_aux(1) ! to ! real l_aux(1300) , f_int_aux(1300) , f_obs_aux(1300) ! This compatibilizes this FUNCTION with the HYPER-one - at least dae2's gfortran 4.6.1 does ! not issue any more warnings :-) ! ! ElCid@Sanchica - 21/Oct/2011 FUNCTION HYPERZ_RedLaw(l,ilaw_rd) real l_aux(1300) , f_int_aux(1300) , f_obs_aux(1300) real l , q l_aux(1) = l f_int_aux(1) = 1. call HYPERZ_red_spec(l_aux,f_int_aux,1.0,f_obs_aux,1,1,ilaw_rd) q = -2.5 * log10(f_obs_aux(1)) HYPERZ_RedLaw = q return end c ########################################################################### CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C This was "borrowed" from hyperz @ webast.ast.obs-mip.fr/hyperz/ C I've just copied their red_spec.f (in zphot_src_1.1.tar.gz). I C have, though fixed their 'if lambda is in an interval' conditions, C as marked below. C Cid@Lagoa - 14/October/2005 SUBROUTINE HYPERZ_red_spec(wl,fl,av,yob,ired,iwavl,law_rd) c Reads a spectrum and calculates the new one with internal c reddening. c law_rd=1 : the standard variation of absorption with wavelength c is used (Allen, 76) - MW c law_rd=2 : the analytic fit of Seaton (79) curve by c Fitzpatrick (86) - MW c law_rd=3 : Fitzpatrick (86) - LMC c law_rd=4 : Prevot et al. (1984) and Bouchet et al. (1985) - SMC c law_rd=5 : Calzetti (astro-ph/9911459) - SB c !Cid! INCLUDE 'dimension.dec' I've included it here:) PARAMETER (mxz=141,mxage=51,mxtyp=15,mxfil=20,mxred=11,mxwl=1300) INTEGER ired,iwavl,law_rd REAL yob,alambda,wl,fl,wab,amab,aab,av,ff,ff11,ff12,slope,rv DIMENSION yob(mxwl),wl(mxwl),fl(mxwl),wab(30),amab(30),aab(30) c ..... 1. Allen (1976) : wab = lambda in A, amab = k(lambda)/R, c A(lambda) = k(lambda)*E(B-V) = amab*A_V ; R = 3.1 IF (law_rd.eq.1) THEN rv=3.1 wab(1)=1000. amab(1)=4.2 wab(2)=1110. amab(2)=3.7 wab(3)=1250. amab(3)=3.3 wab(4)=1430. amab(4)=3. wab(5)=1670. amab(5)=2.7 wab(6)=2000. amab(6)=2.8 wab(7)=2220. amab(7)=2.9 wab(8)=2500. amab(8)=2.30 wab(9)=2850. amab(9)=1.97 wab(10)=3330. amab(10)=1.69 wab(11)=3650. amab(11)=1.58 wab(12)=4000. amab(12)=1.45 wab(13)=4400. amab(13)=1.32 wab(14)=5000. amab(14)=1.13 wab(15)=5530. amab(15)=1.00 wab(16)=6700. amab(16)=0.74 wab(17)=9000. amab(17)=0.46 wab(18)=10000. amab(18)=0.38 wab(19)=20000. amab(19)=0.11 wab(20)=100000. amab(20)=0.0 DO i=1,19 aab(i)=amab(i)*av END DO DO ik=1,iwavl IF (wl(ik).le.wab(1)) then ccc=(aab(1)-aab(2))/(wab(2)-wab(1)) alambda=aab(1)+(wab(1)-wl(ik))*ccc ELSE IF(wl(ik).ge.wab(19))then ccc=(aab(19)-aab(20))/(wab(20)-wab(19)) alambda=aab(19)+(wab(19)-wl(ik))*ccc ELSE IF (wl(ik).gt.wab(1).and.wl(ik).lt.wab(19)) then DO i=1,19 !Cid-fix! IF (wl(ik).ge.wab(i).and.wl(ik).lt.wab(i+1)) then IF (wl(ik).ge.wab(i).and.wl(ik).le.wab(i+1)) then ccc=(aab(i)-aab(i+1))/(wab(i+1)-wab(i)) alambda=aab(i)+(wab(i)-wl(ik))*ccc END IF END DO END IF IF (alambda.lt.0.) alambda=0. IF (ired.eq.1) yob(ik)=fl(ik)*(10**(-0.4*alambda)) IF (ired.eq.2) yob(ik)=fl(ik)*(10**(0.4*alambda)) END DO RETURN c ..... 2. Seaton (1979) - Fitzpatrick fit : c for lambda < 1200 A slope from 1100-1200 c for lambda > 3650 A points from Allen c ff = E(lambda-V)/E(B-V) = k(lambda)-R c A(lambda)=A_V*(ff/R +1) ; R = 3.1 ELSE IF (law_rd.eq.2) THEN rv=3.1 al0=4.595 ga=1.051 c1=-0.38 c2=0.74 c3=3.96 c4=0.26 call red(1100.,al0,ga,c1,c2,c3,c4,ff) ff11=ff call red(1200.,al0,ga,c1,c2,c3,c4,ff) ff12=ff slope=(ff12-ff11)/100. wab(11)=3650. amab(11)=1.58 wab(12)=4000. amab(12)=1.45 wab(13)=4400. amab(13)=1.32 wab(14)=5000. amab(14)=1.13 wab(15)=5530. amab(15)=1.00 wab(16)=6700. amab(16)=0.74 wab(17)=9000. amab(17)=0.46 wab(18)=10000. amab(18)=0.38 wab(19)=20000. amab(19)=0.11 wab(20)=100000. amab(20)=0.0 DO i=11,19 aab(i)=amab(i)*av END DO DO ik=1,iwavl IF (wl(ik).ge.1200..and.wl(ik).le.3650.) then call red(wl(ik),al0,ga,c1,c2,c3,c4,ff) alambda=av*(ff/rv+1.) ELSE IF (wl(ik).lt.1200.) then ff=ff11+(wl(ik)-1100.)*slope alambda=av*(ff/rv+1.) ELSE IF(wl(ik).ge.wab(19))then !extrapol at high wavelengths ccc=(aab(19)-aab(20))/(wab(20)-wab(19)) alambda=aab(19)+(wab(19)-wl(ik))*ccc ELSE IF (wl(ik).gt.3650..and.wl(ik).lt.wab(19)) then DO i=11,19 !Cid-fix! IF (wl(ik).gt.wab(i).and.wl(ik).lt.wab(i+1)) then IF (wl(ik).ge.wab(i).and.wl(ik).le.wab(i+1)) then ccc=(aab(i)-aab(i+1))/(wab(i+1)-wab(i)) alambda=aab(i)+(wab(i)-wl(ik))*ccc END IF END DO END IF IF (alambda.lt.0.) alambda=0. IF (ired.eq.1) yob(ik)=fl(ik)*(10**(-0.4*alambda)) IF (ired.eq.2) yob(ik)=fl(ik)*(10**(0.4*alambda)) END DO RETURN c ..... 3. Fitzpatrick (1986) : c for lambda < 1200 A slope derived from 1100-1200 c for lambda > 3330 A points from Allen c ff = E(lambda-V)/E(B-V) = k(lambda)-R c A(lambda) = A_V*(ff/R +1) ; R = 3.1 ELSE IF (law_rd.eq.3) THEN rv=3.1 al0=4.608 ga=0.994 c1=-0.69 c2=0.89 c3=2.55 c4=0.50 call red(1100.,al0,ga,c1,c2,c3,c4,ff) ff11=ff call red(1200.,al0,ga,c1,c2,c3,c4,ff) ff12=ff slope=(ff12-ff11)/100. wab(10)=3330. amab(10)=1.682 wab(11)=3650. amab(11)=1.58 wab(12)=4000. amab(12)=1.45 wab(13)=4400. amab(13)=1.32 wab(14)=5000. amab(14)=1.13 wab(15)=5530. amab(15)=1.00 wab(16)=6700. amab(16)=0.74 wab(17)=9000. amab(17)=0.46 wab(18)=10000. amab(18)=0.38 wab(19)=20000. amab(19)=0.11 wab(20)=100000. amab(20)=0.0 DO i=10,19 aab(i)=amab(i)*av END DO DO ik=1,iwavl IF (wl(ik).ge.1200..and.wl(ik).le.3330.) then call red(wl(ik),al0,ga,c1,c2,c3,c4,ff) alambda=av*(ff/rv+1.) ELSE IF (wl(ik).lt.1200.) then ff=ff11+(wl(ik)-1100.)*slope alambda=av*(ff/rv+1.) ELSE IF(wl(ik).ge.wab(19))then !extrapol at high wavelengths ccc=(aab(19)-aab(20))/(wab(20)-wab(19)) alambda=aab(19)+(wab(19)-wl(ik))*ccc ELSE IF (wl(ik).gt.3330..and.wl(ik).lt.wab(19)) then DO i=10,19 !Cid-fix! IF (wl(ik).gt.wab(i).and.wl(ik).lt.wab(i+1)) then IF (wl(ik).ge.wab(i).and.wl(ik).le.wab(i+1)) then ccc=(aab(i)-aab(i+1))/(wab(i+1)-wab(i)) alambda=aab(i)+(wab(i)-wl(ik))*ccc END IF END DO END IF IF (alambda.lt.0.) alambda=0. IF (ired.eq.1) yob(ik)=fl(ik)*(10**(-0.4*alambda)) IF (ired.eq.2) yob(ik)=fl(ik)*(10**(0.4*alambda)) END DO RETURN c ..... 4. Prevot (1984) and Bouchet (1985) : c wab = lambda in A, c amab = E(lambda-V)/E(B-V) = k(lambda)-R c A(lambda) = A_V*(amab/R +1) c N.B. R = 2.72 ELSE IF (law_rd.eq.4) THEN rv=2.72 wab(1)=1275. amab(1)=13.54 wab(2)=1330. amab(2)=12.52 wab(3)=1385. amab(3)=11.51 wab(4)=1435. amab(4)=10.80 wab(5)=1490. amab(5)=9.84 wab(6)=1545. amab(6)=9.28 wab(7)=1595. amab(7)=9.06 wab(8)=1647. amab(8)=8.49 wab(9)=1700. amab(9)=8.01 wab(10)=1755. amab(10)=7.71 wab(11)=1810. amab(11)=7.17 wab(12)=1860. amab(12)=6.90 wab(13)=1910. amab(13)=6.76 wab(14)=2000. amab(14)=6.38 wab(15)=2115. amab(15)=5.85 wab(16)=2220. amab(16)=5.30 wab(17)=2335. amab(17)=4.53 wab(18)=2445. amab(18)=4.24 wab(19)=2550. amab(19)=3.91 wab(20)=2665. amab(20)=3.49 wab(21)=2778. amab(21)=3.15 wab(22)=2890. amab(22)=3.00 wab(23)=2995. amab(23)=2.65 wab(24)=3105. amab(24)=2.29 wab(25)=3704. amab(25)=1.81 wab(26)=4255. amab(26)=1.00 wab(27)=5291. amab(27)=0.00 wab(28)=12500. amab(28)=-2.02 wab(29)=16500. amab(29)=-2.36 wab(30)=22000. amab(30)=-2.47 DO i=1,30 aab(i)=av*(amab(i)/rv+1.) END DO DO ik=1,iwavl IF (wl(ik).le.wab(1)) THEN !extrapol at short wavelengths ccc=(aab(1)-aab(2))/(wab(2)-wab(1)) alambda=aab(1)+(wab(1)-wl(ik))*ccc ELSE IF(wl(ik).ge.wab(30))then !extrapol at high wavelengths ccc=(aab(29)-aab(30))/(wab(30)-wab(29)) alambda=aab(29)+(wab(29)-wl(ik))*ccc ELSE IF (wl(ik).gt.wab(1).and.wl(ik).lt.wab(30)) THEN DO i=1,30 !Cid-fix! IF (wl(ik).gt.wab(i).and.wl(ik).lt.wab(i+1)) THEN IF (wl(ik).ge.wab(i).and.wl(ik).le.wab(i+1)) THEN ccc=(aab(i)-aab(i+1))/(wab(i+1)-wab(i)) alambda=aab(i)+(wab(i)-wl(ik))*ccc END IF END DO END IF IF (alambda.lt.0.) alambda=0. IF (ired.eq.1) yob(ik)=fl(ik)*(10**(-0.4*alambda)) IF (ired.eq.2) yob(ik)=fl(ik)*(10**(0.4*alambda)) END DO RETURN c ..... Calzetti (1999) : c for lambda < 1200 A slope derived from 1100-1200 A c for lambda > 22000A slope derived from 21900-22000 A c ff = k(lambda); A(lambda) = A_V*k(lambda)/R ; R = 4.05 ELSE IF (law_rd.eq.5) THEN rv=4.05 p11=1/0.11 ff11=2.659*(-2.156+1.509*p11-0.198*p11**2 . +0.011*p11**3)+rv p12=1/0.12 ff12=2.659*(-2.156+1.509*p12-0.198*p12**2 . +0.011*p12**3)+rv slope1=(ff12-ff11)/100. ff99=2.659*(-1.857+1.040/2.19)+rv ff100=2.659*(-1.857+1.040/2.2)+rv slope2=(ff100-ff99)/100. DO ik=1,iwavl ala=wl(ik)*1.E-4 !wavelength in microns p=1./ala IF (ala.ge.0.63.and.ala.le.2.2) then ff=2.659*(-1.857+1.040*p)+rv ELSE IF (ala.ge.0.12.and.ala.lt.0.63) then ff=2.659*(-2.156+1.509*p-0.198*p**2+0.011*p**3)+rv ELSE IF (ala.lt.0.12) THEN ff=ff11+(wl(ik)-1100.)*slope1 ELSE IF (ala.gt.2.2) THEN ff=ff99+(wl(ik)-21900.)*slope2 END IF alambda=av*ff/rv IF (alambda.lt.0.) alambda=0. IF (ired.eq.1) yob(ik)=fl(ik)*(10**(-0.4*alambda)) IF (ired.eq.2) yob(ik)=fl(ik)*(10**(0.4*alambda)) END DO RETURN END IF WRITE(*,*) ' No reddening law is given.....' RETURN END c ---------------------------------------------------------------------- SUBROUTINE red(alan,al0,ga,c1,c2,c3,c4,ff) c.......According to Fitzpatrick, 86 ala=alan*1.E-4 !wavelength in microns p=1.0/ala IF (p.lt.5.9) c4=0.0 t1=c3/(((p-(al0**2/p))**2)+ga*ga) t2=c4*(0.539*((p-5.9)**2)+0.0564*((p-5.9)**3)) ff=c1+c2*p+t1+t2 RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c ########################################################################### c Gordon SMC & LMC extinction curves c After failing to implement Gordon's LMC & SMC laws in analytical c form (their equation 5, with parameters from Table 3 and R_V from c Sec 3.4 & Table 2), I have just copied their Table 4 and c interpolate linearly (in x). c c q = A_lambda / A_V from Gordon et al 2003, ApJ, 594, 279, Table 4. c l = lambda, in Angstrons c x = 1 / lambda in 1/microns c red_law_option = 'GD1' => SMC Bar c = 'GD2' => LMC2 SuperShell c = 'GD3' => LMC Average c c Cid@Lagoa - 30/December/2006 FUNCTION GordonTab4_RedLaw(l,red_law_option) implicit real (a-h,j-m,o-z) implicit integer (i,n) parameter (N_Gordon = 29) real x_Gordon(N_Gordon) , q_Gordon(N_Gordon) real q_SMCbar(N_Gordon) , q_LMC2(N_Gordon) , q_LMCave(N_Gordon) character*3 red_law_option c Table 4 of Gordon et al (Sample Average Curves) c OBS: The Table has 2 empty entries for LMC2 & LMCave, at x = 1.235 c & 1.538. These entries were interpolated linearly in the c data-blocks below. data x_Gordon/ 0.455 , 0.606 , 0.800 , 1.235 , 1.538 , 1.818 , $ 2.273 , 2.703 , 3.375 , 3.625 , 3.875 , 4.125 , 4.375 , $ 4.625 , 4.875 , 5.125 , 5.375 , 5.625 , 5.875 , 6.125 , $ 6.375 , 6.625 , 6.875 , 7.125 , 7.375 , 7.625 , 7.875 , $ 8.125 , 8.375 / data q_SMCbar/ 0.016 , 0.169 , 0.131 , 0.567 , 0.801 , 1.000 , $ 1.374 , 1.672 , 2.000 , 2.220 , 2.428 , 2.661 , 2.947 , $ 3.161 , 3.293 , 3.489 , 3.637 , 3.866 , 4.013 , 4.243 , $ 4.472 , 4.776 , 5.000 , 5.272 , 5.575 , 5.795 , 6.074 , $ 6.297 , 6.436 / data q_LMC2/ 0.101 , 0.097 , 0.299 , 0.5004, 0.7600, 1.000 , $ 1.349 , 1.665 , 1.899 , 2.067 , 2.249 , 2.447 , 2.777 , $ 2.922 , 2.921 , 2.812 , 2.805 , 2.863 , 2.932 , 3.060 , $ 3.110 , 3.299 , 3.408 , 3.515 , 3.670 , 3.862 , 3.937 , $ 4.055 , 3.969 / data q_LMCave/ 0.030 , 0.186 , 0.257 , 0.4705, 0.7457, 1.000 , $ 1.293 , 1.518 , 1.786 , 1.969 , 2.149 , 2.391 , 2.771 , $ 2.967 , 2.846 , 2.646 , 2.565 , 2.566 , 2.598 , 2.607 , $ 2.668 , 2.787 , 2.874 , 2.983 , 3.118 , 3.231 , 3.374 , $ 3.366 , 3.467 / c Define x & store appropriate q onto q_Gordon x = 10000. / l do i=1,N_Gordon if (red_law_option.EQ.'GD1') then q_Gordon(i) = q_SMCbar(i) else if (red_law_option.EQ.'GD2') then q_Gordon(i) = q_LMC2(i) else if (red_law_option.EQ.'GD3') then q_Gordon(i) = q_LMCave(i) else write (*,*) 'OOPS! Bad red_law_option = ',red_law_option stop end if end do c Linear interpolation of q = a x + b do i=1,N_Gordon-1 if ((x.GE.x_Gordon(i)).AND.(x.LE.x_Gordon(i+1))) then q = q_Gordon(i) + (q_Gordon(i+1) - q_Gordon(i)) * $ (x - x_Gordon(i)) / (x_Gordon(i+1) - x_Gordon(i)) GordonTab4_RedLaw = q return end if end do c If lambda is outside Table 4 range, return zero, GordonTab4_RedLaw = 0. return end c ########################################################################### c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + SYNTHETIC SPECTRUM, CHI2 & RAPID-CHI2 ("RC") ROUTINES + c + + c + calc_Fsyn + c + Kcalc_Fsyn + c + SlowF_chi2 + c + FK_chi2 + c + Calc_RC_terms + c + VeryFastF_chi2 + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c ########################################################################### c Compute synthetic spectrum f_syn(l_syn) for given population & c extinction vectors, x(j) & AV_tot(j). Stellar kinematics (if any) c is inside the f_base matrix (as set elsewhere)! c OBS: Reddening term, base matrix & Nl_obs passed by common! c Cid@Lagoa - Jan/11/2005 SUBROUTINE calc_Fsyn(x,AV_tot,f_syn) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) real l_obs(Nl_max) , f_obs(Nl_max) , weight_obs(Nl_max) real x(Nb_max) , AV_tot(Nb_max) real f_base(Nb_max,Nl_max) , f_syn(Nl_max) common/Red_factor/ red_term(Nl_max) common/Base/ N_base , f_base common/Obs/ Nl_obs , l_obs , f_obs , weight_obs do i=1,Nl_obs f_syn(i) = 0. do j=1,N_base f_syn(i) = f_syn(i) + f_base(j,i) * abs(x(j)) * & 10.**(AV_tot(j) * red_term(i)) end do end do end c ########################################################################### c ########################################################################### c Compute synthetic spectrum f_syn(l_syn) for given population & c extinction vectors, x(j) & AV_tot(j), AND kinematical parameters c v0 & vd. A synthetic spectrum f(x,AV_tot) is 1st computed & then c convolved with a Gaussian of velocity center = v0 & velocity c dispersion = vd (both in km/s). c Cid@Lagoa - Jan/11/2005 SUBROUTINE Kcalc_Fsyn(Nl_syn,x,AV_tot,v0,vd,f_syn) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) real l_obs(Nl_max) , f_obs(Nl_max) , weight_obs(Nl_max) real l_aux(Nl_max) , f_aux(Nl_max) , f_syn(Nl_max) real x(Nb_max) , AV_tot(Nb_max) common/Obs/ Nl_obs , l_obs , f_obs , weight_obs common/N_Gauss/ N_int_Gauss !Cid14Jan07-FXK! Added FXK = Fixed kinematics option!! common/FXK_fits/ IsThisAnFXKFit !Cid14Jan07-FXK! If this is a FXK-fit then we should NOT apply the ! kinematical filter, as it has already been applied to the base!! ! Just call calc_Fsyn & return. if (IsThisAnFXKFit.EQ.1) then call calc_Fsyn(x,AV_tot,f_syn) return end if c Synthetic spectrum f_aux. Also define l_aux (used below). It is c presumed that the base spectra in f_base are in their original c form (ie, not convolved with a kinematical filter)!! call calc_Fsyn(x,AV_tot,f_aux) c Apply kinematical filter! (aux variables used to avoid repeating c variable names in the call to GaussSmooth). Returns the convolved c spectrum f_syn. Nl_aux = Nl_syn do i=1,Nl_syn l_aux(i) = l_obs(i) end do call GaussSmooth(Nl_aux,l_aux,f_aux,v0,vd, & N_int_Gauss,Nl_syn,l_obs,f_syn) end c ########################################################################### c ########################################################################### c Compute chi2(x,AV_tot). Kinematical parameters are implicit in f_base! c I now call this function "Slow" because it is slow compared to the c Rapid-Chi2 tricks developed. Most of the code used rapid-chi2 c functions. This one is only used to check results. c Cid@Lagoa - Jan/11/2005 FUNCTION SlowF_chi2(x,AV_tot) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) real l_obs(Nl_max) , f_obs(Nl_max) , weight_obs(Nl_max) real x(Nb_max) , AV_tot(Nb_max) real f_base(Nb_max,Nl_max) , f_syn(Nl_max) common/Red_factor/ red_term(Nl_max) common/Base/ N_base , f_base common/Obs/ Nl_obs , l_obs , f_obs , weight_obs !OPTfn! Optically optimal fn - computed here and passed on common/Optimize_fn_OPT/ IsOptimize_fn_OPT , Optimal_fn_OPT !ESM! chi2_OPTICAL now shared through this common! common/OpticalChi2/chi2_OPTICAL , ETC_GlobalChi2ScaleFactor call calc_Fsyn(x,AV_tot,f_syn) chi2 = 0. do i=1,Nl_obs chi2 = chi2 + (f_syn(i) - f_obs(i)) * weight_obs(i) * & (f_syn(i) - f_obs(i)) * weight_obs(i) end do *ETC* Adding all ETC-chi2's to optical-chi2! !ESM! Defining chi2_OPTICAL, passed via common/OpticalChi2/ chi2_OPTICAL = chi2 chi2_ETC = ETC_CalcETCchi2(x,AV_tot,'SFc') SlowF_chi2 = ETC_GlobalChi2ScaleFactor * $ (chi2_OPTICAL + chi2_ETC) !OPTfn! Added computation of Optimal_fn_OPT just in case... At the very least, the code ! will definitely need it in the unlikely case i_UseSlowChi2Always.EQ.1. ! ElCid@Sanchica - 28/Jan/2012 chi2_2 = 0. chi2_3 = 0. do i=1,Nl_obs chi2_2 = chi2_2 - 2. * f_syn(i) * weight_obs(i) * f_obs(i) * $ weight_obs(i) chi2_3 = chi2_3 + f_syn(i) * weight_obs(i) * f_syn(i) * $ weight_obs(i) end do Optimal_fn_OPT = -(chi2_2/2.) / chi2_3 return end c ########################################################################### c ########################################################################### c Compute chi2(x,AV_tot,v0,vd), INCLUDING kinematical parameters! c This a "Slow" function, ie, no RC-tricks are used. In fact, it is c Very slow, since it convolves the spectrum with the G(v0,vd) c filter... c Cid@Lagoa - Jan/11/2005 FUNCTION FK_chi2(x,AV_tot,v0,vd) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) real l_obs(Nl_max) , f_obs(Nl_max) , weight_obs(Nl_max) real x(Nb_max) , AV_tot(Nb_max) , f_syn(Nl_max) common/Obs/ Nl_obs , l_obs , f_obs , weight_obs !ESM! chi2_OPTICAL now shared through this common! common/OpticalChi2/chi2_OPTICAL , ETC_GlobalChi2ScaleFactor call Kcalc_Fsyn(Nl_obs,x,AV_tot,v0,vd,f_syn) chi2 = 0. do i=1,Nl_obs chi2 = chi2 + (f_syn(i) - f_obs(i)) * weight_obs(i) * & (f_syn(i) - f_obs(i)) * weight_obs(i) end do *ETC* Adding all ETC-chi2's to optical-chi2! !ESM! Defining chi2_OPTICAL, passed via common/OpticalChi2/ chi2_OPTICAL = chi2 chi2_ETC = ETC_CalcETCchi2(x,AV_tot,'FKc') FK_chi2 = ETC_GlobalChi2ScaleFactor * $ (chi2_OPTICAL + chi2_ETC) return end c ########################################################################### c ########################################################################### c Compute RC-terms. These are the terms in chi2 which do NOT depend c on either x, AV nor YAV, and thus do not be recomputed every time c x, AV or YAV changes, allowing enormous speed gains! This trick c requires expanding the 10**(AV_tot(j) * red_term(lambda)) factor c in a series and truncating it to its first NRC_AV terms, which is c Ok as long as |AV| does not go much beyond ~ 1... The first term c (RC1) is always the same, whereas the 2nd and 3rd terms (RC2 & c RC3) need to be re-computed everytime something was done to v0 c and/or vd.... The VeryFastF_chi2 routine below use RC1, RC2 & RC3, c as well as NRC_AV (the number of terms in the truncated c AV-series). See notes for more details! c c This routine can be made faster by introducing some "memory" so c that only new terms in the AV-series need to be computed. However, c this should NOT be useful, since I expect it to be called mostly c when a full-recalculation is needed (eg, when f_base c changes). Re-calls to the routine due to precision bugs should be c only occasional. Hence I did not attempt to optimize it further. c c Cid@Lagoa - 9/May/2004 c OBS: Some of the initial steps, like the definition of the c factorial and beta arrays, could be done only once in the code, c but they take so little time that I kept them here for c conciseness... c Now adapted to AV = AV_tot(j), ie, population dependent c extinctions! c Cid@Lagoa - 12/Jan/2005 SUBROUTINE Calc_RC_terms c *************************************************************************** c * Definitions * c *************************************************************************** implicit real (a-h,k-m,o-z) implicit integer (i,j,n) * MEX-OBS: Changed NRCAV_max parameter (Nl_max = 20000,Nb_max = 300,NRCAV_max = 35) real l_obs(Nl_max) , f_obs(Nl_max) , weight_obs(Nl_max) real f_base(Nb_max,Nl_max) double precision RC1 , RC2(NRCAV_max,Nb_max) , & RC3(NRCAV_max,Nb_max,Nb_max) , eta_AV double precision factorial(NRCAV_max) , rho(Nl_max) , beta(Nl_max) double precision soma , ln10 common/Red_factor/ red_term(Nl_max) common/Base/ N_base , f_base common/Obs/ Nl_obs , l_obs , f_obs , weight_obs common/RapidChi2/ RC1 , RC2 , RC3 , eta_AV common/RC_AV_Stuff/ NRC_AV , i_RC_CRASH_FLAG , NRC_AV_Default c *************************************************************************** c *************************************************************************** c * Initialization * c *************************************************************************** c Test if NRC_AV exceed its limit! If so then set a CRASH_FLAG! c OBS: Once i_RC_CRASH_FLAG = 1, it'll stay so till the end of the c code! If a "crash" occurs we set NRC_AV = NRCAV_max and go on... if (NRC_AV.GT.NRCAV_max) then write (*,9) 9 format (55('@')) write (*,*) '[calc_RC_terms] SERIOUS BUG! NRC_AV > NRCAV_max ', & NRC_AV , NRCAV_max write (*,9) NRC_AV = NRCAV_max i_RC_CRASH_FLAG = 1 end if c Define factorial of 0...NRC_AV-1. c Note array off-set: factorial(i) = (i-1)! factorial(1) = 1. factorial(2) = 1. do i=3,NRC_AV factorial(i) = factorial(i-1) * (i - 1) end do c Define rho(lambda) = ln(10) * red_term(lambda) and compute its c mean. No weighting is applied. This mean serves as the factor c "eta_AV". ln10 = log(10.) soma = 0. do i=1,Nl_obs rho(i) = ln10 * red_term(i) soma = soma + rho(i) end do eta_AV = soma / Nl_obs c Define beta(lambda) = rho(lambda) - eta_AV do i=1,Nl_obs beta(i) = rho(i) - eta_AV end do c *************************************************************************** c *************************************************************************** c * Compute RC terms RC1, RC2 & RC3 * c *************************************************************************** c RC1 = Sum-over-l (O_l * w_l)**2. RC1 = 0. do i=1,Nl_obs RC1 = RC1 + f_obs(i) * weight_obs(i) * f_obs(i) * weight_obs(i) end do c RC2 = -2 * Sum-over-l w_l**2 * O_l * gamma_l,j * beta_l**n c RC2 = RC2(iRC_AV,j) do j=1,N_base do iRC_AV=1,NRC_AV soma = 0. do i=1,Nl_obs soma = soma + f_obs(i) * weight_obs(i) * f_base(j,i) * & weight_obs(i) * beta(i)**(iRC_AV - 1) end do RC2(iRC_AV,j) = -(2 * soma) / factorial(iRC_AV) ! Screen check ! write (*,2) '[calc_RC_terms] RC2: ' , j , iRC_AV , ! & RC2(iRC_AV,j) !2 format (a,2(2x,i4),3x,1p,3(4x,e12.4)) end do end do c RC3 = Sum-over-l w_l**2 * gamma_l,j1 * gamma_l,j2 * beta_l**n c RC3 = RC3(iRC_AV,j1,j2) c OBS: Explore fact that RC3(iRC_AV,j1,j2) = RC3(iRC_AV,j2,j1)... do j1=1,N_base do j2=1,j1 do iRC_AV=1,NRC_AV soma = 0. do i=1,Nl_obs soma = soma + f_base(j1,i) * weight_obs(i) * & f_base(j2,i) * weight_obs(i) * & beta(i)**(iRC_AV - 1) end do RC3(iRC_AV,j1,j2) = soma / factorial(iRC_AV) RC3(iRC_AV,j2,j1) = RC3(iRC_AV,j1,j2) ! Screen check ! write (*,3) '[calc_RC_terms] RC3: ' , j1 , j2 , iRC_AV , ! & RC3(iRC_AV,j1,j2) !3 format (a,3(2x,i4),3x,1p,e12.4) end do end do end do c *************************************************************************** end c ########################################################################### c ########################################################################### c This version of chi2(x,AV_tot) uses the information in the flag c i_IsAVstillTheSame, which is = 1 ("YES") if AV is the same as in c the last call to this function. This allows us to skip the sum c over the NRC_AV terms in the truncated-series approximation to c chi2, thus saving quite a bit of time, hence allowing many more c Metropolis steps! See notes for more details! c Cid@Lagoa - 09/May/2004 c c Now adapted to AV = AV_tot(j), ie, population dependent c extinctions! Double precision variables were defined too! c Cid@Lagoa - 12/Jan/2005 !OPTfn! This function now returns (via common) the (single precision) optimal fn = -(chi2_2/2.) / chi2_3. ! This considers ONLY the OPTICAL spectral fit!! (hence the _OPT subscript!) ! ElCid@Sanchica - 28/Jan/2012 FUNCTION VeryFastF_chi2(x,AV_tot,i_IsAVstillTheSame) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) * MEX-OBS: Changed NRCAV_max parameter (Nl_max = 20000,Nb_max = 300,NRCAV_max = 35) real x(Nb_max) , abs_x(Nb_max) , AV_tot(Nb_max) real f_base(Nb_max,Nl_max) double precision RC1 , RC2(NRCAV_max,Nb_max) , & RC3(NRCAV_max,Nb_max,Nb_max) , eta_AV double precision SMAT1(Nb_max) , SMAT2(Nb_max,Nb_max) double precision chi2 , chi2_1 , chi2_2 , chi2_3 , soma , soma_j2 SAVE SMAT1 , SMAT2 common/Base/ N_base , f_base common/RapidChi2/ RC1 , RC2 , RC3 , eta_AV common/RC_AV_Stuff/ NRC_AV , i_RC_CRASH_FLAG , NRC_AV_Default !!MEX!! IMPORTANT CHANGE: Introduced flag to use SLOW chi2 always! common/ToRCOrNotToRC_ThatIsTheQuestion/ i_UseSlowChi2Always !OPTfn! Optically optimal fn - computed here and passed on common/Optimize_fn_OPT/ IsOptimize_fn_OPT , Optimal_fn_OPT !ESM! chi2_OPTICAL now shared through this common! common/OpticalChi2/chi2_OPTICAL , ETC_GlobalChi2ScaleFactor * !!MEX!! Use Slow Chi2 if told to do so! if (i_UseSlowChi2Always.EQ.1) then chi2 = SlowF_chi2(x,AV_tot) VeryFastF_chi2 = chi2 return end if c Define auxiliar i_IsAVstillTheSame flag, which may be changed in c case of trouble (see bottom) i_aux_IsAVstillTheSame = i_IsAVstillTheSame c 1st term = Sum_l (w_l O_l)**2 10 chi2_1 = RC1 c If AV is NOT the same as in the last call then compute chi2 as in c the fast-chi2 routine, but saving the SMAT1 & SMAT2 arrays for c later use if (i_aux_IsAVstillTheSame.NE.1) then c 2nd term = -2 Sum_l w_l**2 O_l * M_l. c Also, define abs_x() for convenience (= speed), as it's used below. chi2_2 = 0. do j=1,N_base abs_x(j) = abs(x(j)) soma = 0. do iRC_AV=1,NRC_AV soma = soma + AV_tot(j)**(iRC_AV - 1) * RC2(iRC_AV,j) end do SMAT1(j) = soma * exp(eta_AV * AV_tot(j)) chi2_2 = chi2_2 + abs_x(j) * SMAT1(j) end do c 3rd term = Sum_l (w_l M_l)**2. c To speed up the triple loop, first sum over the off-diagnonal c elements j2 < j1, then use the (j1,j2) = (j2,j1) simmetry in RC3 c (hence the chi2_3 = 2 * chi2_3 line below), and finally sum over c the j1 = j2 diagonal elements. chi2_3 = 0. do j1=1,N_base soma_j2 = 0. do j2=1,j1-1 AV_aux = AV_tot(j1) + AV_tot(j2) soma = 0. do iRC_AV=1,NRC_AV soma = soma + AV_aux**(iRC_AV - 1) * RC3(iRC_AV,j1,j2) end do SMAT2(j1,j2) = soma * exp(eta_AV * AV_aux) SMAT2(j2,j1) = SMAT2(j1,j2) soma_j2 = soma_j2 + abs_x(j2) * SMAT2(j1,j2) end do chi2_3 = chi2_3 + soma_j2 * abs_x(j1) end do chi2_3 = 2 * chi2_3 do j1=1,N_base AV_aux = AV_tot(j1) + AV_tot(j1) soma = 0. do iRC_AV=1,NRC_AV soma = soma + AV_aux**(iRC_AV - 1) * RC3(iRC_AV,j1,j1) end do SMAT2(j1,j1) = soma * exp(eta_AV * AV_aux) chi2_3 = chi2_3 + abs_x(j1) * abs_x(j1) * SMAT2(j1,j1) end do else c If AV IS the same as in the last call, then use previously defined c SMAT1 & SMAT2 arrays to speed up computation (skiping the c AV-series-loop) c 2nd term ... Using SMAT1!! chi2_2 = 0. do j=1,N_base abs_x(j) = abs(x(j)) chi2_2 = chi2_2 + abs_x(j) * SMAT1(j) end do c 3rd term ... Using SMAT2!! chi2_3 = 0. do j1=1,N_base soma_j2 = 0. do j2=1,j1-1 soma_j2 = soma_j2 + abs_x(j2) * SMAT2(j1,j2) end do chi2_3 = chi2_3 + soma_j2 * abs_x(j1) end do chi2_3 = 2 * chi2_3 do j1=1,N_base chi2_3 = chi2_3 + abs_x(j1) * abs_x(j1) * SMAT2(j1,j1) end do end if c Add the 3 terms to obtain the total chi2, test it & go back:) chi2 = chi2_1 + chi2_2 + chi2_3 !OPTfn! Computes the OPTically optimal fn Optimal_fn_OPT = -(chi2_2/2.) / chi2_3 *ETC* Adding all ETC-chi2's to optical-chi2! !ESM! Defining chi2_OPTICAL, passed via common/OpticalChi2/ chi2_OPTICAL = chi2 chi2_ETC = ETC_CalcETCchi2(x,AV_tot,'VFc') VeryFastF_chi2 = ETC_GlobalChi2ScaleFactor * $ (chi2_OPTICAL + chi2_ETC) !!MEX!! IMPORTANT CHANGE: In case all else fails, revert to Slow chi2! if ((chi2.LT.0.).AND.((NRC_AV + 1).GT.NRCAV_max)) then write (*,'(a,i3,a,f12.3,a,i3,a)') $ '[VeryFastF_chi2] ATT!! Tried to resize NRC_AV to' , $ NRC_AV +1 , ' because chi2 = ' , chi2 , $ ' but NRCAV_max = ' , NRCAV_max , ' !!' write (*,'(a)') $ '[VeryFastF_chi2] ..... Will revert to SLOW chi2!!' chi2 = SlowF_chi2(x,AV_tot) VeryFastF_chi2 = ETC_GlobalChi2ScaleFactor * $ (chi2_OPTICAL + chi2_ETC) *FIR* Warning msg below was made more informative ... write (*,'(a,1p,e12.5,0p,a)') $ '[VeryFastF_chi2] ..... Done: chi2 = ', chi2 , $ ' **ATT** Reverted to slow chi2! ' end if c Test whether series approximation produced chi2 < 0! If so, try c again with one further term [NRC_AV <== NRC_AV + 1] if (chi2.LT.0.) then NRC_AV = NRC_AV + 1 write (*,'(a,i3,a,f12.3,a)') & '[VeryFastF_chi2] ATT!! Resized NRC_AV to' , NRC_AV , & ' because chi2 = ' , chi2 , '!' call Calc_RC_terms !CRASH: get out in case RC-crashes! If no-crash, re-do chi2 calculation. if (i_RC_CRASH_FLAG.NE.0) return i_aux_IsAVstillTheSame = 0 go to 10 end if return end c ########################################################################### c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + CHI2 FUNCTIONS USED IN THE KINEMATICAL FITS (v0 & vd) + c + + c + fun_vd_chi2 + c + fun_v0_chi2 + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c ########################################################################### c This function is used in the Golden-Section-Search for a best vd. c It computes chi2 as a function of vd using the kinematics-free c (ie, v0 = vd = 0) synthetic spectrum "GSf_syn_NoKin", computed c elsewhere for the current best model. v0_min is passed by the c /GoldenSearch_aux/ common, as it is needed for GaussSmooth. c Nl_aux & l_aux are = Nl_obs & l_obs, but defined elesewhere c for convenience (= speed); their only role is to avoid calling c GaussSmooth with equally named variables... c Cid@Lagoa - Jan/13/2005 *ETC* Added common/ETC_xAndAV4KinFits/ to pass x & AV arrays to * fun_vd_chi2 & fun_v0_chi2. Also needed to add Nb_max in the * parameter list. * Cid@Lagoa - Jan/13/2010 + 07/Jan/2011 FUNCTION fun_vd_chi2(vd) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) real l_obs(Nl_max) , f_obs(Nl_max) , weight_obs(Nl_max) real l_aux(Nl_max) , f_syn(Nl_max) common/N_Gauss/ N_int_Gauss common/Obs/ Nl_obs , l_obs , f_obs , weight_obs common/GoldenSearch_aux/ v0_min , vd_min , & Nl_aux , l_aux , GSf_syn_NoKin(Nl_max) common/ETC_xAndAV4KinFits/ ETC_x4kin(Nb_max) , ETC_AV4kin(Nb_max) !ESM! chi2_OPTICAL now shared through this common! common/OpticalChi2/chi2_OPTICAL , ETC_GlobalChi2ScaleFactor !FIX-DAE2-BUG! Imposing a maximum vd! Set chi2 to "infty" if vd > 5000 km/s ! ElCid@Sanchica - 21/Oct/2011 if (abs(vd).GT.5000.0) then write (*,*) '[fun_vd_chi2] ATT! Trying vd=',vd,'!!!' write (*,*) '[fun_vd_chi2] NOT allowed!' fun_vd_chi2 = 3.0e38 return end if call GaussSmooth(Nl_aux,l_aux,GSf_syn_NoKin,v0_min,vd, & N_int_Gauss,Nl_obs,l_obs,f_syn) chi2 = 0. do i=1,Nl_obs chi2 = chi2 + (f_syn(i) - f_obs(i)) * weight_obs(i) * & (f_syn(i) - f_obs(i)) * weight_obs(i) end do *ETC* Adding all ETC-chi2's to optical-chi2! !ESM! Defining chi2_OPTICAL, passed via common/OpticalChi2/ chi2_OPTICAL = chi2 chi2_ETC = ETC_CalcETCchi2(ETC_x4kin,ETC_AV4kin,'fvd') fun_vd_chi2 = ETC_GlobalChi2ScaleFactor * $ (chi2_OPTICAL + chi2_ETC) return end c ########################################################################### c ########################################################################### c This function is used in the Golden-Section-Search for a best v0. c It computes chi2 as a function of v0 using the kinematics-free c (ie, v0 = vd = 0) synthetic spectrum "GSf_syn_NoKin", computed c elsewhere for the current best model. vd_min is passed by the c /GoldenSearch_aux/ common, as it is needed for GaussSmooth. c Nl_aux & l_aux are = Nl_obs & l_obs, but defined elesewhere c for convenience (= speed); their only role is to avoid calling c GaussSmooth with equally named variables... c Cid@Lagoa - Jan/13/2005 FUNCTION fun_v0_chi2(v0) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) real l_obs(Nl_max) , f_obs(Nl_max) , weight_obs(Nl_max) real l_aux(Nl_max) , f_syn(Nl_max) common/N_Gauss/ N_int_Gauss common/Obs/ Nl_obs , l_obs , f_obs , weight_obs common/GoldenSearch_aux/ v0_min , vd_min , & Nl_aux , l_aux , GSf_syn_NoKin(Nl_max) common/ETC_xAndAV4KinFits/ ETC_x4kin(Nb_max) , ETC_AV4kin(Nb_max) !ESM! chi2_OPTICAL now shared through this common! common/OpticalChi2/chi2_OPTICAL , ETC_GlobalChi2ScaleFactor !FIX-DAE2-BUG! Imposing a maximum |v0|! Set chi2 to "infty" if v0 > 5000 km/s ! ElCid@Sanchica - 21/Oct/2011 if (abs(v0).GT.5000.0) then write (*,*) '[fun_v0_chi2] ATT! Trying v0=',v0,'!!!' write (*,*) '[fun_v0_chi2] NOT allowed!' fun_v0_chi2 = 3.0e38 return end if call GaussSmooth(Nl_aux,l_aux,GSf_syn_NoKin,v0,vd_min, & N_int_Gauss,Nl_obs,l_obs,f_syn) chi2 = 0. do i=1,Nl_obs chi2 = chi2 + (f_syn(i) - f_obs(i)) * weight_obs(i) * & (f_syn(i) - f_obs(i)) * weight_obs(i) end do *ETC* Adding all ETC-chi2's to optical-chi2! !ESM! Defining chi2_OPTICAL, passed via common/OpticalChi2/ chi2_OPTICAL = chi2 chi2_ETC = ETC_CalcETCchi2(ETC_x4kin,ETC_AV4kin,'fv0') fun_v0_chi2 = ETC_GlobalChi2ScaleFactor * $ (chi2_OPTICAL + chi2_ETC) return end c ########################################################################### c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + MARKOV-CHAINS RELATED ROUTINES + c + (This is where the "soul" of the code resides!!) + c + !!actually, most of the sould was moved to the MEX-routines bllock!! + c + + c + Calc_GR_R + c + Generate_PopVector + c + SaveStep + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c ########################################################################### c Compute Gelman & Rubin "R" convergence-test-ratio GR_R(j) for each c parameter j = 1...N_par, given N_chains chains. The input matrices c Cpar_ave & Cpar_var must provide the average and variance of c parameter j in each chain i_chain. N_steps is the number of steps c taken by each chain. See Doran & Muller, astroph/0311331. Return c the R-tations for each parameter (GR_R) and the average, as well c as flags which verify if these R's are <= the given R_threshold. c c Cid@Lagoa - 04/Feb/2005 c c Added i_verbose to control the screen output of the "This should not c happen too often" warning. c Cid@Lagoa - 17/Aug/2017 SUBROUTINE Calc_GR_R(N_steps,N_chains,N_par,Cpar_ave,Cpar_var, $ R_threshold,GR_R,GR_R_ave,IsAveBurnInOver,IsIndBurnInOver, $ i_verbose) c Definitions implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Npar_max = 601 , Nchains_max = 1000) real Cpar_ave(Npar_max,Nchains_max) real Cpar_var(Npar_max,Nchains_max) real GR_R(Npar_max) c Start loop over all j = 1...N_par parameters sum_R_ave = 0. do j=1,N_par c Compute global average of parameter j over all chains! (= "mean of c means"). sum_p = 0. do i_chain=1,N_chains sum_p = sum_p + Cpar_ave(j,i_chain) end do global_ave = sum_p / float(N_chains) c Define GR_B & GR_W: GR_B = "Between chains variance", while GR_W = c "Within chains variance" (eqs 5 & 6 of Doran & Muller). sum_B = 0. sum_W = 0. do i_chain=1,N_chains sum_B = sum_B + (Cpar_ave(j,i_chain) - global_ave) $ * (Cpar_ave(j,i_chain) - global_ave) sum_W = sum_W + Cpar_var(j,i_chain) end do GR_B = (float(N_steps) / float(N_chains - 1)) * sum_B GR_W = sum_W / float(N_chains) c Define GR_R(j) = convergence ratio for parameter # j (eq 7 of c Doran & Muller). Also, update summation for mean R. ! Introduced "protection" against W = j (chains which do not walk!). ! When this happens (eg, due to a small N_sim), I set GR_R(j) to a ! very large value, such that neither not GR_R(j) will ! satisfy the convergence criterion! z = N_steps if (GR_W.LE.0.) then if (i_verbose.GT.0) write (*,'(a,a,i3,1x,f9.6)') $ '[Calc_GR_R] W_j <= 0! This should not happen ', $ 'too often... j & GR_W = ' , j,GR_W GR_R(j) = 10. * N_par * R_threshold + 9999. else GR_R(j) = (((z - 1.) / z) * GR_W + GR_B / z) / GR_W end if sum_R_ave = sum_R_ave + GR_R(j) c Check whether GR_R(j) <= 0, which may happen due to precision bugs! if ((GR_R(j).LE.0.).AND.(i_verbose.GT.0)) $ write (*,'(a,a,i3,1x,1p,2(2x,e12.3))') $ '[Calc_GR_R] R_j <= 0! This should not happen ', $ 'too often... j & GR_W & GR_R = ' , j,GR_W,GR_R(j) end do c Mean GR_R over all N_par parameters GR_R_ave = sum_R_ave / float(N_par) c Verify if Burn-In is over for the Average & Individual R's, given c the input threshold. Set 0/1 (No/Yes) flags accordingly. IsAveBurnInOver = 1 if (GR_R_ave.GT.R_threshold) IsAveBurnInOver = 0 IsIndBurnInOver = 1 do j=1,N_par if (GR_R(j).GT.R_threshold) IsIndBurnInOver = 0 end do end c ########################################################################### c ########################################################################### c # Generate random pop vector x(j), j=1...N, with a scheme c # that allows a few components to dominate. (Simple normalization c # "a la Laerte" does not do this). x() is normalized to sum x = 1 c # (to within roundoff errors...) c # Cid@Lynx - Dec/15/2002 c # Introduced a maximum x_j amplitude (x_max) c # Cid@Lynx - Nov/24/2004 ! This may be re-written using sort! SUBROUTINE Generate_PopVector(idum,N,x_max,x) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nb_max = 300) real x(Nb_max) , ind(Nb_max) if (N.GT.Nb_max) then write (*,*) ' [Generate_PopVector] N > N_max! ' , N , Nb_Max stop end if do j=1,N ind(j) = -99 end do do j=1,N 1 ix = N * ran2(idum) + 1 do i=1,N if (ind(i).EQ.ix) goto 1 end do ind(j) = ix end do sum_x = 0. do j=1,N-1 i = ind(j) 2 x(i) = (1. - sum_x) * ran2(idum) if (x(i).GT.x_max) goto 2 sum_x = sum_x + x(i) end do i = ind(N) x(i) = 1. - sum_x end c ########################################################################### c ########################################################################### c # SAVE STEP IN A FILE (used to sample PDF...) # c ########################################################################### * Heavily simplifyed for MEX-code... * Cid@Lagoa -22/April/2007 SUBROUTINE SaveStep(i_sim,i_chain,N_par,par,Ene) !2BEDONE! Should save chi2_OPTICAL, chi2_FIR, chi2_QHR, chi2_PHO too! !OJO! implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nb_max = 300,Npar_max = 601) real par(Npar_max) common/OutputFileUnits/ i_UnitScubi write (i_UnitScubi,1) i_chain , 2.*Ene ,(100.*par(j),j=1,N_par) 1 format (i3,1x,1p,e11.4,2x,0p,300(1x,f6.1)) end c ########################################################################### ! MISCELANEOUS NOTES... ! Problema da enegia muito baixa... como consertar??? Tem a ver com ! a expansao... uma possib eh sempre usar SlowChi2 qdo se acha um ! minimo... c o prob eh que as vezes da o bug FDP antes do VF_chi2 se dar conta c de q a coisa vai mal (ie, antes do chi2 ficar negativo)... c c bug tem q ser resolvido calibrando qdo ele acontece em funcao de c AV e YAV (possibly only AV+AYV...) Simulations? William?? c Talvez o melhor seja incluir elementos avermelhados na base! WILLIAM! ! ??SERAH que nao vale a pena fixar AV, estimar x e refazer o treco AV ! a AV? Tipo o q a gente faz pra v0,vd com a Golden-search .,..... ! tenho a impressao que podemos ser mais relaxed com o GR_R pra AV, ! pois os valores das cadeias estao BEM proximos (~ centesimos de ! mag) embora GR_R(AV) > 1.2.... ! have to go ASAP to a condensed base! OR TO Fixed v0 & vd (such ! that RC terms need not be recomputed often!) ! se nao mudar kin entao nao precisa recalcular RC sempre! (soh qdo ! AV crescer muito!) o q apressaria bastante a coisa! ideia: 1 - ! convoluir obs e base com vd = 300 km/s; 2 - fazer um fit rapido; 3 ! descvoluir tudo; 4 - estimar vd com um fit usando o pop-vector ! rapido; 5 - fixar kinematics thereafter! c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!! MEX-routines !!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c + ROUTINES IN THIS "MEX" BLOCK + c + + c + + c + MEX_Fit_Scubidu + c + MEX_ScubiduCadeVoce + c + MEX_Fpar_Slowchi2 + c + MEX_Fpar_VFchi2 + c + MEX_Unpack_par2xAVYAVfn + c + MEX_Update_AV_array + c + MEX_EX0s_Fit_Scubi + c +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ c ########################################################################### c # !!MEX!! ANNEALING DRIVER FOR SCUBIDU ....................... # c ########################################################################### C????? ABSTRACT!!! c ... if IsKinFixed = 1 then RCtems & base-convolution are done only c once, before the main loop! c Fit f_obs(l_obs) using a recipe like this: c 1- Smooth & shift BASE spectra to current v0 & vd (Of_base ==> f_base) c 2- Increase weights & decrease step-size, ajdusting number of steps c 3- Run Metropolis for (x,AV,YAV,fn) only, using smothed base (f_base) c 4- Un-smooth base & estimate (v0,vd) for current population parameters c (A Golden-Section-Search is used to find v0 & vd) c 5- Goto 1, starting from new (x,AV,YAV,fn,v0,vd) initial point. c Tests so far proved that this works beautifully!! c Cid@Lynx - 21/Aug/2003 c .... SUBROUTINE MEX_Fit_Scubidu(i_verbose,idum,N_loops,v0_low,v0_upp $ ,vd_low,vd_upp,x_min,AV_min,exAV_min,v0,vd,Ntot_anneal $ ,eff_anneal,Nl_eff,iMassAgeZ_verbose,N_par,Cpar_last $ ,N_chains,Temp_ini,Temp_fin,fini_eps,ffin_eps,R_ini,R_fin $ ,N_sim,Nmax_steps,i_RestartChains,Gpar_min,GE_min,Gpar_ave $ ,Cpar_min,CEne_min,IsKinFixed,IsBurInOver) c *************************************************************************** c * Definitions * c *************************************************************************** implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) parameter (Nchains_max = 1000,Npar_max = 601) real eps(Npar_max) , eps_ini(Npar_max) , eps_fin(Npar_max) real aux1(Npar_max) , aux2(Npar_max) real Cpar_last(Npar_max,Nchains_max) , CEne_last(Nchains_max) real Cpar_min(Npar_max,Nchains_max) , CEne_min(Nchains_max) real Cpar_low(Npar_max) , Cpar_upp(Npar_max) real Gpar_min(Npar_max) , Gpar_ave(Npar_max) real l_obs(Nl_max) , f_obs(Nl_max) , weight_obs(Nl_max) real l_aux(Nl_max) , f_aux1(Nl_max) , f_aux2(Nl_max) real x_min(Nb_max) , AV_tot(Nb_max) real f_base(Nb_max,Nl_max) , Of_base(Nb_max,Nl_max) real f_syn(Nl_max) , fbase_norm(Nb_max) common/Obs/ Nl_obs , l_obs , f_obs , weight_obs common/Base/ N_base , f_base common/Obase/ Of_base common/N_Gauss/ N_int_Gauss common/GoldenSearch_aux/ v0_min , vd_min , & Nl_aux , l_aux , GSf_syn_NoKin(Nl_max) common/RC_AV_Stuff/ NRC_AV , i_RC_CRASH_FLAG , NRC_AV_Default common/CalcMass/ q_norm , fbase_norm , fobs_norm c Lower & upper limits on parameters (x,AV,exAV,fn) common/ParLimits/ par_low(Npar_max) , par_upp(Npar_max) external fun_vd_chi2 external fun_v0_chi2 *ETC* Added a common to pass x & AV arrays to fun_vd_chi2 & fun_v0_chi2 common/ETC_xAndAV4KinFits/ ETC_x4kin(Nb_max) , ETC_AV4kin(Nb_max) !Cid14Jan07-FXK! Added FXK = Fixed kinematics option!! common/FXK_fits/ IsThisAnFXKFit * MEX-arrays real exAV_min(Nb_max) , exAV_test(Nb_max) common/exAV_stuff/ N_exAV , ind_exAV(Nb_max) * MEX-BruteForce (AV,exAV) search stuff !FIX4CALIFA! Was parameter (n_pt_MaxBF = 10000,n_Dim_MaxBF = 10,n_BF_Range = 5), but now is: parameter (n_pt_MaxBF = 100,n_Dim_MaxBF = 10,n_BF_Range = 5) integer ind_BFmat(n_pt_MaxBF,n_Dim_MaxBF) real d_BF(Nb_max) , par_BF(Npar_max) , BF_low(Npar_max) , $ BF_upp(Npar_max) !CFl! Charlot & Fall law stuff: AV_Young = a0_CFl + a1_CFl * AV_Old common/CFl_stuff/ a0_CFl , a1_CFl , IsCFlawOn c *************************************************************************** c *************************************************************************** c * Initialization * c *************************************************************************** *ETC* Overcaution/paranoid reset of several things ... do j=1,Nb_max exAV_test(j) = 0. ETC_x4kin(j) = 0. ETC_AV4kin(j) = 0. end do do j=1,Npar_max aux1(j) = 0. aux2(j) = 0. eps_ini(j) = 0. eps_fin(j) = 0. end do do i=1,Nl_max l_aux(i) = 0. f_aux1(i) = 0. end do c Reset best kinematic parameters to initial values v0_min = v0 vd_min = vd c Define AV, exAV & fn positions in par-vector N_par = N_base + 1 + N_exAV + 1 j_AV = N_base + 1 j_exAV = N_base + 2 j_fn = N_par c Set step-size schedule in terms of input parameters fini_eps & c ffin_eps. We restrict AV/exAV eps sizes to up to 1 mag / fini_eps c (initial) & 1 mag / ffin_eps (final). do j=1,N_par eps_ini(j) = (par_upp(j) - par_low(j)) / fini_eps eps_fin(j) = (par_upp(j) - par_low(j)) / ffin_eps end do eps_ini(j_AV) = min(eps_ini(j_AV),(1.0/fini_eps)) eps_fin(j_AV) = min(eps_fin(j_AV),(1.0/ffin_eps)) do j=j_exAV,j_fn-1 !OBS: This loop only runs if Nex_AV > 0! eps_ini(j) = min(eps_ini(j),(1.0/fini_eps)) eps_fin(j) = min(eps_fin(j),(1.0/ffin_eps)) end do c Reset total efficiency & number of steps counters. They will count c all steps for all chains and all annealing loops. eff_anneal = 0. Ntot_anneal = 0 !Cid14Jan07-FXK! If IsThisAnFXKFit = 1 then base is **already smoothed** ! and the steps below should be skipped! Start with a sanity check: ! If IsThisAnFXKFit = 1 then IsKinFixed MUST be 1! if ((IsThisAnFXKFit.EQ.1).AND.(IsKinFixed.NE.1)) then write (*,'(a,2(a,f9.3),a)') $ '[Fit_Scubidu] BUG/PROBLEM! IsThisAnFXKFit = ' , $ IsThisAnFXKFit , 'but IsKinFixed = ', IsKinFixed stop end if if (IsThisAnFXKFit.NE.1) then c Store l_obs & Nl_obs onto auxiliar variables (used in all calls to c GaussSmooth below). do i=1,Nl_obs l_aux(i) = l_obs(i) end do Nl_aux = Nl_obs c Smooth & shift original base Of_base to f_base for input vd & c v0. This has to be done here (before the annealing loop) because c we need to compute chain energies. These energies MAY be used to c initialize the cooling schedule (but we're not really doing it!!) if (i_verbose.GE.1) write (*,'(a,2(a,f9.3),a)') $ '[Fit_Scubidu] Smoothing base to' ,' v0 = ' , v0 , $ ' & vd = ' , vd , ' km/s...' do j=1,N_base do i=1,Nl_obs f_aux1(i) = Of_base(j,i) end do call GaussSmooth(Nl_aux,l_aux,f_aux1,v0,vd, & N_int_Gauss,Nl_obs,l_obs,f_aux2) do i=1,Nl_obs f_base(j,i) = f_aux2(i) end do end do if (i_verbose.GT.1) write (*,'(a)') '[Fit_Scubidu] ... done!' end if c Initialize RC-terms (so that we can compute energies!). Note that c the 1st-guess kinematical filter has just been applied. Presumably c the default number of RC_AV terms will be used the first time the c code goes through this call to Calc_RC_terms... if (i_verbose.GE.1) write (*,'(a)') $ '[Fit_Scubidu] Computing RC-terms ...' call Calc_RC_terms if (i_verbose.GE.1) write (*,'(a)') $ '[Fit_Scubidu] ... RC-terms computed!' c Compute initial chain energies & reset initial chain-minima. c OBS: Note that if a previous best minimum was found and NOT stored c in one of the Cpar_last's then it will be lost!! do i_chain=1,N_chains do j=1,N_par aux1(j) = Cpar_last(j,i_chain) Cpar_min(j,i_chain) = Cpar_last(j,i_chain) end do Ene_initial = 0.5 * MEX_Fpar_VFchi2(N_par,N_base,aux1,0) CEne_last(i_chain) = Ene_initial CEne_min(i_chain) = Ene_initial end do c Reset initial GLOBAL best-model parameters & energy (Gpar_ & GE_min). GE_min = 2. * CEne_min(1) do i_chain=1,N_chains if (CEne_min(i_chain).LT.GE_min) then do j=1,N_par Gpar_min(j) = Cpar_min(j,i_chain) end do GE_min = CEne_min(i_chain) end if end do c Unpack Gpar_min to x_min, AV_min, exAV_min & fn_min, and then c update AV_tot with AV_min & exAV_min... call MEX_Unpack_par2xAVYAVfn(N_par,N_base,Gpar_min,x_min,AV_min, $ exAV_min,fn_min) call MEX_Update_AV_array(N_base,AV_min,exAV_min,AV_tot) c *************************************************************************** c *************************************************************************** c * Annealing loop * c *************************************************************************** c 1- Smooth & shift f_base spectra to current v0 & vd c 2- Recompute RC-terms & test NRC_AV c 3- Recompute Chain Energies (min, last & global-min) c 4- Adjust Temperature, R_Threshold & step-sizes according to c cooling schedule c 5- Run Subidu-Metropolis for (x,AV,YAV,fn) only, using smothed base c until GR-convergence is reached. c 6- Do Quick brute-force search for better AV & YAV for fixed x,fn,v0,vd c 7- Restart Chains: put each chain back to its min-position & replace c worst chain by global minimum c 8- Un-smooth base & estimate (v0,vd) for current population parameters c 9- Goto 1, starting from new (x,AV,YAV,fn,v0,vd) initial point. do i_loop=1,N_loops c Given that the base was smoothed & RC-terms were already computed c in the initialization above, we do not have to re-do these steps c it in the 1st loop.... if ((i_loop.GT.1).AND.(IsKinFixed.NE.1)) then c -------------------> Smooth & shift BASE spectra <--------------------- c Smooth & shift original base Of_base to f_base for current vd & v0 c The smoothed f_base is passed by common to other routines! ATT: c f_base is NOT renormalized after convolution with G(v0,vd). After c checking my formulae, I concluded that renormalization is not c desirable afterall. if (i_verbose.GE.1) write (*,'(a,2(f9.3),a)') $ '[Fit_Scubidu] REsmoothing base to ',v0,vd ,' km/s...' do j=1,N_base do i=1,Nl_obs f_aux1(i) = Of_base(j,i) end do call GaussSmooth(Nl_aux,l_aux,f_aux1,v0,vd,N_int_Gauss $ ,Nl_obs,l_obs,f_aux2) do i=1,Nl_obs f_base(j,i) = f_aux2(i) end do end do if (i_verbose.GE.1) write (*,'(a)') '[Fit_Scubidu] ...done!' c ----------------------------------------------------------------------- c -----------------------> Recompute RC-terms <-------------------------- c Since the base-spectra changed (new v0,vd), we need to re-compute c the RC-terms. Before doing so, I estimate the number NRC_AV of c terms in the AV-series as a function of AV_min, such that NRC_AV c increases linearly with |AV_min| up to a maximum value. This c relation needs to be calibrated through experiments... In any c case, the test a few lines below fix any bad-guess for NRC_AV. !!MEX!! Picking largest AV_tot for this ... if (i_verbose.GE.1) write (*,'(a)') $ '[Fit_Scubidu] Computing RC-terms ...' call MEX_Unpack_par2xAVYAVfn(N_par,N_base,Gpar_min,x_min, $ AV_min,exAV_min,fn_min) call MEX_Update_AV_array(N_base,AV_min,exAV_min, $ AV_tot) z1 = 0. do j=1,N_base if (abs(AV_tot(j)).GT.z1) z1 = abs(AV_tot(j)) end do z1 = 5. + 6. * z1 NRC_AV = min(z1,1.*NRC_AV_Default) call Calc_RC_terms if (i_verbose.GE.1) write (*,'(a,i3)') $ '[Fit_Scubidu] ... RC-terms re-computed: NRC_AV = ' $ , NRC_AV c ----------------------------------------------------------------------- end if c -------------> Test whether more RC terms are needed <---------------- c Compare the approximate (fast) and exact (slow) chi2's. If the c relative difference exceeds a threshold, then increase the number c of terms (NRC_AV) in the AV-truncated-series until convergence is c achieved. More terms are needed when AV increases... Since the two c terms always agree well for AV = 0, I carry out the test with AV = c 0.3 (typical of SDSS galaxies...) unless |AV_min| is larger, and c likewise for YAV. Note also that the chi2 routines themselves may c change NRC_AV when they detect trouble (ie, negative chi2's)! c Hence, we've got plenty of protection. (ATT: we may fail to detect c a bad chi2 which, say, is going towards < 0 but hasn't yet gotten c there...) !!MEX!! Checked this part and it seems Ok! It picks a large AV & exAV for ! the test, which is what should be done. !CFl! In principle **no** CFl-changes are needed here, though one could perhaps ! set exAV_test to the CF-law value instead of max(0.3,(abs(exAV_min)). 100 AV_test = max(0.3,(abs(AV_min))) aux_max_exAV_test = -1000. do jMEX=1,N_exAV exAV_test(jMEX) = max(0.3,(abs(exAV_min(jMEX)))) if (exAV_test(jMEX).GT.aux_max_exAV_test) aux_max_exAV_test $ = exAV_test(jMEX) end do call MEX_Update_AV_array(N_base,AV_test,exAV_test,AV_tot) z1 = VeryFastF_chi2(x_min,AV_tot,0) z2 = SlowF_chi2(x_min,AV_tot) rel_diff = (z1 - z2) / z2 dchi2_threshold = 1.e-3 if (abs(z1 - z2).GT.dchi2_threshold * abs(z2)) then write (*,11) 'fitspec',i_loop,' ATT: Increasing' $ , ' # of terms in AV-series...' , z1 , z2 , rel_diff $ , dchi2_threshold , AV_test , AV_min , $ aux_max_exAV_test , NRC_AV , ' ==> ' , NRC_AV + $ 1 11 format (a7,i3,a,a,1p,4(2x,e12.5),0p,3(f9.3,1x),2x,i2,a,i2) NRC_AV = NRC_AV + 1 call Calc_RC_terms ! CRASH: Get out in case RC-crashes! Otherwise repeat test if (i_RC_CRASH_FLAG.NE.1) goto 100 end if * Screen output - controling difference between Slow & Fast - chi2! if (i_verbose.GT.0) write (*,12) i_loop , z1,z2, 100.* rel_diff $ , NRC_AV , AV_test , (exAV_test(jMEX),jMEX=1,N_exAV) 12 format ('FitScub',i3,' RC-test: Fast chi2=' ,1p,e12.4,2x, $ 'Slow chi2=' ,e12.4,3x,' Dif=',e12.4,0p, $ '% for NRC_AV=',i3,' w/AV_test=',f5.2, $ ' & exAV_test=',10(f5.2,1x)) c ----------------------------------------------------------------------- c -----------------------> Recompute Energies <-------------------------- c Since v0 & vd may have changed, and maybe NRC_AV too, we must c recompute the minimum & last chain energies & the global minimum c before passing these values to ScubiduCadeVoce... Note that c energies are recomputed even if neither v0, vd nor NRC_AV changed, c which should do no harm. do i_chain=1,N_chains do j=1,N_par aux1(j) = Cpar_min(j,i_chain) aux2(j) = Cpar_last(j,i_chain) end do CEne_min(i_chain) =0.5*MEX_Fpar_VFchi2(N_par,N_base,aux1,0) CEne_last(i_chain) =0.5*MEX_Fpar_VFchi2(N_par,N_base,aux2,0) end do GE_min = 0.5 * MEX_Fpar_VFchi2(N_par,N_base,Gpar_min,0) c ----------------------------------------------------------------------- c ---------------------> Metropolis/Scubidu Run <------------------------ c Update Temperature, R & step-sizes. Then run ScubiduCadeVoce. z1 = 0. if (N_loops.GT.1) z1 = float(i_loop - 1) / float(N_loops - 1) Temperature = Temp_ini * (Temp_fin / Temp_ini)**z1 R_Threshold = R_ini * (R_fin / R_ini)**z1 do j=1,N_par eps(j) = eps_ini(j) * (eps_fin(j) / eps_ini(j))**z1 end do call MEX_ScubiduCadeVoce(idum,N_par,N_chains,N_sim,Nmax_steps $ ,Temperature,R_Threshold,i_verbose,IsBurInOver,Cpar_last $ ,CEne_last,eps,eff_Scubi,N_steps,Gpar_min,GE_min,Cpar_min $ ,CEne_min,Cpar_low,Cpar_upp,Gpar_ave) c ----------------------------------------------------------------------- c ------------> Brute-Force search for better AV/exAV's <--------------- * --> "Quick" brute force search for better AV/exAV's for each chain <-- * BLABLABLA... BIG CHANGE IN BF-SCHEME WITH ind_MatBF... * Cid@Lagoa - 22/April/2007 !CFl! A BF on both exAV & AV is **NOT** compatible with a CF-law, where exAV is ! tied to AV.... To implement CFl-fits we use a dirty/sloppy trick: We just ! undo the BF gridding on exAV [= par_BF(j_exAV) in the code], replacing it ! with the value determined from AV [=par_BF(j_AV)] and the a0 & a1 CFl ! coefficients. Sloppy, but effective! ! Cid@Lagoa - 03/Aug/2017 * i_BruteForceFlag = just a flag to tell if the BF seach found a * better minimum for at least one chain! Reset is before we start. i_BruteForceFlag = 0 * nBF_Dim = number of dimensions to BF-search (1 for each of AV and * each of the exAV's) nBF_Dim = 1 + N_exAV if (nBF_Dim.GT.n_Dim_MaxBF) then write (*,*) '[Fit_Scubidu] OOPS!!!! too much!! ' , nBF_Dim stop end if * n_pt_PerDim = number of grid points in each dimension * n_pt_BF = total number of points in BF-search grid n_pt_PerDim = (float(n_pt_MaxBF))**(1. / float(nBF_Dim)) n_pt_BF = n_pt_PerDim**nBF_Dim * echo BF numbers if (i_verbose.GT.0) then write (*,'(a,3(a,i5),a)') $ '[Fit_Scubidu] Starting BruteForce AV/exAV:' , $ ' nBF_Dim = ' , nBF_Dim , ' n_pt_PerDim = ' , $ n_pt_PerDim , ' n_pt_BF = ' , n_pt_BF , ' ...' end if * Build ind_BFMat matrix do i_pt=1,n_pt_BF do i_Dim=1,nBF_Dim nS = n_pt_PerDim**(nBF_Dim - i_Dim) nL = n_pt_PerDim**(nBF_Dim - i_Dim + 1) ia = 1 + int((i_pt - 1) / nL) ib = nL * (ia - 1) + 1 ind_BFmat(i_pt,i_Dim) = (i_pt - ib) / nS + 1 end do ! write (*,'(a,i5,a,15i5)') 'HELP==BF ',i_pt,' : ', ! $ ((ind_BFmat(i_pt,i_Dim)),i_Dim=1,nBF_Dim) end do * BF-search for each chain do i_chain=1,N_chains * Define BF step sizes for each of the dimensions * OBS: The parameter n_BF_Range defines the range of AV/exAV search * as +/- n_BF_range X the current corresponding step size. If this * range is < 0.1 mag then use 0.1 instead. do j=j_AV,j_fn-1 BF_range = max(n_BF_Range*eps(j),0.1) BF_low(j) = Cpar_min(j,i_chain) - BF_range BF_upp(j) = Cpar_min(j,i_chain) + BF_range if (BF_low(j).LT.par_low(j)) BF_low(j) = par_low(j) if (BF_upp(j).GT.par_upp(j)) BF_upp(j) = par_upp(j) d_BF(j) = (BF_upp(j) - BF_low(j)) / (n_pt_PerDim - 1) end do * Set par_BF = best in this chain do j=1,N_par par_BF(j) = Cpar_min(j,i_chain) end do * BF-grid-search for better AV & exAV for current chain. * For each of the n_pt_BF points in the DCP-BF-grid, modify the AV & * exAV entries in par_BF. Then compute the energy for par_BF & * compate it to CE_min. If the new model is better, store it (and * update i_BruteForceFlag = 1 to inform this was all worth the * trouble!). do i_pt=1,n_pt_BF do i_Dim=1,nBF_Dim j = j_AV + i_Dim - 1 par_BF(j) = BF_low(j) + (ind_BFmat(i_pt,i_Dim) - 1) $ * d_BF(j) !CFl! Dirty & sloppy trick to undo the BF on exAV & force a CF-law ... if (IsCFlawOn.EQ.1) par_BF(j_exAV) = a0_CFl + $ (a1_CFl - 1.) * par_BF(j_AV) ! write (*,'(a,4i5,5f8.4)') 'CFl-TEST> ' , ! $ i_chain , i_pt , i_Dim , j , BF_low(j) , par_BF(j) , ! $ d_BF(j) , a0_CFl , a1_CFl end do Ene_BF = 0.5 * MEX_Fpar_VFchi2(N_par,N_base,par_BF,0) if (Ene_BF.LT.CEne_min(i_chain)) then ! write (*,'(a,i5,i5,3(a,f9.3),a,30(1x,f7.3))') 'BF ', ! $ i_chain , i_pt , ' Eold=' , CEne_min(i_chain) , ! $ ' Enew=' , Ene_BF , ! $ ' Diff =' , Ene_BF - CEne_min(i_chain) , ! $ ' | par_BF= ', (par_BF(j),j=j_AV,j_fn-1) CEne_min(i_chain) = Ene_BF do j=1,N_par Cpar_min(j,i_chain) = par_BF(j) end do i_BruteForceFlag = 1 end if end do * Goto BF-search for next chain end do * Now repeat the same brute-force search for the Global-best model * so far... do j=j_AV,j_fn-1 BF_range = max(n_BF_Range*eps(j),0.1) BF_low(j) = Gpar_min(j) - BF_range BF_upp(j) = Gpar_min(j) + BF_range if (BF_low(j).LT.par_low(j)) BF_low(j) = par_low(j) if (BF_upp(j).GT.par_upp(j)) BF_upp(j) = par_upp(j) d_BF(j) = (BF_upp(j) - BF_low(j)) / (n_pt_PerDim - 1) end do do j=1,N_par par_BF(j) = Gpar_min(j) end do do i_pt=1,n_pt_BF do i_Dim=1,nBF_Dim j = j_AV + i_Dim - 1 par_BF(j) = BF_low(j) + (ind_BFmat(i_pt,i_Dim) - 1) $ * d_BF(j) !CFl! Dirty & sloppy trick to undo the BF on exAV & force a CF-law ... if (IsCFlawOn.EQ.1) par_BF(j_exAV) = a0_CFl + $ (a1_CFl - 1.) * par_BF(j_AV) end do Ene_BF = 0.5 * MEX_Fpar_VFchi2(N_par,N_base,par_BF,0) if (Ene_BF.LT.GE_min) then ! write (*,'(a,i5,3(a,f9.3),a,30(1x,f7.3))') 'GBF ', ! $ i_pt , ' Eold=' , GE_min , ! $ ' Enew=' , Ene_BF , ' Diff =' , Ene_BF - GE_min , ! $ ' | par_BF= ', (par_BF(j),j=j_AV,j_fn-1) GE_min = Ene_BF do j=1,N_par Gpar_min(j) = par_BF(j) end do i_BruteForceFlag = 2 end if end do * Done with BF-searches if (i_verbose.GT.0) write (*,'(a,i2)') $ '[Fit_Scubidu] ... done! i_BruteForceFlag = ' , $ i_BruteForceFlag * ----------------------------------------------------------------------- c ---------------------> A few simple things ... <----------------------- c Re-find best Global minimum among the chains (which may have c changed after the brute-force AV/YAV minimization above). do i_chain=1,N_chains if (CEne_min(i_chain).LE.GE_min) then do j=1,N_par Gpar_min(j) = Cpar_min(j,i_chain) end do GE_min = CEne_min(i_chain) end if end do c Update total annealing step-counter & efficiency summation. Note c that all chains are counted, but Brute-Force steps are not. Ntot_anneal = Ntot_anneal + N_chains * N_steps eff_anneal = eff_anneal + eff_Scubi * N_chains * N_steps c ----------------------------------------------------------------------- c ----------------> Replace Cpar_last by Cpar_min... <------------------- c Here we reset Cpar_last to Cpar_min, so that next time it will c start from its best location. Also, the chain with highest energy c is replaced by best Global model so far. This should improve their c convergence a tiny little bit. To use this feature you must set c i_RestartChains = "YES" (= 1). !Cid01April07-FIX! Found a "BUG" here while preparing the final ! v04! I did not realize this before because of another bug (namely, ! that we did not use i_RestartChains = 1 in the BI-phase fits)! The ! new bug is that by setting the last values equal to the best ones, ! if one of these best chain values = the global best so far then ! the trick of resetting the chain with worst energy = to the best ! global model may result in this chain-values appearing TWICE!! Ie, ! 2 of the chains would start from IDENTICAL positions. This is not ! a killer bug, but I never wanted to do this... ! ! To fix it I 1st figure out if any of the chain-minima differ from ! the global-minimum by less than 1/1000 in energy (this is flagegd ! with i_GEminIsAmongCEmins = 1 below). ONLY if NONE of them is this ! close to the minimum I then apply the Worst2Best chain trick. (I ! suspect that this is never gonna happen, but to be on the safe ! side I decided to code it in this way). ! ! I also introduce a new option: i_RestartChains = 2, which will ! reset ONLY the worst chain to the best model, but leave the others ! wherever they are. if (i_RestartChains.EQ.1) then i_GEminIsAmongCEmins = 0 do i_chain=1,N_chains do j=1,N_par Cpar_last(j,i_chain) = Cpar_min(j,i_chain) end do CEne_last(i_chain) = CEne_min(i_chain) test_diff = abs(GE_min - CEne_min(i_chain)) if (test_diff.LE.(0.001*GE_min)) i_GEminIsAmongCEmins = 1 end do if (i_GEminIsAmongCEmins.EQ.0) then WorstEne = CEne_min(1) i_WorstChain = 1 do i_chain=2,N_chains if (CEne_min(i_chain).GT.WorstEne) then WorstEne = CEne_min(i_chain) i_WorstChain = i_chain end if end do do j=1,N_par Cpar_last(j,i_WorstChain) = Gpar_min(j) Cpar_min(j,i_WorstChain) = Gpar_min(j) end do CEne_last(i_WorstChain) = GE_min CEne_min(i_WorstChain) = GE_min if (i_verbose.GT.1) write (*,'(a,a)') $ '[Fit_Scubidu] GEmin NOT among the CEne_mins!' , $ ' Worst2Best trick applied.' end if end if ! New option: With i_RestartChains = 2 only the worst chain is ! reset, and to the best global minimum. if (i_RestartChains.EQ.2) then WorstEne = CEne_min(1) i_WorstChain = 1 do i_chain=1,N_chains if (CEne_min(i_chain).GT.WorstEne) then WorstEne = CEne_min(i_chain) i_WorstChain = i_chain end if end do do j=1,N_par Cpar_last(j,i_WorstChain) = Gpar_min(j) Cpar_min(j,i_WorstChain) = Gpar_min(j) end do CEne_last(i_WorstChain) = GE_min CEne_min(i_WorstChain) = GE_min end if c ----------------------------------------------------------------------- c ----------------------------------------------------------------------- c Unpack Gpar_min onto x_min, AV_min, YAV_min & fn_min call MEX_Unpack_par2xAVYAVfn(N_par,N_base,Gpar_min,x_min, $ AV_min,exAV_min,fn_min) call MEX_Update_AV_array(N_base,AV_min,exAV_min,AV_tot) c ----------------------------------------------------------------------- c -----> Golden Search for better kinematical parameters: v0 & vd <------ if (IsKinFixed.NE.1) then c 1st RESTORE f_base to original un-smoothed & un-shifted base spectra!! if (i_verbose.GT.1) write (*,'(a)') $ '[Fit_Scubidu] Starting Re-fit of v0 & vd...' do i=1,Nl_obs do j=1,N_base f_base(j,i) = Of_base(j,i) end do end do c Define "Kinematics-free" spectrum GSf_syn_NoKin, passed by the c common/GoldenSearch_aux/. call calc_Fsyn(x_min,AV_tot,GSf_syn_NoKin) *ETC* The external functions fun_vd_chi2 & fun_v0_chi2 called bellow do * NOT admit x and AV_tot as arguments (they must have just 1 * argument to be used with NR's mnbrak & golden routines). I thus * store x_min & AV_tot in ETC_x4kin() & ETC_AV4kin(), now acessible * to fun_vd_chi2 & fun_v0_chi2 via common/ETC_xAndAV4Kinematics/. do j=1,N_base ETC_x4kin(j) = x_min(j) ETC_AV4kin(j) = AV_tot(j) end do c Compute chi2 of current model - USES fun_v0_chi2, which convolves c GSf_syn_NoKin through the kinematical filter! c OBS1: This is the same as chi2 = FK_chi2(x_min,AV_tot,v0_min,vd_min) c OBS2: This should differ slightly from the chi2_min returned from c the Metropolis routine because in fun_v0_chi2 & fun_vd_chi2 c the reddening term is convolved with the Gaussian filter too. c OBS3: Note that here NO AV-truncated-series trick is used in neither c fun_v0_chi2 nor fun_vd_chi2! chi2 = fun_v0_chi2(v0_min) c Find (with a Golden-Section-Search method) the vd & v0 which c produce the best chi2-match using the current best (x,AV,YAV) c estimated above. The searches are done separately, and in this c order. Values of v0 & vd outside their _low ==> _upp limits are c rejected. Seems to work fine, but it's rather slow. (Can be c improved with FFT-convolution...). OBS: In Starlight05 I c introduced the chi2 = chi2_vd & chi2 = chi2_v0 resets which were c not present before. ax = 0. bx = 500. tol = 1.e-6 call mnbrak(ax,bx,cx,fa,fb,fc,fun_vd_chi2) chi2_vd = golden(ax,bx,cx,fun_vd_chi2,tol,vd_Gold) vd_Gold = abs(vd_Gold) if ((chi2_vd.LT.chi2).AND.(vd_Gold.GE.vd_low).AND. & (vd_Gold.LE.vd_upp)) then vd_min = vd_Gold chi2 = chi2_vd end if ax = -300. bx = 300. tol = 1.e-6 call mnbrak(ax,bx,cx,fa,fb,fc,fun_v0_chi2) chi2_v0 = golden(ax,bx,cx,fun_v0_chi2,tol,v0_Gold) if ((chi2_v0.LT.chi2).AND.(v0_Gold.GE.v0_low).AND. & (v0_Gold.LE.v0_upp)) then v0_min = v0_Gold chi2 = chi2_v0 end if if (i_verbose.GT.1) write (*,'(a)') '[Fit_Scubidu] ...done!' end if c Store v0_min & vd_min onto v0 (we could use only the *_min variables...) v0 = v0_min vd = vd_min c ----------------------------------------------------------------------- c ------------------------> Screen output <------------------------------ ! Screen check! if (i_verbose.GT.0) then write (*,912) 912 format ('# i_loop Temp eps N ', & 'chi2 adev eff | v0 vd | ', & 'sum A_V | x_j... [%]') if (IsKinFixed.EQ.1) then chi2 = 2. * GE_min / float(Nl_eff) call calc_Fsyn(x_min,AV_tot,f_syn) else chi2 = chi2 / float(Nl_eff) call Kcalc_Fsyn(Nl_obs,x_min,AV_tot,v0_min,vd_min,f_syn) end if adev = F_adev(f_syn) sum_x = 100. * Sum_of_x(x_min,N_base) write (*,913) 'FitScub' , i_loop , Temperature, eps(1) , & Ntot_anneal , chi2 , adev , 100.*eff_Scubi , & v0_min , vd_min , & sum_x , AV_min , & (100.*x_min(j),j=1,min(10,N_base)) 913 format (a7,i3,1x,1p,e7.1,0p,2x,f5.3,1x,i9,1x,1p,e10.4,0p,2x, $ f7.4,2x,f4.1,' | ',f6.1,1x,f5.1,' | ', f7.3,1x,f5.2,1x, $ ' | ', 10(1x,f5.2)) do j_out=2,int(N_base/10)+1 j1 = (j_out - 1) * 10 + 1 j2 = min(j1+9,N_base) write (*,'(96x,10(1x,f5.2))') (100.*x_min(j),j=j1,j2) end do write (*,'(96x,a)') ' AV_j... [mag]' do j_out=1,int(N_base/10)+1 j1 = (j_out - 1) * 10 + 1 j2 = min(j1+9,N_base) write (*,'(96x,10(1x,f5.2))') (AV_tot(j),j=j1,j2) end do write (*,'(97x,a,1p,e12.4)') 'Total chi2 = ', chi2 * Nl_eff ! Screen output mean age & z to check convergence. ! OBS: Gives stupid results when called from EXOs-routine! if (iMassAgeZ_verbose.GT.0) then call Calc_Mean_Age_and_Z(N_base,x_min,a_age,s_age, & a_met,s_met) write (*,914) a_age , s_age , a_met , s_met 914 format(97x,' = ',f7.4,' +/- ',f7.4, & ' = ',f7.4,' +/- ',f7.4) ! Screen output of "total mass". Actually, Mass_tot is just ! proportional to the true mass. I just output it here to have a ! coarse idea of how robust the total mass is... ! OBS: Gives stupid results when called from EXOs-routines! ! Cid@lynx 19/Mar/2004 N_aux = N_base Mass_tot = 0. do j=1,N_aux Mass_tot = Mass_tot + x_min(j) * & (10.**(0.4 * AV_tot(j) * q_norm)) / fbase_norm(j) end do Mass_tot = Mass_tot * 383171.17 write (*,915) Mass_tot , log10(Mass_tot) 915 format(97x,'Mass = ',1p,e12.3,6x,'log Mass = ',0p,f8.3, & ' [ref units]') end if ! Inform whether Brute-Force AV/exAV search helped...' if (i_BruteForceFlag.GT.0) write (*,'(97x,a)') & 'OBS: Brute-Force AV/exAV search helped in this loop!' end if c ----------------------------------------------------------------------- c Goto next annealing-loop iteration end do c *************************************************************************** c Compute final annealing efficiency (just for output) & go home:) eff_anneal = eff_anneal / Ntot_anneal c RESTORE f_base to original un-smoothed & un-shifted base spectra c if no kinematical fitting was atempted above. if (IsKinFixed.EQ.1) then do i=1,Nl_obs do j=1,N_base f_base(j,i) = Of_base(j,i) end do end do end if end c ########################################################################### c ########################################################################### c # !!MEX!! SCUBIDUCADEVOCE # c ########################################################################### c Evolve N_chains with Metropolis N_sim steps at a time, iterating c with more steps until GR-convergence is achieved or more than c Nmax_steps are taken. c c LOTS of details to comment!!!!!!! c c Cid@Lagoa - 25/Feb/2005 !OPTfn! Implemented optimal fn! See more on this below. ! OBS: When IsOptimize_fn_OPT.EQ.1 the normalization factor fn will be ! computed analyticaly. It is therefore pointless to (1) allow it to ! be perturbed as any other par, and (2) to verify its low <--> upp ! limits. We do both these pointless but HARMELESS things just for ! fear of changing the code... ! ! ElCid@Sanchica - 28/Jan/2012 SUBROUTINE MEX_ScubiduCadeVoce(idum,N_par,N_chains,N_sim $ ,Nmax_steps,Temperature,R_Threshold,i_verbose,IsBurInOver $ ,Cpar_last,CEne_last,eps_in,eff_Scubi,N_steps,Gpar_min,GE_min $ ,Cpar_min,CEne_min,Cpar_low,Cpar_upp,Gpar_ave) c *************************************************************************** c * DEFINITIONS * c *************************************************************************** implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nb_max = 300) parameter (Nchains_max = 1000,Npar_max = 601) c Current & tentative new parameter, and step-size-scales for each c parameter (for built-in Metropolis) real par(Npar_max) , par_try(Npar_max) real eps_in(Npar_max) , eps(Npar_max) c Global minimum & average & std. dev. real Gpar_min(Npar_max) , Gpar_ave(Npar_max) , Gpar_sig(Npar_max) c "Cpar" denotes Chain-parameter (ie, for each chain...) matrices... real Cpar_ave(Npar_max,Nchains_max) real Cpar_var(Npar_max,Nchains_max) real Cpar_last(Npar_max,Nchains_max) real Cpar_min(Npar_max,Nchains_max) real Cpar_low(Npar_max) , Cpar_upp(Npar_max) c Chain energies (current/last & minimum) real CEne_last(Nchains_max) , CEne_min(Nchains_max) c Summations of par & par**2 "Memory" arrays. Using double precision! double precision S_par(Npar_max,Nchains_max) double precision S_par2(Npar_max,Nchains_max) c Scaling factor & efficiency arrays for each chain real Chain_alpha(Nchains_max) , Chain_eff(Nchains_max) c GR_R(j) = Gelman & Rubin covergence ratio for parameter j. real GR_R(Npar_max) c Auxiliar array(s) real aux1(Npar_max) , aux2(Npar_max) c We don't change NRC_AV directly here, but it's good to know if it c changes on the way... common/RC_AV_Stuff/ NRC_AV , i_RC_CRASH_FLAG , NRC_AV_Default c Lower & upper limits on parameters (x,AV,YAV,fn) common/ParLimits/ par_low(Npar_max) , par_upp(Npar_max) c ScubiduCadeVoce Technical Parameters common/Scubi_TechnicalParameters/ alpha , Falpha , IsGRTestHard , $ eff_IDEAL , i_UpdateEps , Feps , i_UpdateAlpha , $ i_MoveOneParOnly , i_HelpParWithMaxR , prob_jRmax , $ Npar4GRtest ,i_UpdateAVYAVStepSeparately , $ ind_HelpParMove2Average(Npar_max) , $ prob_HelpParMove2Average(Npar_max) common/OutputFileUnits/ i_UnitScubi * !!MEX!! common/exAV_stuff/ N_exAV , ind_exAV(Nb_max) !OPTfn! Optically optimal fn - computed elsewhere and used here to adjust fn! common/Optimize_fn_OPT/ IsOptimize_fn_OPT , Optimal_fn_OPT !CFl! Charlot & Fall law stuff: AV_Young = a0_CFl + a1_CFl * AV_Old common/CFl_stuff/ a0_CFl , a1_CFl , IsCFlawOn c *************************************************************************** c *************************************************************************** c * INITIALIZATION * c *************************************************************************** c Reset what needs to be reset'd! N_steps = 0 do j=1,N_par GR_R(j) = 0. do i_chain=1,N_chains S_par(j,i_chain) = 0. S_par2(j,i_chain) = 0. end do end do do i_chain=1,N_chains Chain_alpha(i_chain) = alpha end do c Counter of number of chain-minima found throughout this Scubi run c (just for control). N_min = 0 c Store input eps (eps_in) in eps (which may change during the run). do j=1,N_par eps(j) = eps_in(j) end do c Define who's who in par() vector. N_base = N_par - 1 - N_exAV - 1 j_AV = N_base + 1 j_exAV = N_base + 2 j_fn = N_par c Reset "Burn-In" flag & global-efficiency, as well as the index of c parameter with largest GR_R, and reset NRC_AV_last to its initial c value. IsBurInOver = 0 eff_Scubi = 0. jR_max = 0 NRC_AV_last = NRC_AV c Defines how many pars will enter the GR-test (exclude fn). It's c necessary to define it here in case we call this routine using a c condensed base... Npar4GRtest = N_par - 1 c *************************************************************************** c *************************************************************************** c * BURN-IN CONVERGENCE LOOP (at fixed Temperature) * c *************************************************************************** c Define N_steps = number of steps taken in EACH chain AFTER the c next call to Metropolis is over. (Will come back here & add more c points if GR-convergence test fails...) 100 N_steps = N_steps + N_sim c Reset counters of total & rejected AV/YAV steps (valid only for c the next N_sim * N_chains moves). N_AVYAV_steps = 0 N_AVYAV_skip = 0 c -------------------- Run N_chains Metropolis chains ------------------- c Run N_chains Metropolis chains, each N_sim steps long. do i_chain=1,N_chains c ++++++++++++++++++ Metropolis run for chain # i_chain +++++++++++++++++ c (0) Reset initial par-vector, Energy & N_skip. Start Metropolis run. c (1) Modify par => par_try (within low => upp boundaries). c Move can be in all par_j's or in just one-at-a-time, c according to i_MoveOneParOnly = 0/1. c (2) Compute new energy (Ene_try); then accept or not the change. c (3) Verify if new state is an energy minimum (for current chain). c (4) Updates summations of p_j & p_j**2 & goto next step (i_sim). c (5) When done, compute chain-efficiency. do j=1,N_par par(j) = Cpar_last(j,i_chain) end do ! OBS: Ene MUST be computed with a direct call to Fpar_VFchi2 with ! i_IsAVstillTheSame = 0 = "NO" here, since AV/YAV varies from chain ! to chain. Ene = 0.5 * MEX_Fpar_VFchi2(N_par,N_base,par,0) N_skip = 0 !Cid06Dec05-FIX! Introduce counter of repeated steps (ie those which don't vary) N_Retry = 0 do i_sim=1,N_sim c For safety, recompute Ene & CEne_min here if NRC_AV changed since c last time an energy was computed for this chain. NRC_AV_last c itself is only updated when all chains have run N_sim steps. if (NRC_AV.NE.NRC_AV_last) then Ene = 0.5 * MEX_Fpar_VFchi2(N_par,N_base,par,0) do j=1,N_par aux1(j) = Cpar_min(j,i_chain) end do CEne_min(i_chain) = 0.5 * MEX_Fpar_VFchi2(N_par,N_base, $ aux1,0) end if if (i_MoveOneParOnly.EQ.1) then c ........... Modifies par --> par_try: One par_j per move!.............. c First set par_try = par. Then chose ONE of the N_par variables & c perturb it. If the chosen variable doesn't really vary (eg, it was c and still is = to its lower limit), then try again, otherwise this c step would be wasted. This ensures that all N_sim steps actually c attempt to change the state. If i_HelpParWithMaxR = 1 then the c parameter with largest R_j will have an extra chance of beeing c picked. c par_try <-- par do j=1,N_par par_try(j) = par(j) end do c Pick jj 10 if ((i_HelpParWithMaxR.EQ.1).AND.(jR_max.GT.0).AND. $ (ran2(idum).LE.prob_jRmax)) then jj = jR_max else jj = N_par * ran2(idum) + 1 end if if (jj.GT.N_par) goto 10 !OPTfn! Pointless (but harmless) to pick jj = j_fn when IsOptimize_fn_OPT = 1. !CFl! If exAV was chosen then change to AV! (They are tied in a CF-law.) if ((IsCFlawOn.EQ.1).AND.(jj.EQ.j_exAV)) jj = j_AV c Perturb jj-th component of par(jj) => par_try(jj). par_try(jj) = par(jj) + Chain_alpha(i_chain) * eps(jj) $ * gasdev(idum) c Here we give a little extra help to par_j, inverting the sign of c the perturbation (with probability = prob_HelpParMove2Average) if c the move took par_j away from the current global-average c value. This makes par_j converge faster, and is analogous to using c a smarter parameter-change proposal-scheme. Note that Gpar_ave is c only defined after N_steps > N_sim (ie, after the 1st loop). if ((ind_HelpParMove2Average(jj).EQ.1).AND.(N_steps.GT. $ N_sim)) then z1 = par(jj) - (par_try(jj) - par(jj)) dist0 = abs(par_try(jj) - Gpar_ave(jj)) dist1 = abs(z1 - Gpar_ave(jj)) if ((dist1.LT.dist0).AND.(ran2(idum).LE. $ prob_HelpParMove2Average(jj))) par_try(jj) = z1 end if c Limit par_try(jj) to its boundaries & try again if nothing changed. !OPTfn! Pointless (but harmless) if jj = j_fn and IsOptimize_fn_OPT = 1. if (par_try(jj).LT.par_low(jj)) par_try(jj) = par_low(jj) if (par_try(jj).GT.par_upp(jj)) par_try(jj) = par_upp(jj) !CFl! If AV was changed then compute exAV cf. our generalixed CF-law. if ((IsCFlawOn.EQ.1).AND.(jj.EQ.j_AV)) par_try(j_exAV) = $ a0_CFl + (a1_CFl - 1.) * par_try(j_AV) !Cid06Dec05-FIX! Update N_Retry & only retry the step if N_Retry <= N_sim! ! (Otherwise we may get into an infinite loop...) if (par_try(jj).EQ.par(jj)) then N_Retry = N_Retry + 1 if (N_Retry.LE.N_sim) goto 10 end if c Perturbed x(jj) or fn ==> so renormalize x() to sum = fn. c Also, AV & YAV are the same ==> so set i_IsAVstillTheSame to "YES"! if ((jj.LE.N_base).OR.(jj.EQ.j_fn)) then i_IsAVstillTheSame = 1 fn_try = par_try(j_fn) sum_x = 0. do j=1,N_base sum_x = sum_x + par_try(j) end do do j=1,N_base par_try(j) = (par_try(j) / sum_x) * fn_try end do c fffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !OPTfn! If chosen by the user (in arq_config), we now rescale the pop vector (and thus fn) such ! that it produces the best possible chi2. Optimal_fn_OPT comes via common from the ! VeryFastF_chi2 function (called from within MEX_Fpar_VFchi2) if (IsOptimize_fn_OPT.EQ.1) then zilt = MEX_Fpar_VFchi2(N_par,N_base, par_try,1) do j=1,N_base par_try(j) = par_try(j) * Optimal_fn_OPT end do par_try(j_fn) = fn_try * Optimal_fn_OPT !OPTfn! Screen test ! zolt = MEX_Fpar_VFchi2(N_par,N_base, par_try,1) ! write (*,'(a,5(a,1x,f10.4,1x))') ! & '[MEX_ScubiduCadeVoce] OPTfn: ' , ! & 'fn changed from',fn_try,'to',par_try(j_fn), ! & 'and energy decreased(?) from', 0.5*zilt , ! & 'to',0.5*zolt,'=> OLD/NEW energy=',zilt/zolt end if c fffffffffffffffffffffffffffffffffffffffffffffffffffffffffff c Perturbed AV or exAV ==> so set i_IsAVstillTheSame to "NO". Also, c update counter of AV/exAV steps. else if ((jj.GE.j_AV).AND.(jj.LT.j_fn)) then i_IsAVstillTheSame = 0 N_AVYAV_steps = N_AVYAV_steps + 1 c Safety precaution (shouldn't really get here anyway) else print *, ' ??? What am I doing here??? ' , $ i_IsAVstillTheSame , jj , par(jj) , par_try(jj) par_try(jj) = par(jj) goto 10 end if c ....................................................................... else c ........ Modifies par --> par_try: Shakes ALL par_j's per move!........ c Perturb/move par => par_try (limiting to low <=> upp boundaries). c Then renormalize population vector x_try = par_try(1...N_base) to c fn_try = par_try(j_fn). Also turn-off i_IsAVstillTheSame if AV/YAV c changed (which's VERY likely in this scheme). do j=1,N_par par_try(j) = par(j) + Chain_alpha(i_chain) * eps(j) $ * gasdev(idum) if (par_try(j).LT.par_low(j)) par_try(j) = par_low(j) if (par_try(j).GT.par_upp(j)) par_try(j) = par_upp(j) end do !CFl! Undo random exAV change and impose CF-law if (IsCFlawOn.EQ.1) par_try(j_exAV) = $ a0_CFl + (a1_CFl - 1.) * par_try(j_AV) fn_try = par_try(j_fn) sum_x = 0. do j=1,N_base sum_x = sum_x + par_try(j) end do do j=1,N_base par_try(j) = (par_try(j) / sum_x) * fn_try end do i_IsAVstillTheSame = 1 do j=j_AV,j_fn-1 if (par_try(j).NE.par(j)) i_IsAVstillTheSame = 0 end do c ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !OPTfn! !OJO! As above, but not really tested since I never used this shake-it-all-pars option anyway! if (IsOptimize_fn_OPT.EQ.1) then zilt = MEX_Fpar_VFchi2(N_par,N_base,par_try, & i_IsAVstillTheSame) do j=1,N_base par_try(j) = par_try(j) * Optimal_fn_OPT end do par_try(j_fn) = fn_try * Optimal_fn_OPT end if c ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff c ....................................................................... end if c Compute energy at par_try. Then accept new position or not c according to Metropolis rule. Also, verify if par_try is a new c minimum for this chain. Ene_try = 0.5 * MEX_Fpar_VFchi2(N_par,N_base,par_try, $ i_IsAVstillTheSame) prob = 1. - exp(-(Ene_try - Ene) / Temperature) if ((Ene_try.LE.Ene).OR.(ran2(idum).GT.prob)) then do j=1,N_par par(j) = par_try(j) end do Ene = Ene_try if (Ene.LT.CEne_min(i_chain)) then do j=1,N_par Cpar_min(j,i_chain) = par(j) end do CEne_min(i_chain) = Ene N_min = N_min + 1 end if else c Step was rejected. Since we are using the fast skip-over-AV-loop c trick, the saved-summations in the fast-chi2-routine must be c restored to correct values if a change in AV (or YAV) was c rejected, as is the case in the "if" below. A simple call to the c routine using the previous values will fix it. In this case, we c also update the counter of rejected AV/YAV steps. N_skip = N_skip + 1 if ((i_MoveOneParOnly.EQ.1).AND. $ (i_IsAVstillTheSame.EQ.0)) $ rubish = MEX_Fpar_VFchi2(N_par,N_base,par,0) if ((jj.GE.j_AV).AND.(jj.LT.j_fn)) N_AVYAV_skip = $ N_AVYAV_skip + 1 end if c Update par & par**2 summations for this chain (used in GR-test). do j=1,N_par S_par(j,i_chain) = S_par(j,i_chain) + par(j) S_par2(j,i_chain) = S_par2(j,i_chain) + par(j) * par(j) end do !2BEDONE! AQUI teria que passar todos os chi2s pra salvar e ver a influencia deles nos fits!! !2BEDONE!!tvz a linha que diz rubish = MEX_Fpar_VFchi2(N_par,N_base,par,0) atrapalhe... se houverem commons... c Save Step if i_UnitScubi > 0 if (i_UnitScubi.GT.0) call SaveStep(i_sim,i_chain,N_par,par $ ,Ene) !!MEX!! Just testing AV & exAV steps... ! if ((jj.GE.j_AV).AND.(jj.LT.j_fn)) write (* ! $ ,'(4(i5,2x),20(f6.3,2x))') i_chain , i_sim , jj ,N_skip ! $ ,(par(j),j=1,N_par) c Goto next step i_sim for chain # i_chain end do c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Screen check of running-AV/YAV-efficiency... ! AVYAV_eff = 1. - float(N_AVYAV_skip) / float(N_AVYAV_steps) ! write (*,'(a,3(1x,i5),3(a,f10.5))') ' AVYAVeff ' , i_chain , ! $ N_AVYAV_steps , N_AVYAV_skip , ' eff%=' , 100. ! $ * AVYAV_eff , ' eps_AV=', eps(j_AV) , ' last_AV=' ! $ ,par(j_AV) c Compute chain-efficiency (latest N_sim steps only) & update global c efficiency summation (eff_Scubi). Chain_eff(i_chain) = 1. - float(N_skip) / float(N_sim) eff_Scubi = eff_Scubi + N_skip c Store final chain parameters in Cpar_last (used to restart it the c next time), and compute Cpar_ave = mean & Cpar_var = variance of c par(j), used in the GR test. Note the abs in the variance to avoid c precision bugs... do j=1,N_par Cpar_last(j,i_chain) = par(j) Cpar_ave(j,i_chain) = S_par(j,i_chain) / float(N_steps) Cpar_var(j,i_chain) = abs(S_par2(j,i_chain) - $ float(N_steps) * Cpar_ave(j,i_chain) * Cpar_ave(j $ ,i_chain)) / float(N_steps - 1) end do c Goto next chain end do c ----------------------------------------------------------------------- c -------------- Re-evaluate CEne_min's if NRC_AV changed --------------- c If NRC_AV changed since last loops through the chains it's a good c idea to recompute all minimum chain-energies. Also, reset c NRC_AV_last to current value. if (NRC_AV.NE.NRC_AV_last) then do i_chain=1,N_chains do j=1,N_par aux1(j) = Cpar_min(j,i_chain) end do CEne_min(i_chain) = 0.5*MEX_Fpar_VFchi2(N_par,N_base,aux1,0) end do NRC_AV_last = NRC_AV end if c ----------------------------------------------------------------------- c -- Brief break to search 4 a better Global minimum & define Gpar_ave -- c Look up which chain has the smallest minimum & store it in the c Global minimum arrays if it's better than GE_min. do i_chain=1,N_chains if (CEne_min(i_chain).LT.GE_min) then do j=1,N_par Gpar_min(j) = Cpar_min(j,i_chain) end do GE_min = CEne_min(i_chain) end if end do c Verify if one of the N_chains-Cpar_ave's is a better Global-minimum... do i_chain=1,N_chains do j=1,N_par aux1(j) = Cpar_ave(j,i_chain) end do Ene_ave = 0.5 * MEX_Fpar_VFchi2(N_par,N_base,aux1,0) if (Ene_ave.LT.GE_min) then do j=1,N_par Gpar_min(j) = aux1(j) end do GE_min = Ene_ave end if end do c Define global-par-average & verify if it is a better Global-minimum... do j=1,N_par Gpar_ave(j) = 0. do i_chain=1,N_chains Gpar_ave(j) = Gpar_ave(j) + Cpar_ave(j,i_chain) end do Gpar_ave(j) = Gpar_ave(j) / float(N_chains) end do GEne_ave = 0.5 * MEX_Fpar_VFchi2(N_par,N_base,Gpar_ave,0) if (GEne_ave.LT.GE_min) then do j=1,N_par Gpar_min(j) = Gpar_ave(j) end do GE_min = GEne_ave end if c ----------------------------------------------------------------------- !CFl! !OJO! Not sure if CFl-related changes are needed below ... Beware! c --------------- Update alpha & eps(AV/YAV) (if wanted) ---------------- c Update alpha based on efficiency using an exponential recipe. c Updates can be made for all chains at once (i_UpdateAlpha = 1), in c which case the mean efficiency is used. Using i_UpdateAlpha = 2 c will update alpha for each chain using its own efficiency. c ATT: Alpha-updates are only done if the resulting step size is c not too big (> 20% of low==>upp range)!! if (i_UpdateAlpha.EQ.1) then call avevar(Chain_eff,N_chains,ave_eff,var_eff) alp_factor = Falpha**((ave_eff - eff_IDEAL) / eff_IDEAL) if (ave_eff.GE.eff_IDEAL) alp_factor = Falpha**((ave_eff - $ eff_IDEAL) / (1. - eff_IDEAL)) test_alpha = Chain_alpha(1) * alp_factor do j=1,N_par z1 = test_alpha * eps(j) z2 = (par_upp(j) - par_low(j)) / 5. if (z1.GT.z2) goto 50 end do do i_chain=1,N_chains Chain_alpha(i_chain) = test_alpha end do else if (i_UpdateAlpha.EQ.2) then do i_chain=1,N_chains alp_factor = Falpha**((Chain_eff(i_chain) - eff_IDEAL) / $ eff_IDEAL) if (Chain_eff(i_chain).GE.eff_IDEAL) alp_factor = $ Falpha**((Chain_eff(i_chain) - eff_IDEAL) / (1. - $ eff_IDEAL)) test_alpha = Chain_alpha(i_chain) * alp_factor do j=1,N_par z1 = test_alpha * eps(j) z2 = (par_upp(j) - par_low(j)) / 5. if (z1.GT.z2) goto 40 end do Chain_alpha(i_chain) = test_alpha 40 DoNothingOnThisSillyLine = 0. end do end if 50 DoNothingOnThisSillyLine = 0. c Adjust the step-size for AV & YAV according to how efficient were c the moves in these 2 variables in the past N_sim steps of all c chains. This is equivalent to the alpha-update above, but here we c operate on eps itself instead of on alpha. Again, precautions are c taken against too large step-sizes. Also, we consider that the c effective step size depends on alpha (updated above). if (i_UpdateAVYAVStepSeparately.EQ.1) then AVYAV_eff = 1. - float(N_AVYAV_skip) / float(N_AVYAV_steps) eps_factor = Falpha**((AVYAV_eff - eff_IDEAL) / eff_IDEAL) if (AVYAV_eff.GE.eff_IDEAL) eps_factor = Falpha**((AVYAV_eff - $ eff_IDEAL) / (1. - eff_IDEAL)) alp_ave = Chain_alpha(1) if (i_UpdateAlpha.EQ.2) call avevar(Chain_alpha,N_chains $ ,alp_ave,alp_var) z1 = alp_ave * eps_factor * eps(j_AV) z2 = (par_upp(j_AV) - par_low(j_AV)) / 5. if (z1.LT.z2) eps(j_AV) = eps_factor * eps(j_AV) do j=j_exAV,j_fn-1 z1 = alp_ave * eps_factor * eps(j) z2 = (par_upp(j) - par_low(j)) / 5. if (z1.LT.z2) eps(j) = eps_factor * eps(j) end do ! Screen check ! write (*,'(a,2(1x,i5),2(a,f10.6),a,9(2x,f10.6))') ! $ ' *> AVYAV-step-update: ',N_AVYAV_steps , N_AVYAV_skip , ! $ ' eff%=' , 100.* AVYAV_eff, ' eps_AV=',eps(j_AV), ! $ ' eps_exAV=',(eps(j),j=j_exAV,j_fn-1) end if c ----------------------------------------------------------------------- c ----------------------- GR Convergence Test --------------------------- c Perform Gelman & Rubin R-test. Note that we EXCLUDE fn from the c test! This is justifiable because fn is already inside the c pop-vector... Since fn is the last entry in par(), we just pretend c there are N_par - 1 parameters. call Calc_GR_R(N_steps,N_chains,Npar4GRtest,Cpar_ave,Cpar_var, $ R_Threshold,GR_R,GR_R_ave,IsAveBurnInOver,IsIndBurnInOver, $ i_verbose) c Verify if GR-R converged. If so, we are close enough to the end of c the burn-in to get out of the convergence loop and start a proper c mapping of the parameter space with other routines. Otherwise, c iterate again adding more points to the chains, until either R < c R_Threshold or we exceed our limit on N_steps... (<= Nmax_steps). i_aux = IsAveBurnInOver if (IsGRTestHard.EQ.1) i_aux = IsIndBurnInOver c Burn-In over:) print something & go home. if (i_aux.EQ.1) then IsBurInOver = 1 if (i_verbose.GE.1) write (*,'(a,i8,a,1p,e9.3)') $ '[Scubidu] Burn In over after ' ,N_steps , $ ' steps :) @ T = ' , Temperature goto 200 c GR-convergence was NOT reached after Nmax_steps:( Issue a Warning c and give up! else if ((i_aux.EQ.0).AND.(N_steps.GT.Nmax_steps)) then if (i_verbose.EQ.1) write (*,'(a,i8,1p,2(a,e9.3),a)') $ '[Scubidu] ATT: NO CONVERGENCE after ' ,N_steps , $ ' steps:( @ Temperature = ' , Temperature, ' =' $ ,GR_R_ave,' :( ...but will keep going...' goto 200 end if c ----------------------------------------------------------------------- c ------------------- Burn In NOT over: Iterate More -------------------- c Burn-In NOT over:( Do a few things, print stuff & iterate more... alp_ave = Chain_alpha(1) alp_var = 0. if (i_UpdateAlpha.EQ.2) call avevar(Chain_alpha,N_chains,alp_ave $ ,alp_var) call avevar(Chain_eff,N_chains,ave_eff,var_eff) c Find out which parameter has the largest R. par(jR_max) will be c given an extra help in the next loop through the chains. R_max = GR_R(1) jR_max = 1 do j=2,Npar4GRtest if (GR_R(j).GT.R_max) then R_max = GR_R(j) jR_max = j end if end do c Increase step size for parameters with large R_j (compared to ) c NEED TESTS!!! Maybe ABANDON this feature???? if (i_UpdateEps.EQ.1) then do j=1,Npar4GRtest if ((GR_R(j)/GR_R_ave).GT.3.0) then test_eps = eps(j) * Feps z1 = (par_upp(j) - par_low(j)) / 5. if ((alp_ave * test_eps).LT.z1) then write (*,*) ' ????Re-scaled eps_j: ', j , eps(j) $ ,test_eps , GR_R(j) , GR_R_ave eps(j) = test_eps end if end if end do end if c Print stuff... if (i_verbose.GT.1) then min_pRmax = Cpar_last(jR_max,1) max_pRmax = Cpar_last(jR_max,1) do i_chain=1,N_chains z1 = Cpar_last(jR_max,i_chain) if (z1.LT.min_pRmax) min_pRmax = z1 if (z1.GT.max_pRmax) max_pRmax = z1 aux1(i_chain) = z1 end do call avevar(aux1,N_chains,ave_aux,var_aux) write (*,1) '[Scubidu] N_steps=',N_steps ,' 2Emin=',2*GE_min , $ ' T=',Temperature , ' a=',alp_ave , ' a*eps_x=' $ ,alp_ave*eps(1), ' a*eps_AV=',alp_ave*eps(j_AV), $ ' eff%=',100*ave_eff ,' =' ,GR_R_ave , ' <' ,R_max $ ,jR_max, ' d=', max_pRmax - min_pRmax , ' sig=', $ sqrt(var_aux) 1 format (a,i9,1p,a,e12.6,4(a,e8.2),0p,3(a,f6.2),1x,i3,2(a,f7.4)) ! screen test ! write (*,'(a,i3,7(1x,f8.3))') 'TEST>',jR_max, ! $ (aux1(i_chain),i_chain=1,N_chains) ! write (*,'(a,i3,7(1x,f8.3))') 'TEST>',jR_max, par_low(jR_max), ! $ par_upp(jR_max) , Gpar_min(jR_max) end if c Iterate all chains another N_sim steps goto 100 c ----------------------------------------------------------------------- c *************************************************************************** c *************************************************************************** c * FINALIZATION... * c *************************************************************************** c Just check if yields a better model than the last point for c each chain. If so, reset Cpar_last to Cpar_ave (& maybe Cpar_min c too) before returning. Take the oportunity to verify if a new c global minimum is found on the way. 200 do i_chain=1,N_chains do j=1,N_par par(j) = Cpar_last(j,i_chain) aux1(j) = Cpar_ave(j,i_chain) end do Ene_last = 0.5 * MEX_Fpar_VFchi2(N_par,N_base,par,0) Ene_ave = 0.5 * MEX_Fpar_VFchi2(N_par,N_base,aux1,0) CEne_last(i_chain) = Ene_last if (Ene_ave.LT.Ene_last) then do j=1,N_par Cpar_last(j,i_chain) = Cpar_ave(j,i_chain) end do CEne_last(i_chain) = Ene_ave end if if (Ene_ave.LT.CEne_min(i_chain)) then do j=1,N_par Cpar_min(j,i_chain) = Cpar_ave(j,i_chain) end do CEne_min(i_chain) = Ene_ave end if if (Ene_ave.LT.GE_min) then do j=1,N_par Gpar_min(j) = Cpar_ave(j,i_chain) end do GE_min = Ene_ave end if end do c Store low-->upp range among last parameters of all chains in c Cpar_low & _upp, just for control... do j=1,N_par Cpar_low(j) = Cpar_last(j,1) Cpar_upp(j) = Cpar_last(j,1) do i_chain=2,N_chains z1 = Cpar_last(j,i_chain) if (z1.LT.Cpar_low(j)) Cpar_low(j) = z1 if (z1.GT.Cpar_upp(j)) Cpar_upp(j) = z1 end do end do c Define mean alpha (to be returned as "alpha") alp_ave = Chain_alpha(1) alp_var = 0. if (i_UpdateAlpha.EQ.2) call avevar(Chain_alpha,N_chains $ ,alp_ave,alp_var) alpha = alp_ave c Define overall efficiency (to be returned) eff_Scubi = 1. - eff_Scubi / float(N_steps * N_chains) ! Screen output , , , ... chi2(

)...Gpar_ave & ! p_last-stats... if (i_verbose.GT.1) then call avevar(Chain_eff,N_chains,ave_eff,var_eff) call avevar(CEne_last,N_chains,ave_Ene,var_Ene) call avevar(eps,N_par,ave_eps,var_eps) do j=1,N_par aux1(j) = 0. do i_chain=1,N_chains aux1(j) = aux1(j) + Cpar_last(j,i_chain) end do aux1(j) = aux1(j) / float(N_chains) end do chi2_ave_last = MEX_Fpar_VFchi2(N_par,N_base,aux1,0) write (*,'(1p,3(a,e12.5))') $ '[Scubidu] Leaving routine with = ',2*ave_Ene, $ ' +/- ' , 2*sqrt(var_Ene) , ' | chi2() = ' $ , chi2_ave_last zlix = MEX_Fpar_Slowchi2(N_par,N_base,Gpar_min) write (*,'(28x,1p,2(a,e12.5),a)') 'Gchi2_min = ' , 2. * GE_min $ , ' (FAST) & ' , zlix , ' (SLOW)' write (*,'(30x,2(a,f12.5))') ' = ' , 100* ave_eff , $ ' +/- ', 100 * sqrt(var_eff) write (*,'(30x,1p,2(a,e12.5))') ' = ' , alp_ave, $ ' +/- ' ,sqrt(alp_var) write (*,'(30x,1p,4(a,e12.5))') ' = ' , ave_eps, ' +/- ' $ , sqrt(var_eps) , ' | * = ',alp_ave $ * ave_eps , ' | * eps_AV = ',alp_ave * eps(j_AV) write (*,'(34x,2(a,f12.5),a,i1,a)') ' = ' , GR_R_ave , $ ' | R_Threshold = ',R_Threshold , ' (',IsGRTestHard,')' write (*,'(30x,a,i8,a,i8)') 'N_steps = ' , N_steps , $ ' <= Nmax_steps = ' , Nmax_steps write (*,'(28x,a,1p,e12.5)') 'eff_min % = ' , 100. $ * float(N_min) / float(N_steps * N_chains) write (*,*) write (*,'(a,a)') '[Scubidu] Gpar_ave & par_last(j) ' , $ 'chain-stats after Scubi-run' do j=1,N_par c Define std-dev among the Cpar_ave's for each parameter. Also c define std-dev & etc among the Cpar_last's for each parameter do i_chain=1,N_chains aux1(i_chain) = Cpar_ave(j,i_chain) - Gpar_ave(j) aux2(i_chain) = Cpar_last(j,i_chain) end do call avevar(aux1,N_chains,ave_diff,var_diff) Gpar_sig(j) = sqrt(abs(var_diff)) if (var_diff.LT.0.) Gpar_sig(j) = - Gpar_sig(j) call avevar(aux2,N_chains,ave_p,var_p) sig_p = sqrt(var_p) min_p = Cpar_low(j) max_p = Cpar_upp(j) p_best = Gpar_min(j) z1 = 1. if (j.LE.N_base) z1 = 100. write (*,'(a,i3,7(a,f6.2),a,f7.3,a,i3,a,f7.3)') $ '[Scubidu] j =' ,j , $ ' = ',z1*Gpar_ave(j),' +/- ',z1 *Gpar_sig(j) , $ ' | = ',z1*ave_p,' +/- ',z1*sig_p , $ ' | Range=',z1*min_p,' --> ',z1*max_p , $ ' | Delta= ',z1*max_p - z1*min_p , $ ' | Gp_min= ',z1*p_best , ' ~ ',nint(z1*p_best) , $ ' | R_j = ' , GR_R(j) end do write (*,*) write (*,'(a)') '[Scubidu] Chains Minima after Scubi-run' write (*,'(a,1p,40(1x,e8.2))') '[Scubidu] Chain-chi2_min = ' $ , (2.* CEne_min(i_chain),i_chain=1,N_chains) do j=1,N_par z1 = 1. if (j.LE.N_base) z1 = 100. write (*,'(a,i3,a,40(2x,f7.3))') '[Scubidu] j =' ,j , $ ' | p_j = ', (z1*Cpar_min(j,i_chain),i_chain=1 $ ,N_chains) end do c Prints best chain energy & compare it to global minimum... z_min = CEne_min(1) i_min = 1 do i_chain=2,N_chains if (CEne_min(i_chain).LT.z_min) then z_min = CEne_min(i_chain) i_min = i_chain end if end do write (*,'(a,i3,1p,3(a,e8.2))') '[Scubidu] Best Chain = ' , $ i_min,' 2*CEne_min = ', 2.*z_min , ' | 2*GE_min = ',2. $ *GE_min,' | Diff = ' , 2.*(z_min - GE_min) write (*,*) end if c *************************************************************************** c This is the end of SUBROUTINE MEX_ScubiduCadeVoce! end c ########################################################################### c ########################################################################### c Unpack par-vector to (x,fn,AV,exAV) & compute chi2 using c SlowF_chi2. Assumes x is already normalized to sum x_j = fn! FUNCTION MEX_Fpar_Slowchi2(N_par,N_base,par) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nb_max = 300,Npar_max = 601) real par(Npar_max) , x(Nb_max) , AV_tot(Nb_max) ,exAV(Nb_max) call MEX_Unpack_par2xAVYAVfn(N_par,N_base,par,x,AV,exAV,fn) call MEX_Update_AV_array(N_base,AV,exAV,AV_tot) MEX_Fpar_Slowchi2 = SlowF_chi2(x,AV_tot) return end c ########################################################################### c ########################################################################### c Unpack par-vector to (x,fn,AV,exAV) & compute chi2 using c VeryFastF_chi2 Assumes x is already normalized to sum x_j = fn! c This version use the i_IsAVstillTheSame-trick! FUNCTION MEX_Fpar_VFchi2(N_par,N_base,par,i_IsAVstillTheSame) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nb_max = 300,Npar_max = 601) real par(Npar_max) , x(Nb_max) , AV_tot(Nb_max) , exAV(Nb_max) call MEX_Unpack_par2xAVYAVfn(N_par,N_base,par,x,AV,exAV,fn) call MEX_Update_AV_array(N_base,AV,exAV,AV_tot) MEX_Fpar_VFchi2 = VeryFastF_chi2(x,AV_tot,i_IsAVstillTheSame) return end c ########################################################################### c ########################################################################### c Unpack par-vector to x(), AV, exAV() & fn c Cid@Lagoa - 19/April/2007 SUBROUTINE MEX_Unpack_par2xAVYAVfn(N_par,N_base,par,x,AV,exAV,fn) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nb_max = 300,Npar_max = 601) real par(Npar_max) , x(Nb_max) , exAV(Nb_max) *FIR* Reset outputs for safety/caution/paranoia! - Cid@Lagoa 16/Jan/2010 AV = 0. fn = 0. do j=1,Nb_max x(j) = 0. exAV(j) = 0. end do if ((N_par.LE.0).OR.(N_base.LE.0)) then write (*,*) $ '[MEX_Unpack_par2xAVYAVfn] N_base <= 0!! N_base = ' $ ,N_base , ' N_par = ' , N_par stop end if j_AV = N_base + 1 j_exAV = N_base + 2 j_fn = N_par do j=1,N_base x(j) = par(j) end do AV = par(j_AV) do j=j_exAV,j_fn-1 !OBS: This loop only runs if Nex_AV > 0! jMEX = j - j_exAV + 1 exAV(jMEX) = par(j) end do fn = par(j_fn) end c ########################################################################### c ########################################################################### c Simple routine just to store AV & YAV onto an AV_tot array. The c array ind_exAV(), defined elsewhere, says which components have c which of the exAV(1...N_exAV) N_exAV extra extinctions allowed. c Routines which compute a synthetic spectrum and the chi2-routines c combine AV & exAV to build the population dependent total c extinction AV_tot(j) c Cid@Lagoa - 21/April/2007 !!MEX!! VERY IMPORTANT! I have introduced a CUMULATIVE AV-scheme! ! For instance, if a component has ind_exAV = 2, its AV will be ! the global one PLUS exAV(1) AND exAV(2).. ! Cid@Lagoa - 27/May/2007 !ESM! Used to have N_par as a parameter, but it's not used! removed it. ! Cid@Lagoa - 19/Aug/2017 SUBROUTINE MEX_Update_AV_array(N_base,AV,exAV,AV_tot) implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nb_max = 300) real AV_tot(Nb_max) , exAV(Nb_max) common/exAV_stuff/ N_exAV , ind_exAV(Nb_max) *FIR* Reset outputs for safety/caution/paranoia! - Cid@Lagoa 16/Jan/2010 do j=1,Nb_max AV_tot(j) = 0. end do !!MEX!! Cumulative AV_tot... do j=1,N_base AV_tot(j) = AV !CFl! Because in the CFl-scheme ind_exAV = -1 or 0, I had to introduce ! the abs() in the command below - Cid@Lagoa - 03/Aug/2017 do jMEX = 1,abs(ind_exAV(j)) AV_tot(j) = AV_tot(j) + exAV(jMEX) end do end do end c ########################################################################### c ########################################################################### c # !!MEX!! CONDENSE BASE (excluding irrelevant x_j) & RUN Fit_Scubi # c ########################################################################### c This routine reduces/condenses the spectral base (Of_base & c f_base, used in all routines), excluding all components in c x_Test() which fail and EX0s-criterion which depends on the c EX0s_method_option-string. In the 'CUMUL' method we exclude the c weaker components which add up to < EX0s_Threshold. In the 'SMALL' c method we throw away any component which contributes with less c flux than EX0s_Threshold / N_base. This reduction is limited to a c smaller base dimension of N_base_min. x_Test may be, for instance, c the best, or the global-average population vector. c c All "Irrelevant" components are zero'ed. We then call Fit_Scubidu c to obtain new fits. Before exiting, the base matrices & other c arrays are restored to their original format, otherwise things c would become a total mess! c c Cid@Lagoa - 27/Mar/2005 !ESM! x_Test could/should include ETC info (ie, the % contributions to QHR, ! PHO & FIR) , otherwise one might end up eliminating a component that is ! irrelevan in the optical but relevant in, say, FUV or NUV. On the other ! hand, we probably do **not** want optically components in a STARLIGHT ! analysis ... I thus dropped my qualms about this point and left things ! the way they were, i.e., measuring relavance through an optical-based ! x. In any case, to change this logic, one would need to do it before ! calling this routine, by inventing sie truely pan-chromatic ! pop vector and using it for x_Test. ! Cid@Lagoa - 07/Aug/2017 SUBROUTINE MEX_EX0s_Fit_Scubi(i_verbose,idum,N_loops,v0_low,v0_upp $ ,vd_low,vd_upp,x_min,AV_min,exAV_min,v0_min,vd_min,Ntot_EX0s $ ,eff_EX0s,Nl_eff,iMassAgeZ_verbose,N_par,ChainPar,N_chains $ ,Temp_ini,Temp_fin,fini_eps,ffin_eps,R_ini,R_fin,N_sim $ ,Nmax_steps,i_RestartChains,Gpar_min,GE_min,Gpar_ave,Cpar_min $ ,CEne_min,x_Test,EXOs_method_option,EX0s_Threshold,N_base_min $ ,IsKinFixed_EX0s,IsBurInOver_EX0s,N_base_Relevant $ ,IsScaleNstepsInEX0sFits,IsNoKin4LargeBaseInEX0sFits $ ,frac_NoKin4LargeBaseInEX0sFits) c *************************************************************************** c * DEFINITIONS * c *************************************************************************** implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) parameter (Nchains_max = 1000,Npar_max = 601) parameter (NAVgrid_max = 1001) *PHO* parameter (NPHO_Ys_max=100) c Observed spectra & etc. (Not really needed here, but I'm using the c Obs-common to read Nl_obs) real l_obs(Nl_max) , f_obs(Nl_max) , weight_obs(Nl_max) c Population vector & base arrays real x_Test(Nb_max) , x_min(Nb_max) real f_base(Nb_max,Nl_max) , Of_base(Nb_max,Nl_max) real FULL_Of_base(Nb_max,Nl_max) c Auxiliar pop vector & its sorting-index-array real x_aux(Nb_max) integer ind_x_aux(Npar_max) c Auxiliar array which map components with x(j) > x_RelevantThreshold! integer ind_Relevant(Npar_max) c Original Full-Base parameter limits real Opar_low(Npar_max) , Opar_upp(Npar_max) c Chain-stuff-arrays! real ChainPar(Npar_max,Nchains_max) real Gpar_min(Npar_max) , Gpar_ave(Npar_max) real Cpar_min(Npar_max,Nchains_max) , CEne_min(Nchains_max) c Original Full-Base HelpParMove2Average arrays integer iO_ind_HelpParMove2Average(Npar_max) real Oprob_HelpParMove2Average(Npar_max) c Short-arrays! real Shortx_min(Nb_max) , ShortChainPar(Npar_max,Nchains_max) real ShortGpar_min(Npar_max) , ShortGpar_ave(Npar_max) real ShortCpar_min(Npar_max,Nchains_max) real ShortCEne_min(Nchains_max) c Option-String which defines which method will be used to define c who is relevant and who is not in the pop vector x_Test! character*5 EXOs_method_option c commons... common/Obs/ Nl_obs , l_obs , f_obs , weight_obs common/Base/ N_base , f_base common/Obase/ Of_base c Lower & upper limits on parameters (x,AV,YAV,fn) common/ParLimits/ par_low(Npar_max) , par_upp(Npar_max) c ScubiduCadeVoce Technical Parameters - All we actually need here c are the ind_HelpParMove2Average & prob_HelpParMove2Average arrays! common/Scubi_TechnicalParameters/ alpha , Falpha , IsGRTestHard , $ eff_IDEAL , i_UpdateEps , Feps , i_UpdateAlpha , $ i_MoveOneParOnly , i_HelpParWithMaxR , prob_jRmax , $ Npar4GRtest ,i_UpdateAVYAVStepSeparately , $ ind_HelpParMove2Average(Npar_max) , $ prob_HelpParMove2Average(Npar_max) * MEX-arrays real exAV_min(Nb_max) common/exAV_stuff/ N_exAV , ind_exAV(Nb_max) * Original/FULL ind_exAV_array integer IFULL_ind_exAV(Nb_max) *FIR* FIR-Base-common + Original FIRRmat matrix & FIRBolCor * ATT1: ONLY FIRRmat & FIRBoldCor are condensed & then restored! * ATT2: We condense-&-restore these FIR-things even for * non-FIR-fits, in which case these arrays may be empty/undefined!! common/FIR_BaseStuff/ NFIR_AV , FIRAV_grid(NAVgrid_max) , $ FIRAV_low , FIRAV_upp , FIRdAV , $ FIRLbol(Nb_max) , FIRFracLion(Nb_max) , FIRBolCor(Nb_max) , $ FIRR_opt(Nb_max,NAVgrid_max) , FIRR_Lya(Nb_max,NAVgrid_max) , $ FIRR_LCE(Nb_max,NAVgrid_max) , $ FIRRmat(Nb_max,NAVgrid_max) , FIR_q_norm , NFIR_base real OFIRRmat(Nb_max,NAVgrid_max) , OFIRBolCor(Nb_max) *QHR* QHR-Base-common + Original OQHR_Q2Lnorm40 array. * ATT1: ONLY OQHR_Q2Lnorm40 is condensed & then restored, as it is * the only one actually used in function QHR_CalcQHRchi2. * ATT2: As above, this is done even for non-QHR-fits! common/QHR_BaseStuff/ QHR_qH40(Nb_max) , QHR_Q2Lnorm40(Nb_max) , $ QHR_q_norm , QHRbeta_I , NQHR_base real OQHR_Q2Lnorm40(Nb_max) *PHO* Base-info-common. !FOCA!... common/PHO_BaseStuff/ NPHO_AV , PHOAV_grid(NAVgrid_max) , $ PHOAV_low , PHOAV_upp , PHOdAV , $ PHO_MeanLambda(NPHO_Ys_max) , PHO_StdDevLambda(NPHO_Ys_max) , $ PHO_PivotLambda(NPHO_Ys_max) , $ PHO_q_MeanLambda(NPHO_Ys_max) , $ PHO_3Mat(Nb_max,NPHO_Ys_max,NAVgrid_max) , $ PHO_q_norm , NPHO_base real OPHO_3Mat(Nb_max,NPHO_Ys_max,NAVgrid_max) *PHO* OBS: This routine does not have access to NPHO_Ys, and yet need * to set/reset PHO_3Mat & OPHO_3Mat in the following lines: * PHO_3mat(j,iY,i_AV) = OPHO_3mat(j_in_full_base,iY,i_AV) * PHO_3mat(j,iY,i_AV) = OPHO_3mat(j,iY,i_AV) * OPHO_3Mat(j,iY,i_AV) = PHO_3Mat(j,iY,i_AV) * For simplicity, I just use NPHO_Ys_max in the iY set/reset do-loops, * which is fine. c *************************************************************************** c *************************************************************************** c * INITIALIZATION: STORE ORIGINAL STUFF * c *************************************************************************** c Store original N_base, N_par & AV/exAV/fn indices. NO_base = N_base NO_par = N_base + 1 + N_exAV + 1 jO_AV = N_base + 1 jO_exAV = N_base + 2 jO_fn = NO_par c Store original full base Of_base ==> FULL_Of_base, since Of_base c will be modified below! Do the same thing for the ind_exAV array. do j=1,NO_base do i=1,Nl_obs FULL_Of_base(j,i) = Of_base(j,i) end do IFULL_ind_exAV(j) = ind_exAV(j) end do c Store original par-limits & arrays which say whether to help c parameters to converge and with what probability. do j=1,NO_par Opar_low(j) = par_low(j) Opar_upp(j) = par_upp(j) iO_ind_HelpParMove2Average(j) = ind_HelpParMove2Average(j) Oprob_HelpParMove2Average(j) = prob_HelpParMove2Average(j) end do *FIR* Store original FIRRmat matrix & FIRBolCor array *QHR* Store original QHR_Q2Lnorm40 array *PHO* Store original PHO_3Mat 3D array * ATT: using NPHO_Ys_max since NPHO_Ys is nor available to this * routine! do j=1,NO_base do i_AV=1,NFIR_AV OFIRRmat(j,i_AV) = FIRRmat(j,i_AV) end do !IIB! This is where the Illegal Instruction bug appeared... c Rafa Faltaba un bucle para NPHO_AV. Solo estaba para NFIR_AV c pero si no ajustamos FIR entonces NFIR_AV = 0 c Aparece dos veces mas en MEX_EX0s_Fit_Scubi, ya esta cambiado :) * Cid@UFSC - 04/Jul/2017: Rafa thought this was not a bug, but it wasn't, since * NFIR_AV = NPHO_AV. In any case, I kept his changes cause it's more elegant. do i_AV=1,NPHO_AV do iY=1,NPHO_Ys_max OPHO_3Mat(j,iY,i_AV) = PHO_3Mat(j,iY,i_AV) end do end do OFIRBolCor(j) = FIRBolCor(j) OQHR_Q2Lnorm40(j) = QHR_Q2Lnorm40(j) end do c *************************************************************************** c *************************************************************************** c * CONSTRUCT INDEX-ARRAY OF "RELEVANT" COMPONENTS * c *************************************************************************** c Zero-in ind_Relevant() array for precaution do j=1,Npar_max ind_Relevant(j) = 0 end do N_base_Relevant = 0 sum_x_Relevant = 0 c Figure out the normalization of x_Test sum_x_Test = 0 do j=1,NO_base sum_x_Test = sum_x_Test + x_Test(j) end do c Now create x_aux, the normalized version of x_Test, and indexx it c in ind_x_aux, such that x_aux(ind_x_aux) is sorted in a increasing c order (stronger components last). do j=1,N_base x_aux(j) = x_Test(j) / sum_x_Test end do call indexx(N_base,x_aux,ind_x_aux) ! Screen output if (i_verbose.GT.0) then sum_x = 0 do j=1,NO_base j_aux = ind_x_aux(j) sum_x = sum_x + x_aux(j_aux) write (*,'(2(a,i3),2(a,f7.3),a)') '[EX0s_Fit_Scubi] ', j, $ ' : x_Test(',j_aux,' ) = ' ,100.*x_aux(j_aux), $ '% ==> Cumulative Sum = ' ,100*sum_x ,'%' end do end if c CUMULATIVE-EX0s-METHOD: In this case EX0s_Threshold means the c fraction of light in x_Test which will be thrown away! if (EXOs_method_option.EQ.'CUMUL') then c Construct array ind_Relevant() which contains the indices of the c N_base_Relevant components in x_Test(j) which add-upp to >= 1 - c EXOs_Threshold. (Actually, the loop below works the other way c around: it discards from ind_Relevant() the smallest-x elements, c which add up to a fraction <= EX0s_Threshold.) sum_x = 0 i_flag = 0 do j=1,NO_base j_aux = ind_x_aux(j) sum_x = sum_x + x_aux(j_aux) if ((i_flag.EQ.0).AND.(sum_x.GT.EX0s_Threshold)) i_flag = 1 if (i_flag.EQ.1) then sum_x_Relevant = sum_x_Relevant + x_aux(j_aux) N_base_Relevant = N_base_Relevant + 1 ind_Relevant(N_base_Relevant) = j_aux if (i_verbose.GT.1) then write (*,'(a,4(i4),3(f10.3))') $ '[EX0s_Fit_Scubi] Relevant comps.: ', j ,j_aux, $ N_base_Relevant ,ind_Relevant(N_base_Relevant), $ 100 *x_aux(j_aux),100*sum_x,100*sum_x_Relevant end if end if end do c SMALL-X-EX0s-METHOD: In this case EX0s_Threshold / N_base defines c the minimum value of x for a component to be kept in the c base. Weaker components will be thrown away! else if (EXOs_method_option.EQ.'SMALL') then c Set Threshold for elimination! x_RelevantThreshold = EX0s_Threshold / float(N_base) c Construct array ind_Relevant() which contains the indices of the c N_Relevant components in x_aux (= normalized x_Test) which are c stronger (ie, >) than x_RelevantThreshold. do j=1,NO_base if (x_aux(j).GT.x_RelevantThreshold) then N_base_Relevant = N_base_Relevant + 1 ind_Relevant(N_base_Relevant) = j sum_x_Relevant = sum_x_Relevant + x_aux(j) if (i_verbose.GT.1) then write (*,'(a,3(i4),2(f10.3))') $ '[EX0s_Fit_Scubi] Relevant comps.: ', j, $ N_base_Relevant ,ind_Relevant(N_base_Relevant), $ 100 *x_aux(j),100*sum_x_Relevant end if end if end do end if c PROTECTION against too large reductions in the base! If less than c N_base_min of the original base elements survived the reduction c above then just pick the N_base_min stonger elements. (Use the c sorting/index-array for this.) if (N_base_Relevant.LT.N_base_min) then write (*,'(a,i3,a,i3,a)') write (*,'(a,i5,a,i5,a)') $ '[EX0s_Fit_Scubi] ATT: N_base_Relevant = ' , $ N_base_Relevant , ' < N_base_min = ' ,N_base_min $ ,' elements in the reduced base! ' write (*,'(a,f7.3,a)') '[EX0s_Fit_Scubi] They they add up to ' $ ,100.*sum_x_Relevant , '% of the light.' write (*,'(a,i3,a)') $ '[EX0s_Fit_Scubi] Will fix this picking the ',N_base_min , $ ' strongest ones!!' write (*,*) N_base_Relevant = 0 sum_x_Relevant = 0 i_flag = 0 do j=NO_base,(NO_base-N_base_min+1),-1 j_aux = ind_x_aux(j) sum_x_Relevant = sum_x_Relevant + x_aux(j_aux) N_base_Relevant = N_base_Relevant + 1 ind_Relevant(N_base_Relevant) = j_aux ! write (*,'(a,3(i4),2(f10.3))') ! $ '[EX0s_Fit_Scubi] Relevant comps.: ', j ,j_aux ! $ ,N_base_Relevant ,100 *x_aux(j_aux),100 *sum_x_Relevant end do end if ! Screen output if (i_verbose.GT.0) then write (*,'(a,i3,a,f8.3,a)') '[EX0s_Fit_Scubi] There are ' $ , N_base_Relevant , $ ' elements in the reduced base, and they add up to ' , $ 100.*sum_x_Relevant , '% of the light.' write (*,'(a,a)') '[EX0s_Fit_Scubi] EX0-method = ' $ ,EXOs_method_option write (*,'(a,f7.3)') $ '[EX0s_Fit_Scubi] EX0s_Threshold = ' , EX0s_Threshold end if c Freeze kinematics for EX0-fits if condensed base is still "too c large": > frac_NoKin4LargeBaseInEX0sFits * N_base. OBS: In c StarlightChains_v01 we froze the kinematics for > 50 c components. Now we set this with the *NoKin4LargeBaseInEX0sFits c config variables. !Cid14Jan07-FXK! IsKinFixed_EX0s may already be 1 if doing FXK fits! N_aux = nint(frac_NoKin4LargeBaseInEX0sFits * N_base) if ((IsKinFixed_EX0s.NE.1).AND.(IsNoKin4LargeBaseInEX0sFits.EQ.1) $ .AND.(N_base_Relevant.GT.N_aux)) IsKinFixed_EX0s = 1 ! Screen output - to freeze or not to freeze kinematical fits... if (i_verbose.GT.0) then if (IsKinFixed_EX0s.EQ.1) then ! Note: If IsThisAnFXKFit = 1, the message below will be shown but ! means nothing which we did not already know! write (*,'(a,a)') '[EX0s_Fit_Scubi] ATT: ' , $ ' We will freeze in the kinematical parameters!' else write (*,'(a,a)') '[EX0s_Fit_Scubi] ATT: ', $ ' We will NOT freeze in the kinematical parameters!' end if end if c *************************************************************************** c *************************************************************************** c * SCALE N_sim & Nmax_steps for reduced base! * c * Cid@Lagoa - 09/October/2005 * c *************************************************************************** ! I realized that in StarlightChains_v01.for I fixed the numbers of ! steps N_sim & Nmax_steps for the EX0s runs as multiples of N_par ! (as in other parts of the code). As a consequence runs where only ! a few components are used in the EX0s fits do many more ! steps/per-parameter than runs whereas galaxies with many EX0s ! components do much less. A perhaps more reasonable thing to do is ! to scale the number of steps in terms of the number of Relevant ! parameters, which is only known once the code gets here. To use ! this new feature I introduced the IsScaleNstepsInEX0sFits = Y/N ! (1/0) flag. if (IsScaleNstepsInEX0sFits.EQ.1) then N_par_Relevant = N_base_Relevant + 1 + N_exAV + 1 scale_down_fac = float(N_par_Relevant) / float(NO_par) N_sim = nint(N_sim * scale_down_fac) Nmax_steps = nint(Nmax_steps * scale_down_fac) ! Safety: Lower limits to N_sim & Nmax_steps if (N_sim.LT.(10*N_par_Relevant)) N_sim = 10 * N_par_Relevant if (Nmax_steps.LT.(10*N_sim)) Nmax_steps = 10 * N_sim ! Screen output if (i_verbose.GT.0) then write (*,'(2(a,i8))') $ '[EX0s_Fit_Scubi] N_sim scaled from ' , $ nint(N_sim/scale_down_fac), ' to ' , N_sim write (*,'(2(a,i8))') $ '[EX0s_Fit_Scubi] Nmax_steps scaled from ' , $ nint(Nmax_steps/scale_down_fac) , ' to ',Nmax_steps end if end if c *************************************************************************** c *************************************************************************** c * CONDENSE BASE TO ITS "RELEVANT" COMPONENTS * c *************************************************************************** c Reset all Short* arrays do j=1,Nb_max Shortx_min(j) = 0. end do do j=1,Npar_max ShortGpar_min(j) = 0. ShortGpar_ave(j) = 0. do i_chain=1,Nchains_max ShortChainPar(j,i_chain) = 0. end do end do * Redefine N_base, N_par & par-indices of AV, exAV's & fn N_base = N_base_Relevant N_par = N_base + 1 + N_exAV + 1 j_AV = N_base + 1 j_exAV = N_base + 2 j_fn = N_par * Fill in last N_exAV + 2 elements of ind_Relevant() with AV, exAV's * & fn indices. ind_Relevant(j_AV) = jO_AV do j=j_exAV,j_fn-1 !OBS: This loop only runs if Nex_AV > 0! ind_Relevant(j) = jO_exAV + (j - j_exAV) end do ind_Relevant(j_fn) = jO_fn * Condense/shorten base N_base_Relevant components. Also condense * ind_exAV() array & recompute N_exAV_components for the smaller * base (both passed by the commom /exAV_stuff/ to other routines). * OBS: Everything must be restored before exiting!! do j=1,N_base j_in_full_base = ind_Relevant(j) do i=1,Nl_obs Of_base(j,i) = FULL_Of_base(j_in_full_base,i) f_base(j,i) = FULL_Of_base(j_in_full_base,i) end do ind_exAV(j) = IFULL_ind_exAV(j_in_full_base) end do c Condense par-limits & ind_HelpParMove2Average & c prob_HelpParMove2Average arrays (passed by common...) do j=1,N_par j_in_full_base = ind_Relevant(j) par_low(j) = Opar_low(j_in_full_base) par_upp(j) = Opar_upp(j_in_full_base) ind_HelpParMove2Average(j) = $ iO_ind_HelpParMove2Average(j_in_full_base) prob_HelpParMove2Average(j) = $ Oprob_HelpParMove2Average(j_in_full_base) end do * Reset exAV's NOT used in the condensed base to = 0! This must be * done after the Scubi run too, since irrelevant exAV's are NOT * excluded form the parameter list for simplicity! !!MEX!! NO! Now that we are using exAVs to compute CUMULATIVE total ! extinctions, we should NOT reset any exAV to zero, even if the ! components associated to it have zero flux! I have thus commented ! out the fragment below. ! ! Cid@Lagoa - 27/May/2007 ! do jMEX=1,N_exAV ! i_flag = 0 ! do j=1,N_base ! if (ind_exAV(j).EQ.jMEX) i_flag = 1 ! end do ! if (i_flag.EQ.0) then ! write (*,'(a,a,i2,a)') ! $ '[MEX_EX0s_Fit_Scubi] ATT: ', ! $ 'None of the Relevant components uses exAV (',jMEX, ! $ ') so I will reset it to ZERO!' ! j_aux = jMEX + j_AV ! do i_chain=1,N_chains ! ChainPar(j_aux,i_chain) = 0. ! Cpar_min(j_aux,i_chain) = 0. ! end do ! Gpar_min(j_aux) = 0. ! Gpar_ave(j_aux) = 0. ! end if ! end do c Condense pop vectors ChainPar() ==> ShortChainPar() for each c chain, plus the global average & minimum. do j=1,N_par j_in_full_base = ind_Relevant(j) do i_chain=1,N_chains ShortChainPar(j,i_chain) = ChainPar(j_in_full_base,i_chain) end do ShortGpar_min(j) = Gpar_min(j_in_full_base) ShortGpar_ave(j) = Gpar_ave(j_in_full_base) end do c Since we are throwing away all "irrelevant" components, it is a c good idea renormalize all chain-pop-vectors to their respective fn c (the irrelevant x_j's may still carry some flux if c x_RelevantThreshold > 0). 1st renomalize the chain-pop-vectors. do i_chain=1,N_chains sum_x = 0. do j=1,N_base sum_x = sum_x + ShortChainPar(j,i_chain) end do fn = ShortChainPar(j_fn,i_chain) do j=1,N_base ShortChainPar(j,i_chain) = ShortChainPar(j,i_chain)*sum_x/fn end do end do c Now renomalize the Global Average & Minimum pop-vectors. c (This is probably not necessary but it should do no harm!) sum1_x = 0. sum2_x = 0. do j=1,N_base sum1_x = sum1_x + ShortGpar_min(j) sum2_x = sum2_x + ShortGpar_ave(j) end do fn1 = ShortGpar_min(j_fn) fn2 = ShortGpar_ave(j_fn) do j=1,N_base ShortGpar_min(j) = ShortGpar_min(j) * sum1_x / fn1 ShortGpar_ave(j) = ShortGpar_ave(j) * sum2_x / fn2 end do * Define x_min, AV_min & exAV_min (probably un-necessary!) !!MEX!! This IS indeed un-necessary, and so I comment it out. ! do j=1,N_base ! Shortx_min(j) = ShortGpar_min(j) ! end do ! AV_min = ShortGpar_min(j_AV) ! do j=j_exAV,j_fn-1 !OBS: This loop only runs if Nex_AV > 0! ! jMEX = j - j_exAV + 1 ! exAV_min(jMEX) = ShortGpar_min(j) ! end do c Empty x_min, ChainPar, Gpar_min & Gpar_ave arrays. These arrays c will all be filled back in after the fit with a condensed base is c over. Here we empty them just to make sure we are zero-ing the c "irrelevant" components! do j=1,Nb_max x_min(j) = 0. end do do j=1,Npar_max Gpar_min(j) = 0. Gpar_ave(j) = 0. do i_chain=1,Nchains_max ChainPar(j,i_chain) = 0. end do end do *FIR* Condense FIR-related stuff: NFIR_base, FIRRmat(j,i_AV) & * FIRBolCor(j) OBS: Other FIR-arrays need not be condended (as * they're not used in the FIR_CalcFIRchi2 function!) *QHR* Condense QHRelated stuff: NQHR_base & QHR_Q2Lnorm40(j) *PHO* Condense PHO-related stuff: NPHO_base & PHO_3Mat(j,iY,i_AV) * ATT: using NPHO_Ys_max since NPHO_Ys is nor available to this * routine! NFIR_base = N_base NQHR_base = N_base NPHO_base = N_base do j=1,N_base j_in_full_base = ind_Relevant(j) do i_AV=1,NFIR_AV FIRRmat(j,i_AV) = OFIRRmat(j_in_full_base,i_AV) end do do i_AV=1,NPHO_AV do iY=1,NPHO_Ys_max PHO_3Mat(j,iY,i_AV) = OPHO_3Mat(j_in_full_base,iY,i_AV) end do end do FIRBolCor(j) = OFIRBolCor(j_in_full_base) QHR_Q2Lnorm40(j) = OQHR_Q2Lnorm40(j_in_full_base) end do c Screen output (Added on Jan/2010, but not a FIR-thing) if (i_verbose.GT.1) then do j=1,N_base write (*,'(3(a,i5,3x))') $ '[EX0s_Fit_Scubi] j=', j , $ 'ind_Relevant(j)=' , ind_Relevant(j) , $ 'ind_exAV(j) =' , ind_exAV(j) end do end if c *************************************************************************** c *************************************************************************** c * FIT SPECTRUM USING SHORTENED/CONDENSED BASE * c *************************************************************************** c Call MEX_Fit_Scubidu with condensed base call MEX_Fit_Scubidu(i_verbose,idum,N_loops,v0_low,v0_upp,vd_low $ ,vd_upp,Shortx_min,AV_min,exAV_min,v0_min,vd_min,Ntot_EX0s $ ,eff_EX0s,Nl_eff,0,N_par,ShortChainPar,N_chains,Temp_ini $ ,Temp_fin,fini_eps,ffin_eps,R_ini,R_fin,N_sim,Nmax_steps $ ,i_RestartChains,ShortGpar_min,GE_min,ShortGpar_ave $ ,ShortCpar_min,ShortCEne_min,IsKinFixed_EX0s, $ IsBurInOver_EX0s) c *************************************************************************** c *************************************************************************** c * RESTORE ORIGINAL BASE & REARRANGE POP-VECTORS * c *************************************************************************** c Rearrange all parameters onto correct full-base order. (Irrelevant c components have been zero'ed above!) do j=1,N_par j_in_full_base = ind_Relevant(j) do i_chain=1,N_chains ChainPar(j_in_full_base,i_chain) = ShortChainPar(j,i_chain) Cpar_min(j_in_full_base,i_chain) = ShortCpar_min(j,i_chain) CEne_min(i_chain) = ShortCEne_min(i_chain) end do Gpar_min(j_in_full_base) = ShortGpar_min(j) Gpar_ave(j_in_full_base) = ShortGpar_ave(j) end do * Reset exAV's NOT used in the condensed base to = 0! !!MEX!! NO! Now that we are using exAVs to compute CUMULATIVE total ! extinctions, we should NOT reset any exAV to zero, even if the ! components associated to it have zero flux! I have thus commented ! out the fragment below. ! ! Cid@Lagoa - 27/May/2007 ! do jMEX=1,N_exAV ! i_flag = 0 ! do j=1,N_base ! if (ind_exAV(j).EQ.jMEX) i_flag = 1 ! end do ! if (i_flag.EQ.0) then ! write (*,'(a,a,i2,a)') ! $ '[MEX_EX0s_Fit_Scubi] ATT: ', ! $ 'None of the Relevant components uses exAV (',jMEX, ! $ ') so I will reset it to ZERO!' ! j_aux = jMEX + jO_AV ! do i_chain=1,N_chains ! ChainPar(j_aux,i_chain) = 0. ! Cpar_min(j_aux,i_chain) = 0. ! end do ! Gpar_min(j_aux) = 0. ! Gpar_ave(j_aux) = 0. ! end if ! end do * Restore Original base: FULL_Of_base ==> Of_base & f_base do i=1,Nl_obs do j=1,NO_base Of_base(j,i) = FULL_Of_base(j,i) f_base(j,i) = Of_base(j,i) end do end do * Restore Original ind_exAV array do j=1,NO_base ind_exAV(j) = IFULL_ind_exAV(j) end do * Restore original par-limits & arrays which say whether to help * parameters to converge and with what probability. do j=1,NO_par par_low(j) = Opar_low(j) par_upp(j) = Opar_upp(j) ind_HelpParMove2Average(j) = iO_ind_HelpParMove2Average(j) prob_HelpParMove2Average(j) = Oprob_HelpParMove2Average(j) end do * Restore original base dimension, number of exAV components, number * of parameters & indices of AV, exAV's & fn N_base = NO_base N_par = NO_par j_AV = jO_AV j_exAV = jO_exAV j_fn = jO_fn * Unpack Gpar_min onto x_min,AV_min & YAV_min explicitly. call MEX_Unpack_par2xAVYAVfn(N_par,N_base,Gpar_min,x_min,AV_min $ ,exAV_min,fn_min) *FIR* Restore Original values of FIRRmat(j,ind_FIRAV), FIRBolCor(j) & * NFIR_base *QHR* Restore original values of QHR_Q2Lnorm40(j) & NQHR_base *PHO* Restore originalvalues of NPHO_base & PHO_3Mat(j,iY,i_AV) * ATT: using NPHO_Ys_max since NPHO_Ys is nor available to this * routine! NFIR_base = NO_base NQHR_base = NO_base NPHO_base = NO_base do j=1,NO_base do i_AV=1,NFIR_AV FIRRmat(j,i_AV) = OFIRRmat(j,i_AV) end do do i_AV=1,NPHO_AV do iY=1,NPHO_Ys_max PHO_3Mat(j,iY,i_AV) = OPHO_3Mat(j,iY,i_AV) end do end do FIRBolCor(j) = OFIRBolCor(j) QHR_Q2Lnorm40(j) = OQHR_Q2Lnorm40(j) end do c *************************************************************************** end c ########################################################################### !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!! END of MEX-routines block !!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR FIR c FIR Start of FIR-Routines Block FIR c FIR FIR c FIR FIR c FIR FIRInitialization(i_verbose,N_base,Nl,l,..,FIRbeta_I,FIRbeta_D) FIR c FIR FIR_CalcFIRchi2(x,AV_tot,WhereFrom) FIR c FIR AverageXoverLambda(x,AV_tot,avelamb_x) FIR c FIR FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR ! Initialize FIR-related stuff. ! ! For each of the j=1...N_base base spectra in Of_base: ! ! (1) integrate the spectrum to obtain the bolometric luminosity: ! FIRLbol(j) and the bolometric correction FIRBolCor(j), defined as ! the monocromathic base luminosity at l_norm divided by Lbol; ! (2) Compute the fraction of Lbol which comes from ionizing ! photons: FIRFracLion(j) ! ! (3) For each AV in a predefined grid FIRAV_grid(), compute the ! fraction of Lbol which is absorbed via "optical" ! extinction/attenuation [R_opt(j,i_AV)], through reprocessing of ! Ly-alpha [R_Lya(j,i_AV)] and through Lyman Continuum Extinction ! [R_LCE(j,i_AV)]. These things add up to the total reprocessing ! matrix Rmat(j,i_AV), which is used to compute predicted FIR ! luminosities. ! ! The computation of R_opt is straight-forward: It comes from the ! integral in lambda of L_SSP(j,l) * (1 - exp(-tau(l)) * dl, divided ! by Lbol(j). Note that tau(l) = tau_V * q(l), with q(l) being the ! reddening-law given by the input choice of red_law_option (at this ! point I strongly recommend CCC!) ! The conversion of ionizing luminosities to dust-reprocessed ! radiation is done with a model based on Inoue (2002) ideas, but ! with adaptations/corrections. Inoue (2002) proposes (actually, ! postulates!) that tau_LC^HII (see his paper and my notes) can be ! scaled from tau_V^ISM, and says that his data shows that qsi = ! tau_LC^HII/tau_V^ISM is ~ 1. Since he also assumes that ! tau_V^total = tau_V^SF = tau_V^BC + tau_V^ISM and that tau_V^BC = ! 2 * tau_V^ISM (following Charlot & Fall 2000), we can estimate ! tau_LC^HII/tau_V^tot is ~ 1/3. This 1/3 factor is what I call ! FIRbeta_I, read from the config file, passed as an input argument ! to this function, and used below to estimate tau_LC^HII from ! AV_tot(j). ! ! A key ingreedient in Inoue's formulation is f_INOUE = the fraction ! of ionizing luminosity which is absorbed by gas (photoionization), ! as a function of the dust optical depth to ionizing photons ! (tau_LC^HII). The formula adopted by Inoue (2002) is eq 8 of ! Petrosian et al (1972), but that formula gives WRONG results for ! low tau_LC^HII! (Besides having the wrong assymptotic behaviour, ! it also suffers from numerical instability). Luckly, I have ! verified that exp(-0.785 * tau_LC^HII) gives very-very similar ! results, so I adopt this expression here. ! ! Besides LCE, Inoue postulates (quite reasonably) that ALL Ly-alpha ! flux is thermalized by dust (after scattering around in the HII ! region). We adopt Dopita's suggestion that a fraction beta_D (of ! the order of 30%) of the ionizing luminosity is converted into ! Ly-alpha, and ultimately transformed (by dust) into FIR ! emission. This is Ok, but there is a caveat: We turn all Ly-alpha ! flux/luminosity into FIR EVEN WHEN AV= 0!! Beware of this caveat. ! ! ! All these was done when implementing the FIR-constraints in our ! MEX-STARLIGHT analysis of LIRGs. ! ! ! Misc-notes 1: Notice that the array FIRAV_grid() is actually ! superfluous, as all that is actually needed to locate an entry in ! this grid is FIRAV_low, FIRAV_upp and FIRdAV. Still, as it does no ! harm and helps debugging, FIRAV_grid() is defined. ! ! Misc-notes 2: FIRAV_grid(Nl_max) and FIRRmat(Nb_max,Nl_max) are ! defined NAVgrid_max, in an effort to reduce memory ! cost and fix the Illegal Instruction bug! Cid@Lagoa - 11/Jan/2011 ! ! Misc-notes 3: Since the whole base spectrum (from "lambda = 0") is ! needed, this routine MUST be called BEFORE chopping the original ! base spectra to the optical range being synthesized! ! ! Cid@Granada - 29/Jan/2010 SUBROUTINE FIRInitialization(i_verbose,N_base,Nl,l,l_norm, $ red_law_option,FIRbeta_I,FIRbeta_D) c *************************************************************************** c Defs implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) parameter (NAVgrid_max = 1001) real l(Nl_max) , dl(Nl_max) , q(Nl_max) , f_aux(Nl_max) real Of_base(Nb_max,Nl_max) character*3 red_law_option common/Obase/ Of_base common/FIR_BaseStuff/ NFIR_AV , FIRAV_grid(NAVgrid_max) , $ FIRAV_low , FIRAV_upp , FIRdAV , $ FIRLbol(Nb_max) , FIRFracLion(Nb_max) , FIRBolCor(Nb_max) , $ FIRR_opt(Nb_max,NAVgrid_max) , FIRR_Lya(Nb_max,NAVgrid_max) , $ FIRR_LCE(Nb_max,NAVgrid_max) , $ FIRRmat(Nb_max,NAVgrid_max) , FIR_q_norm , NFIR_base c Reset things not zero'ed in the MAIN routine. do i=1,Nl_max dl(i) = 0. q(i) = 0. f_aux(i) = 0. end do c Warn & STOP (!) if the wavelength array seems too restricted for c FIR-modeling... if ((l(1).GT.800.0).OR.(l(Nl).LT.7000.0)) then write (*,'(a,2(a,1x,f9.1))') '[FIRInitialization] ATT! ' , & ' lambda covers only from ',l(1),' to = ', l(Nl) stop end if c Warn if reddening-law being used is not = CCC. The CCC law is NOT c really mandatory, but it is the only one I tested! if (red_law_option.NE.'CCC') then write (*,'(70(a))') ('*',i=1,70) write (*,'(4(a))') '[FIRInitialization] ATT!' , & ' red_law_option is = ' , red_law_option , & ' but I recommend CCC!!' write (*,'(70(a))') ('*',i=1,70) end if c Setup q-law: Use Calc_red_term routine & invert red_term(l) = -0.4 c * (q(l) - q(l_norm)) to obtain q(l), zeroing small things by hand c to circumvent numerical residuals. Just in case, also SET q = 0 c FOR l < 912 Angs. call Calc_red_term(red_law_option,l_norm,Nl,l,f_aux,FIR_q_norm) do i=1,Nl q(i) = FIR_q_norm - 2.5 * f_aux(i) if ((l(i).LT.912.0).OR.(q(i).LE.1.e-5)) q(i) = 0. end do c Setup dl-array dl(1) = (l(2) - l(1) ) / 2. dl(Nl) = (l(Nl) - l(Nl-1)) / 2. do i=2,Nl-1 dl(i) = (l(i+1) - l(i-1)) / 2. end do c Find the index of lambda >= 912 Angs (for convenience/speed) c ind_l912 is the index of the **last lambda BEFORE 912 Angs**. ind_l912 = 0 do i=1,Nl-1 if ((l(i).LT.912.0).AND.(l(i+1).GE.912.0)) ind_l912 = i end do if (i_verbose.GT.0) write (*,'(a,i4,2(a,f7.2))') $ '[FIRInit..] index of last l < 912 Angs = ', ind_l912 , $ ' ==> l(i)=' , l(ind_l912), ' & l(i+1)=' , l(ind_l912+1) c *************************************************************************** c *************************************************************************** c Store N_base in NFIR_base, such that it is available through the c FIR_BaseStuff common above. NFIR_base = N_base c Sanity check on NFIR_AV if (NFIR_AV.GT.NAVgrid_max) then write (*,'(a,2(a,1x,i5))') '[FIRInitialization] ATT! ' , & ' NFIR_AV = ', NFIR_AV , ' too large! > ', NAVgrid_max stop end if c Setup FIRAV_grid for R_matrix(i_AV=1...NFIR_AV;j=1,N_base). c NFIR_AV , FIRAV_low & FIRAV_upp were read from arq_config. FIRdAV = (FIRAV_upp - FIRAV_low) / (NFIR_AV - 1) do i_AV=1,NFIR_AV FIRAV_grid(i_AV) = FIRAV_low + (i_AV - 1) * FIRdAV end do c Screen output if (i_verbose.GT.0) write (*,'(a,i4,3(2x,a,f6.3))') & '[FIRInit..] AVgrid: NFIR_AV=',NFIR_AV, & 'FIRAV_low=',FIRAV_low , 'FIRAV_upp=',FIRAV_upp , & 'FIRdAV=',FIRdAV c *************************************************************************** c *************************************************************************** c For each base spectrum, compute Lbol(j), BolCor(j) (= c monocromathic base luminosity at l_norm divided by Lbol), c FracLion(j), & Reprocessed-Lbol-fraction matrices R_opt(j,i_AV), c R_Lya(j,i_AV), R_LCE(j,i_AV) & the total one Rmat(j,i_AV). do j=1,N_base c ----------------------------------------------------------------------- c Lbol(j) & BolCor(j) Lbol = 0. do i=1,Nl Lbol = Lbol + Of_base(j,i) * dl(i) f_aux(i) = Of_base(j,i) end do call calc_Fnorm(Nl,l,f_aux,l_norm,f_norm) FIRLbol(j) = Lbol FIRBolCor(j) = f_norm / Lbol c FracLion(j) = ionizing luminosity / bolometric luminosity Lion = 0. do i=1,ind_l912 Lion = Lion + Of_base(j,i) * dl(i) end do FIRFracLion(j) = Lion / Lbol c ----------------------------------------------------------------------- c ----------------------------------------------------------------------- c R_opt + R_Lya + R_LCE & Rmat reprocessing (j,i_AV) matrices. do i_AV=1,NFIR_AV tauV = FIRAV_grid(i_AV) * 0.4 / log10(exp(1.)) c R_opt(j,i_AV) = "optical" (l >= 912 Angs, non-ionizing) c reprocessing matrix, given as a fraction of Lbol. s = 0. do i=ind_l912+1,Nl s = s + Of_base(j,i) * dl(i) * (1. - exp(-tauV * q(i))) end do FIRR_opt(j,i_AV) = s / FIRLbol(j) c R_Lya(j,i_AV) & R_LCE(j,i_AV) reprocessing matrices (for ionizing c photons). Both give fractions of Lbol. Notice the use of the c beta_D & beta_I parameters (this is the only place they are c used!), as well as my approximate (and more correct in the small c tau limit!) version of eq 8 (for the factor f_INOUE) of Petrosian c et al (1972). This factor measures/estimates the fraction of Lion c which is used up by the gas (photoionization), so that 1 - f_INOUE c remains for the dust-LCE. tau_dust_LC_HII = FIRbeta_I * tauV f_Inoue = exp(-0.785 * tau_dust_LC_HII) FIRR_Lya(j,i_AV) = FIRFracLion(j) * FIRbeta_D * f_Inoue FIRR_LCE(j,i_AV) = FIRFracLion(j) * (1. - f_Inoue) c TOTAL reprocessing matrix: Rmat(j,i_AV) = R_opt + R_Lya + R_LCE FIRRmat(j,i_AV) = FIRR_opt(j,i_AV) + FIRR_Lya(j,i_AV) + $ FIRR_LCE(j,i_AV) end do c ----------------------------------------------------------------------- end do c *************************************************************************** c *************************************************************************** c Screen output if (i_verbose.GT.0) then istep = float(NFIR_AV) / float(21) ilast = 21 * istep 11 format ('[FIRInit..]',i4,2(1x,f7.4),2x,f5.2,2x,a,201(1x,i4)) 12 format (153('-')) 13 format ('[FIRInit..] j BC_j Lbol_j %-ion ', & 'AV_grid=',21(1x,f4.2)) write (*,12) write (*,13) (FIRAV_grid(i_AV),i_AV=1,ilast,istep) write (*,12) do j=1,N_base write (*,11) j , log10(FIRBolCor(j)) , log10(FIRLbol(j)) , & 100.*FIRFracLion(j) , '%-R_opt=' , & (int(0.5+100*FIRR_opt(j,i_AV)),i_AV=1,ilast,istep) write (*,11) j , log10(FIRBolCor(j)) , log10(FIRLbol(j)) , & 100.*FIRFracLion(j) , '%-R_Lya=' , & (int(0.5+100*FIRR_Lya(j,i_AV)),i_AV=1,ilast,istep) write (*,11) j , log10(FIRBolCor(j)) , log10(FIRLbol(j)) , & 100.*FIRFracLion(j) , '%-R_LCE=' , & (int(0.5+100*FIRR_LCE(j,i_AV)),i_AV=1,ilast,istep) write (*,11) j , log10(FIRBolCor(j)) , log10(FIRLbol(j)) , & 100.*FIRFracLion(j) , '%-Rmat =' , & (int(0.5+100*FIRRmat(j,i_AV)),i_AV=1,ilast,istep) if (j.NE.N_base) write (*,*) end do write (*,12) write (*,*) end if c *************************************************************************** end c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR ! Computes the FIR-part of chi2... ! ! Given x(j) and AV_tot(j) population and extinction vectors from my ! MEx-STARLIGHT fits, and the stuff initialized in routine ! FIRInitialization (passed though the FIR_BaseStuff common), this ! function computes the predicted FIR luminosity (actually the total ! bolometric dust-attenuated luminosity) and, comparing it to the ! observed FIR luminosity, returns a chi2. ! ! The value of chi2 can be a simple [(data-model)/error]**2, but it ! can be more complicated/interesting/powerful than this, to allow ! for upper-limits and range-fitting. If the predicted L_FIR ! [FIR_ModlogLFIR, in L_sun if BC03-like bases are being used AND if ! the input optical spectrum is given in units of ergs/s/cm2/Angs - ! THIS IS A MUST for FIR-fits!!] lies within the FIR_logLFIR_low --> ! FIR_logLFIR_upp range, then we assign chi2_FIR = 0. Outside this ! flat core, chi2 grows quadraticaly, emulating a gaussian ! likelyhood. Setting low = upp limits (they both come from the ! input file arq_FIRinfo), we obtain a simple gaussian, but I ! anticipate that this is not what we will be more interested in ! the LIRGS-work with Rosa@IAA/2010. ! !ESM! ATT: OUTDATED! (see below) ! In order that chi2_FIR, which is based on a single datum, competes ! in absolute value with, chi2_OPTICAL, the folllowing scaling is ! adopted: chi2_FIR --> chi2_FIR * * chi2_OPTICAL ! (This recipe is more general than scaling by Nl_eff, as done in ! initial FIRc-versions.) ! ! WhereFrom is just a string which tells from where this function ! was called. When it is = 'OUT', then the FIR-pop vector is ! computed (for output purposes only). ! ! Misc notes 1: In this version of the code EVERY time chi2 is ! evaluated this function is called up! When the fit is NOT a ! FIR-fit (i.e., no FIR data provided), then this function returns 0 ! immediately after being called. ! ! Cid@La-Laguna - 07/Feb/2010 ! !ESM! The whole ETC-chi2-scaling-method has been revamped in July/2017. ! Now FIR_CalcFIRchi2 is a traditional squared reduced deviation, ie., ! [(obs - mod) / err)]**2. Scaling of this chi2 to combine it with ! the OPT + other chi2's is left for the calling function (ETC_CalcETCchi2. ! ! Minor change: Renamed FIRChi2ScaleFactor --> FIR_GlobalChi2ScaleFactor ! * Things returned via common: ! FIR_ModlogLFIR + the stuff computed when WhereFrom = 'OUT' ! (FIR_ModlogLBOL, x_FIR(j), x_BOL(j)) ! ! Cid@Lagoa - 19/July/2017.... FUNCTION FIR_CalcFIRchi2(x,AV_tot,WhereFrom) c *************************************************************************** c Definitions implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) parameter (NAVgrid_max = 1001) real x(Nb_max) , AV_tot(Nb_max) character*3 WhereFrom common/FIR_BaseStuff/ NFIR_AV , FIRAV_grid(NAVgrid_max) , $ FIRAV_low , FIRAV_upp , FIRdAV , $ FIRLbol(Nb_max) , FIRFracLion(Nb_max) , FIRBolCor(Nb_max) , $ FIRR_opt(Nb_max,NAVgrid_max) , FIRR_Lya(Nb_max,NAVgrid_max) , $ FIRR_LCE(Nb_max,NAVgrid_max) , $ FIRRmat(Nb_max,NAVgrid_max) , FIR_q_norm , NFIR_base common/FIR_DataStuff/ FIR_logLobs_norm , $ FIR_logLFIR_TOT , FIR_LFIRFrac2Model , $ FIR_logLFIR_obs , FIR_ErrlogLFIR , $ FIR_logLFIR_low , FIR_logLFIR_upp , FIR_RangelogLFIR , $ FIR_GlobalChi2ScaleFactor , iFIR_IsFIRcOn common/FIR_OutputStuff/ FIR_ModlogLFIR , FIR_ModlogLBOL , & x_FIR(Nb_max),x_BOL(Nb_max) c Reset output chi2 FIR_CalcFIRchi2 = 0. c If FIR is not turned on, just set the FIR-chi2 to zero & go back! c OBS: In fits without FIR, I may temporarely "turn FIR On" just to c call this routine to obtain the model FIR luminosity... if (iFIR_IsFIRcOn.EQ.0) return c *************************************************************************** c *************************************************************************** c Compute predicted L_FIR. See notes for formulae! c OBS1: NO interpolation of AV_tot() in the Rmat grid is done :( c This **assumes/works-well-if** that the Rmat grid is c sufficiently finely spaced (~0.1 mag should be enough). c OBS2: Skip negative extinctions, in case you're daring to allow c so. In principle, AV=0 could also be skipped (no dust => c no FIR-reprocessing) but Ly-alpha is assumed to be eaten c by dust even when AV=0! s = 0. do j=1,NFIR_base if (AV_tot(j).GE.0.0) then c Find index of entry in FIRAV_grid which best matches AV_tot ind_FIRAV = int(0.5 + (AV_tot(j) - FIRAV_low) / FIRdAV) + 1 if (ind_FIRAV.LT.1) ind_FIRAV = 1 if (ind_FIRAV.GT.NFIR_AV) ind_FIRAV = NFIR_AV c Computes this element's addition to the integral s z1 = 10.**(0.4 * FIR_q_norm * AV_tot(j)) z2 = FIRRmat(j,ind_FIRAV) / FIRBolCor(j) s = s + x(j) * z1 * z2 !OOPA! Testing... ! if (NFIR_base.LT.12) then ! write (*,34) j,100.*x(j),AV_tot(j),ind_FIRAV, ! $ FIRAV_grid(ind_FIRAV),FIRRmat(j,ind_FIRAV), ! $ FIRBolCor(j),s ! 34 format ('[f] ',i2,' x=',f5.1,' AV=',f7.4,' iAV=',i4 ! $ ,' AVgrid=',f7.4,' Rmat=',f7.5,' BC=',1p,e12.5,0p ! $ ,' s=',1p,e9.3) ! end if end if end do c Before taking the log of the sum (s), add 1e-30 for safety! FIR_ModlogLFIR = FIR_logLobs_norm + log10(s + 1.e-30) c chi2-value for a Gaussian-Smooth-Top-Hat Likelyhood function, c which gives parabolic chi2-profiles with a core @ chi2 = zero. *ETC* Added if iFIR_IsFIRcOn.EQ.1 to cope with -1 (predict-only) option! * (I did this change during QHR+ETC-development, @ Jan/2010!) chi2_FIR = 0. if (iFIR_IsFIRcOn.EQ.1) then if (FIR_ModlogLFIR.GE.FIR_logLFIR_upp) then chi2_FIR = ((FIR_ModlogLFIR-FIR_logLFIR_upp)/FIR_ErrlogLFIR)**2 else if (FIR_ModlogLFIR.LE.FIR_logLFIR_low) then chi2_FIR = ((FIR_ModlogLFIR-FIR_logLFIR_low)/FIR_ErrlogLFIR)**2 end if end if !ESM! NEW recipe: FIR_CalcFIRchi2 is now a pure chi2! (no scaling done here) FIR_CalcFIRchi2 = chi2_FIR c *************************************************************************** c *************************************************************************** c FINAL OUTPUT: Calling this function with WhereFrom = 'OUT' means c we are done, and all that is left to do is (for output purposes c only), to compute the x_FIR population vector (the fractional c contribution of each base element to the dust-reprocessed c FIR-luminosity, normalize by the s-integral from above). This c vector, along with the predicted FIR-luminosity, is passed back to c the calling routine via the common FIR_OutputStuff. if (WhereFrom.EQ.'OUT') then do j=1,NFIR_base if (AV_tot(j).GE.0.0) then ind_FIRAV = int(0.5 + (AV_tot(j) - FIRAV_low)/FIRdAV) + 1 if (ind_FIRAV.LT.1) ind_FIRAV = 1 if (ind_FIRAV.GT.NFIR_AV) ind_FIRAV = NFIR_AV z1 = 10.**(0.4 * FIR_q_norm * AV_tot(j)) z2 = FIRRmat(j,ind_FIRAV) / FIRBolCor(j) x_FIR(j) = x(j) * z1 * z2 / s end if end do c Bolometric pop vector x_BOL(j) & luminosity sBOL = 0. do j=1,NFIR_base z1 = (10.**(0.4 * FIR_q_norm * AV_tot(j))) / FIRBolCor(j) sBOL = sBOL + x(j) * z1 x_BOL(j) = x(j) * z1 end do do j=1,NFIR_base x_BOL(j) = x_BOL(j) / sBOL end do FIR_ModlogLBOL = FIR_logLobs_norm + log10(sBOL + 1.e-30) end if ! Screen output/test ! if (WhereFrom.EQ.'FKc') then ! write (*,'(a,a,a,2(a,f7.3,1x),2(a,1p,e10.3,0p,2x))') ! $ '[FIR_CalcFIRchi2 from ' , WhereFrom , '] : ' , ! $ 'LFIR=' , FIR_ModlogLFIR ,' X ' , FIR_logLFIR_obs , ! $ 'chi2_FIR=' , FIR_CalcFIRchi2 , ! $ 's=' , s ! end if c *************************************************************************** end c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c This routine uses a given input pop & extinction vector (x & c AV_tot) to compute the average of the pop-vector across all c lambdas. The motivation for this came during the FIR-work c (@Granada/Jan/2010), and is the fact that sometimes a base c component contributes little at lambda = l_norm but may be much c more sigificant at another lambda. Hence, to decide which c components are relevant (as we do in the EX0s-routines), it may c be important to considered all lambdas in the fit, instead of just c l_norm. The output is avelamb_x(j=1...N_base), which give you the c weigthed average of x(lambda) across all lambdas; the weigthing is c done with weight_obs. c c Cid@Granada - 31/Jan/2010 ! ! In April/2017 Fabio Herpich told STARLIGHT to fit from 100 Angs to ! 6950 Angs. With a dl_cushion of 40 Angs, the fits actually started at ! l_obs 60 Angs. Since the base spectra started at 91 Angs, f_base(j,i) = 0. ! from 60 to 91, which lead to x(lambda) = 0 / 0 = NaN! This fucked up ! the selection of EX0 components and produced crazy results. ! A simple sum(x) > 0 sanity check was added to circumvent this user's bug! ! Cid@Lagoa - 13/Apr/2017 SUBROUTINE AverageXoverLambda(x,AV_tot,avelamb_x) c Defs implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) real x_lambda(Nb_max,Nl_max) , aux(Nb_max) , avelamb_x(Nb_max) real x(Nb_max) , AV_tot(Nb_max) real f_base(Nb_max,Nl_max) real l_obs(Nl_max) , f_obs(Nl_max), weight_obs(Nl_max) common/Red_factor/ red_term(Nl_max) common/Base/ N_base , f_base common/Obs/ Nl_obs , l_obs , f_obs , weight_obs c 1st compute x_lambda(j,i) = matrix of lambda-dependent pop vectors c OBS: Keep normalization equal to that of the input x. s_x = Sum_of_x(x,N_base) do i=1,Nl_obs do j=1,N_base aux(j) = (abs(x(j)) * f_base(j,i) * & 10.**(AV_tot(j) * red_term(i))) end do s_aux = Sum_of_x(aux,N_base) ! Added s_aux>0 sanity check to circumvent Herpich's bug! ! Cid@Lagoa - 13/Apr/2017 do j=1,N_base x_lambda(j,i) = 0. if (s_aux.GT.0.) x_lambda(j,i) = aux(j) * s_x / s_aux end do end do c Now, for each j, average x_lambda over lambda, weigthing by c weight_obs s_w = 0. do i=1,Nl_obs s_w = s_w + weight_obs(i) end do do j=1,N_base s = 0. do i=1,Nl_obs s = s + x_lambda(j,i) * weight_obs(i) end do avelamb_x(j) = s / s_w end do end c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR FIR c FIR End of FIR-Routines Block FIR c FIR FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR QHR c QHR Start of QHR-Routines Block QHR c QHR QHR c QHR QHR c QHR QHRInitialization(i_verbose,N_base,Nl,l,l_norm,red_law_option) QHR c QHR QHRIntegrateIonizingSpec(N_base,Nl,l) QHR c QHR QHR_CalcQHRchi2(x,AV_tot,WhereFrom) QHR c QHR QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR ! Initialize QHR-related stuff. ! ! For each base spectrum, compute qH in units of 1e40 ! photons/sec/initial-solar-mass [QHR_qH40(j)], and the ratio of QH ! to the monochromatic luminosity at l_norm in units of 1e40 ! (photons/s) / (Lsun/Angs) [QHR_Q2Lnorm40(j)] ! OBS: The units of 1e40 came about to allow single precision work. ! This routine produces the following output, all of which are ! passed through common/QHR_BaseStuff/: ! QHR_qH40() ! QHR_Q2Lnorm40() ! QHR_q_norm ! NQHR_base ! ! Cid@Lagoa - 31/Dec/2010 !QHi! Added IsReadQHfromBaseFile. When IsReadQHfromBaseFile = 1 (re)open the ! base file )arq)base) and read the rate of ionizing photos of each ! population, in units of 1e40 photons / s / (initial) Msun ! Cid@UFSC - 03/July/2017 SUBROUTINE QHRInitialization(i_verbose,N_base,Nl,l,l_norm, $ red_law_option,IsReadQHfromBaseFile,arq_base) c *************************************************************************** c Defs implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) real l(Nl_max) , f_aux(Nl_max) real Of_base(Nb_max,Nl_max) character*3 red_law_option common/Obase/ Of_base common/QHR_BaseStuff/ QHR_qH40(Nb_max) , QHR_Q2Lnorm40(Nb_max) , $ QHR_q_norm , QHRbeta_I , NQHR_base character*100 arq_aux , arq_base character*15 Delme_name c Defines QHR_q_norm, passed on to other routines via the c QHR_BaseStuff common. call Calc_red_term(red_law_option,l_norm,Nl,l,f_aux,QHR_q_norm) c Store N_base in NQHR_base, such that it is available through the c QHR_BaseStuff common above. NQHR_base = N_base c If arq_base does not tabulate qH40's, then obtain them by integrating c the base spectra directly. Otherwise read them from 8th-column in arq_base. if (IsReadQHfromBaseFile.NE.1) then if (i_verbose.GT.0) write (*,'(a)') & '[QHRInitialization] Integrating qH from base spectra...' call QHRIntegrateIonizingSpec(N_base,Nl,l) else if (i_verbose.GT.0) write (*,'(a,a)') & '[QHRInitialization] Reading qH from arq_base = ',arq_base open (unit=3,file=arq_base,status='old') read (3,*) Delme_N_base do j=1,N_base read (3,*,ERR=999,END=999) & arq_aux,z2,z3,Delme_name,z5,z6,z7 , QHR_qH40(j) end do close(3) end if c Now compute the ratio of qH to the monochromatic luminosity at c l_norm, QHR_Q2Lnorm40(j), in units of (1e40 photons/s) / c (Lsun/Angs). In fact, this is what I really need for QHRc-fits. do j=1,N_base do i=1,Nl f_aux(i) = Of_base(j,i) end do call calc_Fnorm(Nl,l,f_aux,l_norm,f_norm) QHR_Q2Lnorm40(j) = QHR_qh40(j) / f_norm if (i_verbose.GT.1) write (*,11) j , QHR_qh40(j) , & QHR_Q2Lnorm40(j) 11 format ('[QHRInitialization]',i4, & ' qH__40 = ',1p,e9.3,0p,3x,' QH/Lnorm__40 = ',1p,e9.3) end do if (i_verbose.GT.1) then write (*,12) write (*,*) end if 12 format (62('-')) return 999 write (*,'(a,a,a,a)') & '[QHRInitialization] !!@!!ATT!!@!! You tried to read qH__40 ', & 'from the 8th column in arq_base but it is NOT there! ' , & 'Fix arq_base = ' , arq_base stop c *************************************************************************** end c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR ! When ionizing photon rates are NOT given in arq_base, then we have to ! integrate the base spectra directly to obtain them. ! ! For each base spectrum, compute qH in units of 1e40 ! photons/sec/initial-solar-mass, QHR_qH40(j), which is returned ! through common/QHR_BaseStuff/. ! OBS: The units of 1e40 came about to allow single precision work. ! ! Cid@UFSC - 03/July/2017 SUBROUTINE QHRIntegrateIonizingSpec(N_base,Nl,l) c *************************************************************************** c Defs implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) real l(Nl_max) , dl(Nl_max) real Of_base(Nb_max,Nl_max) common/Obase/ Of_base common/QHR_BaseStuff/ QHR_qH40(Nb_max) , QHR_Q2Lnorm40(Nb_max) , $ QHR_q_norm , QHRbeta_I , NQHR_base c Warn & STOP if the wavelength array seems too restricted for QHRc-modeling... if (l(1).GT.800.0) then write (*,'(a,2(a,1x,f9.1))') & '[QHRIntegrateIonizingSpec] ATT! ' , & ' lambda covers only from ',l(1),' to = ', l(Nl) stop end if c Setup dl-array for trapezoidal integrations. dl(1) = (l(2) - l(1) ) / 2. dl(Nl) = (l(Nl) - l(Nl-1)) / 2. do i=2,Nl-1 dl(i) = (l(i+1) - l(i-1)) / 2. end do c For each base spectrum, compute QHR_qH(j) in units of 1e40 photons/sec/initial-solar-mass c OBS: The units of 1e40 allow single precision work: 1e2 = 10.**(33 + 27 - 18 - 40) K_Lsun_hc = (3.826 / (6.626 * 2.997925)) * 1.e2 do j=1,N_base s = 0. do i=1,Nl if (l(i).LT.912.0) s = s + l(i) * Of_base(j,i) * dl(i) end do QHR_qh40(j) = K_Lsun_hc * s end do c *************************************************************************** end c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR ! Computes the QHR-part of chi2... ! Given x(j) and AV_tot(j) population and extinction vectors from my ! MEx-STARLIGHT fits, and the stuff initialized in routine ! QHRInitialization (passed though the QHR_BaseStuff common), this ! function computes the predicted emission line luminosities (Y) for ! the NQHR_Ys line informed in the arq_ETCinfo and passed on via ! common/QHR_DataStuff/. The main output is the chi2 of the ! comparison of these predicted Ys with the observed ones. ! The predicted Ys take into account the contribution of each base ! element to the ionizing photon rate, accounting for its own ! extinction [AV_tot(j)] both in the predicted Y (which must be ! reddedned to be compared to the observed one) and in the reduction ! of the population's QH due to dust [a la Inoue, as in the FIR-work]. ! An AV-dependent fraction of QH is presumed to be eaten up by dust. ! The fraction which actually goes into photoionization is ! f_Inoue = exp(-0.785*beta_I*tau_V) [see MY FIRc-related notes]. ! In routine FIRInitialization this is coded in as follows: ! tauV = FIRAV_grid(i_AV) * 0.4 / log10(exp(1.)) ! tau_dust_LC_HII = FIRbeta_I * tauV ! f_Inoue = exp(-0.785 * tau_dust_LC_HII) ! Here I rewrite this as 10**(-0.4*AV_tot(j)*0.785*QHRbeta_I). This ! factor is included in the emission-line predictions below (as a ! reduction of the actually available number of ionizing photons). ! ! * NOTE: When doing this, I realized there is a subtle detail: ! f_INOUE, as defined in my FIRc-work, is the fraction of the ! ionizing luminosity [hence energy] which goes into ! photoionization, whereas what we'd need here is a fraction of ! ionizing photons! I will IGNORE this difference, which tantamounts ! to assuming no big differences in mean ionizing photon-energies ! exists... ! As in the FIRc-routines, the value of chi2 is = 0 between lower & ! upper limits, rising parabolically beyond these limits, such that ! the likelyhood is a flat-top with gaussian wings. The chi2 of each ! emission line is scaled such that it can compete with the optical ! fit (same scheme as for the FIR work). ! WhereFrom is just a string which tells from where this function ! was called. When it is = 'OUT', then some quantities are computed ! for output purposes only! ! Cid@Lagoa - 03/Jan/2011 !ELR! I've now included the option to fit an EmissionLineRatio (ELR)! ! The ELR info is read in the QHR-block of arq_ETCinfo. If you only ! want to fit the ELR, then you must still provide the QHR info, but ! may set the chi2-scale factors of the QHR-lines to 0! Notice that ! chi2_ELR is included in the calculation of the QHR-chi2. ! ! Cid@Granada - 29/Jan/2011 !ESM! Stuff introduced in July/2017 while revamping the chi2-scaling scheme ! ! Note that QHR_chi2_Y(iY) & ELR_chi2_logR are traditional squared reduced ! deviations [(obs - mod) / err)]**2, i.e.: ! ! QHR_chi2_Y(iY) = [(QHR_logY_obs - QHR_ModlogY(iY)) / QHR_ErrlogY(iY)]**2 ! ELR_chi2_logR = [(ELR_ModlogR - ELR_logRobs) / ELR_ErrlogR]**2 ! ! These do **not** include the *_Chi2ScaleFactor's, which are **only** ! used to compute the final QHR_CalcQHRchi2 retuned by this function: ! ! QHR_CalcQHRchi2 = SUM_iY { QHR_chi2_Y(iY) * QHR_Chi2ScaleFactor(iY) } + ! ELR_chi2_logR * ELR_Chi2ScaleFactor ! ! (Obs: These QHR_Chi2ScaleFactor(iY)'s + ELR_Chi2ScaleFactor are normed ! to sum = Np_QHR in routine Read_ETC_Info.) ! ! Note also that QHR_GlobalChi2ScaleFactor is **not** used here. It's is ! the job of the calling function (ETC_CalcETCchi2) to use it when combining ! the chi2-QHR computed here with other chi2's (Opt, PHO, FIR) ! * Things returned via common: ! QHR_ModlogY(iY) , QHR_chi2_Y(iY) , ELR_ModlogR , ELR_chi2_logR ! + the stuff computed when WhereFrom = 'OUT'! ! ! Cid@Lagoa - 19/Jul/2017 FUNCTION QHR_CalcQHRchi2(x,AV_tot,WhereFrom) c *************************************************************************** c Definitions implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nb_max = 300, NQHR_Ys_max=10) real x(Nb_max) , AV_tot(Nb_max) character*3 WhereFrom *QHR* Data-info-common for QHR-work common/QHR_DataStuff/ QHR_lambda(NQHR_Ys_max) , $ QHR_frecomb(NQHR_Ys_max) , $ QHR_logY_TOT(NQHR_Ys_max) , QHR_YFrac2Model(NQHR_Ys_max) , $ QHR_ErrlogY(NQHR_Ys_max) , QHR_RangelogY(NQHR_Ys_max) , $ QHR_Chi2ScaleFactor(NQHR_Ys_max) , $ QHR_logY_obs(NQHR_Ys_max) , $ QHR_logY_upp(NQHR_Ys_max) , QHR_logY_low(NQHR_Ys_max) , $ QHR_qlambda(NQHR_Ys_max) , $ QHR_GlobalChi2ScaleFactor , $ QHR_logLobs_norm , $ NQHR_Ys , iQHR_IsQHRcOn *ELR* Data-info for ELR-work - goes together w/QHR-things! common/ELR_DataStuff/ ELR_lambdaA , ELR_lambdaB , $ ELR_logRint , ELR_logRobs , $ ELR_ErrlogR , ELR_logR_low , ELR_logR_upp , $ ELR_RangelogR , ELR_Chi2ScaleFactor , $ iY_ELR_A , iY_ELR_B , IsELROn , $ IsELRInputInconsistentWarningFlag common/QHR_BaseStuff/ QHR_qH40(Nb_max) , QHR_Q2Lnorm40(Nb_max) , $ QHR_q_norm , QHRbeta_I , NQHR_base common/QHR_OutputStuff/ QHR_x_QH0(Nb_max) , QHR_x_QHeff(Nb_max) , $ QHR_x_Y(Nb_max,NQHR_Ys_max) , QHR_ModlogY(NQHR_Ys_max) , $ QHR_chi2_Y(NQHR_Ys_max) , QHR_log_QH0 , QHR_log_QHeff , $ ELR_chi2_logR , ELR_ModlogR c Reset output chi2 QHR_CalcQHRchi2 = 0. c If QHR is not turned on, just set the QHR-chi2 to zero & go back! c OBS: In non-QHRc-fits, I may temporarely "turn QHR On" just to c call this routine to obtain the model QHRelated quantities... if (iQHR_IsQHRcOn.EQ.0) return c *************************************************************************** c *************************************************************************** c For each line, compute the predicted line luminosity, which is the c sum of luminosities coming from each population, each one with its c own total extinction, and accounting for the fraction of ionizing c radiation which is eaten up by dust (and thus not used in c photoionization). The log of each of these NQHR_Ys c line-luminosities is used to compute the chi2, in the fashion c described above. c OBS: AV < 0 is reset to zero here! s_chi2_Ys = 0. do iY=1,NQHR_Ys c Add upp contributions of all base elements to line-Y. s = 0. do j=1,NQHR_base aux_AV_tot = AV_tot(j) if (AV_tot(j).LT.0.0) aux_AV_tot = 0. z = 0.4 * aux_AV_tot * (QHR_q_norm - QHR_qlambda(iY) - $ 0.785 * QHRbeta_I) s = s + QHR_Q2Lnorm40(j) * x(j) * 10.**z end do if (s.LE.0.) then write (*,*) '[QHR_CalcQHRchi2] HELP! s = ',s, ' iY=',iY write (*,*) ' Run aborted :(' do j=1,NQHR_base write (*,*) j , x(j) , AV_tot(j) , QHR_Q2Lnorm40(j) , $ QHR_q_norm , QHR_qlambda(iY) , 0.785 * QHRbeta_I , $ ' from : ', WhereFrom end do stop end if !ESM! Minor/irrelevant correction: The coefficient here was 5.1918e-2, but the !ESM! correct value is 5.1919108 ... - Cid@UFSC - 3/July/2017 QHR_ModlogY(iY) = log10(s) + QHR_logLobs_norm + $ log10(5.1919e-2 / (QHR_lambda(iY) * QHR_frecomb(iY))) c Compute the corresponding contribution to chi2 c Added if iQHR_IsQHRcOn.EQ.1 to cope with -1 (predict-only) option! chi2_Y = 0. if (iQHR_IsQHRcOn.EQ.1) then if (QHR_ModlogY(iY).GE.QHR_logY_upp(iY)) then z = (QHR_ModlogY(iY) - QHR_logY_upp(iY)) /QHR_ErrlogY(iY) chi2_Y = z**2 else if (QHR_ModlogY(iY).LE.QHR_logY_low(iY)) then z = (QHR_ModlogY(iY) - QHR_logY_low(iY)) /QHR_ErrlogY(iY) chi2_Y = z**2 end if end if QHR_chi2_Y(iY) = chi2_Y !ESM! Apply the input-defined relative weight to this constraint ! (QHR_Chi2ScaleFactor(iY)) and update the chi2 sum. s_chi2_Ys = s_chi2_Ys + $ QHR_chi2_Y(iY) * QHR_Chi2ScaleFactor(iY) end do c For ELR-fits, compute the predicted A/B emission line ratio and c the associated chi2 if (IsELROn.EQ.1) then ELR_ModlogR = QHR_ModlogY(iY_ELR_A) - QHR_ModlogY(iY_ELR_B) chi2_ELR = 0. if (ELR_ModlogR.GE.ELR_logR_upp) then z = (ELR_ModlogR - ELR_logR_upp) / ELR_ErrlogR chi2_ELR = z**2 else if (ELR_ModlogR.LE.ELR_logR_low) then z = (ELR_ModlogR - ELR_logR_low) / ELR_ErrlogR chi2_ELR = z**2 end if ELR_chi2_logR = chi2_ELR !ESM! Apply the input-defined relative weight to this constraint ! (ELR_Chi2ScaleFactor) and update the chi2 sum. s_chi2_Ys = s_chi2_Ys + ELR_chi2_logR * ELR_Chi2ScaleFactor end if c Here's the result of this function QHR_CalcQHRchi2 = s_chi2_Ys c *************************************************************************** c *************************************************************************** c FINAL OUTPUT: Calling this function with WhereFrom = 'OUT' means c we are done and that all that is left to do is compute c output-purpose-only QHR_* things: c QHR_log_QH0 & QHR_log_QHeff - [scalars] c QHR_x_QH0(j) & QHR_x_QHeff(j) - [arrays] c QHR_x_Y(j,iY) - [matrix] c These are all passed back to the calling routine via the common c QHR_OutputStuff. if (WhereFrom.EQ.'OUT') then c QHR_log_QH0 = log of the total rate of ionizing photons c QHR_log_QHeff = log of the rate of ionizing photons actually used up in c photoionization (the rest is eaten by dust). s_QH0 = 0. s_QHeff = 0. do j=1,NQHR_base aux_AV_tot = AV_tot(j) if (AV_tot(j).LT.0.0) aux_AV_tot = 0. z = 0.4 * aux_AV_tot * QHR_q_norm s_QH0 = s_QH0 + QHR_Q2Lnorm40(j) * x(j) * 10.**z z = 0.4 * aux_AV_tot * (QHR_q_norm - 0.785 * QHRbeta_I) s_QHeff = s_QHeff + QHR_Q2Lnorm40(j) * x(j) * 10.**z end do if ((s_QH0.LT.0.).OR.(s_QHeff.LT.0)) then write (*,*) '[QHR_CalcQHRchi2] HELP s_QH0=', s_QH0 , $ 's_QHeff=',s_QHeff write (*,*) ' Run aborted :(' stop end if QHR_log_QH0 = log10(s_QH0) + QHR_logLobs_norm + 40. QHR_log_QHeff = log10(s_QHeff) + QHR_logLobs_norm + 40. c QHR_x_QH0(j) = fraction of QH0 associated w/population j c QHR_x_QHeff(j) = fraction of QHeff associated w/population j do j=1,NQHR_base aux_AV_tot = AV_tot(j) if (AV_tot(j).LT.0.0) aux_AV_tot = 0. z = 0.4 * aux_AV_tot * QHR_q_norm QHR_x_QH0(j) = (QHR_Q2Lnorm40(j) * x(j) * 10.**z) /s_QH0 z = 0.4 * aux_AV_tot * (QHR_q_norm - 0.785 * QHRbeta_I) QHR_x_QHeff(j) = (QHR_Q2Lnorm40(j) * x(j) * 10.**z) /s_QHeff end do c QHR_x_Y(j,iY) = fractional contribution to line iY from population j do iY=1,NQHR_Ys s = 0. do j=1,NQHR_base aux_AV_tot = AV_tot(j) if (AV_tot(j).LT.0.0) aux_AV_tot = 0. z = 0.4 * aux_AV_tot * (QHR_q_norm - QHR_qlambda(iY) - $ 0.785 * QHRbeta_I) s = s + QHR_Q2Lnorm40(j) * x(j) * 10.**z end do do j=1,NQHR_base aux_AV_tot = AV_tot(j) if (AV_tot(j).LT.0.0) aux_AV_tot = 0. z = 0.4 * aux_AV_tot * (QHR_q_norm - QHR_qlambda(iY) - $ 0.785 * QHRbeta_I) QHR_x_Y(j,iY) = (QHR_Q2Lnorm40(j) * x(j) * 10.**z) / s end do end do end if c *************************************************************************** end c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR QHR c QHR End of QHR-Routines Block QHR c QHR QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO PHO c PHO Start of PHO-Routines Block PHO c PHO PHO c PHO SUBROUTINE PHOInitialization(PHO_redshift,NPHO_Ys,....) PHO c PHO FUNCTION PHO_CalcPHOchi2(x,AV_tot,WhereFrom) PHO c PHO PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c Initialize PHO-related things c Here I (1) read filter curves, pad and resample to dl = 1 Angs and c normalize them; (2) compute transmission-weighted mean lambdas & c the filter's curve std dev; (3) compute the q-factor applicable to c the filter's mean lambda; (4) resample each base spectrum (after c redshifting it to the source's redshift!!) to the same lambdas as c the padded + resampled filters & compute the 3D-array c PHO_3Mat(j,iY,i_AV), which gives the filter luminosity wrt to that c at the normalization wavelength (l_norm) for each population j, c filter iY and extinction AV_tot(i_AV) in PHOAV_grid(i_AV) - the c AV-effect on PHO_3Mat is only a within-the-filter thing (and thus c ~ negligible to 1st order, except when AV grows crazily). c The main output of this routine are: c c PHO_MeanLambda(iY) = integral of lambda * T(lambda) * dlambda c PHO_StdDevLambda(iY) = sqrt[ - **2] = a measure of the c filter's width (just for output purposes) c PHO_PivotLambda = sqrt[integral of T(lambda) * dlambda c / integral of T(lambda) * lambda ** -2 c * dlambda] ==> Foca@ufsc, May 2017 c PHO_q_MeanLambda(iY) = q(l) at the MeanLambda of the filter c PHO_q_norm = q_norm for PHO-routines c NPHO_base = N_base for PHO-routines c PHOdAV & PHOAV_grid(i_AV) = the AV-grid for PHO-work c PHO_3Mat(j=1..N_base;,iY=1..NPHO_Ys;i_AV=1...NPHO_AV), defined c as the integral, over the filter range, of c c t(l) * b_j(l) * exp[-tau_V * [q(l) - q(l_MeanLambda)] * dl c c where t(l) is the normalized filter transmission curve, b_j(l) is c the j-th base-spectrum normalized to l_norm, tauV is the optical c depth and q(l) is the usual A(l)/A(V). c OBS2: some of the steps, like normalizing base spectra to their c flux at l_norm, and reddening-curve definitions are also done c later-on in the main routine, but I need to do them here and now c for PHO-purposes. c c OBS2: PHO_redshift & NPHO_Ys belong to PHP_DataStuff-common, but, c for compactness, are passed as arguments to this routine. (They c are not changed, anyway.) c Cid@Lagoa - 11/Jan/2011 c AKI! falta acertar redshifting .... c???? ! NAO TENHO CERTZEZA DE EM QUE PONTO NORMAZLIAR?? ANTES OU DEPOIS DE APLICAR z??? !AKI! cosmetic change Nl,l <==> NOl_base,Ol_base for similarity with QHRInit??? SUBROUTINE PHOInitialization(PHO_redshift,NPHO_Ys,i_verbose,N_base $ ,NOl_base,Ol_base,l_norm,red_law_option,etc_dir) c *************************************************************************** c Defs implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) parameter (NPHO_Ys_max=100) parameter (NPHO_Nl_max=7000) !IIB! Changed Nl_max to NAVgrid_max! parameter (NAVgrid_max = 1001) c Original base things real Ol_base(Nl_max) real Of_base(Nb_max,Nl_max) common/Obase/ Of_base character*3 red_law_option character*100 arq , etc_dir c Auxiliar lambda & transmission arrays for filters ... real l0(NPHO_Nl_max) , l1(NPHO_Nl_max) , l2(NPHO_Nl_max) real T0(NPHO_Nl_max) , T1(NPHO_Nl_max) , T2(NPHO_Nl_max) real l0_aux(NPHO_Nl_max) c Auxiliar lambda & base-flux arrays for base-spectra.... real lb0(Nl_max) , lb1(Nl_max) real fb0(Nl_max) , fb1(Nl_max) , fb2(Nl_max) c These arrays/matrices are used only here - don't need to be passed c back nowhere!!! integer NPHO_Nl_Filter(NPHO_Ys_max) real q_lambda(NPHO_Nl_max) , $ PHO_l_Filter(NPHO_Ys_max,NPHO_Nl_max) , $ PHO_T_Filter(NPHO_Ys_max,NPHO_Nl_max) *PHO* filter name & file name common for PHO-work character*10 PHO_name(NPHO_Ys_max) character*100 PHO_Filter_file(NPHO_Ys_max) common/PHO_NamesStuff/ PHO_name , PHO_Filter_file *PHO* Base-info-common. !FOCA!... common/PHO_BaseStuff/ NPHO_AV , PHOAV_grid(NAVgrid_max) , $ PHOAV_low , PHOAV_upp , PHOdAV , $ PHO_MeanLambda(NPHO_Ys_max) , PHO_StdDevLambda(NPHO_Ys_max) , $ PHO_PivotLambda(NPHO_Ys_max) , $ PHO_q_MeanLambda(NPHO_Ys_max) , $ PHO_3Mat(Nb_max,NPHO_Ys_max,NAVgrid_max) , $ PHO_q_norm , NPHO_base c *************************************************************************** c *************************************************************************** c Resets. OBS: PHOAV_grid(), PHO_MeanLambda(), PHO_StdDevLambda() & c PHO_3Mat(,,) already zero'ed in the MAIN routine! do i=1,NPHO_Nl_max l0(i) = 0. l1(i) = 0. l2(i) = 0. T0(i) = 0. T1(i) = 0. T2(i) = 0. q_lambda(i) = 0. l0_aux = 0. end do do i=1,Nl_max lb0(i) = 0. lb1(i) = 0. fb0(i) = 0. fb1(i) = 0. fb2(i) = 0. end do do iY=1,NPHO_Ys_max NPHO_Nl_Filter(iY) = 0 do i=1,NPHO_Nl_max PHO_l_Filter(iY,i) = 0. PHO_T_Filter(iY,i) = 0. end do end do c Defines PHO_q_norm, passed on to other routines via the c PHO_BaseStuff common. call Calc_red_term(red_law_option,l_norm,NOl_base,Ol_base, $ fb0,PHO_q_norm) c Store N_base in NPHO_base, such that it is available through the c PHO_BaseStuff common above. NPHO_base = N_base c Sanity check on NPHO_AV if (NPHO_AV.GT.NAVgrid_max) then write (*,'(a,2(a,1x,i5))') '[PHOInitialization] ATT! ' , & ' NPHO_AV = ', NPHO_AV , ' too large! > ', NAVgrid_max stop end if c Setup PHOAV_grid for PHO_3Mat(j=1..N_base;,iY=1..NPHO_Ys;i_AV=1...NPHO_AV) c OBS: NPHO_AV, PHOAV_low & PHOAV_upp were read from arq_config and c passed on via common/PHO_BaseStuff. PHOdAV = (PHOAV_upp - PHOAV_low) / (NPHO_AV - 1) do i_AV=1,NPHO_AV PHOAV_grid(i_AV) = PHOAV_low + (i_AV - 1) * PHOdAV end do c Screen output if (i_verbose.GT.0) write (*,'(a,i4,4(2x,a,f6.3))') & '[PHOInit..] AVgrid: NPHO_AV=',NPHO_AV, & 'PHOAV_low=',PHOAV_low , 'PHOAV_upp=',PHOAV_upp , & 'PHOdAV=',PHOdAV , ' PHO_q_norm=',PHO_q_norm c *************************************************************************** c *************************************************************************** c Read, pad, resample & normalize filters c *************************************************************************** c Read filter curves, pad them, resample to dl = 1 Angs, and c normalize. Also, compute transmission-weighted mean lambdas and c the std dev of the filter curve. The output of this block is: c c NPHO_Nl_Filter(iY) = array with # of points (lambdas) in filter iY c PHO_l_Filter(iY,il) = matrix of lambdas in filter iY c PHO_T_Filter(iY,il) = matrix of transmission coef. in filter iY c PHO_MeanLambda(iY) = integral of lambda * T(lambda) * dlambda c PHO_StdDevLambda(iY) = sqrt[ - **2] = a measure of the c filter's width (just for output purposes) c c It is assumed that the transmission curves in files c PHO_Filter_file(iY) are given in a lambda,T(lambda) format, c possibly with **header** lines starting with a # in the 1st c column. i_last_non_blank_char = 0 do i=1,99 if ((etc_dir(i:i+1).EQ.' ').AND.(i_last_non_blank_char.EQ.0)) & i_last_non_blank_char = i - 1 end do do iY=1,NPHO_Ys c Read filter file PHO_Filter_file(iY), assumed to be in etc_dir. c ==> T0(l0) arq = etc_dir(1:i_last_non_blank_char) // PHO_Filter_file(iY) call ReadSpecWithHeader(arq,NPHO_Nl_max,N0,l0,T0) if (i_verbose.GT.0) write (*,9) iY , PHO_Filter_file(iY) , $ PHO_name(iY) , N0 , l0(1) , l0(N0) 9 format ('[PHOInit...]',i3,2x,a20,2x,a10,2x, $ ' N=',i5,2x,f9.2,'==>',f9.2,' Angs') c Test whether lambda-range is too large to fit in the allocated arrays! c (after padding & resampling to 1 Angs below...) c ATT: filters may get very wide in the IR! ntest = l0(N0) - l0(1) + 10 if (ntest.GT.NPHO_Nl_max) then write (*,*) '[PHOInit] Filter too wide! ' , iY , $ l0(1) , ' ==> ', l0(N0) , NPHO_Nl_max write (*,*) ' Run aborted:-(' stop end if c Pad filter-curve with a T=zero @ 2 Angs before and 2 Angs after the c filter lambda-range. T0(l0) ===> T1(l1) N1 = N0 + 2 l1(1) = l0(1) - 2.0 l1(N1) = l0(N0) + 2.0 T1(1) = 0.0 T1(N1) = 0.0 do i1=2,N1-1 l1(i1) = l0(i1-1) T1(i1) = T0(i1-1) end do c Resample padded filter to dl = 1 Angs - use Interpol_Spec. T1(l1) ==> T2(l2) l2_ini = int(l1(1)) N2 = int(l1(N1) - l1(1)) + 1 do i2=1,N2 l2(i2) = l2_ini + (i2 - 1) * 1.0 end do call Interpol_Spec(N1,l1,T1,N2,l2,T2) c Normalize padded+resampled filter & compute weighted-mean-lambda. c For checking purposes, computes the std dev of the filter curve, c ie., PHO_StdDevLambda(iY) = sqrt[ - **2], a measure of c its width. sum_T = 0. do i2=1,N2 sum_T = sum_T + T2(i2) end do sum_lT = 0. sum_l2T = 0. sum_lm1T = 0. do i2=1,N2 T2(i2) = T2(i2) / sum_T sum_lT = sum_lT + l2(i2) * T2(i2) sum_l2T = sum_l2T + l2(i2)**2 * T2(i2) sum_lm1T = sum_lm1T + T2(i2) / l2(i2) end do c Store things into proper names PHO_MeanLambda(iY) = sum_lT PHO_StdDevLambda(iY) = sqrt(abs(sum_l2T - sum_LT**2)) PHO_PivotLambda(iY) = sqrt(sum_lT / sum_lm1T) NPHO_Nl_Filter(iY) = N2 do i2=1,N2 PHO_l_Filter(iY,i2) = l2(i2) PHO_T_Filter(iY,i2) = T2(i2) end do ! write (*,*) 'test ', iY , PHO_MeanLambda(iY) , l2(1) , l2(N2) , ! $ T2(1) , T2(N2) , ' >> ', l2(int(N2/2)) , T2(int(N2/2)) , PHO_StdDevLambda(iY) c Sanity check: Mean lambda must be within filter's range! if ((PHO_MeanLambda(iY).LT.l2(1)).OR. $ (PHO_MeanLambda(iY).GT.l2(N2))) then write (*,*) '[PHOInit] Mean filter lambda = ', $ PHO_MeanLambda(iY) , ' is outside filter boundaries: ' $ , l2(1) , ' ==> ' , l2(N2) , ' iY=' , iY write (*,*) ' Run aborted:-(' stop end if end do c *************************************************************************** c *************************************************************************** c Compute PHO_q_MeanLambda(iY) c *************************************************************************** c A few lines above we called Calc_red_term with fb0 as an auxiliar c array for red_term. Here We use it to define the corresponding c q_lambda array (stored in fb1), from which we interpolate (using c calc_Fnorm) to obtain the q-value at the mean lambda of each c filter. c The output of this block is PHO_q_MeanLambda(iY). do i=1,NOl_base fb1(i) = PHO_q_norm - 2.5 * fb0(i) end do do iY=1,NPHO_Ys l_MeanLambda = PHO_MeanLambda(iY) call calc_Fnorm(NOl_base,Ol_base,fb1,l_MeanLambda,q_MeanLambda) PHO_q_MeanLambda(iY) = q_MeanLambda end do c *************************************************************************** c *************************************************************************** c Compute PHO_3Mat(j,iY,i_AV) "3D-array" c *************************************************************************** c Normalize base specra, redshift them, & then, for each filter iY, c compute the PHO_3Mat(j,iY,i_AV) 3D-array... used in PHO-calculations. c Start (outer) loop in j=1...N_base do j=1,N_base c Normalize j-th base spectrum ==> fb0(lb0) Nb0 = NOl_base do ib0=1,Nb0 lb0(ib0) = Ol_base(ib0) fb0(ib0) = Of_base(j,ib0) end do call calc_Fnorm(Nb0,lb0,fb0,l_norm,fbase_norm) do ib0=1,Nb0 fb0(ib0) = fb0(ib0) / fbase_norm end do c Redshifting normalized base spectrum to PHO_redshift ==>fb1(lb1) c ATT! THIS IS NOT RIGHT ..???.. need (1+z)**3 factors & etc... <** AKI FIX IT!! c FOCA: THIS COMMENT IS OUTDATED.. Rafa fixed this Nb1 = Nb0 do ib1=1,Nb1 !RAFA! Now we are going to do the redshift corrections on the base spectra lb1(ib1) = lb0(ib1) * (1. + PHO_redshift) fb1(ib1) = fb0(ib1) / (1. + PHO_redshift) c fb1(ib1) = fb0(ib1) end do c ----------------------------------------------------------------------- c Start (middle) loop in filters iY=1...NPHO_Ys do iY=1,NPHO_Ys c Store iY-filter things into aux variables N0, l0 & T0 N0 = NPHO_Nl_Filter(iY) do i0=1,N0 l0(i0) = PHO_l_Filter(iY,i0) T0(i0) = PHO_T_Filter(iY,i0) end do c Sanity check: Test whether the redshifted base spectrum fb1(lb1) c covers the range of filter-iY, otherwise interpolation will fail! if ((l0(1).LT.lb1(1)).OR.(l0(N0).GT.lb1(Nb1))) then write (*,*) '[PHOInit]' , $ ' Filter overshoots redshifted base spectrum!' write (*,*) ' Filter ' , iY , ' : ' , l0(1) , ' ==> ', $ l0(N0) ,' | Base ' , j , ' : ' , lb1(1) , ' ==> ', $ lb1(Nb1) , ' | z = ' , PHO_redshift write (*,*) ' Run aborted:-(' stop end if c Resample redshifted j-th base spectrum to 1 Angs in the range of c the (already resampled) iY-filter curve: fb1(lb1) ==> fb2(l0) call Interpol_Spec(Nb1,lb1,fb1,N0,l0,fb2) c Compute array q_lambda = q(l0) = AV(l0) / AV(l_norm) in l0-grid. c ==> q_lambda(l0) c OBS: red_term(l0) = -0.4 * (q(l0) - q_norm) is stored in aux-variable T1. c Rafa Al mover lambda de la base hay que tener en cuenta donde se aplica la extincion c Hay que hacer la misma correccion. do i0=1,N0 l0_aux(i0) = l0(i0)/(1. + PHO_redshift) end do call Calc_red_term(red_law_option,l_norm,N0,l0_aux, $ T1,q_norm) do i0=1,N0 q_lambda(i0) = q_norm - 2.5 * T1(i0) end do c ....................................................................... c Compute PHO_3Mat(j,iY,i_AV), defined as the integral, over the c filter range, of c c t(l) * b_j(l) * exp[-tau_V * [q(l) - q(l_MeanLambda)] * dl c c where t(l) is the nomarlized filter transmission curve, b_j(l) is c the j-th base-spectrum normalized to l_norm, tauV is the optical c depth and q(l) is the usual A(l)/A(V). c OBS: Notice that dl = 1 Angs is implicit below. c Start (inner) loop in predefined PHOAV_grid. ==> PHO_3Mat(j,iY,i_AV) do i_AV=1,NPHO_AV tauV = PHOAV_grid(i_AV) * 0.4 / log10(exp(1.)) s = 0. s_filter = 0. do i0=1,N0 c s = s + T0(i0) * fb2(i0) * !RAFA¡ We are going to change the integral to compute AB_magnitude s = s + T0(i0) * fb2(i0) * l0(i0) * $ exp(-tauV * (q_lambda(i0) - PHO_q_MeanLambda(iY))) !RAFA¡ s_filter = s_filter + T0(i0) / l0(i0) end do c PHO_3Mat(j,iY,i_AV) = s !RAFA¡ PHO_3Mat(j,iY,i_AV) = s/s_filter end do c ----------------------------------------------------------------------- c close middle loop: goto next filter iY, same base element j end do c close outer loop: goto next base element end do c *************************************************************************** c *************************************************************************** c Screen output if (i_verbose.GT.0) then istep = float(NPHO_AV) / float(14) ilast = 14 * istep 11 format ('[PHOInit..]',i3,1x,i3,1x,a10,2(1x,i5),1x,f6.4, $ ' | ',a,201(1x,f6.2)) 12 format (157('-')) 13 format ('[PHOInit..] j iY Filter sig_l q() ', & '| AV_grid=',14(1x,f6.2)) write (*,12) write (*,13) (PHOAV_grid(i_AV),i_AV=1,ilast,istep) write (*,12) do j=1,N_base do iY=1,NPHO_Ys write (*,11) j , iY , PHO_name(iY) , $ int(PHO_MeanLambda(iY) + 0.5) , $ int(PHO_StdDevLambda(iY) + 0.5) , $ PHO_q_MeanLambda(iY) , $ 'log3Mat=' , $ (log10(PHO_3Mat(j,iY,i_AV)),i_AV=1,ilast,istep) end do if ((j.NE.N_base).AND.(NPHO_Ys.GT.1)) write (*,*) end do write (*,12) write (*,*) end if c *************************************************************************** end c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO ! Computes the PHO-part of chi2... ! Given x(j) and AV_tot(j) population and extinction vectors from my ! MEx-STARLIGHT fits, and the stuff initialized in routine ! PHOInitialization (passed though the common/PHO_BaseStuff), this ! function computes the predicted filter-luminosities (Y) for the ! NPHO_Ys photometric bands informed in the arq_ETCinfo and passed ! on via common/PHO_DataStuff/. The main output is the chi2 of the ! comparison of these predicted Ys with the observed ones. ! As in the FIRc-routines, the value of chi2 is = 0 between lower & ! upper limits, rising parabolically beyond these limits, such that ! the likelyhood is a flat-top with gaussian wings. The chi2 of each ! predicted band is scaled such that it can compete with the optical ! fit (same scheme as for the FIR work). ! WhereFrom is just a string which tells from where this function ! was called. When it is = 'OUT', then some quantities are computed ! for output purposes only - see common/PHO_OutputStuff/. ! A NOTE ABOUT AV < 0: In principle, PHOAV_grid does NOT contain AV ! < 0 (although that, in principle, could be set in arq_config ! ...). Hence, there is no entry in PHO_3Mat(j,iY,i_AV) ! corresponding to AV < 0. However, the effect of AV < 0 (as long as ! not too large) upon PHO_3Mat(j,iY,i_AV) should be small (the ! reddening effect in this matrix is small by definition, since it ! applies to within-the-filter only!). AV < 0 will still affect the ! 10**[-0.4 * AV * (q_norm - q_MeanLambda)] term in the predicted ! band luminosity! This is **good**, because a AV<0 should lead to ! large effects in UV-luminosities.... ! Cid@Lagoa - 11/Jan/2011 !ESM! Stuff introduced in July/2017 while revamping the chi2-scaling scheme ! ! Note that PHO_chi2_Y(iY) is a traditional squared reduced ! deviations [(obs - mod) / err)]**2. These do **not** include the ! *_Chi2ScaleFactor's, which are **only** used to compute the final ! PHO_CalcQHRchi2 retuned by this function. ! (Obs: These PHO_Chi2ScaleFactor(iY)'s are normed ! to sum = Np_QHR in routine Read_ETC_Info.) ! ! Note also that PHO_GlobalChi2ScaleFactor is **not** used here. It's is ! the job of the calling function (ETC_CalcETCchi2) to use it when combining ! the chi2-QHR computed here with other chi2's (Opt, PHO, FIR) ! * Things returned via common: ! PHO_ModlogY(iY) , PHO_chi2_Y(iY) ! the stuff computed when WhereFrom = 'OUT'! ! ! Cid@Lagoa - 19/Jul/2017 FUNCTION PHO_CalcPHOchi2(x,AV_tot,WhereFrom) c *************************************************************************** c Definitions implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nl_max = 20000,Nb_max = 300) parameter (NPHO_Ys_max=100) parameter (NAVgrid_max = 1001) real x(Nb_max) , AV_tot(Nb_max) character*3 WhereFrom *PHO* filter name & file name common for PHO-work character*10 PHO_name(NPHO_Ys_max) character*100 PHO_Filter_file(NPHO_Ys_max) common/PHO_NamesStuff/ PHO_name , PHO_Filter_file *PHO* Base-info-common. !FOCA!... common/PHO_BaseStuff/ NPHO_AV , PHOAV_grid(NAVgrid_max) , $ PHOAV_low , PHOAV_upp , PHOdAV , $ PHO_MeanLambda(NPHO_Ys_max) , PHO_StdDevLambda(NPHO_Ys_max) , $ PHO_PivotLambda(NPHO_Ys_max) , $ PHO_q_MeanLambda(NPHO_Ys_max) , $ PHO_3Mat(Nb_max,NPHO_Ys_max,NAVgrid_max) , $ PHO_q_norm , NPHO_base *PHO* Data-info-common for PHO-work common/PHO_DataStuff/ PHO_logY_TOT(NPHO_Ys_max) , $ PHO_YFrac2Model(NPHO_Ys_max) , PHO_ErrlogY(NPHO_Ys_max) , $ PHO_RangelogY(NPHO_Ys_max) , $ PHO_Chi2ScaleFactor(NPHO_Ys_max) , $ PHO_logY_obs(NPHO_Ys_max) , $ PHO_logY_low(NPHO_Ys_max) , PHO_logY_upp(NPHO_Ys_max) , $ PHO_GlobalChi2ScaleFactor , $ PHO_redshift , PHO_logFobs_norm , NPHO_Ys , iPHO_IsPHOcOn *PHO* Common for predicted PHO-things common/PHO_OutputStuff/ PHO_ModlogY(NPHO_Ys_max) , $ PHO_chi2_Y(NPHO_Ys_max) , PHO_x_Y(Nb_max,NPHO_Ys_max) c Reset output chi2 PHO_CalcPHOchi2 = 0. c If PHO is not turned on, just set the PHO-chi2 to zero & go back! c OBS: In non-PHOc-fits, I may temporarely "turn PHO On" just to c call this routine to obtain the model PHO-related quantities... if (iPHO_IsPHOcOn.EQ.0) return c *************************************************************************** c *************************************************************************** c For each filter, compute the predicted line luminosity, which is c the sum of luminosities coming from each population, each one with c its own total extinction. The log of each of these NPHO_Ys c band-luminosities is used to compute the chi2, in the fashion c described above. s_chi2_Ys = 0. do iY=1,NPHO_Ys c Add upp contributions of all base elements to filter-iY. s = 0. do j=1,NPHO_base c Find index of entry in PHOAV_grid which best matches AV_tot(j) c ATT: AV < 0 will lead to AV_grid = 0 = 1st element in PHOAV_grid. c Cannot bluen PHO-models here, but see below!) ind_PHOAV = int(0.5 + (AV_tot(j) - PHOAV_low) / PHOdAV) + 1 if (ind_PHOAV.LT.1) ind_PHOAV = 1 if (ind_PHOAV.GT.NPHO_AV) ind_PHOAV = NPHO_AV c Computes this base-element's addition to the integral s. c ATT: Note that here AV<0 will work!! c !!!Rafa: He cambiado z1 = -0.4 etc. .....por z1 = 0.4 etc. z1 = 0.4 * AV_tot(j) * (PHO_q_norm - PHO_q_MeanLambda(iY)) s = s + x(j) * (10.**z1) * PHO_3Mat(j,iY,ind_PHOAV) end do c Sanity check if (s.LE.0.) then write (*,*) '[PHO_CalcPHOchi2] HELP! s = ',s, ' iY=',iY write (*,*) ' Run aborted :(' stop end if c Model logY for filter iY c PHO_ModlogY(iY) = log10(s) + PHO_logLobs_norm c !RAFA¡ We want to compute AB_magnitude PHO_ModlogY(iY) = -2.5*log10(s) -2.41 & -2.5*PHO_logFobs_norm c Foca@ufsc May 2017: c PHO_logLobs_norm changed to PHO_logFobs_norm, which means c that now we are fitting magnitudes! c Compute the corresponding contribution to total chi2 c Added if iPHO_IsPHOcOn.EQ.1 to cope with -1 (predict-only) option! chi2_Y = 0. if (iPHO_IsPHOcOn.EQ.1) then if (PHO_ModlogY(iY).GE.PHO_logY_upp(iY)) then z = (PHO_ModlogY(iY) - PHO_logY_upp(iY)) /PHO_ErrlogY(iY) chi2_Y = z**2 else if (PHO_ModlogY(iY).LE.PHO_logY_low(iY)) then z = (PHO_ModlogY(iY) - PHO_logY_low(iY)) /PHO_ErrlogY(iY) chi2_Y = z**2 end if end if PHO_chi2_Y(iY) = chi2_Y !ESM! Apply the input-defined relative weight to this constraint ! (PHO_Chi2ScaleFactor(iY)) and update the chi2 sum. s_chi2_Ys = s_chi2_Ys + $ PHO_chi2_Y(iY) * PHO_Chi2ScaleFactor(iY) ! write (*,*) 'test-AKI PHO_CalcPHOchi2- ', iY , PHO_name(iY) , ! $ ' ModlogY = ', PHO_ModlogY(iY) , chi2_Y , PHO_chi2_Y(iY) , ! $ PHO_Chi2ScaleFactor(iY) , s_chi2_Ys end do c Here's the result of this function PHO_CalcPHOchi2 = s_chi2_Ys c *************************************************************************** c *************************************************************************** c FINAL OUTPUT: Calling this function with WhereFrom = 'OUT' means c we are done, and all that is left to do is compute (for output c purposes only) PHO_x_Y(j,iY): the filter-by-filter pop vector c matrix, defined as the fractional contribution to filter iY from c population j, and passed back to the calling routine via the c common PHO_OutputStuff. if (WhereFrom.EQ.'OUT') then do iY=1,NPHO_Ys s = 0. do j=1,NPHO_base ind_PHOAV = int(0.5 + (AV_tot(j) - PHOAV_low)/PHOdAV) + 1 if (ind_PHOAV.LT.1) ind_PHOAV = 1 if (ind_PHOAV.GT.NPHO_AV) ind_PHOAV = NPHO_AV c Rafa; he vuelto a cambiar z1 = -0.4 etc..... por z1 = 0.4etc.... z1 = 0.4*AV_tot(j) * (PHO_q_norm - PHO_q_MeanLambda(iY)) PHO_x_Y(j,iY) = x(j) *(10.**z1)* PHO_3Mat(j,iY,ind_PHOAV) s = s + PHO_x_Y(j,iY) end do do j=1,NPHO_base PHO_x_Y(j,iY) = PHO_x_Y(j,iY) / s end do end do end if c *************************************************************************** end c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO PHO c PHO End of PHO-Routines Block PHO c PHO PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC ETC c ETC Start of ETC-Routines Block ETC c ETC ETC c ETC ETC c ETC Read_ETC_Info(i_verbose,arq) ETC c ETC ETC_CalcETCchi2(x,AV_tot,WhereFrom) ETC c ETC ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c Read general ETC-info routine. Reads a file designed to contain c FIR and/or QHR and/or PHO data to be used as extra constraints in c the optical fits. c c This routine works like this: First search arq to find the line c numbers correspondig to key-string: FIR, QHR and PHO. Then reads c the blocks available. Note that the FIR/QHR/PHO info can come in c any order. All that maters is that the corresponding key-string is c found, in which case the following lines contain data in the c expected format. If a key string is not found as the 1st entry in c any line of arq, no data corresponding data is read. A quite c flexible (if not excedingly elegant) coding:-) c Except for FIR_logLobs_norm & iFIR_IsFIRcOn, all c common/FIR_DataStuff/ variables are defined here. c c Except for QHR_qlambda(), QHR_logLobs_norm & iQHR_IsQHRcOn, all c common/QHR_DataStuff/ variables are defined here. c Cid@Lagoa - Jan/2011 !ESM! ESM adaptations implemented on Aug/2017. SUBROUTINE Read_ETC_Info(i_verbose,arq) c *************************************************************************** c Defs implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (NQHR_Ys_max=10) parameter (NPHO_Ys_max=100) character*3 char3 character*100 arq *FIR* Data-info-common for FIR-work common/FIR_DataStuff/ FIR_logLobs_norm , $ FIR_logLFIR_TOT , FIR_LFIRFrac2Model , $ FIR_logLFIR_obs , FIR_ErrlogLFIR , $ FIR_logLFIR_low , FIR_logLFIR_upp , FIR_RangelogLFIR , $ FIR_GlobalChi2ScaleFactor , iFIR_IsFIRcOn *QHR* Data-info-common for QHR-work common/QHR_DataStuff/ QHR_lambda(NQHR_Ys_max) , $ QHR_frecomb(NQHR_Ys_max) , $ QHR_logY_TOT(NQHR_Ys_max) , QHR_YFrac2Model(NQHR_Ys_max) , $ QHR_ErrlogY(NQHR_Ys_max) , QHR_RangelogY(NQHR_Ys_max) , $ QHR_Chi2ScaleFactor(NQHR_Ys_max) , $ QHR_logY_obs(NQHR_Ys_max) , $ QHR_logY_upp(NQHR_Ys_max) , QHR_logY_low(NQHR_Ys_max) , $ QHR_qlambda(NQHR_Ys_max) , $ QHR_GlobalChi2ScaleFactor , $ QHR_logLobs_norm , $ NQHR_Ys , iQHR_IsQHRcOn *ELR* Data-info for ELR-work - goes together w/QHR-things! common/ELR_DataStuff/ ELR_lambdaA , ELR_lambdaB , $ ELR_logRint , ELR_logRobs , $ ELR_ErrlogR , ELR_logR_low , ELR_logR_upp , $ ELR_RangelogR , ELR_Chi2ScaleFactor , $ iY_ELR_A , iY_ELR_B , IsELROn , $ IsELRInputInconsistentWarningFlag *PHO* filter name & file name common for PHO-work character*10 PHO_name(NPHO_Ys_max) character*100 PHO_Filter_file(NPHO_Ys_max) common/PHO_NamesStuff/ PHO_name , PHO_Filter_file *PHO* Data-info-common for PHO-work common/PHO_DataStuff/ PHO_logY_TOT(NPHO_Ys_max) , $ PHO_YFrac2Model(NPHO_Ys_max) , PHO_ErrlogY(NPHO_Ys_max) , $ PHO_RangelogY(NPHO_Ys_max) , $ PHO_Chi2ScaleFactor(NPHO_Ys_max) , $ PHO_logY_obs(NPHO_Ys_max) , $ PHO_logY_low(NPHO_Ys_max) , PHO_logY_upp(NPHO_Ys_max) , $ PHO_GlobalChi2ScaleFactor , $ PHO_redshift , PHO_logFobs_norm , NPHO_Ys , iPHO_IsPHOcOn !ESM! Factors involved in the July/2017 recipe for ETC-chi2-scaling character*3 ETC_ESM common/ETC_Chi2Scaling/ G_FIR,G_QHR,G_PHO , k_FIR,k_QHR,k_PHO , $ ETC_alpha,ETC_beta,ETC_gamma , $ Np_OPT,Np_FIR,Np_QHR,Np_PHO , ETC_ESM c OBS: All resets were made in the MAIN routine:-) c *************************************************************************** c *************************************************************************** c Finds where (and if) FIR, QHR & PHO information are located in c arq, finding the line numbers for the 3 key strings FIR/QHR/PHO. c OBS1: The strings must be the 1st entries in their respective lines, c as for all info read realted to each FIR/QHR/PHO block. c OBS2: Assumes arq does not have > 1000 lines! c OBS3: The file MUST NOT CONTAIN BLANCK LINES!!! !ESM! Reset FIR/QHR/PHO GlobalChi2ScaleFactor's as passed via common/ETC_Chi2Scaling/ G_FIR = 0. G_PHO = 0. G_QHR = 0. iFIR = 0 iQHR = 0 iPHO = 0 open (unit=1,file=arq,status='old') do i=1,1000 read (1,*,end=401) char3 if (char3.EQ.'FIR') iFIR = i if (char3.EQ.'QHR') iQHR = i if (char3.EQ.'PHO') iPHO = i end do 401 close(1) c Screen check if (i_verbose.GT.0) then write (*,'(3(a,i3))') '[Read_ETC_Info] iFIR = ' , iFIR , $ ' iQHR = ', iQHR , ' iPHO = ', iPHO end if c A series of sanity checks... if ((iFIR.LE.0).AND.(iFIR_IsFIRcOn.EQ.1)) then write (*,'(a,a,a)') '[Read_ETC_Info] You asked for a FIRc fit', $ ' but provided no FIR-data in ', arq write (*,'(a)') ' Run aborted:-(' stop end if if ((iQHR.LE.0).AND.(iQHR_IsQHRcOn.EQ.1)) then write (*,'(a,a,a)') '[Read_ETC_Info] You asked for a QHRc fit', $ ' but provided no QHR-data in ', arq write (*,'(a)') ' Run aborted:-(' stop end if if ((iPHO.LE.0).AND.(iPHO_IsPHOcOn.EQ.1)) then write (*,'(a,a,a)') '[Read_ETC_Info] You asked for a PHOc fit', $ ' but provided no PHO-data in ', arq write (*,'(a)') ' Run aborted:-(' stop end if if ((iFIR.GT.0).AND.(iFIR_IsFIRcOn.NE.1)) then write (*,'(a,a)') '[Read_ETC_Info] ***WARNING*** ', $ 'FIR-data will be IGNORED since you asked for a non-FIRc-fit!' write (*,'(a,a)') '[Read_ETC_Info] ... arq = ', arq end if if ((iQHR.GT.0).AND.(iQHR_IsQHRcOn.EQ.0)) then write (*,'(a,a)') '[Read_ETC_Info] ***WARNING*** ', $ 'QHR-data will be IGNORED since you asked for a non-QHRc-fit!' write (*,'(a,a)') '[Read_ETC_Info] ... arq = ', arq end if if ((iPHO.GT.0).AND.(iPHO_IsPHOcOn.EQ.0)) then write (*,'(a,a)') '[Read_ETC_Info] ***WARNING*** ', $ 'PHO-data will be IGNORED since you asked for a non-PHOc-fit!' write (*,'(a,a)') '[Read_ETC_Info] ... arq = ', arq end if if ((iQHR.GT.0).AND.(iQHR_IsQHRcOn.EQ.-1)) then write (*,'(a,a)') '[Read_ETC_Info] ATT: ', $ 'QHR-info will only be used to PREDICT QHR-stuff!' write (*,'(a,a)') '[Read_ETC_Info] arq = ', arq end if if ((iPHO.GT.0).AND.(iPHO_IsPHOcOn.EQ.-1)) then write (*,'(a,a)') '[Read_ETC_Info] ATT: ', $ 'PHO-info will only be used to PREDICT PHO-stuff!' write (*,'(a,a)') '[Read_ETC_Info] arq = ', arq end if c *************************************************************************** c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c Read FIR-input - the lines following the "FIR" key string in arq Np_FIR = 0 if ((iFIR.GT.0).AND.(iFIR_IsFIRcOn.EQ.1)) then !ESM! Define Np_FIR, passed back via common/ETC_Chi2Scaling/ Np_FIR = 1 write (*,'(a,a)') '[Read_ETC_Info] ... Reading FIR-info from ' $ ,arq open (unit=1,file=arq,status='old') do i=1,iFIR read (1,*) end do read (1,*) FIR_logLFIR_TOT read (1,*) FIR_LFIRFrac2Model read (1,*) FIR_ErrlogLFIR read (1,*) FIR_RangelogLFIR read (1,*) FIR_GlobalChi2ScaleFactor close(1) c As the name implies, FIR_logLFIR_TOT is the total (say, IRAS) c FIR-luminosity, but the user may want to use only a FRACTION of it c as a constraint (say, because the IRAS data covers a much wider c region than the optical spectrum, or Spitzer images show that most c of the FIR comes from a companion not included in the optical c slit...). This is what the entry FIR_LFIRFrac2Model is for. The c fit is carried out considering an "observed" FIR luminosity c 10**FIR_logLFIR_obs which is a fraction FIR_LFIRFrac2Model of c FIR_logLFIR_TOT. FIR_logLFIR_obs = FIR_logLFIR_TOT + log10(FIR_LFIRFrac2Model) c Define upper & lower soft-limits for the FIR luminosity c===> Natalia's suggestion: Range >/< 0 makes obs = upper/lower limit! if (FIR_RangelogLFIR.LT.0.) then FIR_logLFIR_low = FIR_logLFIR_obs FIR_logLFIR_upp = FIR_logLFIR_obs + abs(FIR_RangelogLFIR) else FIR_logLFIR_upp = FIR_logLFIR_obs FIR_logLFIR_low = FIR_logLFIR_obs - FIR_RangelogLFIR end if c Screen check ... if (i_verbose.GT.0) then write (*,'(a,f7.3)') '[FIR]>> log L_FIR_TOT = ' , & FIR_logLFIR_TOT write (*,'(a,f7.3)') '[FIR]>> Frac to Model = ' , & FIR_LFIRFrac2Model write (*,'(a,f7.3)') '[FIR]>> log L_FIR_obs = ' , & FIR_logLFIR_obs write (*,'(a,f7.3)') '[FIR]>> Error in log L_FIR = +/-' , & FIR_ErrlogLFIR write (*,'(a,f8.2)') '[FIR]>> Range in log L_FIR = ' , & FIR_RangelogLFIR write (*,'(2(a,f7.3))') '[FIR]>> log L_FIR range from ' , & FIR_logLFIR_low , ' --> ' , FIR_logLFIR_upp write (*,'(a,f7.3)')'[FIR]>> FIR_GlobalChi2ScaleFactor = ' $ ,FIR_GlobalChi2ScaleFactor end if c Basic sanity checks on input FIR-info... if ((FIR_logLFIR_TOT.LT.0.0).OR. $ (FIR_logLFIR_obs.LT.0.0).OR. $ (FIR_LFIRFrac2Model.LE.0.0).OR. $ (FIR_LFIRFrac2Model.GT.1.0).OR. $ (FIR_ErrlogLFIR.LE.0.0).OR. $ (FIR_GlobalChi2ScaleFactor.LT.0.0)) then write (*,'(a)') $ '[Read_ETC_Info] Something wrong with FIR the input!!' stop end if end if c FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR-FIR c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c Read QHR-input - the lines following the "QHR" key string in arq c QHR-info: c NQHR_s = number of lines used c QHR_GlobalChi2ScaleFactor = each line has a weight specified by c QHR_Chi2ScaleFactor(iY), read below. The sum of the chi2's of c all lines is expected to have a global weight of c QHR_GlobalChi2ScaleFactor wrt to the optical fit. This feature c was introduced quite late in the development, and is expected c to be useful when more than 1 line is used. C c ELR-info: IsELROn , ELR_lambdaA & ELR_lambdaB , ELR_ErrlogR , c ELR_RangelogR , ELR_Chi2ScaleFactor. c c IsELROn = 0/1 = N/Y decide if 2 of the lines will be used to c perform a EmissionLineRatio-constraint (eg Hbeta/Hgamma, c Halpha/Hbeta). c ELR_lambdaA , ELR_lambdaB = the lambdas of the lines. There c recombination factors and fluxes MUST be given below in the c QHR-entries! c ELR_ErrlogR , ELR_RangelogR , ELR_Chi2ScaleFactor error, range & c chi2-scaling for the logR fit. c c This info is used to predict L_A / L_B and compare it to the c observed value. c QHR_lambda(iY) is the lambda in Angs of the emission line. c QHR_frecomb(iY) is the fraction of ionizing photons which end c up producing an iY-line-photon, such that the iY-line luminosity c can be computed as f_Inoue * h nu(iY) / f_recomb(iY)] * QH, c where f_Inoue = accounts for the fact that some of the ionizing c radiation is eaten up by dust [and thus is not available for c photoionization; see below]. c The next input info follows the same logic as for FIR-work (except c that now we may have more than one constraint if NQHR_Ys > 1): c QHR_logY_TOT(iY) = total Y-line-luminosity, in Lsun. c QHR_YFrac2Model(iY) = fraction of Y-luminosity to be modeled. c QHR_ErrlogY(iY) = error in logY c QHR_RangelogY(iY) = Range in logY ! QHR_Chi2ScaleFactor(iY) = extra relative weight of this logY-value. c ==> QHR_qlambda(iY) = A(lambda(iY)) / AV - this is defined elsewhere! c ATT: The "abs" in the if below is to allow for reading QHR-info c also when iQHR_IsQHRcOn = -1, ie, in the predict-only option. (We c need the lines info in order to predict them!) if ((iQHR.GT.0).AND.(abs(iQHR_IsQHRcOn).EQ.1)) then write (*,'(a,a)') '[Read_ETC_Info] ... Reading QHR-info from ' $ ,arq open (unit=1,file=arq,status='old') do i=1,iQHR read (1,*) end do c Read & check number of lines to be used read (1,*) NQHR_Ys if (NQHR_Ys.GT.NQHR_Ys_max) then write (*,*) $ '[Read_ETC_Info] OOPS! Too many QHR-Ys: ' , NQHR_Ys , $ '! Maximum is = ', NQHR_Ys_max write (*,*) ' Run aborted :-(' stop end if c Read ELR info: On/Off, the 2 lines, error, range & chi2-scaling read (1,*) IsELROn , ELR_lambdaA , ELR_lambdaB , ELR_ErrlogR , $ ELR_RangelogR , ELR_Chi2ScaleFactor c Sanity check: ELR requires >= 2 lines! Also, for the sake of a c logical output, reset to 0 ELR things if they are not used (ie., c when IsELROn = 0). Finaly, make sure ELR will have chi2 = 0 in c the predict-QHR-only-mode! if ((IsELROn.EQ.1).AND.(NQHR_Ys.LT.2).AND. $ (ELR_Chi2ScaleFactor.GT.0.)) then write (*,*) $ '[Read_ETC_Info] OOPS! ELR needs >= 2 lines,' , $ 'but you have only ' , NQHR_Ys , ' !!' write (*,*) ' Run aborted :-(' stop end if if (IsELROn.EQ.0) then ELR_lambdaA = 0. ELR_lambdaB = 0. ELR_ErrlogR = 0. ELR_RangelogR = 0. ELR_Chi2ScaleFactor = 0. end if if (iQHR_IsQHRcOn.EQ.-1) ELR_Chi2ScaleFactor = 0. c Global Chi2 Scaling factor for QHR read (1,*) QHR_GlobalChi2ScaleFactor c Read data for each QHRelated emission line do iY=1,NQHR_Ys read (1,*) QHR_lambda(iY) , QHR_frecomb(iY) , $ QHR_logY_TOT(iY) , QHR_YFrac2Model(iY) , $ QHR_ErrlogY(iY) , QHR_RangelogY(iY) , $ QHR_Chi2ScaleFactor(iY) c As the name implies, QHR_logY() is the total line-luminosity, but c the user may want to use only a FRACTION of it as a constraint c (say, because of a potential AGN-contribution or due to aperture c issues). This is what the entry QHR_YFrac2Model() is for. The fit c is carried out considering "observed" line luminosities of c 10**QHR_logY_obs which are a fraction QHR_YFrac2Model of c 10**QHR_logY_TOT. QHR_logY_obs(iY) = QHR_logY_TOT(iY) + $ log10(QHR_YFrac2Model(iY)) c Define upper & lower soft-limits for the Y (log) luminosity c===> Natalia's suggestion: Range >/< 0 makes obs = upper/lower limit! if (QHR_RangelogY(iY).LT.0.) then QHR_logY_low(iY) = QHR_logY_obs(iY) QHR_logY_upp(iY) = QHR_logY_obs(iY) + $ abs(QHR_RangelogY(iY)) else QHR_logY_upp(iY) = QHR_logY_obs(iY) QHR_logY_low(iY) = QHR_logY_obs(iY) - QHR_RangelogY(iY) end if c For the sake of a "rational output", reset Chi2ScaleFactor to zero c when QHR-stuff is only going to be predicted (not fitted)! if (iQHR_IsQHRcOn.EQ.-1) QHR_Chi2ScaleFactor(iY) = 0. end do c ....................................................................... c Find ELR lines lambda_A & lambda_B in QHR-line-list, define c intrinsic & observed line ratios, lower & upper values for the c ratio R. Also, do some tests on the way. if (IsELROn.EQ.1) then iY_ELR_A = 0 iY_ELR_B = 0 do iY=1,NQHR_Ys if (int(QHR_lambda(iY)).EQ.int(ELR_lambdaA)) iY_ELR_A=iY if (int(QHR_lambda(iY)).EQ.int(ELR_lambdaB)) iY_ELR_B=iY end do c Check if lambda_A & lambda_B were found among the QHR_lambda's... if ((iY_ELR_A.EQ.0).OR.(iY_ELR_B.EQ.0)) then write (*,'(a)') $ '[Read_ETC_Info] Error with the ELR+QHR input!' write (*,*) ' Could not find ELR lines ' , ELR_lambdaA , $ ' and ' , ELR_lambdaB , ' in the QHR list...' write (*,*) ' Run aborted :-(' stop end if c Check if there are actual line luminosities for lines A & B ... if ((ELR_Chi2ScaleFactor.GT.0.).AND. $ ((QHR_logY_TOT(iY_ELR_A).LE.0.).OR. $ (QHR_logY_TOT(iY_ELR_B).LE.0.))) then write (*,'(a)') $ '[Read_ETC_Info] Error with the ELR+QHR input!!' write (*,*) ' No decent luminosities for ELR lines ' , $ ELR_lambdaA ,' and ' , ELR_lambdaB , ' !' write (*,*) ' Run aborted :-(' stop end if c Intrinsic (dust-free) L_A/L_B line ratio (computed from lambda's & c frecomb's given in QHR-line-list) & its log ELR_Rint = (QHR_lambda(iY_ELR_B) * QHR_frecomb(iY_ELR_B)) / $ (QHR_lambda(iY_ELR_A) * QHR_frecomb(iY_ELR_A)) ELR_logRint = log10(ELR_Rint) c Observed L_A/L_B line ratio & its log ELR_logRobs = QHR_logY_TOT(iY_ELR_A)-QHR_logY_TOT(iY_ELR_B) ELR_Robs = 10.**ELR_logRobs !ATT! In my 1st trial runs (@IAA/Jan/2011) I faced the problem that my ! ETCinfo files occasionally implied an AVneb(A,B) < 0! (For ! instance, Halpha/Hbeta < 2.87 or Hbeta/Hgamma < 2.146). Even ! though the associated errors were large, the runs were aborted in ! the previous version of the code (a temporary elr4.for). Here I, ! instead, set Robs to Rint plus an epsilon (for numerical ! safety/paranoia) and turn on the flag IsELRInputInconsistent, to ! remind the reader, on output, that (s)he screwed up with the input ! info! BUT notice that this is only done if ELR_Chi2ScaleFactor > ! 0, ie, if the ELR is in fact being used seriously! c ELR-sanity check: Robs must be > Rint if lambda_A > lambda_B & vice-versa! c If not, MODIFY Robs & WARN! IsELRInputInconsistentWarningFlag = 0 if (ELR_Chi2ScaleFactor.GT.0.) then if (((ELR_lambdaA.GT.ELR_lambdaB).AND. $ (ELR_Robs.LT.ELR_Rint)).OR. $ ((ELR_lambdaA.LT.ELR_lambdaB).AND. $ (ELR_Robs.GT.ELR_Rint))) then write (*,'(a,a)') $ '[Read_ETC_Info] Error with the ELR+QHR input:' , $ ' Inconsistent line ratios !!! ' write (*,*) ELR_lambdaA , ELR_lambdaB , ' Rint= ', $ ELR_Rint ,' but Robs=', ELR_Robs write (*,*) ' I am turning Robs to slightly > than ' , $ 'Rint ...and turning on a FIX-IT flag!' ELR_Robs = ELR_Rint + 1.e-3 ELR_logRobs = ELR_logRint + 1.e-3 IsELRInputInconsistentWarningFlag = 1 end if end if c Define upper & lower soft-limits for logR c===> Natalia's suggestion: Range >/< 0 makes obs = upper/lower limit! if (ELR_RangelogR.LT.0.) then ELR_logR_low = ELR_logRobs ELR_logR_upp = ELR_logRobs + abs(ELR_RangelogR) else ELR_logR_upp = ELR_logRobs ELR_logR_low = ELR_logRobs - ELR_RangelogR end if end if c ....................................................................... c ....................................................................... !ESM! Compute the number of QHR points to be considered for the fit. ! Note that an ELR counts as 1 point, even if the lines are fitted too. ! This is passed back via common/ETC_Chi2Scaling/ ! Also, Re-scale QHR_Chi2ScaleFactor(iY) & ELR_Chi2ScaleFactor such ! that their sum equals the number of QHR constraints s = 0. Np_QHR = 0 if (IsELROn.EQ.1) then s = ELR_Chi2ScaleFactor Np_QHR = 1 end if do iY=1,NQHR_Ys s = s + QHR_Chi2ScaleFactor(iY) Np_QHR = Np_QHR + 1 end do if (s.GT.0.) then if (IsELROn.EQ.1) ELR_Chi2ScaleFactor = & ELR_Chi2ScaleFactor * float(Np_QHR) / s do iY=1,NQHR_Ys QHR_Chi2ScaleFactor(iY) = QHR_Chi2ScaleFactor(iY) * & float(Np_QHR) / s end do end if c ....................................................................... c Screen check ... (ELH & QHR) if (i_verbose.GT.0) then write (*,'(a,i3)') '[Read_ETC_Info]>> NQHR_Ys = ', NQHR_Ys write (*,'(a,f9.3)') $ '[Read_ETC_Info]>> QHR_GlobalChi2ScaleFactor = ', $ QHR_GlobalChi2ScaleFactor if ((IsELROn.EQ.1).AND.(ELR_Chi2ScaleFactor.GT.0.0)) then write (*,'(2(a,i5),2(a,f9.4))') ' ==> [ELR]>> log' , $ int(ELR_lambdaA) , ' /', int(ELR_lambdaB) , ' =' , $ ELR_Robs , ' while intrinsic ratio is =' , $ ELR_Rint write (*,'(3(a,f9.4))') ' ==> [ELR]>> ErrlogR =', $ ELR_ErrlogR , ' RangelogR=', RangelogR , $ ' Chi2ScaleFactor=',ELR_Chi2ScaleFactor end if do iY=1,NQHR_Ys write (*,'(a,i3,12(1x,a,f9.3))') $ ' ==> [QHR]>> iY=', iY , $ 'lambda=' , QHR_lambda(iY) , $ 'frecomb= ' , QHR_frecomb(iY) , $ 'logY=' , QHR_logY_TOT(iY) , $ 'Frac2Model=' , QHR_YFrac2Model(iY) , $ 'ErrlogY=' , QHR_ErrlogY(iY) , $ 'Range=' , QHR_RangelogY(iY) , $ 'Chi2Scale=' , QHR_Chi2ScaleFactor(iY) end do end if c Basic sanity checks on input QHR-info... do iY=1,NQHR_Ys if ((QHR_lambda(iY).LE.0.).OR. $ (QHR_frecomb(iY).LE.0.).OR. $ ((QHR_logY_TOT(iY).LE.0.).AND. $ (QHR_Chi2ScaleFactor(iY).GT.0.)).OR. $ ((QHR_YFrac2Model(iY).LE.0.).AND. $ (QHR_Chi2ScaleFactor(iY).GT.0.)).OR. $ ((QHR_ErrlogY(iY).LE.0.).AND. $ (QHR_Chi2ScaleFactor(iY).GT.0.)).OR. $ (QHR_Chi2ScaleFactor(iY).LT.0.)) then write (*,'(a)') $ '[Read_ETC_Info] Something wrong with QHR the input!!' stop end if end do close(1) end if c QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR-QHR c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO c Read PHO-input - the lines following the "PHO" key string in arq c ATT: The "abs" in the if below is to allow for reading PHO-info c also when iPHO_IsPHOcOn = -1, ie, in the predict-only option. c (We need the filters info in order to predict them!) Np_PHO = 0 if ((iPHO.GT.0).AND.(abs(iPHO_IsPHOcOn).EQ.1)) then write (*,'(a,a)') '[Read_ETC_Info] ... Reading PHO-info from ' $ ,arq open (unit=1,file=arq,status='old') do i=1,iPHO read (1,*) end do read (1,*) PHO_redshift c Read & check number of bands to be used read (1,*) NPHO_Ys if (NPHO_Ys.GT.NPHO_Ys_max) then write (*,*) $ '[Read_ETC_Info] OOPS! Too many PHO-Ys: ' , NPHO_Ys , $ '! Maximum is = ', NPHO_Ys_max stop end if c Global Chi2 Scaling factor for PHO read (1,*) PHO_GlobalChi2ScaleFactor c Read data for each PHOtometric band do iY=1,NPHO_Ys read (1,*) PHO_name(iY) , PHO_Filter_file(iY) , $ PHO_logY_TOT(iY) , PHO_YFrac2Model(iY) , $ PHO_ErrlogY(iY) , PHO_RangelogY(iY) , $ PHO_Chi2ScaleFactor(iY) c As the name implies, PHO_logY() is the total band-luminosity, but c the user may want to use only a FRACTION of it as a constraint c (say, due to aperture issues). This is what the entry c PHO_YFrac2Model() is for. The fit is carried out considering c "observed" band luminosities of 10**PHO_logY_obs which are a c fraction PHO_YFrac2Model of 10**PHO_logY_TOT. PHO_logY_obs(iY) = PHO_logY_TOT(iY) + $ log10(PHO_YFrac2Model(iY)) c Define upper & lower soft-limits for the Y (log) luminosity c===> Natalia's suggestion: Range >/< 0 makes obs = upper/lower limit! if (PHO_RangelogY(iY).LT.0.) then PHO_logY_low(iY) = PHO_logY_obs(iY) PHO_logY_upp(iY) = PHO_logY_obs(iY) + abs(PHO_RangelogY(iY)) else PHO_logY_upp(iY) = PHO_logY_obs(iY) PHO_logY_low(iY) = PHO_logY_obs(iY) - PHO_RangelogY(iY) end if c For the sake of a "rational output", reset Chi2ScaleFactor to zero c when PHO-stuff is only going to be predicted (not fitted)! if (iPHO_IsPHOcOn.EQ.-1) PHO_Chi2ScaleFactor(iY) = 0. end do c ....................................................................... !ESM! Compute the number of PHO points to be considered for the fit. ! This is passed back via common/ETC_Chi2Scaling/ ! Also, Re-scale PHO_Chi2ScaleFactor(iY) such that their sum equals ! the number of QHR constraints if (iPHO_IsPHOcOn.EQ.1) then s = 0. do iY=1,NPHO_Ys if (PHO_Chi2ScaleFactor(iY).GT.0.) then Np_PHO = Np_PHO + 1 s = s + PHO_Chi2ScaleFactor(iY) end if end do do iY=1,NPHO_Ys PHO_Chi2ScaleFactor(iY) = PHO_Chi2ScaleFactor(iY) * & float(Np_PHO) / s end do end if c ....................................................................... c Screen check ... if (i_verbose.GT.0) then write (*,'(a,i3)')'[Read_ETC_Info]>> NPHO_Ys = ', NPHO_Ys write (*,'(a,f9.3)') $ '[Read_ETC_Info]>> PHO_GlobalChi2ScaleFactor = ', $ PHO_GlobalChi2ScaleFactor do iY=1,NPHO_Ys write (*,'(a,i3,2(1x,a,1x,a10),12(1x,a,f8.3))') $ '[Read_ETC_Info]>> iY=', iY , $ 'name=' , PHO_name(iY) , $ 'Filter_file=', PHO_Filter_file(iY) , $ 'logY=' , PHO_logY_TOT(iY) , $ 'Frac2Model=' , PHO_YFrac2Model(iY) , $ 'ErrlogY=' , PHO_ErrlogY(iY) , $ 'Range=' , PHO_RangelogY(iY) , $ 'Chi2Scale=' , PHO_Chi2ScaleFactor(iY) end do end if c Basic sanity screen checks on input PHO-info... c do iY=1,NPHO_Ys c if ((PHO_logY_TOT(iY).LE.0.).OR. c $ (PHO_YFrac2Model(iY).LE.0.).OR. c $ (PHO_ErrlogY(iY).LE.0.).OR. c $ (PHO_Chi2ScaleFactor(iY).LT.0.)) then c write (*,'(a)') c $ '[Read_ETC_Info] Something wrong with PHO the input!!' c stop c end if c end do close(1) end if c Another basic sanity checks on input PHO-info... if ((NPHO_Ys.LE.0).AND.(abs(iPHO_IsPHOcOn).EQ.1)) then write (*,'(a,a,i4,a,a)') $ '[Read_ETC_Info] You wanna use/predict PHO-things,', $ ' but says NPHO_Ys = ', NPHO_Ys, $ ' !! ==> Check info in' , arq write (*,'(a)') ' Run aborted:-(' stop end if c PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO-PHO !ESM! Alternative names for FIR/QHR/PHO GlobalChi2ScaleFactor's. ! These are defined just to pack the in common/ETC_Chi2Scaling/ ! The original names are already in other commons ... G_FIR = FIR_GlobalChi2ScaleFactor G_PHO = PHO_GlobalChi2ScaleFactor G_QHR = QHR_GlobalChi2ScaleFactor end c end of Read_ETC_Info c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c "Intermediary-function" which calls others to get FIR, QHR & PHO c chi2's, scales them cf the July/2017 ESM recipe, and adds them up into a c total ETC-chi2.as a result. chi2_FIR, chi2_QHR & chi2_PHO are stored c common/ETC_Chi2s/ for output purposes. c c Cid@Lagoa - 07/Jan/2011 FUNCTION ETC_CalcETCchi2(x,AV_tot,WhereFrom) c Definitions implicit real (a-h,k-m,o-z) implicit integer (i,j,n) parameter (Nb_max = 300, NQHR_Ys_max=10) real x(Nb_max) , AV_tot(Nb_max) character*3 WhereFrom common/ETC_Chi2s/ chi2_FIR , chi2_QHR , chi2_PHO !ESM! Factors involved in the July/2017 recipe for ETC-chi2-scaling character*3 ETC_ESM common/ETC_Chi2Scaling/ G_FIR,G_QHR,G_PHO , k_FIR,k_QHR,k_PHO , $ ETC_alpha,ETC_beta,ETC_gamma , $ Np_OPT,Np_FIR,Np_QHR,Np_PHO , ETC_ESM !ESM! chi2_OPTICAL now shared through this common! common/OpticalChi2/chi2_OPTICAL , ETC_GlobalChi2ScaleFactor c Resets k_FIR = 0. k_QHR = 0. k_PHO = 0. chi2_FIR = 0. chi2_QHR = 0. chi2_PHO = 0. ETC_CalcETCchi2 = 0. c Compute the FIR/QHR/PHO chi2's, scale them & add to total ETC-chi2 c OBS: The ugly if's are just to avoid division by 0 when an Np_* = 0... if (Np_FIR.GT.0) then chi2_FIR = FIR_CalcFIRchi2(x,AV_tot,WhereFrom) k_FIR = G_FIR * (float(Np_OPT)/float(Np_FIR))**ETC_alpha * $ (chi2_OPTICAL/float(Np_FIR))**ETC_beta ETC_CalcETCchi2 = ETC_CalcETCchi2 + k_FIR * chi2_FIR end if if (Np_QHR.GT.0) then chi2_QHR = QHR_CalcQHRchi2(x,AV_tot,WhereFrom) k_QHR = G_QHR * (float(Np_OPT)/float(Np_QHR))**ETC_alpha * $ (chi2_OPTICAL/float(Np_QHR))**ETC_beta ETC_CalcETCchi2 = ETC_CalcETCchi2 + k_QHR * chi2_QHR end if if (Np_PHO.GT.0) then chi2_PHO = PHO_CalcPHOchi2(x,AV_tot,WhereFrom) k_PHO = G_PHO * (float(Np_OPT)/float(Np_PHO))**ETC_alpha * $ (chi2_OPTICAL/float(Np_PHO))**ETC_beta ETC_CalcETCchi2 = ETC_CalcETCchi2 + k_PHO * chi2_PHO end if ! Screen-check ! write (*,'(3a,4(1x,i5),1p,2(a,3(1x,e8.2)),1x,a,4(1x,e8.2))') ! $ '[ETC_CalcETCchi2] ' , WhereFrom , ! $ ' | Np: OPT FIR QHR PHO =', Np_OPT, Np_FIR , Np_QHR , Np_PHO , ! $ ' | k: FIR QHR PHO =', k_FIR , k_QHR , k_PHO , ! $ ' | G: FIR QHR PHO =', G_FIR , G_QHR , G_PHO , ! $ ' | chi2: OPT FIR QHR PHO =' , ! $ chi2_OPTICAL , chi2_FIR , chi2_QHR , chi2_PHO ! ! write (*,'(2a,1p,3(a,e8.2))') ! $ '[ETC_CalcETCchi2] ' , WhereFrom , ! $ ' | ETC_GlobalChi2ScaleFactor = ', ETC_GlobalChi2ScaleFactor , ! $ ' | ETC_CalcETCchi2 = ', ETC_CalcETCchi2 , ! $ ' | chi2 TOTAL =' , ! $ ETC_GlobalChi2ScaleFactor * (chi2_OPTICAL+ETC_CalcETCchi2) return end c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC ETC c ETC End of ETC-Routines Block ETC c ETC ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC c ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC-ETC