c c-----Arnold I. Boothroyd: VERSION of SEPTEMBER 7, 2007----------z5xcotrin21.f c c This version (Z-interpolation parameter nz = 5): needs 9.2 Mb of storage. c c Send any questions/comments/bug-reports to boothroy@cita.utoronto.ca c------------------------------------------------------------------------------ c OPAL 1995: Reference: C.A. Iglesias & F.J. Rogers (1996), ApJ, 464, 943-953 c------------------------------------------------------------------------------ c Note OPAL opacities are available at http://www-phys.llnl.gov/Research/OPAL/ c This program is from http://www.cita.utoronto.ca/~boothroy/kappa.html c****************************************************************************** c 1995 OPAL opacities for arbitrary metallicity Z (in the range 0.0 to 0.1), c including C,O-rich opacities. Interpolation in Z can be performed when the c opacities are read in and/or when the opacity-calculation routine is called; c this choice is under user control. It is possible to obtain opacities at c arbitrary values of [O/Fe] by using the non-CO-rich opacity files 'GN93hz' c and (one of) 'Alrd96a2', 'C95hz', or 'W95hz' (but this can only be done at c the time when the opacities are being read in, not subseqently when the c opacity-calculation routine is called). Arbitrary hydrogen abundances and c arbitrary amounts of excess carbon and oxygen are always allowed. Uses the c 40 OPAL opacity files Gz???.x?? (also checks for earlier names Gx??z* ). c--ALSO: accurate opacity values can be interpolated as a function of varying c relative C, N, O, and Ne abundances (and/or a user-specified element). c--ALSO: molecular opacities may be read in and used (at low T). c--ALSO: conductive opacities may be read in and used (at high density). c****************************************************************************** c Based on the old OPAL routines xcotrin.f and xcotrinz.f, modified to use c the new (1995) opacity tables Gz???x?? and GN93hz --- similar to xcotrin21.f c (but with a significantly different interface, as described further below). c****************************************************************************** c c------------------------------------------------------------------------------ c*** UPDATED SEPTEMBER 7, 2007: from version of AUGUST 26, 2007: c --Added automatic handling of the new alpha-enhanced GS98 molecular opacities c that are now available from http://webs.wichita.edu/physics/opacity/ c------------------------------------------------------------------------------ c*** UPDATED AUGUST 26, 2007: from version of APRIL 6, 2007: c --Fixed a bug so that FZEDGE is now set correctly to 0.0 for Z out-of-range c (previous version incorrectly set FZEDGE = 1.0 in such a case, and returned c the conductive opacity [if available], rather than a value of 1.0E+35 to c indicate that the opacity could not be computed; this bug is now fixed). c --Smoother switch-off of non-exC,O-opacity-shifts for 0.2 < exC+exO < 0.3 c (this change only affects 0.2 < exC+exO < 0.3 at X > 0.03 [such compositions c should seldom actually occur], and even there has almost negligible effect). c------------------------------------------------------------------------------ c*** UPDATED APRIL 6, 2007: from version of MARCH 29, 2007: c --Minor modifications, for smoother extrapolation in temperature and density c (this will also improve the switchover from OPAL to conductive opacities). c --Fixed a bug that caused incorrect CNO-interpolation at X = 0.03 (actually, c for 0.029999 < X < 0.030001), yielding errors (usually, small ones) there. c --Fixed a bug that could yield an incorrect name for the default [O/Fe] file. c------------------------------------------------------------------------------ c*** UPDATED MARCH 29, 2007: from version of MARCH 24, 2007: c --Added updated conductive opacities: from 'Potekhin et al.' (2006). c------------------------------------------------------------------------------ c*** UPDATED MARCH 24, 2007: from version of FEBRUARY 2, 2007: c --Simplified quadratic interpolation routines to reduce call overhead. c --Added option to print out the names of the opacity files that were read in. c --Fixed bug in Hubbard & Lampe conductive opacity interpolation (that had c been introduced by quadratic-interpolation formula of FEBRUARY 2, 2007). c------------------------------------------------------------------------------ c*** UPDATED FEBRUARY 2, 2007: from version of DECEMBER 16, 2006: c --Added support for Ferguson et al. 2005 molecular opacities (essentially, c updated versions of the Alexander and Ferguson 1994 molecular opacities). c --Fixed bug in exC- and exO-interpolation at small helium abundances. c --Modified quadratic-interpolation formulae to reduce roundoff error. c------------------------------------------------------------------------------ c*** UPDATED DECEMBER 16, 2006: from version of NOVEMBER 23, 2006: c --Allow bzip2 (de)compression of input files (suffix '.bz2') as well as gzip c (suffix '.gz') and compress (suffix '.Z'). c------------------------------------------------------------------------------ c*** UPDATED NOVEMBER 23, 2006: from version of SEPTEMBER 21, 2006: c --Some updates in the comments below, and a minor bug-fix. c------------------------------------------------------------------------------ c*** UPDATED SEPTEMBER 21, 2006: from versions of SEPTEMBER 6 and 13, 2006: c --Fixed the (allowed) extension of OPAL opacities using conductive opacities; c such extension now works correctly, when specified by the user. c------------------------------------------------------------------------------ c*** UPDATED SEPTEMBER 6, 2006: from previous version of OCTOBER 20, 2004: c ***************************************************************************** c * NOTE that BINARY OPACITY DUMPS of previous versions are INCOMPATIBLE with * c * this new version, due to changes in the arrays: any such binary dumps * c * MUST BE RECOMPUTED using DUMP_OPAL_OPAC with this new program version. * c ***************************************************************************** c --New, simpler subroutines have been added for reading in the opacities. c --Alexander & Ferguson (1994) molecular opacity routines and storage added, c with relevant subroutines to control its use (by default, it is NOT used). c --Conductive opacity routines added, allowing use of Hubbard & Lampe (1969), c & Itoh et al. (1983), Mitake et al. (1984) [by default these are NOT used]. c --Common block /opalGS98mixes/ revised, to hold the meteoritic Z-mix as well. c --Minor bug fixed in computation of opacities that require the user-defined c (nonCNO-interpolation) file CF_USER. c --Added new routines: ASK_OPAL_Z_MIX to return abundances of components of c the metallicity Z, and a few others involving opacity filename control. c------------------------------------------------------------------------------ c*** UPDATED OCTOBER 20, 2004: from version of JUNE 30, 2004: c --Common blocks revised, to reduce the file-size of the compiled program (by c refraining from initializing any parts of very large common blocks). c------------------------------------------------------------------------------ c*** UPDATED JUNE 30, 2004: from version of MARCH 9, 2004: c --Some redundant variables removed, to avoid compiler warning messages. c------------------------------------------------------------------------------ c*** UPDATED MARCH 9, 2004: from version of FEBRUARY 1, 2004: c --Minor bug-fix in subroutine OPAL_X_CNO_FU, to handle more correctly the c previously-ignored possibility that N+Ne may have decreased relative to Z c (the bug-fix does its best to prevent exC and exO from becoming negative). c------------------------------------------------------------------------------ c*** UPDATED FEBRUARY 1, 2004: from version of JANUARY 9, 2004: c --Added subroutines DUMP_OPAL_OPAC and READ_OPAL_DUMP which allow one to c store a set of opacities in unformatted binary form for future re-use (gives c a large speed advantage when later one wishes to read opacities with the c same inputs, at the cost of some disk space for the opacity dumpfile). c --Added subroutines ASK_KHIGHZ_OFE and ASK_MAIN_OPAL_FILE. c --Moved all initializations of common block variables into a BLOCK DATA, as c required by some compilers; fixed a few other minor bugs. c------------------------------------------------------------------------------ c*** UPDATED JANUARY 9, 2004: from version of AUGUST 2, 2003: minor changes: c --Added subroutines ASK_LAST_OPAC and ASK_LAST_XCNOU (which just return c values contained in common blocks /E_OPAL_Z/ and /X_OPAL_Z/, respectively). c --Fixed subroutine OPAL_X_CNO_FU so that it no longer yields an error if one c calls this subroutine OPAL_X_CNO_FU before calling the subroutine READZEXCO. c --Fixed the places where some compilers objected to the use of the string c concatenation operator. c------------------------------------------------------------------------------ c*** UPDATED AUGUST 2, 2003: from version of APRL 27, 2001: Add the option of c using an alternate set of OPAL files (e.g., 'GS98hz' rather than 'GN93hz') c to get opacities appropriate to an updated solar composition (e.g., Grevesse c and Sauval 1998) --- note that the files Gz???.x?? need not be updated, as c their opacities are shifted to agree with those from the file 'GS98hz' . c ALSO, add the option of interpolating the opacities as a function of varying c relative C, N, O, and Ne abundances (as well as in the "excess" C and O). c ALSO, increase the allowed file-plus-directory name length to 255 characters c (rather than 80); this affects common /opdir/ and the alternate OPAL file c set, but not common /opalmixes/ (default OPAL files, 8 characters long). c Also, maximum allowed T6,R extrapolation is now just over one grid spacing c (instead of just under); this latter change should have negligible effect. c Also, an approximation used previously when computing the abundances for c mixes that are interpolated in [O/Fe] has been replaced by the exact formula c (this change should also have little effect: none at all for [O/Fe]=0.0). c------------------------------------------------------------------------------ c*** UPDATED APRIL 27, 2001: from version of MARCH 4, 2001: for more accurate c X-interpolation at X > 0.1 (with a LARGE improvement in the accuracy as X c approaches 1-Z), using the added X-values available in the file GN93hz . c Also fixed a minor bug in the CO-interpolation (that could have caused small c errors in the interpolated opacity, but only in the seldom-encountered c situation of near-maximal CO-enrichment combined with a non-zero hydrogen c abundance: X > 0.0 with C+O just less than 1-X-Z). c------------------------------------------------------------------------------ c*** UPDATED MARCH 4, 2001: from version of MAY 28, 1999: add the metallicity Z c to the list { X, C, O, T6, R } of variables in which the OPAL opacities can c be interpolated (rather than being restricted to only a single metallicity, c defined when the opacities were read in). This is required if gravitational c settling of metals takes place. Also, newly added subroutines allow easier c opacity-directory specification, and easier user control of how Z, T, and R c edges and extrapolation are handled. Also, the opacity files Gz???x?? and c GN93hz are allowed to be in compressed form (they must have suffix .gz if c they were compressed using 'gzip', or suffix .Z if they were compressed c using 'compress'); any compressed opacity files will be decompressed, read c in, and compressed again. c------------------------------------------------------------------------------ c Updated MAY 28, 1999: from version of JUNE 26, 1997: to look for the CO-rich c opacity file names in the newer format Gz???.x?? before trying the old c format Gx??z* . Note that some opacity values in Gz001.x35 Gz004.x70 c Gz050.x35 Gz100.x70 differ by roundoff amounts (+/- 0.001 in log10[kappa]) c from corresponding older files Gx35z001 Gx70z004 Gx35z05 Gx70z10 ; also, c Gz050.x35 and Gz100.x70 each omit a redundant duplicate composition table c present in Gx35z05 and Gx70z10 . In all other cases, the newer OPAL c files Gz???.x?? are identical to the corresponding older files Gx??z* . c******* ALSO: the name of the common block that returns the opacity values c has been changed from common/e/ to common/e_opal_z/ in order to avoid c compilation errors when compiling using f2c (Fortran to C conversion). c------------------------------------------------------------------------------ c c****************************************************************************** c c TEMPERATURES AND DENSITIES CONTAINED IN OPAL OPACITY TABLES: c ************************************************************ c c The OPAL opacities are tabulated in terms of logT and logR, where c logR = logRHO - 3 * ( logT - 6 ) , i.e., R = RHO / T6^3 c (with T being temperature in Kelvins and RHO being density in g/cm^3) c The "density" and temperature ranges contained in the tables are: c logR : -8.0 to 1.0 [at logR = -8.0 (0.5) 1.0, i.e., delta_logRHO = 0.5] c logT : 3.75 to 8.70 [at logT = 3.75 (0.05) 6.00 (0.10) 8.10 (0.20) 8.70] c c COMPOSITIONS FOR WHICH OPACITY TABLES ARE AVAILABLE: c **************************************************** c c Type 2 OPAL Tables - including enhanced C & O (40 files): c ========================================================= c These are 40 files of the form Gz???.x?? , where the "z???" part may be c any of { "z000", "z001", "z004", "z010", "z020", "z030", "z050", "z100" } c and the "x??" part may be any of { "x00", "x03", "x10", "x35", "x70" }. c These have 8 metallicities Z = { 0.0, .001, .004, .01, .02, .03, .05, .1 } c and 5 hydrogen abundances X = { 0.0, 0.03, 0.1, 0.35, 0.7 }; each pair of c { X, Z } has up to 60 different compositions with varying amounts of c "excess" carbon and oxygen (above that contained in Z), i.e., mixes having c exC,exO = { 0.0, .01, .03, .1, .2, .4, .6, 1-X-Z } (such that no mix has c X+Z+exC+exO > 1.0). These files allow fairly good interpolated opacities c for X < 0.75 and Z < 0.12, with any amount of excess carbon and oxygen. c This may suffice if there is not much diffusion (to yield high X values), c but these opacities are NOT AT ALL ACCURATE for X > 0.75 (very high hydrogen c abundances); opacities at X = 1-Z may be off by up to an order of magnitude c (unless corrected by including the Type 1 tables below). c c The above files are ALWAYS read in, for one or more Z-values (as determined c by your call to one of the opacity-reading subroutines). c c Type 1 OPAL Tables - fixed metal distribution (by default, 4 files): c ==================================================================== c file 'GN93hz' [O/Fe]=0.0: solar composition, Grevesse and Noels (1993) c file 'Alrd96a2' [O/Fe]=0.3: alpha enhanced elements, Allard (1996) c file 'C95hz' [O/Fe]=0.4: alpha enhanced elements, Chaboyer (1995) c file 'W95hz' [O/Fe]=0.5: alpha enhanced elements, Weiss (1995) c Each of these 4 files contains 126 compositions: opacities at 13 Z-values c Z = {0.0,0.0001,0.0003,0.001,0.002,0.004,0.01,0.02,0.03,0.04,0.06,0.08,0.1} c and at 10 X-values X = {0.0,0.1,0.2,0.35,0.5,0.7,0.8,0.9,0.95,1-Z}; they do c NOT have enhanced-CO ("excess-C,O") compositions. c c One or two of these Type 1 files will typically be read in (as determined by c your call to one of the opacity-reading subroutines). For non-CO-rich cases c this allows slightly improved Z-interpolation (for Z < 0.12) and slightly c improved X-interpolation (for 0.03 < X < 0.75); for high hydrogen abundances c (X > 0.75), such as may result from diffusion (e.g., helium settling), the c accuracy is GREATLY IMPROVED. c c NOTE THAT additional Type 1 tables can be computed at the OPAL website, or c may be available elsewhere. By default, this program alows for counterparts c of the above 4 files with a different composition (e.g., for the Grevesse & c Sauval 1998 mix: 'GS98hz', 'GS98hz_OFe.3_Alrd96a2', 'GS98hz_OFe.4_C95', and c 'GS98hz_OFe.5_W95', or the more recent Asplund, Grevesse, & Sauval 2004 mix: c 'AGS04hz', etc.). This program also allows for the existence of files where c C, N, O, and Ne abundances are interconverted (as by nuclear burning: e.g., c 'GN93hz.CtoN', 'GN93hz.COtoN', 'GN93hz.CNOtoNe'); such files can be used c to enable the program to return accurate opacity values as a function of c varying relative C, N, O, and Ne abundances. Some other user-specified c element (or set of elements) can also be interpolated (e.g., 'GN93hz.user'). c c The program can also be set to use 'AGS04hz' etc., instead of the above. c c c Additional (OPTIONAL) non-OPAL tables: conductive and molecular opacities: c ************************************** =================================== c c -- They are available for the sake of convenience (to allow extension of the c OPAL opacities to lower T and higher R), and some testing has been done c to check that the switchover between tables works reasonably, but the c USER MUST CHOOSE whether to read in (and use) these extensions or not. c c c 'Potekhin et al.' (2006) CONDUCTIVE OPACITIES: opacity file 'condall06.d' c ========================================================================= c -- Conductive opacities available: http://www.ioffe.rssi.ru/astro/conduct/ c****************************************************************************** c***** NOTE: as of March 9, 2007: the revised/updated file condall06.d ***** c***** containing conductive opacities is available on the website. ***** c***** This should be an improvement over the Hubbard & Lampe (1969) ***** c***** plus Itoh (1984) conductive opacities described further below. ***** c****************************************************************************** c These 'condall06.d' electron conductivities are available in the ranges: c -6 < logRHO < 9.75 in density RHO, with spacing delta logRHO = 0.25 c 3 < logT < 9 in temperature T, with spacing delta logT = 1/3 c Zion = {1,2,3,4,6,8,12,16,20,26,30,36,42,48,60} mean nuclear charge c c-----FROM THE ABOVE WEBPAGE: "The plasma is assumed fully ionized (electron c collisions with neutrals are neglected, the ions are assumed pointlike). c This model may be still useful for evaluation of conductivities of partially c ionized plasmas, if one uses a mean-ion model. Then the ion charge Zion c should be replaced by an effective (or average) ion charge Zeff. For c nondegenerate plasmas, the results are based on a continuation from the c degenerate domain (using Fermi-Dirac averaging) and can be considered as c order-of-magnitude estimates. For degenerate plasmas, on the contrary, the c results come from the exact theory and should be much more accurate." c "Non-magnetic conductivities have been updated 18 July 2006. The updated c codes and table have been put at this site 9 September 2007. There are two c modifications. 1. The electron-electron (ee) scattering contribution is c now included in such a way that both the cases of strongly degenerate and c nondegenerate plasmas are recovered accurately. Now the high-T limit of our c data matches the numerical tables of Hubbard & Lampe, 1968, ApJS 18, 297 c (which remain the most accurate calculations of conductive opacities for c astrophysical use in nonmagnetic, nondegenerate, weakly coupled plasma). c 2. The ee contribution is updated according to the results by Shternin and c Yakovlev (2006)." c c-----References for the above (non-magnetic) electron thermal conductivities: c A. Y. Potekhin, D. A. Baiko, P. Haensel, D. G. Yakovlev (1999), "Transport c properties of degenerate electrons in neutron star envelopes and white c dwarf cores", Astron. Astrophys. 346, 345 c O. Y. Gnedin, D. G. Yakovlev, A. Y. Potekhin (2001), "Thermal relaxation c of young neutron stars", Mon. Not. R. Astron. Soc. 324, 725 c P. S. Shternin, D. G. Yakovlev (2006), "Electron thermal conductivity c owing to collisions between degenerate electrons", Phys. Rev. D 74, 043004 c S. Cassisi, A. Y. Potekhin, A. Pietrinferni, M. Catelan, M. Salaris (2007) c "Updated electron-conduction opacities: the impact on low-mass stellar c models", Astrophys. J., in press [astro-ph/0703011] c c-----NOTE: the last reference above suggests that the rms ionic charge is the c appropriate one for use in plasmas not so dense as to be crystalline, i.e., c Zion = ()^0.5 = sqrt( SUM_i{ z_i * z_i * n_i } / SUM_i{ n_i } ) c = sqrt( SUM_i{ z_i * z_i * X_i / A_i } / SUM_i{ X_i / A_i } ) c where z_i is the ionic charge of element i and n_i is its number density; c n_i is proportional to X_i / A_i, the mass fraction over the atomic mass. c [Correctly summing the contributions of different ions in a multicomponent c plasma would be "much more complicated", according to the references.] c Also: the log of the electron thermal conductivity logCHI (stored in the c file condall06.d) converts to the log of the conductive opacity logKAPPA_c c via: c logKAPPA_c = log( 16 * sigma / 3 ) + 3 * logT - logRHO - logCHI c where c sigma = the Stefan-Boltzmann constant. c c - By default, if conductive opacities are read in, then the (OPAL) opacity- c calculating subroutines will actually return the overall effective opacity c Kappa = 1 / ( 1 / Kappa_radiative + 1 / Kappa_conductive ) . c This will be allowed to extend the opacities to the highest densities for c which valid conductive opacities are available (significantly higher than c the upper density limit of the OPAL opacity table, at most temperatures). c c c The above are preferable to the older available conductive opacities: c c W.B. Hubbard & M. Lampe (1969) ApJS, 163, 297: H&L opacity file 'Condopac' c ========================================================================== c -- In a form usable by these opacity subroutines, this file is available c only from http://www.cita.utoronto.ca/~boothroy/kappa.html c (the same website as for this file containing the opacity subroutines). c This file includes 'H&L' conductive opacities for H, He, and C, for somewhat c irregular temperature ranges in the density range -6 < logRHO < 6. When c this file is read in, approximate tables for O and Ne are also stored (by c adding a constant to the table for C). c c 'Itoh' (1984) conductive opacities (to supplement the above input file) c ======================================================================= c - By default, the 'H&L' tables are superseded by the later 'Itoh' conductive c opacities at high density (where the latter are valid), using formulae from c N. Itoh, S. Mitake, H. Iyetomi, & S. Ichimaru (1983), ApJ 273, 774, plus c S. Mitake, S. Ichimaru, & N. Itoh (1984), ApJ 277, 375. [The formulae are c used to get the combined effects of conductive opacities for H, He, C, O, c and Ne, where Ne represents all elements heavier than oxygen.] c c - "Reasonable" interpolated (and extrapolated) conductive opacity values are c computed in regions where neither of the above are valid. c c c J.W. Ferguson et al. (2005) ApJ, 623, 585: (updated) MOLECULAR OPACITY files c ============================================================================ c -- Opacity files available from http://webs.wichita.edu/physics/opacity/ c****************************************************************************** c***** NOTE that these 2005 molecular opacities should supersede and ***** c***** replace those of Alexander & Ferguson (1994) below; the authors ***** c***** state that the accuracy should be significantly better. ***** c****************************************************************************** c The Ferguson et al. (2005) molecular opacity table ranges are: c 2.7 < logT < 4.5 in temperature T [one table may be missing logT < 2.8] c at logT = 4.5 (-0.05) 3.5 (-0.01) 2.9 (-0.05) 2.7 c -8.0 < logR < 1.0 in R = RHO / T6^3 [this is same range as OPAL tables] c at logR = -8.0 (0.5) 1.0 c Z = { 0.0 0.00001 0.00003 0.0001 0.0003 0.001 0.002 0.004 0.01 0.02 0.03 c 0.04 0.05 0.06 0.08 0.1 } c X = { 0.0 0.1 0.2 0.35 0.5 0.7 0.8 0.9 0.95 1-Z } c Each of the 155 (X,Z) cases has its own ASCII file of opacity values, with c the file name reflecting the values of X and Z (as per examples below). c Several different mixes are available, each with its set of 155 (X,Z) cases c (contained in a gzip-compressed tar archive on the above web page); for most c of these, compositions are also specified: c --- GN93 mix (Grevesse & Noels 1993): tar archive f05.g93.tar.gz contains c g0.0.tron g0.00001.tron ... g99999.00001.tron g10.0.tron c --- GS98 mix (Grevesse & Sauval 1998): f05.gs98.tar.gz contains c g98.0.0.tron g98.0.00001.tron ... g98.99999.00001.tron g98.10.0.tron c --- L03 mix (Lodders 2003): f05.l03.tar.gz contains c l03.0.0.tron l03.0.00001.tron ... l03.99999.00001.tron l03.10.0.tron c --- AGS04 mix (Asplund, Grevesse & Sauval 2004): f05.ags04.tar.gz contains c ags04.0.0.tron ags04.0.00001.tron ... ags04.99999.00001.tron ags04.one.tron c Compositions are listed on the website for these mixes. There are also two c mixes for which opacities are available but the composition is not listed: c --- S92 mix (Seaton 1992) -- composition unspecified, but mix is presumably c very similar to GN93 (opacities are very similar): f05.s92.tar.gz contains c s92.0.0.tron s92.0.00001.tron ... s92.99999.00001.tron s92.one.tron c --- S92AE mix (alpha-element-enhanced version of S92) -- composition not c specified, except for [alpha/Fe] = [O/Fe] = 0.3: f05.s92ae.tar.gz contains c s92ae.0.0.tron s92ae.0.00001.tron ... s92ae.99999.00001.tron s92ae.one.tron c --- alpha-enhanced mixes for Grevesse & Sauval 1998 (the compositions for c these are listed on the website): c --- GS98-.2 with [alpha/Fe] = [O/Fe] = -0.2: f05.gs98-.2.tar.gz contains c gs98-.2.0.0.tron ... gs98-.2.99999.00001.tron gs98-.2.one.tron c --- GS98+.2 with [alpha/Fe] = [O/Fe] = 0.2: f05.gs98+.2.tar.gz contains c gs98+.2.0.0.tron ... gs98+.2.99999.00001.tron gs98+.2.one.tron c --- GS98+.4 with [alpha/Fe] = [O/Fe] = 0.4: f05.gs98+.4.tar.gz contains c gs98+.4.0.0.tron ... gs98+.4.99999.00001.tron gs98+.4.one.tron c --- GS98+.6 with [alpha/Fe] = [O/Fe] = 0.6: f05.gs98+.6.tar.gz contains c gs98+.6.0.0.tron ... gs98+.6.99999.00001.tron gs98+.6.one.tron c --- GS98+.8 with [alpha/Fe] = [O/Fe] = 0.8: f05.gs98+.8.tar.gz contains c gs98+.8.0.0.tron ... gs98+.8.99999.00001.tron gs98+.8.one.tron c c***Any excess C or O is simply added to Z, yielding LESS ACCURATE OPACITIES. c c - Opacities are considered to be O.K. for Ztotal < 0.10, and Ztotal > 0.12 c is considered to be "unavailable" (where Ztotal = Z + exC + exO). c c - By default, the switchover from OPAL to Ferguson et al. 2005 opacities c will occur smoothly as logT is reduced from 4.4 to 4.2 (this is the c temperature range in the overlap region where the two opacity tables seem c to be the closest to being equal). c c c D.R. Alexander & J.W. Ferguson (1994) ApJ, 437, 879: opacity file 'Alexopac' c ============================================================================ c -- In a form usable by these opacity subroutines, this file is available c only from http://www.cita.utoronto.ca/~boothroy/kappa.html c (the same website as for this file containing the opacity subroutines). c****************************************************************************** c***** NOTE that these 1994 molecular opacities are SUPERSEDED by the ***** c***** 2005 opacities from http://webs.wichita.edu/physics/opacity/ ***** c***** (see Ferguson et al. 2005, ApJ, 623, 585), as DESCRIBED ABOVE. ***** c****************************************************************************** c This file includes molecular opacities and dust opacity; table ranges are: c 3.0 < logT < 4.1 in temperature T, c -12.0 < logRHO < -6.0 in density RHO (not R, unlike OPAL), for c Z = { 0.0001, 0.0003, 0.001, 0.002, 0.004, 0.01, 0.02, 0.03, 1.0 } and c X = { 0.0001, 0.03, 0.10, 0.35, 0.70, 0.80 } . c [note that the Z = 1.0 table is of course only available for X = 0.0]. c Extensions of this table: c - The X = 0.0001 tables are treated as having X = 0.0 (the difference is c negligible for the above metallicity range 0.0001 < Z < 0.03). c - Unlike the OPAL 'GN93hz' opacities, these must be extrapolated for X > 0.8 c but this yields errors no larger than the difference between Alexander and c OPAL opacities even up to X = 1 - Z. c - To match the available OPAL tables, tables at Z = 0.05 and Z = 0.10 were c extrapolated from the Z = 0.02 and 0.03 cases, taking the average of the c result of extrapolating Kappa in Z and of logKappa in logZ (this yielded the c best results in the temperature region of overlap between Alxander and OPAL c opacities). c - A set of { Z = 0.0, X = 0.7 } opacities have been obtained using Fig. 1 of c Alexander & Ferguson 1994, and the OPAL opacities at logT = 3.75 or higher. c - A rough approximation of opacities for { Z = 0.0, X = 0.0 } was obtained c by using the OPAL opacities at high-T, and extrapolating logKappa downwards c in logT by fitting a least-squares quadratic. c - For other X-values at Z=0.0 these two opacity sets were interpolated in X. c c***This extends the tables of low-temparature opacities from 0.0001 < Z < 0.03 c to the full available metalliticy range 0.0 < Z < 0.1 of the OPAL tables; c but THE ACCURACY OF THE EXTENSIONS MAY BE POOR (especially for Z < 0.0001); c it is better to use the Ferguson et al. (2005) molecular opacities instead. c c***Also, any excess carbon or oxygen is simply added to Z: for significant c "excess-C,O" (exC,exO comparable to Z) this yields LESS ACCURATE OPACITIES, c and for large "excess-C,O" (0.1 < Z + exC + exO < 1.0) one must interpolate c between the Z = 0.1 and Z = 1.0 mixes, yielding VERY INACCURATE OPACITES. c c - By default, if 'Alexopac' is read in, then the switchover from OPAL to c Alexander opacities will occur smoothly as logT is reduced from 3.97 to 3.87 c (this is the temperature range in the overlap region where the two opacity c tables seem to be the closest to being equal). c c - By default, Alexander opacities are considered to be O.K. for Z < 0.10 at c all X, and for all Z at X = 0.0; they are considered to be "unavailable" in c the region where Z > 0.15 at X > 0.03 (this constraint be tightened by the c user at the time when the opacities are read in). c c c------------------------------------------------------------------------------ c c c ========================================== c List of subroutines contained in this file c ========================================== c c This file contains the following subroutines; the nine subroutines marked c with ** are those the user is most likely to wish to use (and are the c first subroutines described below), while those marked with * can be c called by the user (and are described in the comments further below): c c BLOCK DATA OPAL_OPAC_DATA c SUBROUTINE OPALINIT( KHIGHZ, OFEBRACK, Z, KZ, KMET ) c SUBROUTINE GET_ZAVAIL c SUBROUTINE GET_TRVALS c ** SUBROUTINE OPAC( Z, XH, EXC, EXO, T6, R ) c ** SUBROUTINE OPAL( Z, XH, EXC, EXO, SLT, SLR ) c ** SUBROUTINE OPAL_X_CNO_FU( XH, SLT, SLR, XMET, NMET, FU ) c * SUBROUTINE OPAL_F_CNOU( Z, XH, EXC, EXO, SLT, SLR, FCN, FCON, FCNONE, FU ) c SUBROUTINE OPAL_F_XCON_CNOU( Z, XH, EXC, EXO, Y, XCN, XON, XNEHEAVY, c FMUAINV, FMUEINV, ZSQBAR, SLT, SLR, FCN, FCON, FCNONE, FU ) c SUBROUTINE Z_FCNO( XH,XMET,NMET,FU, Z,EXC,EXO, Y,XCN,XON,XNEHEAVY, c FMUAINV,FMUEINV,ZSQBAR, FCN,FCON,FCNONE,FUSE ) c * SUBROUTINE KAPFERG(SLT,SLR,XH,Z,EXC,EXO,FLKA,DLKATR,DLKARO,DLKAT,FKAEDGE) c * SUBROUTINE CACHEFERG( KSTO, XH, XZCO ) c * SUBROUTINE KAP_MOL(SLT,SLR,XH,Z,EXC,EXO,FLKA,DLKATR,DLKARO,DLKAT,FKAEDGE) c * SUBROUTINE KAPALEX( FLT, FLRO, X, XZCO, FLKA, DLKAT, DLKARO, FKAEDGE ) c * SUBROUTINE ASK_LAST_ALEX_EDGE( FKAEDGE, FTRA, FTRA_LO, FTRA_HI, FZKAEDGE ) c * SUBROUTINE KAPCOND( FLRO, FLT, X, Y, XCN, XON, XNEHEAVY, FMUAINV, FMUEINV, c ZSQBAR, IDER, FLKC, FLKCT, FLKCRO, FKCEDGE, FKCOK ) c * SUBROUTINE KAP_COND_POT( FLRO, FLT, ZION, IDER, c FLKC, FLKCT, FLKCRO, FKCEDGE, FKCOK ) c * SUBROUTINE OPAL_K_ONLY( Z, XH, EXC, EXO, SLT, SLR, FCN, FCON, FCNONE, FU ) c ** SUBROUTINE ASK_LAST_OPAC( OP, DOPT, DOPR, DOPTD, FEDGE, FTREDGE, FZEDGE ) c * SUBROUTINE ASK_LAST_XCNOU( Z, X, XC, XO, SLT, SLR, FCN, FCON, FCNONE, FU ) c * SUBROUTINE ASK_OPAL_Z_MIX( IMIX, XIZ, N_X, FNINZ, N_N ) c * SUBROUTINE ASK_OPAL_MIX_WT( ATWT, NWT, ATWTHHE, NHHE, ATZ, NZ ) c ** SUBROUTINE SET_OPAL_DIR( CDIRIN ) c ** SUBROUTINE SET_MOL_DIR( CDIR_MOL ) c ** SUBROUTINE SET_COND_DIR( CDIR_COND ) c ** SUBROUTINE SET_OPAL_LIST_LEVEL( LIST_LEVEL ) c * SUBROUTINE SET_OPAL_LIST_UNIT( LIST_IU ) c ** SUBROUTINE READ_BASIC_OPAL_OPAC( IU, Z, CF_HZ, OFEBRACK, CF_OFE ) c ** SUBROUTINE READ_EXTENDED_OPAC( IU, Z, CF_HZ, OFEBRACK, CF_OFE, c I_MOL, I_COND, I_CNO, CF_USER ) c * SUBROUTINE SET_OFE_FILE( CFILEOFE ) c * SUBROUTINE SET_ALTMIX_OFE_FILE( CFILEOFE ) c * SUBROUTINE SET_METEOR_MIX_FILE( CFILEMET ) c * SUBROUTINE SET_ALTMIX_MAIN_FILE( CFILE_HZ ) c * SUBROUTINE SET_CNO_FILES( CF_HZ, CF_C, CF_O, CF_N, CF_U ) c * SUBROUTINE SET_CNO_EXT( IE, CE_HZ, CE_C, CE_O, CE_N, CE_U ) c * SUBROUTINE SET_COND_FILE( CFILECOND, I_FULL_PATH ) c * SUBROUTINE SET_COND_USE( KCOND, KREPLACE_ITOH ) c * SUBROUTINE SET_COND_INFLAGS( KCOND_FIX, KCOND_GAP, KCOND_HAVE ) c * SUBROUTINE ASK_COND_USE( KCOND, KCOND_AVAIL, KREPLACE_ITOH ) c * SUBROUTINE ASK_COND_INFLAGS( KC_FIX, KC_GAP, KC_FIX_N, KC_GAP_N ) c * SUBROUTINE SET_FERG_USER( CBEG_FERG ) c * SUBROUTINE ASK_FERG_USER( CBEG_FERG ) c * SUBROUTINE SET_FERG_ACC( IACC ) c * SUBROUTINE ASK_FERG_ACC( IACC ) c * SUBROUTINE SET_ALEX_FILE( CFILEALEX, I_FULL_PATH ) c * SUBROUTINE SET_ALEX_USE( KALEX ) c * SUBROUTINE SET_ALEX_DO_RHOSW( IRHOSW ) c * SUBROUTINE ASK_ALEX_USE( KALEX, KALEX_AVAIL, ITYPE ) c * SUBROUTINE ASK_KHIGHZ_OFE( KHIGHZ_USED, OFEBRACK_USED ) c * SUBROUTINE ASK_OPAL_FILE_USED( ITYPE, CF_USED ) c * SUBROUTINE SET_XHI( KXHI ) c * SUBROUTINE ASK_XHI( KXHI, KAVAIL ) c * SUBROUTINE SET_CNO_INTERP( KCNO, KUSER ) c * SUBROUTINE ASK_CNO_INTERP( KCNO, KUSER, KCNO_AVAIL, KUSER_AVAIL ) c * SUBROUTINE SET_ERR_CHECK( LEVEL ) c * SUBROUTINE ASK_ERR_CHECK( LEVEL ) c * SUBROUTINE SET_LOGT6_LIMITS( VLO, DVLO, VHI, DVHI ) c * SUBROUTINE SET_LOGR_LIMITS( VLO, DVLO, VHI, DVHI ) c * SUBROUTINE RESET_Z_LIMITS( VLO, DVLO, VHI, DVHI ) c * SUBROUTINE ASK_LOGT6_LIMITS( VLO, DVLO, VHI, DVHI ) c * SUBROUTINE ASK_LOGR_LIMITS( VLO, DVLO, VHI, DVHI ) c * SUBROUTINE ASK_Z_LIMITS( NZMAX, ZMIN, ZMAX ) c * SUBROUTINE ASK_Z_USE( NZUSE, ZLO, ZMID, ZHI, ZLOEX, ZHIEX ) c * SUBROUTINE ASK_Z_ARRAY( KZSTART, KARRAYSTART, ZARRAY, NARRAY ) c * SUBROUTINE SET_SMOOTH( INITSMOOTH, LOWCOSMOOTH, INTERPCOSMOOTH ) c * SUBROUTINE ASK_SMOOTH( INITSMOOTH, LOWCOSMOOTH, INTERPCOSMOOTH ) c * SUBROUTINE SET_LOGT_SW_FERG( FLTSW_LO, FLTSW_HI ) c * SUBROUTINE ASK_LOGT_SW_FERG( FLTSW_LO, FLTSW_HI ) c * SUBROUTINE SET_LOGT_SW_ALEX( FLTSW_LO, FLTSW_HI ) c * SUBROUTINE SET_LOGRHO_SW_ALEX( FLRHOSW_LO, FLRHOSW_HI ) c * SUBROUTINE SET_LOGT_RHOSW_ALEX( FLTSW_R_LO, FLTSW_R_HI ) c * SUBROUTINE ASK_LOGT_SW_ALEX( FLTSW_LO, FLTSW_HI ) c * SUBROUTINE ASK_LOGRHO_SW_ALEX( FLRHOSW_LO, FLRHOSW_HI ) c * SUBROUTINE ASK_LOGT_RHOSW_ALEX( FLTSW_R_LO, FLTSW_R_HI ) c * SUBROUTINE READCO( Z, KALLRD, KHIGHZ, IULOW ) c * SUBROUTINE READEXCO( Z, KALLRD, KHIGHZ, IULOW, OFEBRACK ) c * SUBROUTINE READZEXCO( NZIN, ZLO, Z, ZHI, KHIGHZ, IULOW, OFEBRACK ) c * SUBROUTINE READ_BEST_MOL( IU, I_MOL, CF_HZ, OFEBRACK ) c * SUBROUTINE READFERG( IU ) c * SUBROUTINE ADDFILE_FERG( IU, F_STO, F_READ, CFILEFERG, I_FULL_PATH ) c * SUBROUTINE READ_ADD_FERG( IU, F_STO, F_READ, KTYPE_FERG ) c SUBROUTINE FIND_FERG( KTYPE_FERG, LEN_BEG, CFILE_USE ) c SUBROUTINE INIT_FERG_INDICES c * SUBROUTINE READALEX( IU ) c * SUBROUTINE READ_COND_POT( IU ) c * SUBROUTINE READCOND( IU ) c SUBROUTINE FIND_RJUMP_HL_COND c ** SUBROUTINE DUMP_OPAL_OPAC( IU, CF_D ) c ** SUBROUTINE READ_OPAL_DUMP( IU, CF_D ) c SUBROUTINE READ_KZ( KZ, Z, KALLRD, KHIGHZ, IULOW, OFEBRACK ) c SUBROUTINE REVISE_HITR_FOR_INITSMOOTH c SUBROUTINE COINTSMO( XXC, XXO, KZ ) c SUBROUTINE COINTERP( XXC, XXO, KZ ) c SUBROUTINE T6RINTERP( SLR, SLT ) c SUBROUTINE SNGL_CINTERP3(ZM,Z0,Z1,ZP,Z,N0,MXNV,VM,V0,V1,VP,VF,DF,D2,XH) c SUBROUTINE QZLOG4INT( ZLOGD ) c FUNCTION QUADSL( IC, I, X, Y1, Y2, Y3, X1, X2, X3 ) c FUNCTION QDERSL( IC, I, X, Y1, Y2, Y3, X1, X2, X3 ) c FUNCTION QCHKSL( IC, I, X, Y1, Y2, Y3, X1, X2, X3 ) c FUNCTION QUAD( IC, I, X, Y1, Y2, Y3, X1, X2, X3 ) c FUNCTION QDER( IC, I, X, Y1, Y2, Y3, X1, X2, X3 ) c FUNCTION QCHK( IC, I, X, Y1, Y2, Y3, X1, X2, X3 ) c FUNCTION QZINTER( IC, I, Z, NMOREZ, F1, F2, F3, F4, Z1, Z2, Z3, Z4, ZDEL ) c FUNCTION MIXFIND( IU, IOFE, IGETZXI, IREW, ITAB, LINE, Z, X, C, O ) c SUBROUTINE CHK_DIR_NAME( CDIRIN, COPDIR, KOPE ) c SUBROUTINE CHK_OFE_ALT_FILE( K_OFE ) c SUBROUTINE INDEX_CO_DELTAS( ISET, KXHZ, JX, JC, JO ) c SUBROUTINE FINISH_CNO c SUBROUTINE SPLINE( X, Y, N, Y2 ) c SUBROUTINE SPLINT( XA, YA, N, Y2A, X, Y, YP ) c SUBROUTINE FITY c SUBROUTINE FITX c SUBROUTINE GETD( F, N, D, FP1, FPN ) c SUBROUTINE INTERP( FLT, FLRHO, G, DGDT, DGDRHO, IERR ) c SUBROUTINE SMOOTH c SUBROUTINE OPALTAB c SUBROUTINE OPEN_CHK_ZIP( IU, FNAME, IGZIP, CMSG ) c SUBROUTINE CLOSE_CHK_ZIP( IU, FNAME, IGZIP ) c SUBROUTINE QUADSLSTO( I, X, X1, X2, X3 ) c FUNCTION QUADSLGET( I, Y1, Y2, Y3 ) c SUBROUTINE QDERSLSTO( I, X, X1, X2, X3 ) c SUBROUTINE QDERSLGET( I, Y1, Y2, Y3, Y, DYDX ) c SUBROUTINE QCHKSLSTO( I, X, X1, X2, X3 ) c FUNCTION QCHKSLGET( I, Y1, Y2, Y3 ) c SUBROUTINE QCHKSTO( I, X, X1, X2, X3 ) c FUNCTION QCHKGET( I, Y1, Y2, Y3 ) c SUBROUTINE QDERNSTO( I, NMORE, X, X1, X2, X3, X4 ) c SUBROUTINE QDERNGET( I, NMORE, Y1, Y2, Y3, Y4, Y, DYDX ) c SUBROUTINE QUADNSTO( I, NMORE, X, X1, X2, X3, X4 ) c FUNCTION QUADNGET( I, NMORE, Y1, Y2, Y3, Y4 ) c SUBROUTINE QDER4STO( I, X, X1, X2, X3, X3 ) c SUBROUTINE QDER4GET( I, Y1, Y2, Y3, Y4, Y, DYDX ) c SUBROUTINE QUAD4STO( I, X, X1, X2, X3, X3 ) c FUNCTION QUAD4GET( I, Y1, Y2, Y3, Y4 ) c SUBROUTINE QDERSTO( I, X, X1, X2, X3 ) c SUBROUTINE QDERGET( I, Y1, Y2, Y3, Y, DYDX ) c SUBROUTINE QUADSTO( I, X, X1, X2, X3 ) c FUNCTION QUADGET( I, Y1, Y2, Y3 ) c FUNCTION NUM_BLANKS_CONTAINED( FNAME ) c FUNCTION NON_BLANK_BEGIN( FNAME ) c SUBROUTINE OPOLDR( IU, FNAME ) c SUBROUTINE OPOLUF( IU, FNAME ) c SUBROUTINE OPNEUF( IU, FNAME ) c SUBROUTINE INQFIL( FNAME, LXST ) c SUBROUTINE LINUX_GET_HOME_DIR( FNAME, FNALT, IALT ) c FUNCTION LNBLNK( FNAME ) c c The last 6 of the above subroutines contain file-handling routines; if one c is using VMS rather than some flavor of Unix or Linux, then one may have to c comment out some statements in these subroutines and uncomment others, as c well as in the "data cb" statement at the end of BLOCK DATA OPAL_OPAC_DATA. c (The last 2 routines should be needed only if you are using fort77 under c Linux, but should still work correctly on any flavor of Unix/Linux system.) c c Note that the above routines have been tested on several Linux systems (and c Unix, for some earlier versions), but have NOT been tested on a VMS system. c c ********************************************************** c NOTE THAT ALL REAL VARIABLES ARE SINGLE PRECISION (real*4) c ********************************************************** c c ********************************************************** c NOTE THAT NO FILENAME MAY EXCEED 255 CHARACTERS IN LENGTH. c ********************************************************** c c c------------------------------------------------------------------------------ c c c ========================================================== c The subroutines that interpolate among the OPAL opacities: c ========================================================== c c c-----NOTE that the following four opacity-calculating subroutines CAN extend c the OPAL opacities to lower temperatures (by using molecular opacities) or c to higher densities (using conductive opacities); whether they do either c (or both) of these extensions DEPENDS ON HOW YOU READ IN THE OPACITIES via c the subroutines described further below. c c c*** OPAC( z, xh, exC, exO, T6, R ) The purpose of the subroutines OPAC or c ------------------------------ OPAL is to perform up to 6-variable c*** OPAL( z, xh, exC, exO, slt, slr ) interpolation on log10(kappa), to yield c --------------------------------- the opacity (and also its temperature c and density derivatives) at the given composition, temperature, and density c values (the details of how this interpolation is performed are discussed c further below). The user can control how the opacities are initially read c in via subroutines discussed further below; otherwise, the first time OPAC c or OPAL is called, opacities will be read in for an estimated "optimum" c range of Z-values (that encompass the input value z). These subroutines c actually call OPAL_F_CNOU( z, xh, exC, exO, slt, slr, 0.0, 0.0, 0.0, 0.0 ) c (see description below) to perform the opacity interpolation. c c The SINGLE-PRECISION REAL interpolation variables are: c c z The metallicity, Z (excluding any "excess" C and O) c xh The hydrogen mass fraction, X c exC The enhanced ("excess") carbon mass fraction, exC. c The total carbon mass fraction, Xc, is the sum of exC and c the initial amount included in the metal mass fraction Z c exO The enhanced ("excess") oxygen mass fraction, exO. c OPAC: c T6 The temperature in millions of degrees Kelvin, T6 c R = { rho(gm/cc) / T6**3 }, the temperature-shifted density value c OPAL: c slt log10(T6) = log10(T) - 6 c slr log10(R) = log10(rho) - 3 * slt = log10(rho) - 3 * [log10(T)-6] c c (by definition, the helium mass fraction is Y = 1.0 - z - xh - exC - exO). c Note that, while z and xh must be non-negative, small NEGATIVE values for c exC and/or exO are allowed, provided that the sums { z + exC , z + exO , c z + exC + exO } are non-negative; this leads to (linear) extrapolation c in log(z+exC+0.001) and/or log(z+exO+0.001), unlike the earlier version of c MAY 28, 1999 (where negative exC or exO values were treated as being zero). c c c Your routine that calls to OPAC or OPAL should either include the statement: c c common/e_opal_z/ opact,dopact,dopacr,dopactd,fedge,ftredge,fzedge c c OR ELSE, after calling the opacity-calculation routine (e.g., OPAC or OPAL): c c call ASK_LAST_OPAC(OPACT,DOPACT,DOPACR,DOPACTD,FEDGE,FTREDGE,FZEDGE) c --------------------------------------------------------------- c c (this subroutine ASK_LAST_OPAC just returns the values from the common block c /e_opal_z/ in its user-supplied arguments). c c These SINGLE-PRECISION REAL variables have the following meanings: c c OPACT returns the Log of the Rosseland mean opacity: Log10(kappa) c DOPACT returns dLog(kappa)/dLog(T6) at constant R (NOT rho!) c DOPACR returns dLog(kappa)/dLog(R) at constant T6, which is c = dLog(kappa)/dLog(rho) at constant temperature c DOPACTD returns dLog(kappa)/dLog(T6) at constant density, which is c = dLog(kappa)/dLog(T) at constant density c = DOPACT - 3.0 * DOPACR c FEDGE returns the degree-of-extrapolation product FTREDGE * FZEDGE c or, in some cases, A SMALLER VALUE (even zero): c - If you have read in conductive opacities, then FEDGE is c reduced in switchover regions (radiative to conductive c or one conductive table to another) where one or both c of the opacities requires some extrapolation (FTREDGE, c described below, is NOT reduced, to indicate that the c opacities should still be quite accurate there). c - If the 'GN93hz' opacities are NOT available, then FEDGE c reduces to zero as X increases from 0.76 to 0.8 (but c the opacity is still calculated out to X = 1 - Z); you c should ALWAYS SUPPLY the file 'GN93hz', since errors c can be quite large in some cases if you do not (up to c an order of magnitude for Z < 0.001 at X = 1 - Z). c FTREDGE returns 1.0 for T6,R inside table boundaries, reduces to 0.0 c as T6,R moves more than one grid spacing outside table c (except, in general, in switchover regions). c FZEDGE returns 1.0 for Z inside the available range [zlow,zhigh], c reduces to 0.0 as Z moves out to the boundaries of the c extreme-Z-extrapolation range [zlo_ex,zhi_ex]. c c BY DEFAULT, the OPAL-opacity calculating routines set OPACT = 1.0E+35 and c return without actually calculating the opacity IF: c (1) FZEDGE = 0.0 , or c (2) FTREDGE = 0.0 and ( logR < -6 or logT < 3.97 ) . c Otherwise, even if FTREDGE = 0.0 , the radiative opacity is extrapolated c (linearly) without limit to high T or R, since an estimate of the radiative c opacity may be needed in such regions to determine whether the conductive c opacity suffices there or not. c c IF YOU HAVE READ IN CONDUCTIVE OPACITIES, then FTREDGE will be non-zero c where they are valid and dominate, even if the radiative opacities are not c valid there: i.e., conductive opacities can be used to EXTEND the radiative c opacities, as well as being combined with them via the relevant formula c Kappa = 1 / ( 1 / Kappa_rad + 1 / Kappa_cond ) . c Also: FTREDGE will be unity in the density region where opacities switch c over from fully-valid radiative to fully-valid conductive ones, even if c part of this switchover region requires some extrapolation of one or both c of these. However, FEDGE will be less than unity (possibly even zero) in c switchover regions where such such extrapolation is required, and also in c density gaps where different conductive opacity tables do not quite meet. c (Also, at high T and R, an extrapolated conductive opacity value is returned c even in regions where FTREDGE is zero.) c c NOTE THAT, if you have set the error-checking level to 2 (see SET_ERR_CHECK c below), then ANY "out-of-range" case (where the final value of FEDGE = 0.0) c is considered a fatal error and the program halts. c c If FZEDGE = 0.0, then the given Z-value lay too far ouside the available c Z-range to be extrapolated (this is checked first, before T6 and R). c If FTREDGE = 0.0 (and FZEDGE > 0.0), then the given T6 and/or R values lay c too far outside the available table for reasonable extrapolation. c c Details of the extrapolation, and of subroutines allowing user control over c the boundaries, are discussed further below. c c c*** OPAL_X_CNO_FU( xh, slt, slr, xmet, nmet, fu ) This subroutine adds any c --------------------------------------------- opacity shifts due to the c interconversions C --> N, O --> N, and/or N --> Ne (which can arise from c nuclear burning) to the opacities interpolated in the 6 basic variables c { z, xh, exC, exO, slt, slr }. USE OF THIS SUBROUTINE CAN BE TRICKY. c c ---WARNING--- This subroutine estimates Z from the mass fraction of elements c heavier than Ne. UNLESS (1) you keep track of the mass fractions at least c of C, N, O, Ne, and "heavies", and (2) your initial Z-composition, namely c {C, N, O, Ne, "heavies"}, is THE SAME as that in the "solar" opacity table c (e.g., 'GN93hz', 'GS98hz', or 'AGS04hz'), this subroutine will obtain an c ERRONEOUS Z value and thus an INCORRECT OPACITY. c c ---WARNING--- If nmet = 19 in your array, then you must have initialized ALL c of {C,N,O,Ne,Na,Mg,Al,Si,P,S,Cl,Ar,K,Ca,Ti,Cr,Mn,Fe,Ni} to a "solar" opacity c table mix (e.g., from 'GN93hz' or 'GS98hz'), OTHERWSE you will get ERRONEOUS c Z and CNO-interpolation factors (since the program uses stored atomic weight c values to convert xmet into number fractions in this case), and thus an c INCORRECT OPACITY. If you include either fewer or more heavy elements, c e.g., if you combine some of these elements into a collective "Xheavy", then c you MUST use a value of nmet NOT EQUAL TO 19. c c ---WARNING--- OPAL_X_CNO_FU implicitly assumes that elements heavier than Ne c are negligibly affected by nuclear burning. IF ANY ELEMENTS HEAVIER THAN Ne c ARE PRODUCED VIA NUCLEAR BURNING, this will cause the Z-value estimated by c OPAL_X_CNO_FU to increase by roughly 5 to 6 times as much as the increase in c heavy element abundance. This may give LESS GOOD OPACITY values, or even c yield estimated Z-values so large as to be OUT OF RANGE (this will occur for c Xheavy > 0.02, roughly; in the worst case, Xheavy > 0.015 may give estimated c Z > 0.1, i.e., beginning to be out of range). If any elements heavier than c Ne are produced via nuclear burning, you may wish to assign all or most of c the newly-nucleosynthesized "heavies" to the Ne abundance, for purposes of c opacity calculation (or else use some other subroutine). c c The input variables are: c c xh The hydrogen mass fraction, X (as for OPAL or OPAC above) c slt log10(T6) = log10(T) - 6 (as for OPAL above) c slr log10(R) = log10(rho) - 3 * slt (as for OPAL above) c xmet SINGLE-PRECISION REAL ARRAY of size nmet, giving the mass c fractions of the "metals", i.e., of C, N, O, Ne, ... c NOTE that these are the actual mass fractions (NOT the mass c fractions relative to Z), and any "excess" C or O should be c included in the values of xmet(1) or xmet(3), respectively. c By definition, the mass fraction Y of helium is given by c Y = 1 - xh - SUM{xmet(i)} , where i=1,...,nmet in the SUM. c nmet INTEGER size of the array xmet: ideally it should be the case c that nmet = nel_zmix = 19 , in which case xmet is assumed c to hold the mass fractions of the elements of the OPAL mix, c namely, {C,N,O,Ne,Na,Mg,Al,Si,P,S,Cl,Ar,K,Ca,Ti,Cr,Mn,Fe,Ni}. c If the array size nmet is not 19, then the sum of xmet(5) c through xmet(nmet) is used as the total mass fraction of all c elements heavier than Ne, i.e., the array xmet must contain c at least {C,N,O,Ne,Xheavy}. c NOTE that if Xheavy contains any part of the abundances from C, c N, O, or Ne, then the calculated Z value will be in error! c (Also, if you have set the error level to 3 or higher [see the c subroutine SET_ERR_CHECK] and CNO-interpolation is available, c then it is a fatal error if nmet is not equal to 19.) c fu SINGLE-PRECISION REAL variable, giving the fraction of the c opacity shifts to be applied from any user-specified file: fu c multiplies opacity differences between the files CF_USER and c CF_HZ (as specified by the subroutine READ_EXTENDED_OPAC: c see below). c If NO user-specified opacity file CF_USER has been read in, c then the value of fu is ignored (a value of 0.0 is used). c c This subroutine uses the array xmet(nmet) to calculate the metallicity Z, c the excess carbon and oxygen EXC and EXO, and the fractions FCN, FCON, and c FCNONE (to apply the C --> N, O --> N, and N --> Ne opacity shifts --- the c CNO-interpolation of logKappa is linear in the CNO number fractions). In c general, it sets FUSE = fu (except that the value of FUSE is restricted c so that it does not correspond to a reduction by more than a factor of 2 in c the total number density of elements heavier than Ne). This subroutine then c does the equivalent of calling c OPAL_F_CNOU( Z, xh, EXC, EXO, slt, slr, FCN, FCON, FCNONE, FUSE ) . c c NOTE that there would usually be little point in using OPAL_X_CNO_FU unless c you have called READ_EXTENDED_OPAC with a non-zero value of I_CNO (to c allow CNO-interpolation in the opacities) and/or a non-blank CF_USER value c (the user-specified opacity correction filename). c If the CNO-interpolation opacity files have not been read in, then this c subroutine approximates the opacity effects of C,N,O,Ne interconversion by c applying small negative and/or positive values of exC and exO ("excess-C,O") c which may or may not be better than nothing. c c NOTE that interconversion of C,N,O,Ne via CNO-cycle burning changes slightly c the value of Z that this subroutine will compute, for a given set of mass c fractions of elements heavier than Ne: the total number density in C,N,O,Ne c is constant, but the total mass in these elements changes. Thus this c subroutine OPAL_X_CNO_FU should only be used if one has read in a RANGE of c Z-values (see opacity-reading subroutines below): if one has read in only a c single Z-value, then OPAL_X_CNO_FU is likely to yield out-of-range Z values. c c Note that the subroutine SET_CNO_FILES( cf_hz, cf_c, cf_o, cf_n, cf_user ) c (discussed below) can be used to set the names of the opacity files that are c used to get the opacity shifts for CNO-interconversion (files cf_hz through c cf_n) and any user-specified opacity shifts (cf_user, relative to cf_hz). c NOTE that the first four of these files (cf_hz, cf_c, cf_o, cf_n) are those c used for CNO-interpolation, and should all have the SAME number fractions c for the elements heavier than Ne in their compositions (only C,N,O,Ne should c be interconverted in these CNO-interpolation files). c c c*** OPAL_F_CNOU( z, xh, exC, exO, slt, slr, fcn, fcon, fcnone, fu ) For users c --------------------------------------------------------------- who want c to use their own methods to compute the metallicity Z, the "excess" carbon c and oxygen mass fractions EXC and EXO, and CNO-interpolation factors FCN, c FCON, and FCNONE (as well as any user-factor FU) from their composition. c c This interface is similar to OPAL( z, xh, exC, exO, slt, slr ) except for c the added CNO/user-interpolation factors: c c fcn Multiplies opacity differences between files cf_c and cf_hz c fcon Multiplies opacity differences between files cf_o and cf_hz c fcnone Multiplies opacity differences between files cf_n and cf_hz c fu Multiplies opacity differences between files cf_user and cf_hz c c Note that the inputs supplied to the opacity-reading subroutines (described c below) control whether CNO-interpolation and/or user-interpolation opacity c files are read in. If no CNO-interpolation files were read in, then the c values of fcn, fcon, fcnone are ignored; if no user-interpolation file was c read in, then the value of fu is ignored. c c NOTE that all the previous opacity-calculating interfaces above ultimately c call the subroutine OPAL_F_XCON_CNOU (described further below); the values c of Z, XH, EXC, EXO, SLT, SLR, FCN, FCON, FCNONE, FU actually used can be c checked by calling the subroutine ASK_LAST_XCNOU described below. c c c*** ASK_LAST_XCNOU( Z, X, XC, XO, SLT, SLR, FCN, FCON, FCNONE, FU ) c --------------------------------------------------------------- c This subroutine just returns the last-used OPAL_F_CNOU input values: it can c be used to check these values, rather than including common /x_opal_z/ in c the calling program. c c c*** ASK_LAST_OPAC( OPACT, DOPACT, DOPACR, DOPACTD, FEDGE, FTREDGE, FZEDGE ) c ----------------------------------------------------------------------- c This subroutine just returns the last-computed opacity values, taken from c common /e_opal_z/ (as an alternative to including this common block in the c calling program), as described above (under the OPAC and OPAL routines). c c c*** ASK_OPAL_Z_MIX( IMIX, XIZ, N_X, FNINZ, N_N ) c -------------------------------------------- c For the mix specified by IMIX , this subroutine returns the components of c the metallicity Z, in the arrays XIZ(N_X) and FNINZ(N_N) ; note that up c to 19 components are returned, the ratios by mass and by number respectively c of {C,N,O,Ne,Na,Mg,Al,Si,P,S,Cl,Ar,K,Ca,Ti,Cr,Mn,Fe,Ni}. Mix specs are: c c IMIX = 9 (actually, any IMIX > 5 or < -10) : return the actual mixture used c IMIX = 1 : return the 'GN93hz' main solar mix c IMIX = 2 : return the 'Alrd96a2' [O/Fe] = 0.3 mix c IMIX = 3 : return the 'C95hz' [O/Fe] = 0.4 mix c IMIX = 4 : return the 'W95hz' [O/Fe] = 0.5 mix c IMIX = 5 : return the user-specified [O/Fe] > 0 mix c IMIX = 0 : return the meteoritic mix c IMIX = -1 : return the alternate main solar mix (default 'GS98hz') c IMIX = -2 : return the corresponding version of 'Alrd96a2' [O/Fe] = 0.3 mix c IMIX = -3 : return the corresponding version of 'C95hz' [O/Fe] = 0.4 mix c IMIX = -4 : return the corresponding version of 'W95hz' [O/Fe] = 0.5 mix c IMIX = -5 : return the corresponding user-specified [O/Fe] > 0 mix c IMIX = -6 : return the "default-CNO" mix (for CNO-interpolation) c IMIX = -7 : return the CtoN mix (for CNO-interpolation) c IMIX = -8 : return the COtoN mix (for CNO-interpolation) c IMIX = -9 : return the CNOtoNe mix (for CNO-interpolation) c IMIX = -10 : return the user-defined nonCNO-interpolation mix c c c*** ASK_OPAL_MIX_WT( ATwt, Nwt, ATwtHHe, NHHe, ATz, Nz ) This subroutine c ---------------------------------------------------- returns the atomic c weights and nuclear charges used for the components of the metallicity Z: c c ATwt(Nwt) = real array returning up to 19 atomic weight values, as used c for {C,N,O,Ne,Na,Mg,Al,Si,P,S,Cl,Ar,K,Ca,Ti,Cr,Mn,Fe,Ni}; c if Nwt < 19 then only Nwt values will be returned, and c if Nwt < 1 then no atomic weight values will be returned. c ATwtHHe(NHHe) = real array returning up to 2 atomic weight values, as used c for H and He. c ATz(Nz) = real array returning up to 19 atomic numbers (nuclear charges), c for {C,N,O,Ne,Na,Mg,Al,Si,P,S,Cl,Ar,K,Ca,Ti,Cr,Mn,Fe,Ni}. c c c ================================================ c The subroutines that read in the OPAL opacities: c ================================================ c c c*** READ_OPAL_DUMP( IU, CF_D ) If a binary opacity file was created at some c -------------------------- earlier time by DUMP_OPAL_OPAC below, then c this subroutine can read it in again; note that ALL opacities and user c settings are restored from this unformatted binary file. c NOTE that the only advantage of this is speed: reading such an opacity c dumpfile is MUCH faster than using READ_BASIC_OPAL_OPAC (or its alternates). c c IU = integer Fortran unit number: from 1 to 99, and not equal to 5 or 6; c negative value means "use previous/default value" (if no positive c Fortran unit number was ever given earlier, the default is 23). c CF_D = character string: name of opacity dumpfile to be read in (INCLUDING c THE DIRECTORY, if it is not a local file). NOTE that this file c must exist, and must not be in compressed form. c c----[NOTE that the format of this dumpfile is INCONSISTENT with those produced c by program versions between FEBRUARY 1, 2004 and SEPTEMBER 6, 2006; any such c dumpfiles must be re-created by the present version.] c c c*** DUMP_OPAL_OPAC( IU, CF_D ) AFTER you have read in the opacities (from the c -------------------------- plain-text OPAL opacity files) via one of the c subroutines below, this subroutine can be used to dump an unformatted binary c file of the current opacities and user settings (just as read in) for future c re-use by the subroutine READ_OPAL_DUMP above. Note that if you have read c in conductive and/or molecular opacities as well (e.g., via the subroutine c READ_EXTENDED_OPAC below), then these will also be stored in the dumpfile. c c IU = integer Fortran unit number: from 1 to 99, and not equal to 5 or 6; c negative value means "use previous/default value". c CF_D = character string: name of opacity dumpfile to be created (INCLUDING c THE DIRECTORY, if it is not a local file); this file will be c overwritten if it already exists. c c The size of this opacity dumpfile will depend on the number of Z-values c stored; typically, 'z14xcotrin21.f' will store the maximum number of 14, for c a size of about 24 Mb (while 'z5xcotrin21.f' can store at most 5, for 9 Mb; c 'z1xcotrin21.f' will always store 1, for 2.7 Mb) [if no molecular opacities c were read in, these sizes will be 23 Mb, 8 Mb, and 1.7 Mb, respectively]. c c [But if you read opacities using READZEXCO (rather than one of the simpler c subroutines READ_BASIC_OPAL_OPAC or READ_EXTENDED_OPAC described below), c then the input argument NZIN determines how many Z-values are used.] c c c*** SET_OPAL_DIR( cdirin ) The input character variable cdirin can be used c ---------------------- to specify the directory where the OPAL-opacity c ASCII files will subsequently be looked for (default is the local directory, c which can also be specified by supplying a blank argument to SET_OPAL_DIR). c Note: the total length of the directory name MUST NOT exceed 246 characters. c c Example: call set_opal_dir( '/home/username/opal_directory/' ) c c OR: to specify "look in local directory": call set_opal_dir( ' ' ) c c OR: for a local subdirectory: call set_opal_dir( 'opal_directory/' ) c c c*** SET_MOL_DIR( cdir_mol ) The input character variable cdir_mol specifies c ----------------------- the directory where the molecular-opacity ASCII c files will subsequently be looked for (blank input means "use the default": c i.e., try both the OPAL directory and the local directory). c c c*** SET_COND_DIR( cdir_cond ) The input character variable cdir_cond gives c ------------------------- the directory where conductive-opacity ASCII c files will subsequently be looked for (blank input means "use the default": c i.e., try both the OPAL directory and the local directory). c c c*** SET_OPAL_LIST_LEVEL( LIST_LEVEL ) This subroutine can be used to make the c --------------------------------- opacity-reading routines print out the c ASCII opacity files that are actually read in (this can be useful when one c uses a subroutine such as READ_EXTENDED_OPAC to read in the "best available" c Ferguson molecular opacities, for example): c c LIST_LEVEL = integer flag to determine whether names of the ASCII opacity c files that are read in are printed out as they are read in c (note that binary opacity dump-files are NEVER printed). c The input value of LIST_LEVEL has the following effect: c 0 : (default) NO listing (printout) of opacity file names. c 1 : print the first Type 2 OPAL opacity (Gz???.x??) file, c the first of each Ferguson molecular opacity case c (or Alexander file), any conductive opacity file(s), c and any Type 1 OPAL opacity file(s) (e.g., 'GN93hz', c 'GS98hz', 'AGS04hz', 'W95hz', 'AGS04hz_Ofe.5_W95', c 'GS98hz.CtoN', 'GS98hz.COtoN', 'GS98hz.CNOtoNe'...). c > 1 : up to LIST_LEVEL Type 2 OPAL opacity files will be c printed, and up to LIST_LEVEL of each Ferguson c case read in (this is seldom useful, but for c example one might use LIST_LEVEL of 9999 to c print out EVERY opacity file that is read in). c c c*** SET_OPAL_LIST_UNIT( LIST_IU ) Set the integer Fortran unit number for the c ----------------------------- above list output (default is 6, i.e., the c standard output). An input value of 5, of more than 99, or less than 0, c will be reset to the default of 6 (standard output). [Note that if the c value of LIST_IU coincides with one of the Fortran units used to actually c read in an opacity file, a warning will be printed to the standard output, c and all subsequent list output will be printed to the standard output.] c c c*** READ_BASIC_OPAL_OPAC( IU, Z, CF_HZ, OFEBRACK, CF_OFE ) Read in the basic c ------------------------------------------------------ OPAL opacities, c possibly for non-solar alpha-element abundances (i.e., non-zero [O/Fe]): c c IU = integer Fortran unit number: from 7 to 96; note IU through IU+3 may c be used (negative value means "use previous/default value"). Note c that values from 0 to 6 will be reset to 7, and values greater than c 96 will be reset to 96. c Z = (real) "typical" metal-mass-fraction value; opacities will be read in c for as wide a range around Z as possible (negative means "use the c default value of 0.02"). For the version z14xcotrin21.f of these c subroutines, the value of Z is irrelevant, as ALL of the available c metallicities will be read in (from 0.0 to 0.1). For z5xcotrin21.f c metallicities within about a factor of two of Z will be available; c for z1xcotrin21.f on the the single metallicity Z will be read in. c CF_HZ = character variable (or string constant) giving the "main" opacity c file to read in, typically 'GN93hz', 'GS98hz', or 'AGS04hz' (but c one can specify any Type-1 OPAL opacity file having a solar mix; c blank means "use the default of 'GN93hz'"). NOTE that not only c will this file CF_HZ be read in, but ALSO the file 'GN93hz' c and the 40 Type-2 files (Gz???.x??). c OFEBRACK = (real) value of [O/Fe] = log{ (n_O/n_Fe) / (n_O/n_Fe)_Sun } ; c if this is non-zero, then opacities are interpolated between c the file CF_HZ and the file CF_OFE to get opacities for c the given [O/Fe] value. c CF_OFE = character variable (or string constant) giving the name of the c OPAL opacity file with non-zero [O/Fe]; if OFEBRACK = 0.0, then c this argument is ignored (blank means "use the default": for c CF_HZ = 'GN93hz' the default is CF_OFE = 'W95hz', otherwise the c default is to append '_Ofe.5_W95' to the value of CF_HZ). c c ----- NOTE that if the opacity files on disk are in compressed form (suffix c '.gz', '.Z', or '.bz2'), then they will be uncompressed (by gunzip, c uncompress, or bunzip2, respectively), read in, and compressed again; c however, this slows down the input and MAY LEAD TO INPUT ERRORS if c more than one instance of this program is running. c c c*** READ_EXTENDED_OPAC(IU,Z,CF_HZ,OFEBRACK,CF_OFE,I_MOL,I_COND,I_CNO,CF_USER) c ------------------------------------------------------------------------- c This is an extended version of the above subroutine READ_BASIC_OPAL_OPAC: c c IU, Z, CF_HZ, OFEBRACK, CF_OFE : as in READ_BASIC_OPAL_OPAC above. c I_MOL = flag controlling whether the low-temperature molecular opacities c will be used. The most useful values are as follows: c I_MOL = 0 : do not read in any molecular opacities c I_MOL = 1 : look for molecular opacities for the same composition c as the OPAL opacities (if no matching molecular set c of opacities can be found, look for any available c set of molecular opacities). If OFEBRACK is not c zero, try to add opacity-shifts to get opacities c appropriate for this input [O/Fe] value. c I_MOL = -1 : read the molecular opacities, but do not use them to c extend the OPAL opacities to low T when using the c OPAL opacity-calculating subroutines described c above [the molecular opacities can be accessed by c the subroutine KAP_MOL, described further below]. c I_MOL = 21, 31, 41, ... 121 : read ONLY the corresponding set of c Fergson 2005 molecular opacities (21=GN93, 31=GS98, c 41=L03, 51=AGS04, 61=S92, 71=S92AE, 81=GS98-.2, c 91=GS98+.2, 101=GS98+.4, 111=GS98+.6, 121=GS98+.8). c I_MOL = 991 : read ONLY the molecular opacities specified by a c previous call to SET_FERG_USER (described further below). c ------[A more-detailed dexcription of I_MOL than most users will c need follows the descriptions of the other input variables.] c I_COND = flag controlling whether the high-density conductive opacities c will be read in and/or used: c 0 = do not use these high-RHO conductive opacities at all. c 1 = read these opacities in, and use them to extend the OPAL c opacities to high RHO when using opacity-calculating c subroutines described above. By default, the file c 'condall06.d' (Potekhin et al. 2006) is used; if not c found, 'condall06' is tried; if not found, then the OLD c file 'Condopac' (Hubbard & Lampe 1969) is used; if none c of these are found, it is a fatal error. c 2 = same as 1, except that only the Potekhin et al. (2006) c file ('condall06.d' or 'condall06') is looked for. c -1 = same as 1, but do not use conductive opacities to extend c the OPAL opacities when using the opacity-calculating c subroutines described above (they can be accessed by c the subroutine KAPCOND, described further below). c -2 = same as -1, except that only the Potekhin et al. (2006) c file ('condall06.d' or 'condall06') is looked for. c I_CNO = flag controlling whether the varied-CNO opacities will be used: c 0 = these varied-CNO opacities will neither be read in nor used. c 1 = these varied-CNO opacities will be read in from files with c names given by appending '.CtoN', '.COtoN', and '.CNOtoNe' c to the name given by the input CF_HZ , and will be c available to use with the opacity-calculating subroutine c OPAL_X_CNO_FU (or OPAL_F_CNOU) described above. c CF_USER = character variable (or string constant) giving the name of a c user-specified Type-1 OPAL opacity file to read in, for use c with OPAL_X_CNO_FU (or OPAL_F_CNOU); a blank input string c means that no such file will be read in or used. c c ----- A more detailed description of I_MOL and its allowed values c (MOST USERS WILL NOT NEED TO BOTHER WITH THIS): c I_MOL = flag controlling whether the low-temperature molecular opacities c will be used. IF IT IS NON-ZERO, then if possible Ferguson et c al. (2005) molecular opacities MATCHING the OPAL opacity file c will be read in; IF no such matching files are found, then all c possible molecular opacity files are checked for, and the first c one found is read in -- looking first for a user-specified case c (see SET_FERG_USER below), next for a case specified by a prior c call to the subroutine SET_ALEX_FILE (see below), next for the c cases AGS04, L03, GS98, GN93, S92, S92AE, GS98-.2 ... GS98+.8; c if none of these are found, the Alexander & Ferguson (1994) c opacities will be read in from the file 'Alexopac'; if not even c this file is found, then it is a fatal error. c --- If one of the non-alpha-enhanced Ferguson et al. 2005 cases was c read in, and abs(I_MOL) < 10 and the input value of OFEBRACK c is non-zero, then an attempt will be made to read in files so as c to obtain opacity-shifts to yield opacities for this specified c [O/Fe] value, using the GS98 GS98-.2 ... GS98+.8 cases if these c are available, or if not then the S92 and S92AE cases are tried. c --- The input value of I_MOL also has the following effects: c For the (DEFAULT) Ferguson et al. 2005 case: c 0 = do not use low-T molecular opacities at all. c 1 = the molecular opacities are read in, and will be used c to extend the OPAL opacities to low T when using the c opacity-calculating subroutines described above; c the edge factor FKAEDGE will be unity for XZCO < 0.1 c (where XZCO = Z + exC + exO is the total metal mass c fraction), and FKAEDGE will go to c zero for XZCO > 0.12; c 2 = same as I_MOL = 1 c 3 = same as I_MOL = 1 c 4 = similar to I_MOL = 1, but set edge factor FKAEDGE to zero c for too much "excess-CO": abs(exC) + abs(exO) > CO_lim c where CO_lim = 0.2 * max( Z , 0.0001 , Z + exC + exO ) c [this will not be done if you just call the subroutine c KAPFERG (which does not know what Z, exC, and exO are), c but it WILL be done for any other subroutine, including c KAP_MOL, KAPFERG, and any calls to molecular opacity c routines from OPAL-opacity calculating subroutines]. c For the (OLD) Alexander & Ferguson 1994 case: c 0 = do not use low-T molecular opacities at all. c 1 = the molecular opacities are read in; arbitrary values of c XZCO will be allowed at X = 0, and XZCO < 0.1 will be c allowed at all X (the edge factor FKAEDGE will go to c zero for XZCO > 0.15 at X > 0.03). c 2 = similar to I_MOL = 1, but always reduce the edge factor c FKAEDGE to zero as XZCO increases from 0.1 to 0.15, c even for X = 0. c 3 = similar to I_MOL = 2, but restrict to regions where the c Alexander tables were available (0.0001 < XZCO < 0.03, c the original table range), and set the edge factor c FKAEDGE to zero for XZCO < 0.00005 or XZCO > 0.05 . c 4 = similar to I_MOL = 3, but set edge factor FKAEDGE to zero c for too much "excess-CO". c For both types of molecular opacities: c -1 = read in the molecular opacities, but do not use them to c extend the OPAL opacities to low T when using the OPAL c opacity-calculating subroutines described above [the c molecular opacities can be accessed by the subroutine c KAP_MOL (or KAPFERG or KAPALEX), described further c below]. Otherwise, same as I_MOL = 1. c -2 = same as I_MOL = -1, with Z-constraints as for I_MOL = 2 c -3 = same as I_MOL = -1, with Z-constraints as for I_MOL = 3 c -4 = same as I_MOL = -1, with Z-constraints as for I_MOL = 4 c Other input values of I_MOL allow one to specify precisely which c Ferguson et al. 2005 case to read in (note that for the following c cases, NO [O/Fe]-molecular-opacity-shifts will be done): c 11 thru 14, or -11 thru -14 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only the Ferguson et al. 2005 case specified c by a previous call to SET_ALEX_FILE is looked for. c 21 thru 24, or -21 thru -24 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only the Ferguson GN93 case is looked for ... c 31 thru 34, or -31 thru -34 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only the Ferguson GS98 case is looked for ... c 41 thru 44, or -41 thru -44 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only the Ferguson L03 case is looked for ... c 51 thru 54, or -51 thru -54 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only the Ferguson AGS04 case is looked for ... c 61 thru 64, or -61 thru -64 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only the Ferguson S92 case is looked for ... c 71 thru 74, or -71 thru -74 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only the Ferguson S92AE case is looked for ... c 81 thru 84, or -81 thru -84 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only the Ferguson GS98-.2 case is looked for ... c 91 thru 94, or -91 thru -94 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only the Ferguson GS98+.2 case is looked for ... c 101 thru 104 or -101 thru -104 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only the Ferguson GS98+.4 case is looked for ... c 111 thru 114 or -111 thru -114 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only the Ferguson GS98+.6 case is looked for ... c 121 thru 124 or -121 thru -124 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only the Ferguson GS98+.8 case is looked for ... c 991 thru 994 or -991 thru -994 : same as 1 thru 4 or -1 thru -4, c EXCEPT: only a user-specified Ferguson case is looked c for (as previously set by calling SET_FERG_USER). c c c****************************************************************************** c c c ************************************************************************** c SUBROUTINES TO CONTROL THE DETAILS: MOST USERS WILL NOT NEED TO USE THESE: c ************************************************************************** c c c******* NOTE that the opacity-reading subroutines described above call various c versions of the subroutines described below; for example, calling c READ_BASIC_OPAL_OPAC( IU, Z, CF_HZ, OFEBRACK, CF_OFE ) c does the equivalent of: c CALL SET_ALTMIX_MAIN_FILE( CF_HZ ) c CALL SET_OFE_FILE( CF_OFE ) c CALL SET_ALTMIX_OFE_FILE( CF_OFE ) c CALL READZEXCO( -9, -1.0, z, -1.0, khighz, IU, OFEBRACK ) c with a value of khighz determined by the inputs CF_HZ and OFEBRACK; c likewise, calling c READ_EXTENDED_OPAC(IU,Z,CF_HZ,OFEBRACK,CF_OFE,I_MOL,I_COND,I_CNO,CF_USER) c does the equivalent of: c CALL SET_ALTMIX_MAIN_FILE( CF_HZ ) c CALL SET_OFE_FILE( CF_OFE ) c CALL SET_ALTMIX_OFE_FILE( CF_OFE ) c CALL SET_CNO_FILES( ' ', ' ', ' ', ' ', CF_USER ) c CALL READZEXCO( -9, -1.0, Z, -1.0, khighz, IU, OFEBRACK ) c CALL READ_BEST_MOL( IU, I_MOL, CF_HZ, OFEBRACK ) c IF ( IABS( I_COND ) .GT. 1 ) THEN c CALL READ_COND_POT( IU ) c ELSE IF ( I_COND .NE. 0 ) THEN c CALL READCOND( IU ) c ENDIF c CALL SET_COND_USE( MIN(1,MAX(0,I_COND)), 99 ) c where the value of khighz is determined by the various inputs. c c Likewise, the opacity-calculating subroutines OPAC, OPAL, OPAL_X_CNO_FU, c and OPAL_F_CNOU will call OPAL_F_XCON_CNOU, which then calls one or more c of the subroutines OPAL_K_ONLY, KAPCOND, KAPFERG, KAPALEX described below. c c c ===================================================================== c Other subroutines that interpolate among the OPAL or other opacities: c ===================================================================== c c c*** OPAL_K_ONLY( Z, XH, EXC, EXO, SLT, SLR, FCN, FCON, FCNONE, FU ) This is c --------------------------------------------------------------- almost c the same as OPAL_F_CNOU, with the same meaning for the inputs, EXCEPT that c it will only return the OPAL opacities (i.e., it ignores molecular opacities c and conductive opacities, whether or not these have been read in). c c c*** KAPFERG( slt, slr, xh, z, exC, exO, FLKA, DLKATR, DLKARO, DLKAT, FKAEDGE ) c -------------------------------------------------------------------------- c This routine interpolates and returns the Ferguson et al. 2005 molecular c opacity (provided that a set of these opacities has been read in) [NOTE c that if these Ferguson et al. 2005 molecular opacities are available, then c the Alexander & Ferguson 1994 molecular opacities are not, and vice versa]: c c slt, slr, xh, z, exC, exO = (real) input values, as in subroutine OPAL. c FLKA = (real) variable returning Log(kappa), equivalent to OPACT c DLKATR = (real) variable returning dLog(kappa)/dLog(T) at constant R, c equivalent to DOPACT c DLKARO = (real) variable returning dLog(kappa)/dLog(RHO) at constant T, c equivalent to DOPACR c DLKAT = (real) variable returning dLog(kappa)/dLog(T) at constant density, c equivalent to DOPACTD c FKAEDGE = (real) variable returning the edge factor, equivalent to FEDGE c c c*** CACHEFERG( ksto, xh, xzco ) This subroutine caches Z- and X-interpolated c --------------------------- Ferguson et al. 2005 molecular opacity values c for future use [if a LARGE number of low-termperature opacities must be c evaluated with the same Z and X values, this can speed up the evaluation]. c ksto = (integer) storage index, 1 or 2, of the cache storage area (only c two sets of Z- and X-interpolated opacities can be cached, at c X1,Z1 and X2,Z2). c xh = X, (real) hydrogen mass fraction to use. c xzco = Z + exC + exO, (real) total metal mass fraction to use. c c c*** KAP_MOL( slt, slr, xh, z, exC, exO, FLKA, DLKATR, DLKARO, DLKAT, FKAEDGE ) c -------------------------------------------------------------------------- c This routine just calls either KAPFERG (see above) or KAPALEX (see below), c depending on which type of molecular opacities are available. c c c*** KAPALEX( FLT, FLRO, X, XZCO, FLKA, DLKAT, DLKARO, FKAEDGE ) This routine c ----------------------------------------------------------- interpolates c and returns the Alexander & Ferguson 1994 molecular opacities (provided that c these opacities have been read in from the file 'Alexopac') [NOTE that if c these Alexander & Ferguson 1994 molecular opacities are available, then the c Ferguson et al. 2005 molecular opacities are not, and vice versa]: c c FLT = log(T) = SLT + 6.0 c FLRO = log(RHO) = SLR + 3.0 * SLT c X = hydrogen mass fraction (the same as XH above) c XZCO = Z + exC + exO = 1 - X - Y = the total mass fraction of elements c heavier than helium (note that the Alexander & Ferguson 1994 c opacities are available only as a function of temperature, c density, hydrogen abundance, and metallicity) c FLKA = (real) variable returning Log(kappa), equivalent to OPACT c DLKAT = (real) variable returning dLog(kappa)/dLog(T) at constant density, c equivalent to DOPACTD c DLKARO = (real) variable returning dLog(kappa)/dLog(RHO) at constant T, c equivalent to DOPACR c FKAEDGE = (real) variable returning the edge factor, equivalent to FEDGE c c c*** ASK_LAST_ALEX_EDGE( FKAEDGE, FTRA, FTRA_LO, FTRA_HI, FZKAEDGE ) To give c --------------------------------------------------------------- access to c the detailed edge factors for the molecular opacities (which yielded the c final overall value of FKAEDGE, as returned by KAPFERG or KAPALEX above): c c FKAEDGE = real variable returning the final overall edge factor; it is c defined as FKAEDGE = FTRA * FZKAEDGE . c FTRA = real variable returning the temperature-density edge factor, which c is defined as FTRA = min( FTRA_LO , FTRA_HI ) . c FTRA_LO = real variable returning the edge factor for the low T, low RHO c edges of the molecular opacity tables. c FTRA_HI = real variable returning the edge factor for the high T, high RHO c edges of the molecular opacity tables. c FZKAEDGE = real variable returning the molecular Z-edge factor, in the c manner determined by the value of KALEX as set by the c subroutine READ_EXTENDED_OPAC (or SET_ALEX_USE below). c c c*** SET_ALEX_USE( KALEX ) This allows the user to control whether molecular c --------------------- opacities that were read in will actually be used, c and how; it may be called at any time to change this behavior: c c KALEX = integer input flag controlling handling of molecular opacities: c if KALEX > 0, then the OPAL-opacity-calculating subroutines will c use the molecular opacities (if they have been c read in) as an extension to lower T; c if KALEX < 0 or KALEX = 0, then the OPAL opacity-calculating c subroutines will ignore the molecular opacities c whether or not they have been read in (but the c subroutine KAPFERG or KAPALEX will still work). c Specific values for KALEX control the molecular-opacity Z-edge c factor, whether called from OPAL-opacity-calculating subroutines c or from the subroutines KAPFERG or KAPALEX: c 1 : (DEFAULT) For Ferguson et al. 2005 opacities, the Z-edge c factor FZKAEDGE is unity for XZCO < 0.10 at all X, and c goes to zero for XZCO > 0.12; but for the Alexander 1994 c opacities, FZKAEDGE is unity for X = 0 at all XZCO and for c XZCO < 0.10 at all X, and it goes to zero at XZCO > 0.15 c and X > 0.03 (note that XZCO = 1 - X - Y = Z + exC + exO). c 2 : For Ferguson et al. 2005, same meaning as KALEX = 1; but c for Alexander 1994, FZKAEDGE goes to zero for XZCO > 0.15 c at all X. c 3 : For Ferguson et al. 2005, same meaning as KALEX = 1; but c for Alexander 1994, restrict to the regions where tables c were available (not extrapolated or otherwise created): c FZKAEDGE = 1.0 for 0.0001 < XZCO < 0.03, and goes to c FZKAEDGE = 0.0 for XZCO < 0.00005 or XZCO > 0.05 . c 4 : FOR THE OPAL-OPACITY-CALCULATING SUBROUTINES and KAPFERG: c for BOTH the Ferguson et al. 2005 and the Alexander 1994 c cases: multiply the FZKAEDGE value from case 3 above by a c factor that is unity if exC and exO are both zero, c and which goes to zero if abs(exC) + abs(exO) > CO_lim c for CO_lim = 0.2 * max( Z , 0.0001 , Z + exC + exO ) . c [Note that this constraint cannot be applied in KAPALEX, c which does not know the separate values of Z, exC, exO c (but only their sum XZCO); thus, for calls to KAPALEX c itself, KALEX = 4 has the same effect as KALEX = 3.] c 0 : Same as KALEX = -1. c -1 thru -4 : molecular opacities should NOT be used by the OPAL c opacity-calculating routines, even if they are read in; c same as 1 thru 4 when KAPFERG is called explicitly; c same as 1 thru 3 when KAPALEX is called explicitly. c -9 : Set KALEX to its default value of 1. c -99 : Leave the current value of KALEX unchanged. c c c*** ASK_ALEX_USE( KALEX, KALEX_AVAIL, ITYPE ) This subroutine returns the c ----------------------------------------- current value of these integer c flags that control the use of molecular opacities (see SET_ALEX_USE above): c c KALEX = integer variable returning the value of KALEX as in SET_ALEX_USE. c KALEX_AVAIL = integer variable returning a flag value telling whether (and c which) molecular opacities are actually available: c 0 : not available (molecular opacities never read in). c 1 : Alexander & Ferguson 1994 molecular opacities are c available (the file 'Alexopac' has been read in): c subroutine KAPALEX can be used to return Alexander c opacities, and if KALEX > 0 then these will be c used to extend the OPAL opacities to low T. c 2 : some set of Ferguson et al. 2005 molecular opacities c is available; subroutine KAPFERG can be used to c return these, and if KALEX > 0 then these will be c used to extend the OPAL opacities to low T. c ITYPE = integer variable returning a flag value, whose meaning depends on c which type of molecular opacities are available: c ITYPE = ITYPE_FERG for Ferguson et al. 2005 molecular opacities: c the index of the (last) type of Ferguson opacities that were c read in (note that if several types of Ferguson opacities were c combined using READ_ADD_FERG or ADDFILE_FERG, the index refers c to the last type to be read in and combined): c 1 = case specified by CFILE_ALEX (see SET_ALEX_FILE below), c 2 = GN93 case, 3 = GS98 case, 4 = L03 case, c 5 = AGS04 case, 6 = S92 case, 7 = S92AE case, c 8 = GS98-.2 case, 9 = GS98+.2 case, 10 = GS98+.4 case, c 11 = GS98+.4 case, 12 = GS98+.8 case, c 99 = user-specified case (see SET_FERG_USER above). c ITYPE = IRHOSW for Alexander & Ferguson 1994 molecular opacities: c integer variable returning a flag value telling whether there is c a density switchover between OPAL and Alexander opacity tables c (as well as the temperature switchover which must be present) c [see subroutine SET_ALEX_DO_RHOSW described further below; note c Ferguson et al. 2005 opacities NEVER have a density switchover]. c c c*** KAPCOND( FLRO, FLT, X, Y, XCN, XON, XNEHEAVY, FMUAINV, FMUEINV, c ZSQBAR, IDER, FLKC, FLKCT, FLKCRO, FKCEDGE, FKCOK ) c --------------------------------------------------------------- c This subroutine calculates and returns the conductive opacities. c c If the file 'condall06.d' was read in, use the Potekhin et al. 2006 tables; c whether RMS or linear mean ionic charge is used depends on IDER (see below), c where Zion(rms) = ( = FMUEINV / FMUAINV . c c Alternatively, if the file 'Condopac' was read in instead, use the Hubbard & c Lampe 1969 tables, possibly extended and modified by formulae of Itoh et al. c 1983 and Mitake et al. 1984, depending on the value of IDER (see below). c c FLRO = log(RHO) = SLR + 3.0 * SLT c FLT = log(T) = SLT + 6.0 c X = hydrogen mass fraction (the same as XH above). c Y = helium mass fraction. c XCN = Xc + Xn / 2 = effective total carbon mass fraction. c XON = Xo + Xn / 2 = effective total oxygen mass fraction. c XNEHEAVY = Xne + Xheavy = mass fraction of elements heavier than oxygen c [by definition, X + Y + XCN + XON + XNEHEAVY = 1]. c FMUAINV = 1 / mu_A = SUM_i{ X_i / A_i } (for all elements i in the mix -- c note that X_i is the mass fraction and A_i the atomic weight); c if FMUAINV < 0.0, then an approximate value is calculated from c the input values of X, Y, XCN, XON, and XNEHEAVY. c FMUEINV = 1 / mu_e = SUM_i{ X_i * z_i / A_i } (for all elements i in the c mix -- note that z_i is the atomic number of element i); c if FMUEINV < 0.0, then an approximate value is calculated. c ZSQBAR = / mu_A = SUM_i{ X_i * (z_i)^2 / A_i } (for all elements i c in the mix); this is the mean square ionic charge c divided by mu_A (i.e., multiplied by FMUAINV) for the mixture; c if ZSQBAR < 0.0, then an approximate value is calculated. c IDER = flag controlling which conductive opacities are returned. c For the (DEFAULT) Potekhin 2006 ('condall06.d') case: c 1 : bi-quadratic interp, Zion = (, with derivatives; c NOTE: Zion(linear) = = FMUEINV / FMUAINV . c -3 : bi-quadratic interp, Zion = , no derivatives. c -4 : Potekhin-website formulae, Zion = , with derivatives. c For the (OLD) H&L ('Condopac') case: c 1 : combine as necessary, with derivatives: use "H&L" at lower c density, "Itoh" at higher density, with switchover region c 0 : combine as necessary (no derivatives). c -1 : get "Itoh" conductive opacities only (no derivatives) c -2 : get possibly-modified "H&L" opacities only (no derivatives) c -3 : get "Itoh" conductive opacities only (with derivatives) c -4 : get possibly-modified "H&L" only (with derivatives) c NOTE: "H&L" is W. B. Hubbard & M. Lampe 1969, ApJS 163, 297; "Itoh" c is N. Itoh, S. Mitake, H. Iyetomi, & S. Ichimaru 1983, ApJ 273, 774 c plus S. Mitake, S. Ichimaru, & N. Itoh 1984, ApJ 277, 375. c FLKC = (real) variable returning Log(Kappa_cond), equivalent to OPACT c FLKCT = (real) variable returning dLog(kappa_cond)/dLog(T) at constant c density, equivalent to DOPACTD (note that a value of 0.0 will be c returned if IDER indicates derivatives should not be calculated) c FLKCRO = (real) variable returning dLog(kappa_cond)/dLog(RHO) at constant c temperature, equivalent to DOPACR c FKCEDGE = (real) variable returning the edge factor, equivalent to FEDGE c or FTREDGE (note that conductive opacities have no metallicity c restrictions); but a negative value is returned for regions c more than one grid-spacing off the edge of the matrix, and a c value of -99999.0 is returned if conductive opacities are not c available. c FKCOK = (real) variable returning a somewhat less restrictive edge factor, c which is a better indicator of whether the returned conductive c opacity is good enough to combine with (or extend) the radiative c OPAL opacity. c c c*** KAP_COND_POT( FLRO, FLT, ZION, IDER, FLKC, FLKCT, FLKCRO, FKCEDGE, FKCOK ) c -------------------------------------------------------------------------- c This subroutine calculates and returns the Potekhin et al. (2006) conductive c opacities (if they were not read in, it returns, indicating out-of-range). c c FLRO = log(RHO) = SLR + 3.0 * SLT (density, logarithm to the base 10) c FLT = log(T) = SLT + 6.0 (temperature, logarithm to the base 10) c ZION = Zion, the mean ionic charge (the user must calculate this for their c mixture, e.g. the rms nuclear charge weighted by number density). c It is a fatal error if Zion < 0.1 or Zion > 130. c IDER = flag controlling which conductive opacities are returned: c 1 : bi-quadratic interpolation, with derivatives; switched over c to linear extrapolation at matrix edge. c 0 : bi-quadratic interpolation, no derivatives. c -1 : use the Potekhin-website formulae, with derivatives [linear c interpolation in log(Zion), cubic interpolation in logT, c logRHO]; linear extrapolation via slope at matrix edge. c FLKC, FLKCT, FLKCRO, FKCEDGE, FKCOK : (real) variables returning values as c in KAPCOND above. c c c*** SET_COND_USE( KCOND, KREPLACE_ITOH ) This subroutine allows the user to c ------------------------------------ control the way conductive opacities c will be handled; it may be called at any time to change this behavior: c c KCOND = integer input flag controlling handling of conductive opacities: c 1 : (DEFAULT): if a conductive-opacity file has been read in, c then the conductive opacity will be combined with the c OPAL opacity to yield the overall opacity value when OPAL c opacity routines are called (and also used to extend the c OPAL opacity to higher density). c 0 : even if a conductive-opacity file has been read in, the c conductive opacities will be ignored when computing OPAL c opacities (i.e., the conductive opacities can only be c accessed by the subroutine KAPCOND described above). c -9 : reset to the default value of 1. c -99 : leave the present stored value of this flag unchanged. c KREPLACE_ITOH = integer input flag controlling how conductive opacities c are calculated: c 99 : (DEFAULT) use the most recent/best conductive c opacities available. c -9 : reset to the default value of 99. c -99 : leave the present stored value unchanged. c For Potekhin 2006: c 2 : use bi-quadratic interpolation in logRHO, logT, c and log(Zion), where Zion = ()^0.5 (rms). c 1 : use the formulae from the website: i.e., cubic c interpolation in logRHO, linear interpolation in c log(Zion), and cubic interpolation in logT, c where Zion = ()^0.5 (rms). c 0 : use bi-quadratic interpolation in logRHO, logT, c and log(Zion), where Zion = (linear mean). c -1 : use the formulae from the website: i.e., cubic c interpolation in logRHO, linear interpolation in c log(Zion), and cubic interpolation in logT, c where Zion = (linear mean). c For H&L 1969: c 2 : reserved (at present, means the same as 0). c 1 : reserved (at present, means the same as 0). c 0 : use the 1983/1984 'Itoh' conductive opacities to c modify and extend the 'H&L' ones. c -1 : use only these 'H&L' conductive opacities, not the c 1983/1984 'Itoh' ones. c c c*** ASK_COND_USE( KCOND, KCOND_AVAIL, KREPLACE_ITOH ) This returns the values c ------------------------------------------------- of these integer flags c that control the use of conductive opacities (see SET_COND_USE above): c c KCOND = integer variable returning the value of KCOND as in SET_COND_USE. c KCOND_AVAIL = integer variable returning returning a flag value telling c whether the conductive opacities are actually available: c 0 : not available (NO conductive opacities have ever c been read in). c 1 : H&L 1969 conductive opacities have been read in. c 2 : Potekhin 2006 conductive opacities have been read in. c KREPLACE_ITOH = integer variable returning the value of KREPLACE_ITOH as c in SET_COND_USE above. c c [NOTE: if KCOND_AVAIL > 0, then the subroutine KAPCOND can be used to get c conductive opacities, and if KCOND > 0 then these conductive opacities will c be used to extend the OPAL opacities to high RHO.] c c c c ============================================================= c Other subroutines that may be used when reading in opacities: c ============================================================= c c c*** SET_ALEX_FILE( CFILEALEX, I_FULL_PATH ) This subroutine allows the user c --------------------------------------- to specify a molecular opacity c file whose name has been changed, or which is in a different directory. c----NOTE: ANY DIRECTORY that you specified via SET_MOL_DIR will be DISCARDED. c c CFILEALEX = character variable or string constant giving a non-default c name for the molecular opacity file(s); NOTE that if the c input string CFILEALEX ends with a slash ('/'), c then it will be treated as a directory (or subdirectory) c specification and the default filename will be appended. c For Ferguson et al. (2005) molecular opacities, the c (optional) directory specification may be followed by a c filename beginning-part (as in SET_FERG_USER just below). c I_FULL_PATH = integer flag indicating how this should be interpreted: c 0 : (DEFAULT): look for molecular opacity file(s) in the c same directory as the OPAL opacity files (or a c subdirectory thereof, if CFILEALEX contains a c subdirectory specification). c 1 : just look for file(s) called (or whose names start c with) CFILEALEX (i.e., either the file(s) are in c the local directory, or else the string CFILEALEX c includes any required directory pathname). c c c*** SET_FERG_USER( CBEG_FERG ) This subroutine allows the user to set the c -------------------------- beginning-part of the names for a non-default c set of the Ferguson et al. (2005) molecular opacities: c c CBEG_FERG = character variable or string constant giving the beginning of c the file names, including at the end any dot ('.') that c separates beginning part from the X-value in the filename c (for the default mixes, CBEG_FERG would be 'g' 'g98.' c 'l03.' 'ags04.' 's92.' 's92ae.' 'gs98-.2.' 'gs98+.2.' c 'gs98+.4.' 'gs98+.6.' or 'gs98+.8.' for GN93, GS98, L03, c AGS04, S92, S92AE, GS98-.2, GS98+.2, GS98+.4, GS98+.6, or c GS98+.8 mixes, respectively --- note that the GN93 mix is c the only one of these that would not have the separating dot c '.' at the end of the CBEG_FERG value). c [Note that this mix-specification may optionally be preceded c by a subdirectory-specification, e.g., 'f05_gs98/g98.'] c c c*** ASK_FERG_USER( CBEG_FERG ) This subroutine returns the value stored by c -------------------------- calling SET_FERG_USER as described just above. c c CBEG_FERG = character variable, to return the file-name beginning. c c c*** SET_FERG_ACC( IACC ) This subroutine allows one to change the accuracy c -------------------- with which the Ferguson et al. (2005) molecular c opacities are interpolated (YOU SHOULD NOT DO SO): c c IACC = (integer) flag value controlling the accuracy: c 1 : (DEFAULT): when there is a large opacity jump between two c adjacent grid-points at low temperature (logT < 3.48), c avoid the large overshoot that would result just outside c these grid-points from the usual biquadratic interpolation. c 0 : (NOT RECOMMENDED!): just use usual biquadratic interpolation, c which yields somewhat faster computations at logT < 3.48, c but which can lead to errors of order a factor of 2, or c even occasionally of more than an order of magnitude. c c c*** ASK_FERG_ACC( IACC ) This subroutine returns the value of IACC presently c -------------------- in use, as per the subroutine SET_FERG_ACC above. c c IACC = integer variable to return the value of the flag IACC. c c c*** READ_BEST_MOL( IU, I_MOL, CF_HZ, OFEBRACK ) If I_MOL is non-zero, this c ------------------------------------------- subroutine tries to read the c molecular opacities that best match the OPAL opacities specified by CF_HZ c and OFEBRACK (see subroutine READ_EXTENDED_OPAC further above): c c IU, I_MOL, CF_HZ, OFEBRACK : same as in READ_EXTENDED_OPAC further above. c c c*** READFERG( IU ) This subroutine reads in the default set of Ferguson et c -------------- al. (2005) molecular opacities. Ths subroutine just calls c the subroutine READ_ADD_FERG( IU, 0.0, 1.0, 0 ) below: c c IU = (integer) Fortran unit number to use; a value of 5 or of 6 will be c reset to 7, and a negative value means "use the default of 23 or c the previous specified Fortran unit". c c c*** ADDFILE_FERG( IU, F_STO, F_READ, CFILEFERG, I_FULL_PATH ) This subroutine c --------------------------------------------------------- reads in a set c of Ferguson et al. (2005) molecular opacities, as specified by the user, c optionally combining them with a previously-input set (it is a fatal error c if the specified Ferguson opacity files are not found): c c IU = (integer) Fortran unit number (as in READFERG above). c F_STO = (real) value by which to multiply already-stored logKappa values, c before adding the logKappa values newly read in; use F_STO = 0.0 c to just read in a new set of opacities (if no Ferguson molecular c opacities have been read in previously, then the input value of c F_STO is ignored, and a value of 0.0 is used). c F_READ = (real) value by which to multiply the logKappa values read in c from the specified files; typically, F_READ = 1.0 is combined c with F_STO = 0.0 to just read in a new set of opacities (a c value of F_READ = 0.0 returns without reading anything). c CFILEFERG = character variable or string constant giving the beginning of c the Ferguson et al. (2005) molecular opacity filenames (as c in SET_ALEX_FILE or SET_FERG_USER above); this specifies c which set to use. c I_FULL_PATH = integer flag indicating how this should be interpreted (as c in SET_ALEX_FILE above): c 0 : (DEFAULT): look for molecular opacity file(s) in the c same directory as the OPAL opacity files (or a c subdirectory thereof, if CFILEFERG contains a c subdirectory specification). c 1 : just look for files whose names start with CFILEFERG c (i.e., either the files are in the local directory, c or else the string CFILEFERG includes any required c directory pathname). c c c*** READ_ADD_FERG( IU, F_STO, F_READ, KTYPE_FERG ) This subroutine reads in c ---------------------------------------------- a set of either default or c non-default Ferguson et al. (2005) molecular opacities, as specified by the c user, optionally combining them with a previously-input set (it is a fatal c error if no Ferguson opacity files are found): c c IU, F_STO, F_READ = as in subroutine ADDFILE_FERG just above. c KTYPE_FERG = flag indicating which molecular opacities should be read in: c 0 : look for the first available set of Ferguson opacities, c in the order 99,1,5,4,3,2,6,7,8,... of cases below: c 1 : read the Ferguson mix that was specified previously by c a call to SET_ALEX_FILE or ADDFILE_FERG (see above). c 2 : read the GN93 Ferguson mix 'g' --- if this is not found c in the directory specified by SET_OPAL_DIR above (or c by SET_ALEX_FILE above), look in the subdirectory c 'f05_g93/' as well. c 3 : read the GS98 Ferguson mix 'g98.' (also look in the c subdirectory 'f05_gs98/') c 4 : read the L03 Ferguson mix 'l03.' (also look in the c subdirectory 'f05_l03/') c 5 : read the AGS04 Ferguson mix 'ags04.' (also look in the c subdirectory 'f05_ags04/') c 6 : read the S92 Ferguson mix 's92.' (also look in the c subdirectory 'f05_s92/') c 7 : read the S92AE Ferguson mix 's92ae.' (also look in the c subdirectory 'f05_s92ae/') c 8 : read the GS98-.2 Ferguson mix 'gs98-.2.' (also look in c the subdirectory 'f05_gs98-.2/') c 9 : read the GS98+.2 Ferguson mix 'gs98+.2.' (also look in c the subdirectory 'f05_gs98+.2/') c 10 : read the GS98+.4 Ferguson mix 'gs98+.4.' (also look in c the subdirectory 'f05_gs98+.4/') c 11 : read the GS98+.6 Ferguson mix 'gs98+.6.' (also look in c the subdirectory 'f05_gs98+.6/') c 12 : read the GS98+.8 Ferguson mix 'gs98+.8.' (also look in c the subdirectory 'f05_gs98+.8/') c 99 : (actually, any value larger than 12): read the Ferguson c mix specified previously by a call to SET_FERG_USER. c -1 to -99 : first try the case abs(KTYPE_FERG) ; if it is c not found, behave as if case 0 was specified. c c c*** READALEX( IU ) This subroutine just reads in the file 'Alexopac' (with c -------------- Alexander & Ferguson 1994 molecular opacities), using the c Fortran unit IU (provided that this file has not already been read in). c c c*** SET_COND_FILE( CFILECOND, I_FULL_PATH ) This subroutine allows the user c --------------------------------------- to specify a which conductive c opacity file should be read in, and/or a file whose name has been changed, c or which is in a different directory. c----NOTE: ANY DIRECTORY that you specified via SET_COND_DIR will be DISCARDED. c----NOTE: Calling this subroutine SET_COND_FILE causes any previously-stored c conductive opacities to be DISCARDED at once. c c CFILECOND = character variable or string constant giving the revised name c I_FULL_PATH = integer flag indicating how this should be interpreted: c 0 : (DEFAULT): look in same directory as for OPAL files. c 1 : just look for a file called CFILECOND. c c c*** SET_COND_INFLAGS( KCOND_FIX, KCOND_GAP, KCOND_HAVE ) This subroutine sets c ---------------------------------------------------- flags controlling c how the 'H&L' conductive opacity tables are modified when they are read in c (this will have an effect only if called BEFORE you read in the opacities): c c KCOND_FIX = integer input flag controlling an error-fix: c 1 : (DEFAULT): remove an anomalously low Hydrogen conductive c opacity value (at logT = 5.4, logRHO = -0.5). c 0 : do not do this (NOT RECOMMENDED). c -9 : reset to the default value of 1. c -99 : leave the present stored value unchanged. c KCOND_GAP = integer input flag controlling the "gap" in the 'H&L' tables, c i.e., the density region where they do not extend to such c low temperatures as they do at higher or lower densities: c 1 : (DEFAULT): high-density 'Itoh' conductive opacities c are used in this "gap" to improve the 'H&L' opacity c there (beyond the edge of the 'H&L' tables) in order c to improve the H&L-to-Itoh switchover at increasing c density and low temperature (note that no input H&L c values are modified, only the extrapolation region). c 0 : this is not done: H&L tables are just extrapolated. c -9 : reset to the default value of 1. c -99 : leave the present stored value unchanged. c KCOND_HAVE = integer input flag controlling whether the file 'Condopac' c (or 'condall06.d') will be read in again: c 1 : (DEFAULT): it will NOT be read in again (unless it c has never been read in at all), even if you call c the subroutine READCOND a second time, unless you c change the filename by calling SET_COND_FILE. c 0 : re-read the file 'Condopac' the next time you call c the subroutine READCOND. c -9 : if and only if you have changed the stored value(s) of c KCOND_FIX or KCOND_GAP, re-read the file 'Condopac' c the next time you call the subroutine READCOND. c -99 : (equivalent to specifying the default value of 1). c c c*** ASK_COND_INFLAGS( KC_FIX, KC_GAP, KC_FIX_N, KC_GAP_N ) This subroutine c ------------------------------------------------------ returns integer c flag values (as may be set by the subroutine SET_COND_INFLAGS above): c c KC_FIX = integer variable returning the value of KCOND_FIX that was used c the last time 'Condopac' was read in. c KC_GAP = integer variable returning the value of KCOND_GAP that was used c the last time 'Condopac' was read in. c KC_FIX_N = integer variable returning the value of KCOND_FIX that will be c used the NEXT time 'Condopac' is read in. c KC_GAP_N = integer variable returning the value of KCOND_GAP that will be c used the NEXT time 'Condopac' is read in. c c c*** READ_COND_POT( IU ) This subroutine just reads in the Potekhin 2006 c ------------------- conductive opacity file 'condall06.d', using Fortran c unit IU (provided that it has not already been read in). c c c*** READCOND( IU ) This subroutine just reads in either the Potekhin 2006 c -------------- conductive opacity file 'condall06.d' or the older H&L c file 'Condopac', using Fortran unit IU (provided that conductive opacities c have not already been read in). c c c*** SET_OFE_FILE( cfileofe ) The input character variable cfileofe can be c ------------------------ used to set a user-specified filename containing c non-CO-rich opacities with [O/Fe] > 0.0, similar to 'Alrd96a2', 'C95hz', or c 'W95hz'. Only the filename (not the directory pathname) should be specified c and the length of the filename MUST NOT exceed 8 characters. This filename c is only used in the case khighz = 5, 15, 25, or 35 (see READZEXCO below). c c c*** SET_ALTMIX_OFE_FILE( cfileofe ) The input character variable cfileofe c ------------------------------- can be used to set a user-specified c filename containing non-CO-rich GS98 opacities with [O/Fe] > 0.0; the length c of the name is only restricted by the fact that filename plus OPAL directory c name cannot exceed 255 characters in total. This filename is only used in c the case khighz = -5, -15, -25, or -35 (see READZEXCO below). c c c*** SET_ALTMIX_MAIN_FILE( cfile_hz ) The input character variable cfile_hz c -------------------------------- can be used to replace the alternate c main file 'GS98hz' with a user-specified filename; this new file will be c assumed to have [O/Fe] = 0.0, i.e., a solar mix. The length of the name is c only restricted by the fact that filename plus OPAL directory name cannot c exceed 255 characters in total. This filename is used whenever khighz < 0 c (see description in READZEXCO below); note that khighz = -2, -3, and -4 c should NOT be used subsequently, unless this file replacing 'GS98hz' also c has the Grevesse & Sauval 1998 mix. c c c*** SET_CNO_FILES( cf_m, cf_c, cf_o, cf_n, cf_user ) This subroutine can be c ------------------------------------------------ used to set the five c alternate opacity filenames that can be used to obtain the CNO-interpolation c opacity shifts (plus a user-specified case); the input character variables c are only restricted by the fact that filename plus OPAL directory name can't c exceed 255 characters in total (blank values mean "use default filenames"): c c cf_m = a standard opacity file (with standard composition); the default c used in READZEXCO is 'GN93hz' if khighz > 0, or else cfile_hz c (e.g., 'GS98hz': see SET_ALTMIX_MAIN_FILE above) if khighz < 0 c cf_c = an opacity file where most or all C (by number) has been converted c to N; the default filename is cf_hz with '.CtoN' appended c cf_o = an opacity file where most/all of both C and O have been converted c to N; the default filename is cf_hz with '.COtoN' appended c cf_n = an opacity file where all CNO has been converted to Ne; the default c filename is cf_hz with '.CNOtoNe' appended c cf_user = a user-specified opacity file, with a composition that can be c arbitrarily different from that in the file cf_hz; the default c filename is cf_hz with '.user' appended c c NOTE that the first four of these files (cf_m, cf_c, cf_o, cf_n) should all c have the SAME number fractions for the elements heavier than Ne (only C,N,O, c Ne should be interconverted in these CNO-interpolation files). c c Note that as long as the files cf_m, cf_c, cf_o, and cf_n have compositions c that are not linearly dependent (or close to it) in the 3-dimensional space c of interconversion of C, N, O, and Ne, the CNO-interpolation should still c work correctly. However, it has been tested only for the specific case c described above. c c c*** SET_CNO_EXT( ie, ce_hz, ce_c, ce_o, ce_n, ce_u ) This subroutine can c ------------------------------------------------ be used to change the c default extensions for the CNO-interpolation files (which are used to decide c on the default CNO-filenames); this can be used as an alternative to calling c the subroutine SET_CNO_FILES. As noted above, these default extensions are c ' ' , '.CtoN' , '.COtoN' , '.CNOtoNe' , '.user' respectively. Calling this c subroutine sets these default extensions to the values of the character c variables ce_hz, ce_c, ce_o, ce_n, ce_u respectively. The integer ie c controls the meaning of a blank input character value: c ie = 0 : in all cases, a blank input character value means do not change c the corresponding default extension (UNLESS YOU HAVE SOME VERY c PECULIAR NAMING CONVENTIONS FOR CNO FILES, THIS IS THE ONLY c CASE YOU ARE LIKELY TO NEED) c ie = 1 : if ce_hz is blank, reset the corresponding extension to blank c (i.e., the default filename remains 'GN93hz' or cfile_hz); c but if any of the other input character values are blank, do c not change these other corresponding default extension c ie = 2 : if ce_c is blank, reset the corresponding extension to blank c ie = 3 : if ce_o is blank, reset the corresponding extension to blank c ie = 4 : if ce_n is blank, reset the corresponding extension to blank c ie = 5 : if ce_u is blank, reset the corresponding extension to blank c ie = 6 thru 10 : same as ie = 1 thru 5, respectively c Note that an extension longer than 80 characters cannot be accommodated. c c c*** SET_METEOR_MIX_FILE( cfilemet ) The input character variable cfilemet c ------------------------------- can be used to set a user-specified c filename containing a meteoritic mixture. This file is used ONLY to set c the components of Z for a meteoritic mixture, which are available to the c user but are not used in calculating any opacities. c c c*** ASK_OPAL_FILE_USED( ITYPE, CF_USED ) This subroutine returns the name of c ------------------------------------ the specified type of opacity file c that was (or will be) used to read in the opacities: c c ITYPE = integer input flag controlling which file name is returned: c -1 : the name of the OPAL directory CDIRIN. c 0 : meteoritic-mix file CFILEMET (this file may not exist). c 1 : the main mix file CF_HZ. c 2 : molecular opacities file CFILEALEX, including directory. c 3 : conductive opacities file CFILECOND, including directory. c 4 : the file 'GN93hz' (needed to correct Gz???x?? files). c 5 : the non-zero-[O/Fe] file CF_OFE. c 6 : the CNO-interpolation main mix file CF_M. c 7 : the CNO-interpolation C --> N file CF_C. c 8 : the CNO-interpolation CO --> N file CF_O. c 9 : the CNO-interpolation CNO --> Ne file CF_N. c 10 : the user-mix file CF_USER. c CF_USED = character variable returning the filename specified by ITYPE. c c c*** ASK_KHIGHZ_OFE( KHIGHZ_USED, OFEBRACK_USED ) This subroutine returns the c -------------------------------------------- values that were used when c the subroutine READZEXCO was called to read in the opacities (directly or c via READ_BASIC_OPAL_OPAC or READ_EXTENDED OPAC): c c KHIGHZ_USED = integer variable returning the value of KHIGHZ (see below). c OFEBRACK_USED = real variable returning the value of [O/Fe] that was used. c c c*** READZEXCO( Nzin, Zlo, Z, Zhi, khighz, iulow, ofebrack ) This subroutine c ------------------------------------------------------- is used to read c in the OPAL opacity files, allowing the user to control whether and how c opacities will subsequently be interpolated in Z. Note that a new set of c opacities (at a new Z-range or Z-value) can be read in at any time. c c The controlling input variables are: c c Nzin INTEGER: the number of metallicity values Z_i to be stored, c for subsequent Z-interpolation when OPAL or OPAC is called; c this is discussed just below. Nzin = -9 means "use the widest c available Z-range around the input Z-value". c Zlo SINGLE-PRECISION REAL: the lowest metallicity value that will c be required; this is discussed just below. c Z SINGLE-PRECISION REAL: the "typical" or central metallicity c value; this is discussed just below. c Zhi SINGLE-PRECISION REAL: the highest metallicity value that will c be required; this is discussed just below. c khighz INTEGER: controls the use of the C=O=0.0 opacity file 'GN93hz' c (and/or its equivalents with newer mixes, such as 'GS98hz' and c 'AGS04hz'), and of the similar files having [O/Fe] > 0.0: c khighz = 0: use of the file 'GN93hz' is prevented; only for c X < 0.75 is accurate X-interpolation available. c khighz = 1: the file 'GN93hz' is used to obtain opacities for c the C=O=0.0 mixes (i.e., opacities with better c Z-interpolation), including the added X-values c X={0.2,0.5,0.8,0.9,0.95,1-Z} (i.e., allowing c accurate X-interpolation up to X = 1-Z); for c the mixes with C+O > 0.0, corresponding opacity c shifts are applied, for consistency. c khighz = 2: file 'Alrd96a2' with [O/Fe] = 0.3 \ is used in c khighz = 3: file 'C95hz' with [O/Fe] = 0.4 } addition to c khighz = 4: file 'W95hz' with [O/Fe] = 0.5 / 'GN93hz', c if READZEXCO was called with a non-zero value of c ofebrack, in order to interpolate in the excess c oxygen/alpha-element enrichment [O/Fe]. c khighz = 5: the name of a file with non-zero [O/Fe] must have c been set already, by calling the subroutine c SET_OFE_FILE described below; it will be used c instead of 'Alrd96a2', 'C95hz', or 'W95hz' when c interpolating in [O/Fe] (its [O/Fe] value will c be computed when it is read in; if it actually c has [O/Fe] = 0.0, the resulting behavior is not c defined and will surely be erroneous). c khighz = -1 thru -5: similar to khighz = 1 thru 5, except c that a different set of OPAL opacity files is c used, defining a different set of heavy-element c abundances to comprise the solar metallicity Z. c THE OLD FILE 'GN93hz' IS STILL REQUIRED AS WELL, c but the opacities now stored are those from the c new file with the same format (called 'GS98hz', c by default), and this is the composition that c is assigned a value of [O/Fe] = 0.0; khighz = -2 c thru -5 likewise implies the use of files with c [O/Fe] > 0.0 relative to the mix in 'GS98hz': by c default 'GS98hz_OFe.3_Alrd96a2' at [O/Fe] = 0.3, c 'GS98hz_OFe.4_C95' at 0.4, 'GS98hz_OFe.5_W95' c at 0.5, or user-defined for khighz = -5 via the c subroutine SET_ALTMIX_OFE_FILE (see below). The c main alternate solar-composition [O/Fe]=0.0 file c name can be changed from 'GS98hz' by calling the c subroutine SET_ALTMIX_MAIN_FILE (see below); if c this is done, khighz = -2 thru -4 should not be c used subsequently unless the replacement main c file still uses the Grevesse & Sauval 1998 mix; c rather, if one wishes opacities with a non-zero c [O/Fe] value, one should do something such as: c call set_altmix_main_file( 'AGS04hz' ) c call set_altmix_ofe_file( 'AGS04hz_OFe.5_W95' ) c and then use khighz = -5. c khighz = -11 thru -15, OR c 11 thru 15: same as khighz = -1 thru -5 OR 1 thru 5, c except that CNO-interpolation opacity files are c read in (if possible: uses the filenames "CF_HZ, c CF_C, CF_O, CF_N" that can be set by calling c SET_CNO_FILES: see below) c khighz = -21 thru -25, OR c 21 thru 25: same as khighz = -1 thru -5 OR 1 thru 5, c except that a user-specified (OPAL) opacity c interpolation file is read in (if possible: uses c the filenames "CF_HZ, CF_U" that can be set by c calling SET_CNO_FILES: see below) c khighz = -31 thru -35, OR c 31 thru 35: same as khighz = -1 thru -5 OR 1 thru 5, c except that BOTH the CNO- and user-specified c opacity interpolation files are read in (if c possible) c iulow INTEGER: the beginning Fortran unit number for reading opacity c files; Fortran units iulow through iulow + 3 may be used. c Zero or negative iulow values mean "use previous (or default) c value", where the default value is iulow = 23. A fatal error c will result if iulow < 7 or iulow > 96 (unless you have set c the error level to 0, in which case these values are ignored). c (Note: unless the user explicitly calls READZEXCO, READEXCO, c READCO, or READ_OPAL_DUMP, the default-setup call to READZEXCO c in OPAL will be executed, yielding the default iulow of 23). c ofebrack SINGLE-PRECISION REAL: the value of [O/Fe], the logarithmic c oxygen (or alpha-element) enhancement factor, relative to the c Sun: ofebrack = log10{ (O_mix/Fe_mix) / (O_sun/Fe_sun) } , c where O_mix, Fe_mix, O_sun, and Fe_sun are number densities. c If khighz = 0, 1, or -1, then ofebrack is ignored; otherwise, c READZEXCO interpolates (or extrapolates) log(Kappa) linearly c between mix 1 (or -1) and mix mod(khighz,10) , interpolation c factors being such as to yield the desired [O/Fe] by combining c these mixes. Note: 'GN93hz' has [O/Fe] = 0.0 by definition, c 'Alrd96a2' has [O/Fe] = 0.3, 'C95hz' has [O/Fe] = 0.4, and c 'W95hz' has [O/Fe] = 0.5, but they have different patterns of c enhancements for elements other than oxygen; their elemental c abundances and the corresponding opacity shifts are discussed c further below. c c ---------------------------------------------------------------------------- c Discussion of Nzin, Zlo, Z, Zhi in calling the above subroutine READZEXCO: c ---------------------------------------------------------------------------- c c Z-interpolation of opacity is actually carried out in terms of log(Z+0.001). c The maximum number of z-values that can be stored (to interpolate among) is c given by the value of the constant NZ in the parameter statements that c begin as "parameter ( nz=" . The maximum sensible value is NZ = 14, which c requires about 22.7 Mb of opacity matrix storage space. Other reasonable c values include NZ = 8 (13.0 Mb) and NZ = 5 (8.1 Mb); a value of NZ = 3 (4.9 c Mb) still allows quadratic Z-interpolation, while NZ = 2 (3.2 Mb) allows c only linear interpolation in log(Z+0.001); for NZ = 1 (1.6 Mb), the program c behaves much the same as the earlier version of MAY 28, 1999 (or as if the c subroutines READCO or READEXCO were used instead of READZEXCO). c c If you have reduced the error-checking level to 0 (using SET_ERR_CHECK), c then the input value of Nzin will be decreased if necessary so that it c does not exceed NZ , the maximum available number of Z-storage values; c otherwise, a value of Nzin > NZ or of Nzin < 1 is a fatal error, EXCEPT c THAT Nzin = -9 means "use maximum possible value, i.e., as if Nzin = NZ". c If necessary, the subroutine ASK_Z_LIMITS can be called to check the value c of this hard-wired limit NZ , or the subroutine ASK_Z_USE can be called c after READZEXCO to check the number of Z-values actually used (see below). c c Values of Zlo, Z, Zhi that are within 1.E-6 of one of the file z-values c { 0.0, 0.0001, 0.0003, 0.001, 0.002, 0.004, 0.01, 0.02, 0.03, 0.04, 0.05, c 0.06, 0.08, 0.1 } are generally reset to be exactly equal to that value c (except that only the range [ -1.E-6 , 1.E-8 ] is reset to be exactly zero). c Any value of Zlo, Z, or Zhi greater than 0.1 is always a fatal error. c c Significantly negative Z-values (below -1.E-6) mean "use default values": c - if all three of Zlo, Z, Zhi are negative, then Z is reset to 0.02; c - if only Z is negative, then it is reset to lie between Zlo and Zhi ; c - if Zlo and/or Zhi is negative, then the negative value(s) will be c reset to "reasonable" values, according to the values of Nzin and Z. c c If Nzin = 2 , then the stored z-values are given by the input values of c Zlo and Zhi ; if both of these are negative, then a range +/- 10% in Z is c used; if only one of them is negative, a total range of 20% in Z is used, or c more if the remaining interval [Zlo,Z] or [Z,Zhi] is larger than this. c The minimum allowed range is 1% in Z, or delta-Z = 1.E-5 for small Z values; c this is a fatal error, unless you have reduced the error-checking level c to 0, in which case the program quietly uses this lower limit. Likewise c too large a range: Zlo < min{ 0.6 * Zhi , Zhi - 0.0002 } is a fatal error, c unless you have reduced the error-checking level to 0, in which case the c ONLY UPPER LIMIT on the linear Z-interpolation range is that it must lie c within [0.0,0.1]; BEWARE that large ranges yield inaccurate interpolation. c c If Nzin > 2 , then from the set of eight "largest-allowed-spacing" Z-values c { z1=0.0, z2=0.001, z3=0.004, z4=0.01, z5=0.02, z6=0.03, z7=0.05, z8=0.1 }, c choose the largest z_J and the smallest z_K such that z_J is no greater than c Zlo and z_K is no less than Zhi; it is then a fatal error if Nzin < K - J , c i.e., if the Z-range is too large for the given value of Nzin (unless of c course you have reduced the error-checking level to 0, in which case c arbitarily large ranges are accepted: BEWARE!). Also... c c If Nzin > 2 , then: if a set of Nzin adjacent file z-values from the set c { 0.0, 0.0001, 0.0003, 0.001, 0.002, 0.004, 0.01, 0.02, 0.03, 0.04, 0.05, c 0.06, 0.08, 0.1 } encompasses the range [Zlo,Z,Zhi] , then such a set of c Nzin z-values is used (as far as possible, it will be centered on Z ): for c example, for Nzin = 3 , input Z-values [Zlo,Z,Zhi] = [0.01,0.02,0.03] or c [0.017,0.018,0.019] or [0.022,0.022,0.024] or [0.019,0.028,0.029] all yield c { 0.02, 0.03, 0.04 }, while [0.021,0.028,0.029] yields { 0.02, 0.03, 0.04 }. c c If Nzin = 3 and no set of 3 of the above file z-values will work, then the c actual input values are used (except that, if the logarithmic interval from c Zlo to Z is sufficiently different from that from Z to Zhi, the value of Z c is reset to the logarithmic midpoint of Zlo and Zhi): for example, the input c Z-value set [Zlo,Z,Zhi] = [0.012,0.024,0.04] yields { 0.012, 0.024, 0.04 }, c while [0.012,0.015,0.04] yields { 0.012, 0.02208679, 0.04 }. c c If Nzin > 3 and no set of Nzin of the above file z-values will work, c then try whether a similar set that works can be obtained by removing (some c of) the z-values that are not present in the C,O-rich OPAL opacity files c Gz???.x?? , which are available at { 0.0, 0.001, 0.004, 0.01, 0.02, 0.03, c 0.05, 0.1 }; if such a set is found (with somewhat larger z-intervals), then c it is used. Otherwise, endpoints Zlo and Zhi are used, with remaining c z-values equally spaced in log(Z+0.001) between these endpoints. c c******* NOTE that if you have set the error-level to 0, then there is NO UPPER c LIMIT on the maximum allowed Z-range (except that it must lie in the range c [0.0,0.1] where OPAL opacities are available), and thus QUITE INACCURATE c Z-interpolation will occur if the input Z-range [ Zlo , Zhi ] is relatively c large and Nzin (or NZ) is relatively small. c c One or two of the Type-1 OPAL files can be read in (as specified by khighz c in your call to the opacity-reading subroutine READZEXCO). For example, c call readzexco( 14, 0.0, -1.0, 0.1, 1, 23, 0.0 ) c will read in opacities at all Z-values from 0.0 to 0.1, reading additional c opacities from 'GN93hz' (due to the value of khighz=1); Fortran units 23 c through 26 will be used for input, and the opacities will have [O/Fe]=0.0 c (solar composition for the abundances comprising Z). For non-CO-rich cases, c this allows slightly improved Z-interpolation (for Z < 0.12) and slightly c improved X-interpolation (for 0.03 < X < 0.75); for high hydrogen abundances c (X > 0.75), such as may result from diffusion (e.g., helium settling), the c accuracy is GREATLY IMPROVED. c c NOTE that only the version z14xcotrin21.f allows Nzin = 14 as in the above c call; if one is using the less-memory-hogging version z5xcotrin21.f , then c the above call would lead to a fatal error, unless you had reduced the error c checking level, in which case it would lead to opacities being read in only c for the Z-values Z = { 0.0, 0.00217, 0.00905, 0.0309, 0.1 }, yielding MUCH c LESS ACCURATE Z-interpolation; USER BEWARE!! c c For z5xcotrin21.f , only a small Z-range should be read in: for example, c call readzexco( 5, -1.0, 0.02, -1.0, 4, 23, 0.45 ) c reads opacities at Z = .004, .01, .02, .03, .04, using 'GN93hz' and 'W95hz' c to obtain opacities at [O/Fe]=0.45 (the results are then as accurate as with c the version z14xcotrin21.f for the restricted Z-range 0.01 < Z < 0.03: c this is described in more detail below). c c For z1xcotrin21.f , only a SINGLE Z-value can be read in; the opacities c from the files will be interpolated in Z while being read in, if necessary. c c To read opacities in the widest available Z-range around some metallicity Z c that is compatible with accuracy, one would use Nzin = -9, e.g., c call readzexco( -9, -1.0, Z, -1.0, 11, 23, 0.0 ) c This would read opacities with [O/Fe] = 0.0 in a range around Z that is c determined by the value of NZ in the parameter statements in this file. c c NOTE that if opacities have not already been read in, then the first time c that an opacity-calculating subroutine is called (e.g., OPAC or OPAL), it c will use "call readzexco( -9, -1.0, z, -1.0, 1, 23, 0.0 )" to read in the c opacities, i.e., basic opacities for the maximum reasonable Z-range (with c [O/Fe] = 0.0 and no CNO-interpolation, only interpolation in "excess-C,O"). c c c*** READCO( Z, kallrd, khighz, iulow ) These subroutines behave c ---------------------------------- the same as the previous c*** READEXCO( Z, kallrd, khighz, iulow, ofebrack ) version of MAY 28, 1999: c ---------------------------------------------- opacities are read in at c the SINGLE metallicity Z (interpolated among available OPAL opacity files, c if necessary), but subsequently opacities are available only at this single c metallicity, unless and until the user explicitly reads in a new set of c opacities via another call to READCO, READEXCO, or READZEXCO. (For READCO, c any positive value of khighz is set to 1, and any negative value to -1 ). c NOTE THAT the input INTEGER kallrd is ignored (it is included only for c backward compatibility). c c c ============================================================================ c Subroutines used to control the switchover from OPAL to molecular opacities: c ============================================================================ c c c NOTE that the Ferguson and the Alexander switchover spcifications are c entirely separate: only one will take effect at any time, namely, the one c for which the corresponding molecular opacities have been read in. c c c*** SET_LOGT_SW_FERG( FLTSW_LO, FLTSW_HI ) Set the temperature-boundaries of c -------------------------------------- the switchover region from OPAL to c Ferguson et al. (2005) molecular opacities (this subroutine can be called c at any time, to change the switchover temperatures): c c FLTSW_LO = lowest logT of switchover region, where only Ferguson is used: c -99.0 : leave current stored logT value unchanged. c -50.0 : use the default value (of logT = 4.2). c > -20 : use the input value FLTSW_LO, except that: c it will not be lower than 3.75 (lowest T for OPAL), c it will not exceed 4.45 (near highest Ferguson T). c FLTSW_HI = highest logT of switchover region, where only OPAL is used: c -99.0 : leave current stored logT value unchanged. c -50.0 : use the default value (of logT = 4.4). c > -20 : use the input value FLTSW_HI, except that: c it will not exceed 4.50 (highest Ferguson T), c it will not be lower than 3.80 (near lowest OPAL). c c Note that in no case will FLTSW_HI - FLTSW_LO < 0.05 be allowed to occur c (the values will be moved further apart if this happens). c c c*** ASK_LOGT_SW_FERG( FLTSW_LO, FLTSW_HI ) Return the current Ferguson logT c -------------------------------------- switchover values (as above). c c c*** SET_LOGT_SW_ALEX( FLTSW_LO, FLTSW_HI ) Set the temperature-boundaries of c -------------------------------------- the switchover region from OPAL to c Alexander & Ferguson 1994 molecular opacities (this subroutine can be called c at any time, to change the switchover temperatures): c c FLTSW_LO = lowest logT of switchover region, where only Alexander is used: c -99.0 : leave current stored logT value unchanged. c -50.0 : use the default value (of logT = 3.87). c > -20 : use the input value FLTSW_LO, except that: c it will not be lower than 3.75 (lowest T for OPAL), c it will not exceed 4.05 (near highest Alexander T). c FLTSW_HI = highest logT of switchover region, where only OPAL is used: c -99.0 : leave current stored logT value unchanged. c -50.0 : use the default value (of logT = 3.97). c > -20 : use the input value FLTSW_HI, except that: c it will not exceed 4.10 (highest Alexander T), c it will not be lower than 3.80 (near lowest OPAL). c c Note that in no case will FLTSW_HI - FLTSW_LO < 0.05 be allowed to occur c (the values will be moved further apart if this happens). c c c*** ASK_LOGT_SW_ALEX( FLTSW_LO, FLTSW_HI ) Return the current Alexander logT c -------------------------------------- switchover values (as above). c c c*** SET_ALEX_DO_RHOSW( IRHOSW ) Set the flag controlling whether there is a c --------------------------- density-switchover too (in the temperature c region where both OPAL and Alexander 1994 opacities are available, but where c the OPAL opacities are available up to higher densities): c c IRHOSW = input integer flag: c 1 : (DEFAULT): use a density-switchover region too. c 0 : do not do so. c -9 : use the default value of 1. c -99 : leave the stored value unchanged. c c c*** SET_LOGRHO_SW_ALEX( FLRHOSW_LO, FLRHOSW_HI ) Set the density-boundaries c -------------------------------------------- of the switchover region c (for Alexander 1994 opacities) that is enabled/disabled by SET_ALEX_DO_RHOSW c above (this can be called at any time, to change the switchover densities): c c FLRHOSW_LO = lowest logRHO of switchover region, where only Alexander used: c -99.0 : leave current stored logRHO value unchanged. c -50.0 : use the default value (of logRHO = -6.25). c > -20 : use the input value FLTSW_LO, except that it will lie c in the range -14.0 < FLRHOSW_LO < -6.0 . c FLRHOSW_HI = highest logRHO of switchover region, where only OPAL is used: c -99.0 : leave current stored logRHO value unchanged. c -50.0 : use the default value (of logRHO = -5.75). c > -20 : use the input value FLTSW_HI, except that it will lie c in the range -13.75 < FLRHOSW_HI < -5.75 . c c Note that in no case will FLRHOSW_HI - FLRHOSW_LO < 0.25 be allowed to c occur (the values will be moved further apart if this happens). c c c*** ASK_LOGRHO_SW_ALEX( FLRHOSW_LO, FLRHOSW_HI ) Return current switchover c -------------------------------------------- logRHO values (as above). c c c*** SET_LOGT_RHOSW_ALEX( FLTSW_R_LO, FLTSW_R_HI ) Set the temperature-bounds c --------------------------------------------- below which the Alexander- c to-OPAL density-switchover described above does not take place (due to the c low-temperature limit of the OPAL opacities): c c FLTSW_R_LO = lowest logT of switchover region, where only Alexander used: c -99.0 : leave current stored logT value unchanged. c -50.0 : use the default value (of logT = 3.70). c > -20 : use the input value FLTSW_LO, except that: c it will not be lower than 3.70 (the lowest c allowed OPAL-extrapolation logT value), c it will not exceed FLTSW_HI - 0.05 (see the c subroutine SET_LOGT_SW_ALEX above). c FLTSW_R_HI = highest logT of switchover region, where only OPAL is used: c -99.0 : leave current stored logT value unchanged. c -50.0 : use the default value (of logT = 3.80). c > -20 : use the input value FLTSW_HI, except that: c it will not exceed FLTSW_HI, c it will not be lower than 3.75 c Note that in no case will FLTSW_R_HI - FLTSW_R_LO < 0.05 be allowed to c occur (the values will be moved further apart if this happens). c c c*** ASK_LOGT_RHOSW_ALEX( FLTSW_R_LO, FLTSW_R_HI ) Return density-switchover c --------------------------------------------- logT-bounds as above. c c c ========================================================== c The subroutines that control the X-interpolation accuracy: c ========================================================== c c c*** SET_XHI( kxhi ) Set a flag telling whether or not to use the additional c --------------- 'GN93hz' X-values for more accurate X-interpolation c (provided they are available, i.e., 'GN93hz' or 'GS98hz' has been read in). c If kxhi = 2 , then a flag is set such that the 'GN93hz' X-values will be c used whenever they are available (this is the DEFAULT c case, if you never call SET_XHI). Note that only at c X > 0.03 will the 'GN93hz' X-values affect the resulting c interpolated opacity values. c If kxhi = 1 , then a flag is set such that the 'GN93hz' X-values will be c used whenever they are available, but ONLY for values of c X > 0.7 (this yields faster but slightly less accurate c X-interpolation for X < 0.7, while retaining accurate c opacities for large X-values up to X = 1-Z (such as may c arise from diffusive processes). c If kxhi = 0 , then a flag is set such that the 'GN93hz' X-values will c NOT be used, even when they are available (this results c in only slightly poorer X-interpolation for X < 0.75, c but yields wildly incorrect opacities for very large X c values, i.e., for X approaching 1-Z). c Note that the 'GN93hz' X-values are available for X-interpolation ONLY if c the 'GN93hz' file has been read in, i.e., if READZEXCO above has been called c with a non-zero value of khighz among its input parameters. Note also c that, strictly, the 'GN93hz' X-values are defined only for non-CO-rich mixes c (C=O=0.0); but corresponding opacity shifts are applied for consistency up c to a CO-enhancement of C+O = 0.2, these shifts being reduced to zero as C+O c increases from 0.2 to 0.3 and being ignored for C+O of 0.3 or more. c c c*** ASK_XHI( kxhi, kavail ) Returns INTEGER VARIABLE flags telling whether c ----------------------- 'GN93hz' X-values will be used, and whether they c are actually available at the moment: c Returns kxhi value as set most recently by SET_XHI above (i.e., returns c kxhi = 0, 1, or 2, with the same meaning as above); c if SET_XHI was never called, then returns kxhi = 2 . c Returns kavail = 1 if the 'GN93hz' files have been read in, i.e., the c 'GN93hz' X-values are available, and will be used for c X-interpolation if the value of kxhi so indicates. c kavail = 0 if the 'GN93hz' file has NOT (yet) been read in, c i.e., the 'GN93hz' X-values are not available, and c can NOT be used for X-interpolation no matter what c value kxhi has (unless 'GN93hz' is read in later). c c c =============================================================== c The subroutines that control the CNO and/or user-interpolation: c =============================================================== c c c*** SET_CNO_INTERP( kcno, kuser ) Set flags telling whether or not to use the c ----------------------------- CNO/user-interpolation opacity shifts; by c default, both are used, providing they are available (i.e., providing the c relevant opacity files were read in: see flag khighz in READZEXCO above). c If kcno > 0 , then the CNO-interpolation opacity shifts will be used (if c available); otherwise, they will be ignored c If kuser > 0 , then the user-specified opacity shifts will be used (if c available); otherwise, they will be ignored c c c*** ASK_CNO_INTERP( kcno, kuser, kcno_avail, kuser_avail ) Returns INTEGER c ------------------------------------------------------ VARIABLE flags to c indicate whether CNO/user-interpolation opacity shifts will be used when c obtaining opacities. c Returns kcno, kuser as set by SET_CNO_INTERP above (or their default c values of 1 if SET_CNO_INTERP was never called) c Returns kcno_avail, kuser_avail values of 1 if the corresponding opacity c files have been read in, or 0 if not c c c ========================================================= c The subroutines that control the level of error-checking: c ========================================================= c c c*** SET_ERR_CHECK( LEVEL ) This subroutine sets the error-checking level to c ---------------------- the given (integer) input value LEVEL: c Level = 0 : Only minimal error checking is performed on inputs. A Z-value c above 0.1 in the arguments to the opacity-reading subroutine c READZEXCO is a fatal error, as is an inconsistent composition c input to the opacity-calculating subroutines OPAC or OPAL; c most other problematic input is handled or accepted silently, c in a manner that ought to be reasonable (but no guarantees!). c Level = 1 : This is the DEFAULT case (which will occur if you never call the c subroutine SET_ERR_CHECK). At this level, error-checking is c performed on the arguments of the subroutine READZEXCO (which c one calls to read in the opacities). As described above in c the discussion of Nzin, Zlo, Z, Zhi , it is a fatal error c if Nzin < 1 or if Nzin is too large (exceeding the available c number of Z-storage spaces). It is also a fatal error if the c Z-range [Zlo,Zhi] is too small or too large. At this level, c a warning will be issued if you call SET_ALTMIX_MAIN_FILE and c subsequently use khighz = -2, -3, or -4 (see above), or if any c filename exceeds 255 characters (or an extension exceeds 80). c Level = 2 : At this level of error-checking, in addition: If the arguments c to OPAC or OPAL lie too far outside the opacity matrices, it c is a fatal error and the program halts (normally, such a case c would simply be signalled by a zero returned value of FEDGE). c Also, it is a fatal error if you call SET_ALTMIX_MAIN_FILE and c subsequently use khighz = -2, -3, or -4 (see above), or if any c filename exceeds 255 characters (or an extension exceeds 80). c Level = 3 : At this level of error-checking, in addition: if you have read c the CNO-interpolation opacity files, and you then call the c subroutine OPAL_X_CNO_FU with a metals-composition array xmet c with a size nmet other than 19 elements, it is a fatal error c (you would NOT usually want to use this Level = 3). c c c*** ASK_ERR_CHECK( LEVEL ) This subroutine returns the error-checking flag c ---------------------- value LEVEL of as set by SET_ERR_CHECK above. c c c ==================================================== c The subroutines that control matrix Z-edge handling: c ==================================================== c c c*** RESET_Z_LIMITS( vlo, dvlo, vhi, dvhi ) This subroutine can only be called c -------------------------------------- AFTER a set of opacities has been c read in (its effects are nullified during opacity input). WITHOUT affecting c the stored z-values used for Z-interpolation, calling this subroutine resets c the range considered to be "interpolation" (which returns FZEDGE = 1.0) and c the allowed "extrapolation" region (where 0.0 < FZEDGE < 1.0 is returned). c Negative values (actually, below -1.E-6) mean "leave old value unchanged". c All these values should be SINGLE PRECISION REAL. c If vlo is non-negative, then this resets Zlo = vlo . c If dvlo is non-negative, then this resets Zlo_ex = Zlo - dvlo . c If vhi is non-negative, then this resets Zhi = vhi . c If dvhi is non-negative, then this resets Zhi_ex = Zhi + dvhi . c The values of Zlo and Zhi must not lie outside the range of stored z-values c used for Z-interpolation, i.e., cases Zlo < z_low_interpolation_endpoint , c Zhi > z_high_interpolation_endpoint , and Zlo > Zhi are prohibited. The c only constraint on the "extrapolation" region is that Zlo_ex < Zlo and c Zhi_ex > Zhi (setting dvlo and dvhi to zero allows extrapolation by c up to delta-Z = 1.E-6). Note that FZEDGE is positive (and the opacity is c calculated) only for the range Zlo_ex < Z < Zhi_ex . c NOTE that if Zlo and/or Zhi is set inside the range covered by the c stored z-values, the value of FZEDGE will be less than unity for Z outside c the range [Zlo,Zhi] , but the actual calculation of opacity values will c continue to use interpolation (not extrapolation) as long as Z lies inside c the range of stored z-values; however, for FZEDGE = 0.0 , the opacity will c NOT be calculated (even for Z still within the range of stored z-values). c c c*** ASK_Z_LIMITS( nzmax, zmin, zmax ) This subroutine returns the values of c --------------------------------- the hard-wired Z-interpolation limits, c allowing the user to check what these limiting values actually are. c INTEGER variable nzmax returns NZ: max number of interpolation Z-values. c SINGLE-PRECISION REAL variable zmin returns 0.0 (the lowest allowed Z). c SINGLE-PRECISION REAL variable zmax returns 0.1 (the highest allowed Z). c c c*** ASK_Z_USE( nzuse, zlo, zmid, zhi, zloex, zhiex ) This subroutine returns c ------------------------------------------------ the current values of c the variables controlling Z-interpolation, allowing the user to check what c the values actually are. c INTEGER variable nzuse returns the number of stored z-values (that will c be used for Z-interpolation); if no opacity files have been read in yet, c then nzuse = 0 is returned (and the other five variables will return c meaningless values). c SINGLE-PRECISION REAL variable zlo returns the boundary Zlo below c which a Z value is considered to require extrapolation; note that Zlo c may lie above the lowest stored z-value, but not below it. c SINGLE-PRECISION REAL variable zmid returns the "typical" Z-value (which c has no real significance after the opacities have been read in). c SINGLE-PRECISION REAL variable zhi returns the boundary Zhi above c which a Z value is considered to require extrapolation; note that Zhi c may lie below the highest stored z-value, but not above it. c SINGLE-PRECISION REAL variable zloex returns the boundary Zlo_ex at or c below which Z-extrapolation is considered too extreme to be carried out. c SINGLE-PRECISION REAL variable zhiex returns the boundary Zhi_ex at or c above which Z-extrapolation is considered too extreme to be carried out. c c c*** ASK_Z_ARRAY( kzstart, karraystart, Zarray, Narray ) This subroutine will c --------------------------------------------------- return (some of) the c stored z-values (that are used for Z-interpolation), in the user-supplied c array variable Zarray (the other inputs to ASK_Z_ARRAY must have values c supplied by the user, and may be constant integers). c kzstart INTEGER: index of the first stored z-value to be returned. c karraystart INTEGER: the index in the user-supplied array Zarray where c the first returned z-value will be placed. c Zarray SINGLE-PRECISION REAL ARRAY: is where the stored z-values are c returned; the array positions Zarray(karraystart) through c Zarray( min{ Narray , karraystart + nzuse - kzstart } ) c will contain the stored z-values kzstart through nzuse c (where nzuse is the total number of stored z-values); any c subsequent elements of Zarray (up to element Narray ) c will be filled with values of -1.0 (note that in no case c will elements beyond Narray be overwritten). c Narray INTEGER: the size of the user-supplied array Zarray , i.e., c the array is specified as "dimension Zarray(Narray)" . c c c ====================================================== c The subroutines that control matrix T,R-edge handling: c ====================================================== c c c*** SET_LOGT6_LIMITS( VLO, DVLO, VHI, DVHI ) These subroutines can be called c ---------------------------------------- at ANY TIME, and their effects c*** SET_LOGR_LIMITS( VLO, DVLO, VHI, DVHI ) will last until they are called c --------------------------------------- again; they are used to set (or c reset) the LogT6 and LogR boundaries. These input boundaries VLO and VHI c must not lie outside the matrix edges, and extrapolation is never allowed c more than one grid-spacing beyond the edge of the matrix. All these input c values should be SINGLE-PRECISION REAL, given in terms of log10(T6) and c log10(R) = log10(rho/T6**3); values of -90.0 or less mean "leave the present c values unchanged", and are ignored. c If VLO > -90.0 , then (for subroutine SET_LOGT6_LIMITS) it is used to set c the lower boundary LogT6_lo (minimum -2.25: logT=3.75), or (for subroutine c SET_LOGR_LIMITS), to set the lower boundary LogR_lo (minimum -8.0). c If VHI > -90.0 , then it is used to set the upper boundary LogT6_hi c (maximum +2.70: logT=8.70) or the upper boundary LogR_hi (maximum +1.0). c If DVLO is non-negative, it is used to set the amount of "extrapolation" c dLogT6 or dLogR allowed beyond the lower boundary, except that the extreme c values LogT6_lo - dLogT6 and LogR_lo - dLogR are not allowed to lie more c then one grid spacing beyond the matrix edge; if -90.0 < DVLO < 0.0 , then c the amount of extrapolation is set to its default (namely, dLogT6 = 0.05 or c dLogR = 0.5); if DVLO < -90.0 , then it is ignored. c If DVHI is non-negative, it is used to set the amount of "extrapolation" c dLogT6 or dLogR allowed beyond the upper boundary, except that the extreme c values LogT6_hi + dLogT6 and LogR_hi + dLogR are not allowed to lie more c then one grid spacing beyond the matrix edge; if -90.0 < DVHI < 0.0 , then c the amount of extrapolation is set to its default (namely, dLogT6 = 0.20 or c dLogR = 0.5); if DVHI < -90.0 , then it is ignored. c NOTE that even if the boundaries are set inside the matrix, the opacity c calculation continues to use all available matrix entries: interpolation is c still used (not extrapolation) as long as T6 and R lie inside the edge of c matrix. The boundaries and "extrapolation" distances are used to obtain the c value of FTREDGE to return, and whenever FTREDGE = 0.0 the opacity is NOT c calculated (even if T6 and R lie inside the matrix edges). c c c*** ASK_LOGT6_LIMITS( VLO, DVLO, VHI, DVHI ) These subroutines can be called c ---------------------------------------- at any time; they return the c*** ASK_LOGR_LIMITS( VLO, DVLO, VHI, DVHI ) current values of the lower and c --------------------------------------- upper LogT6 or LogR boundaries c and the corresponding allowed amounts of "extrapolation" dLogT6 or dLogR c (SINGLE-PRECISION REAL variables must be supplied to hold returned values). c c NOTE ALSO that the OPAL arrays have a "cut-out" region where opacity values c are not available at high T6,R values; one grid-spacing of extrapolation is c allowed into this "cut-out" region. The boundary of this "cut-out" lies c roughly at LogRho = 4 for 7.0 < logT < 7.5, and at somewhat higher densities c for log T > 7.5 (up to LogRho = 6 at logT = 8.7, the high-T matrix edge). c c NOTE ALSO that the X=0.0 and X=0.03 matrices have small "cut-outs" at low T6 c and small R. As noted by Rogers and Iglesias, "as a result of the mixing c procedure used to calculate the OPAL opacity data, a few X=0.0 and X=0.03 c low T - small R table values fell outside the range of T and R accessible c from the X=0.35 data directly calculated for this purpose. These T-R c locations are filled in with 9.999 (or for diagnostic purposes in some cases c larger values)." In the present program, these regions are treated as a c "cut-out" in the opacity tables (similar to the high T - large R corner), c and one grid spacing of extrapolation is allowed into them, as at any other c edge. For X > 0.1 they have no effect; for 0.03 < X < 0.1, the corner c ( -8.0 < logR < -7.5 , 3.70 < logT < 3.95 ) [i.e., T6 < 0.008912509] is c extrapolated; and for X < 0.03, a ragged part of the region ( logR < -4.5 , c logT < 4.0 ) [i.e., T6 < 0.01] is considered to be outside the opacity grid c (i.e., the opacity is not calculated, and FTREDGE = 0.0 is returned). c Presumably very few users will have applications that take them into these c low T - small R regions at low hydrogen abundances X; in any case, they are c at temperatures where molecular opacities may become non-negligible. c c c ====================================================== c The subroutines that control how smoothing is handled: c ====================================================== c c c*** SET_SMOOTH( initsmooth, lowCOsmooth, interpCOsmooth ) This subroutine c ----------------------------------------------------- allows the user to c control how and whether the opacity smoothing is carried out when the OPAL c opacities are read in, and which subroutine is used to interpolate in C and c O when OPAC or OPAL is called. The smoothing and its effects are discussed c in more detail further below. c --- IT IS RECOMMENDED THAT THE DEFAULT SMOOTHING VALUES NOT BE CHANGED. c c initsmooth INTEGER: if initsmooth = 2 (the default), then the OPAL c opacities are smoothed by the subroutine OPALTAB when c they are read in, in order to remove random numerical c errors; if initsmooth = 0 , then this initial smoothing c will not be carried out. A value initsmooth = 1 means c that opacities used for CNO-interpolation opacity shifts c will not be smoothed. A value initsmooth < 0 means c "do not change the current initial-smoothing setting". c lowCOsmooth INTEGER: if lowCOsmooth = 1 (the default), then the OPAL c opacities for the three mixes having max{C,O} = 0.01 may c be smoothed in the CO-direction when they are read in; c this is only done at (T6,R) points where opacity-changes c between mixes with C,O = 0.0, 0.03, 0.1 are monotonic c but the opacity at C,O = 0.01 does not fit the trend; c the resulting adjustments are small, and only occur at a c small minority of (T6,R) points. If lowCOsmooth = 0 , c then this initial CO-direction smoothing is not carried c out. A value lowCOsmooth < 0 means "do not change the c current initial-CO-smoothing setting". c interpCOsmooth INTEGER: if interpCOsmooth = 1 (the default), then the c subroutine COINTSMO is called by OPAC or OPAL in order c to interpolate in C and/or O. If interpCOsmooth = 0 , c then the older subroutine COINTERP is used instead; this c yields less smooth interpolation, and it has been less c thoroughly tested. A value interpCOsmooth < 0 means c "do not change the current CO-interpolation setting". c c c*** ASK_SMOOTH( initsmooth, lowCOsmooth, interpCOsmooth ) This subroutine c ----------------------------------------------------- returns the current c smoothing settings described above (INTEGER variables must be supplied to c hold the returned values), allowing the user to check how smoothing is being c handled. c c c****************************************************************************** c c c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c Details of how the opacity interpolation is performed by OPAC or OPAL c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c In general, a 6-variable interpolation of log10(Kappa) is performed, using c the arguments of OPAC or OPAL, on a subgrid of the stored opacity matrices. c In general, 4 stored values ("@" in the diagram c at upper right) are used along each interpolation 1:|-----|--v--| c direction. A quadratic fit is performed for @ @ * @ @ c each of the 2 sets of 3 adjacent stored values |--^--|-----|:2 c ("1" and "2" at upper right), and then linear c interpolation between these overlapping quadratics c is used to obtain smoothed results. [For a value @ * @ @ @ c near (or beyond) the edge of the matrix, as in 1:|--^--|-----| c the diagrams at lower right, a single quadratic c is used.] This procedure produces results that * @ @ @ @ c are similar to bicubic spline interpolation, ^--|-----|-----|:1 c but requires storage of only local information. c --- FIRST, unless excess C = O = 0.0, for each ( Z_i , X_j , T6_k , R_n ) c grid value that will be needed, an interpolation is performed in the excess c C and O values ("exC" and "exO" in the arguments to OPAC or OPAL). The c actual C' and O' values used at each ( Z_i , X_j ) gridpoint are adjusted by c a factor cmod = ( 1 - X_i - Z_j ) / ( 1 - X - Z ) , i.e., C' and O' are c set to be proportional to the maximum possible value for their ( Z_i , X_j ) c values, so as to avoid out-of-range C' and O' values (note that X is "xh", c Z is "z" in the arguments to the subroutines OPAC or OPAL described above). c The above formula for cmod can lead to problems when ( 1 - X - Z ) is c small, therefore: as X is increased from 0.7 to 0.8, cmod switches over c smoothly to from the above formula to a constant value of unity (note that c since the largest grid {X_i,Z_j} values are X=0.7 and Z=0.1 respectively, at c X > 0.8 a value of cmod = 1.0 will never yield X_i + Z_j + C' + O' > 1). c The 2-D bi-quadratic interpolation of log(Kappa) in log(C'+Z_i+0.001) c and log(O'+Z_i+0.001) is performed by the subroutine COINTSMO (or by the c older subroutine COINTERP, if you so choose: see description of subroutine c SET_SMOOTH above). The function QCHK is used to evaluate the quadratic: it c checks whether 2 of the 3 grid-points are excessively close together (as may c happen near C + O = 1 - Z - X for some values of Z) and, if so, uses more c nearly liner interpolation to avoid amplifying small errors in the stored c opacity values. For the special case where C or O is slightly negative c (slight depletion in C or O), the function QCHK does a linear extrapolation c using a combination of the lowest three C or O gridpoints. If C and/or O is c zero (to within an accuracy of 1.E-6), then interpolation in that direction c is not necessary, and is not performed (unless the user has specified that c the old subroutine COINTERP should be used). c --- SECOND, unless Z is within 1.E-6 of a stored z-value (or Z < 1.E-8, if c the stored value is 0.0), for each ( X_j , T6_k , R_n ) grid value that will c be needed, an interpolation is performed in log(Z+0.001). If there are only c 2 stored z-values (numz = 2), linear interpolation is used; for numz = 3, a c quadratic is used, while two overlapping quadratics are used for numz > 3 c (unless Z is near the end of the range of stored z-values). The subroutine c QZLOG4INT is called to perform this Z-interpolation. Since numerical errors c in the stored opacities, or in the CO-interpolation, may be comparable to c the opacity differences between adjacent stored z-values, the opacity at Z c is not allowed to lie outside the range of the two opacities at the stored c z-values bracketting it. (Note that, when opacities are read in for values c of Z different from one of those available in the OPAL opacity files, the c same type of interpolation with the same constraint is performed by the c subroutines READZEXCO, READEXCO, or READCO.) c --- THIRD, a two-variable interpolation in performed in the temperature c and density variables T6 and R (note slt = log10(T6) and slr = log10(R) in c the input to OPAL); the 2-D quadratic interpolation in log10(T6) and c log10(R) uses two overlapping quadratics in each direction, unless T6 or R c is within one grid spacing of an edge of the table (in which case a single c quadratic is used in the relevant direction). NOTE that the high-T,RHO c "cutout" has been filled in (by subroutine REVISE_HITR_FOR_INITSMOOTH) with c "reasonable" values, at the time when the opacities were read in; for T or c RHO above the actual upper edges of the matrix, switch from extrapolation c with the slope of the quadratic at the edge of the matrix to 2-point linear c extrapolation one grid-spacing beyone the edge of the matrix. c --- FOURTH, unless X is within 1.E-6 of one of the tabulated X-values c (X is the input variable xh in OPAC or OPAL), log(Kappa) is interpolated c quadratically in log(X+Xdel) , where Xdel = 0.03 is generally used (for c 0.03 < X < 0.35, two overlapping quadratics are used). NOTE that pre-1997 c versions of the opacity interpolation programs used a value of Xdel = 0.005, c which led to non-monotonic behavior of the opacity as a function of X for c small X values: for temperatures logT > 5.0 [T6 > 0.1], the interpolated c opacity first dropped slightly as X was increased from 0.0 to about 0.005, c then increased monotonically thereafter (at least up to X = 0.1). This c spurious dip in the opacity for small X values was small (delta log(Kappa) c of order 0.03), but it seemed worth getting rid of this dip by setting Xdel c to 0.03, in order to obtain qualitatively correct behavior of the opacity c for X close to zero. However, at low temperatures (i.e., for logT < 4), c the X=0.0 opacities are very small with respect to the X=0.03 and X=0.1 c opacities, and a smaller value of Xdel works better near X=0.0. Although c such low X values are unlikely to be encountered at such low temperatures, c provision was made in the program to reduce the value of Xdel used in such c cases to a value that works better (down to a minimum value of 0.001); this c was done ONLY for the quadratic that uses opacities at X = 0.0, 0.03, 0.1 c (note that for the higher X-values, the value of Xdel used is irrelevant). c --- FIFTH, unless X is within 1.E-6 of one of the tabulated X-values or c X < 0.03 or C+O > 0.3 or the "accurate-X" feature was turned off (see the c subroutine SET_XHI described above): for the X-values available in 'GN93hz' c but not 'Gz???.x??', Z-interpolation and (T6,R)-interpolation is performed c in delta-logKappa values, which are then interpolated in X to give opacity c corrections. Improvements are small for X < 0.76, but large for X > 0.76 . c --- SIXTH, if (and only if) CNO- and/or user-interpolation is enabled and c the corresponding CNO-interconverted opacity-files (or user-specified files) c were available to read in: the delta-logKappa values corresponding to the c interconversion of the CNO elements (and/or the user-specified composition c shift) are multiplied by the relevant factors FCN, FCON, FCNONE, FU and then c interpolated in Z, (T6,R), and X in order to give the corresponding opacity c corrections. c c NOTE: for the Ferguson et al. (2005) molecular opacity interpolation, c MODIFIED quadratics are used for logT < 3.48, where sudden jumps in the c opacity can occur between one grid-point and the next in any of the Z-, X-, c R-, and/or T-directions. For a large jump, the original quadratics would c lead to spurious wiggles on each side of the jump, with opacity errors of c order a factor of 2 (occasionally more than an order of magnitude). The c MODIFIED 3-pt quadratics switch over (smoothly), for a large jump, to linear c interpolation in the flat segment, with a quadratic in the "jump" segment c whose slope matches that of the flat segment where the two meet at the c middle of the three points (two adjacent such modified 3-pt quadratics are c still overlapped in general to get the final interpolated value). This gets c rid of almost all the spurious wiggles next to opacity jumps. EXAMPLE: c c Original quadratics: * * c * * * * c combine 4 4 5 4 * * 5 * 6 --> 4 * 5 * * 6 c * * * c * * * with spurious c * * * wiggles in c * * * between pts c * * * 2 and 3 and c 1 * 2 * * 3 2 3 3 1 * * 2 * 3 between pts c * * * * 4 and 5 c * * c c Modified quadratics: c 4 4 * * 5 4 * * 5 * 6 --> 4 * * 5 * 6 c combine * * * c * * * c * * * c * * * c * * * c 1 * 2 * * 3 2 * * 3 3 1 * 2 * * 3 c c The modified quadratic routines QUADSL, QDERSL, and QCHKSL are used only for c Ferguson et al. 2005 opacity interpolation at logT < 3.48; they are similar c to the functions QUAD, QDER, and QCHK [except that QCHKSL assumes that it c is always the case that x1 < x2 and that x2 and x3 are the only pair of c points that may coincide (or almost coincide)]. c c c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c Details of the makeup of Z (relative metal abundances), for various mixes c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c Note that the total metallicity Z for the OPAL mixes includes the following c 19 elements: {C,N,O,Ne,Na,Mg,Al,Si,P,S,Cl,Ar,K,Ca,Ti,Cr,Mn,Fe,Ni}. Their c relative abundances (by mass fraction and/or number fraction) for any mix c can be obtained by calling the subroutine ASK_OPAL_Z_MIX, while their atomic c weights (and their atomic numbers, i.e., nuclear charges) can be obtained by c calling the subroutine ASK_OPAL_MIX_WT (see descriptions further above). c c c The makeup of Z in the files 'GN93hz', 'Alrd96a2', 'C95hz', and 'W95hz' is c shown below, along with the maximum, mean, and spread of opacity differences c relative to 'GN93hz' for Z = 0.1 (where the opacity shifts are largest), for c T6 > 0.01 (logT > 4), for each X-value. Note that [i/Fe] gives the log of c the enhancement of element i relative to Fe, where the solar reference is c the 'GN93hz' mix; note that for i = Fe, [i/Fe] = 0.0 by definition. Newer c "GS98" and "AGS04" mixes are given further below. NOTE THAT THE CO-RICH c OPACITY FILES 'Gz???.x??' HAVE THE SAME COMPOSITION AS THE FILE 'GN93hz'. c c NOTE: for this GN93hz mix, Z/X = 0.02448: c c 'Gx..z...' and c 'GN93hz' 'Alrd96a2' 'C95hz' 'W95hz' c --------------- ------------------- ------------------- ------------------- c [O/Fe] = 0.0 [O/Fe] = 0.3 [O/Fe] = 0.4 [O/Fe] = 0.5 c =============== =================== =================== =================== c i Ni/Nz Xi/Z Ni/Nz Xi/Z [i/Fe] Ni/Nz Xi/Z [i/Fe] Ni/Nz Xi/Z [i/Fe] c - ------- ------- ------- ------- --- ------- ------- --- ------- ------- --- c C .245518 .173285 .147909 .102693 0.0 .131157 .091924 0.0 .108211 .076451 0.0 c N .064578 .053152 .038904 .031499 0.0 .034498 .028196 0.0 .028462 .023450 0.0 c O .512966 .482273 .616594 .570253 .30 .688325 .642620 .40 .714945 .672836 .50 c Ne.083210 .098668 .100010 .116656 .30 .044451 .052341 0.0 .071502 .084869 .29 c Na.001479 .001999 .001778 .002363 .30 .000790 .001060 0.0 .000652 .000882 0.0 c Mg.026308 .037573 .031622 .044428 .30 .035301 .050066 .40 .029125 .041639 .40 c Al.002042 .003238 .000617 .000962 -.3 .001091 .001718 0.0 .000900 .001428 0.0 c Si.024552 .040520 .029512 .047912 .30 .032945 .053992 .40 .021591 .035669 .30 c P .000195 .000355 .000234 .000420 .30 .000104 .000188 0.0 .000086 .000157 0.0 c S .011222 .021142 .013490 .024999 .30 .015059 .028172 .40 .010575 .019942 .33 c Cl.000219 .000456 .000263 .000539 .30 .000117 .000242 0.0 .000096 .000201 0.0 c Ar.002291 .005379 .002754 .006360 .30 .001224 .002853 0.0 .001010 .002373 0.0 c K .000091 .000210 .000055 .000124 0.0 .000122 .000279 .40 .000040 .000092 0.0 c Ca.001586 .003734 .001906 .004415 .30 .002127 .004975 .40 .002210 .005209 .50 c Ti.000075 .000211 .000089 .000245 .29 .000099 .000275 .39 .000137 .000387 .62 c Cr.000329 .001005 .000198 .000595 0.0 .000176 .000533 0.0 .000145 .000443 0.0 c Mn.000170 .000548 .000072 .00023 -.15 .000036 .000116 -.4 .000075 .000242 0.0 c Fe.021877 .071794 .013177 .042538 0.0 .011687 .038085 0.0 .009642 .031675 0.0 c Ni.001293 .004459 .000816 .002769 .02 .000691 .002365 0.0 .000595 .002056 .02 c - ------- ------- ------- ------- --- ------- ------- --- ------- ------- --- c h>.093729 .192623 .096583 .178899 .101569 .184919 .076879 .142395 c================== =================== =================== =================== c where h> is the sum of everything heavier than Ne c c opacity-shifts 'Alrd96a2' 'C95hz' 'W95hz' c dLogKappa ------------------- ------------------- ------------------- c for T6 > .01 [O/Fe] = 0.3 [O/Fe] = 0.4 [O/Fe] = 0.5 c for Z = 0.1, =================== =================== =================== c relative max mean sigma max mean sigma max mean sigma c to 'GN93hz' ------ ------ ----- ------ ------ ----- ------ ------ ----- c X=0: -.1512 -.0270 .0321 -.1844 -.0351 .0371 -.2669 -.0537 .0514 c X=.03: -.1457 -.0258 .0303 -.1835 -.0343 .0364 -.2270 -.0514 .0487 c X=.10: -.1464 -.0249 .0297 -.1849 -.0334 .0361 -.2286 -.0498 .0477 c X=.35: -.1490 -.0236 .0292 -.1886 -.0321 .0359 -.2334 -.0474 .0471 c X=.70: -.1539 -.0227 .0297 -.1952 -.0311 .0367 -.2416 -.0458 .0480 c c------------------------------------------------------------------------------ c NOTE: if you are using 'Alrd96a2' having [O/Fe] = 0.3 (khighz = 2), then your c mix Al abundance will go negative if you extrapolate [O/Fe] > 0.476 ; c the Mn abundance will go negative if you extrapolate [O/Fe] > 0.644 . c --- If you are using 'C95hz' having [O/Fe] = 0.4 (khighz = 3), then your mix c Mn abundance will go negative if you extrapolate [O/Fe] > 0.546 . c --- If you are using 'W95hz' having [O/Fe] = 0.5 (khighz = 4), then your mix c Ti abundance will go negative if you extrapolate [O/Fe] < -0.501 . c c By default, the CNO-interpolation files for the "GN93" mix are 'GN93hz' , c 'GN93hz.CtoN' , 'GN93hz.COtoN' , 'GN93hz.CNOtoNe' , and 'GN93hz.user' ; c for other mixes, the default filenames are obtained by appending '.CtoN' , c '.COtoN' , '.CNOtoNe', and '.user' to the main mix filename ('GS98hz' or c 'AGS04hz'). If such non-GN93 files are not found, CNO-interpolation opacity c differences are obtained from the "GN93" files instead (if these are found). c------------------------------------------------------------------------------ c c c Opacities for the "GS98" solar/meteoritic abundances (N. Grevesse & A.J. c Sauval 1998, Space Sci. Rev. 85, 161) are contained in the file 'GS98hz' ; c three other files were created with opacities for [O/Fe] enhancements (and c alpha-element enhancements) RELATIVE TO THE "GS98" MIX, patterned after the c corresponding three cases above. These files and compositions are: c c NOTE: for this GS98hz mix, Z/X = 0.02300: c c GS98hz GS98hz_OFe.3_Alrd96a2 GS98hz_OFe.4_C95 GS98hz_OFe.5_W95 c --------------- ------------------- ------------------- ------------------- c [O/Fe] = 0.0 [O/Fe] = 0.3 [O/Fe] = 0.4 [O/Fe] = 0.5 c =============== =================== =================== =================== c i Ni/Nz Xi/Z Ni/Nz Xi/Z [i/Fe] Ni/Nz Xi/Z [i/Fe] Ni/Nz Xi/Z [i/Fe] c - ------- ------- ------- ------- --- ------- ------- --- ------- ------- --- c C .245825 .171836 .148069 .101930 0.0 .131883 .091638 0.0 .108877 .076359 0.0 c N .061748 .050335 .037193 .029858 0.0 .033128 .026843 0.0 .027349 .022368 0.0 c O .501922 .467356 .603216 .553139 .30 .676395 .626052 .40 .702986 .656744 .50 c Ne.089265 .104831 .107280 .124072 .30 .047890 .055905 0.0 .077089 .090832 .29 c Na.001562 .002090 .001877 .002473 .30 .000838 .001114 0.0 .000692 .000929 0.0 c Mg.028224 .039924 .033921 .047252 .30 .038036 .053480 .40 .031401 .044563 .40 c Al.002294 .003603 .000693 .001071 -.3 .001231 .001921 0.0 .001016 .001601 0.0 c Si.026954 .044057 .032394 .052144 .30 .036324 .059017 .40 .023820 .039063 .30 c P .000235 .000423 .000282 .000501 .30 .000126 .000226 0.0 .000104 .000188 0.0 c S .012602 .023513 .015145 .027829 .30 .016982 .031497 .40 .011933 .022339 .33 c Cl.000141 .000292 .000170 .000346 .30 .000076 .000156 0.0 .000063 .000130 0.0 c Ar.001865 .004335 .002241 .005131 .30 .001000 .002312 0.0 .000826 .001927 0.0 c K .000100 .000228 .000060 .000135 0.0 .000135 .000305 .40 .000044 .000101 0.0 c Ca.001670 .003896 .002007 .004611 .30 .002251 .005218 .40 .002339 .005474 .50 c Ti.000070 .000195 .000082 .000226 .29 .000092 .000256 .39 .000129 .000362 .62 c Cr.000369 .001117 .000222 .000663 0.0 .000198 .000596 0.0 .000163 .000496 0.0 c Mn.000244 .000779 .000104 .000327-.15 .000052 .000165 -.4 .000108 .000346 0.0 c Fe.023517 .076433 .014165 .045339 0.0 .012616 .040761 0.0 .010416 .033965 0.0 c Ni.001393 .004757 .000878 .002955 .02 .000747 .002537 0.0 .000646 .002214 .02 c - ------- ------- ------- ------- --- ------- ------- --- ------- ------- --- c h>.101240 .205642 .104241 .191003 .110704 .199561 .083700 .153698 c================== =================== =================== =================== c where h> is the sum of everything heavier than Ne c c c Opacities can be read in for the newer "AGS04" solar/meteoritic abundances c (M. Asplund, N. Grevesse, & A.J. Sauval 2004, astro-ph/0410214 [v2]; c ALSO: M. Asplund, N. Grevesse, & A.J. Sauval 2005, Cosmic Abundances as c Records of Stellar Evolution and Nucleosynthesis [eds. F.N. Bush & T.G. c Barnes], ASP Conf. Series, Vol. 336, p. 25; c ALSO: M. Asplund, N. Grevesse, & A.J. Sauval 2006, Nucl. Phys. A 777, 1). c c NOTE: for this AGS04hz mix, Z/X = 0.016555973 c c AGS04hz AGS04hz_OFe.3_Alrd96a2 AGS04hz_OFe.4_C95 AGS04hz_OFe.5_W95 c --------------- ------------------- ------------------- ------------------- c [O/Fe] = 0.0 [O/Fe] = 0.3 [O/Fe] = 0.4 [O/Fe] = 0.5 c =============== =================== =================== =================== c i Ni/Nz Xi/Z Ni/Nz Xi/Z [i/Fe] Ni/Nz Xi/Z [i/Fe] Ni/Nz Xi/Z [i/Fe] c - ------- ------- ------- ------- --- ------- ------- --- ------- ------- --- c C .257854 .176688 .157301 .106433 0.0 .138833 .094547 0.0 .116312 .080363 0.0 c N .063296 .050578 .038613 .030467 0.0 .034080 .027065 0.0 .028551 .023004 0.0 c O .480145 .438260 .584425 .526743 .30 .649367 .589077 .40 .684888 .630346 .50 c Ne.072700 .083693 .088481 .100581 .30 .039143 .044785 0.0 .063935 .074215 .29 c Na.001956 .002565 .002381 .003084 .30 .001053 .001373 0.0 .000882 .001166 0.0 c Mg.035594 .049354 .043324 .059318 .30 .048138 .066338 .40 .040329 .056385 .40 c Al.002827 .004352 .000865 .001315 -.3 .001522 .002328 0.0 .001275 .001979 0.0 c Si.033992 .054464 .041375 .065461 .30 .045972 .073207 .40 .030593 .049426 .30 c P .000264 .000466 .000321 .000560 .30 .000142 .000249 0.0 .000119 .000212 0.0 c S .015184 .027771 .018483 .033381 .30 .020536 .037330 .40 .014644 .027007 .33 c Cl.000178 .000361 .000216 .000431 .30 .000096 .000193 0.0 .000080 .000163 0.0 c Ar.001590 .003623 .001935 .004355 .30 .000856 .001939 0.0 .000717 .001648 0.0 c K .000121 .000269 .000074 .000163 0.0 .000163 .000361 .40 .000054 .000121 0.0 c Ca.002050 .004686 .002495 .005633 .30 .002771 .006297 .40 .002924 .006742 .50 c Ti.000082 .000223 .000099 .000267 .29 .000109 .000296 .39 .000153 .000422 .62 c Cr.000458 .001358 .000279 .000817 0.0 .000247 .000728 0.0 .000207 .000619 0.0 c Mn.000310 .000972 .000133 .000412-.15 .000066 .000206 -.4 .000140 .000442 0.0 c Fe.029696 .094613 .018112 .056981 0.0 .015989 .050629 0.0 .013395 .043032 0.0 c Ni.001703 .005704 .001088 .003598 .02 .000917 .003052 0.0 .000802 .002708 .02 c - ------- ------- ------- ------- --- ------- ------- --- ------- ------- --- c h>.126005 .250781 .131180 .235776 .138577 .244526 .106314 .192072 c================== =================== =================== =================== c where h> is the sum of everything heavier than Ne c c Unlike earlier papers, "AGS04" above gives meteoritic H, He, C, N, O, Ne, Ar c abundances. There are almost no noble gases (He, Ne, Ar ...), less C, N, O c (relative to Si or Fe) than in the solar mix, and almost no hydrogen. [For c other elements, meteoritic abundances were used in the above "AGS04" mix, c instead of the less-accurate solar-surface observations.] The actual values c for the meteoritic mix are given below [with many digits, to show the actual c abundances of He, Ne, Ar; note that Ab_i = log10(N_i/N_H_sun) + 12.0]: c c Complete "AGS04" meteoritic abundances Meteoritic mix (components of Z) c ======================================= ================================== c i Ab_i Ni Xi Ni/Nz Xi/Z c -- ----- ---------------- ---------------- ---------------- ---------------- c H 8.25 .312727500321341 .020944433890450 [Z=.979055556989581] c He 1.29 .000000034289886 .000000009119969 c C 7.40 .044173943244219 .035255788483962 .064274280534767 .036009997831346 c N 6.25 .003127275003213 .002910629954482 .004550269595690 .002972895596887 c O 8.39 .431684461811492 .458939274347532 .628112551500661 .468757131371265 c Ne -1.06 .000000000153167 .000000000205377 .000000000222863 .000000000209770 c Na 6.27 .003274596717318 .005002390294590 .004764626668792 .005109403913677 c Mg 7.53 .059588954783339 .096237981691629 .086703538675350 .098296752420816 c Al 6.43 .004732763251461 .008485288886437 .006886298360263 .008666810403005 c Si 7.51 .056906999803204 .106202066768971 .082801221741094 .108473994157720 c P 5.40 .000441970109086 .000909645014595 .000643078446095 .000929104592789 c S 7.16 .025419977789240 .054153160875713 .036986754263261 .055311632204228 c Cl 5.23 .000297994997793 .000702016082572 .000433590770473 .000717033959472 c Ar -0.45 .000000000623973 .000000001656328 .000000000907898 .000000001691761 c K 5.06 .000202569633331 .000526280567971 .000294744287793 .000537539023413 c Ca 6.29 .003431964862220 .009140199460691 .004993601570053 .009335731149717 c Ti 4.89 .000137278594489 .000436941664783 .000199744062802 .000446288938011 c Cr 5.63 .000766751174096 .002649167869084 .001115643667846 .002705840184626 c Mn 5.47 .000518980052336 .001894561100742 .000755129993520 .001935090493299 c Fe 7.45 .049714940755353 .184489597541457 .072336581572827 .188436290692971 c Ni 6.19 .002851042029444 .011120564522665 .004148343157951 .011358461165226 c -- ----- ---------------- ---------------- ---------------- ---------------- c h> .208286785176682 .481949863998228 .303062898146020 .492259974990732 c ======================================= ================================== c where h> is the sum of everything heavier than Ne c c------------------------------------------------------------------------------ c c Meteoritic mixes as obtained from solar abundances by reducing C,N,O,Ne,Ar c as per the AGS04 meteoritic abundances, and "antimeteor" Z-mixes that yield c solar abundances when added to 50% and 20% as much meteoritic Z-material: c c GN93hz.meteor GN93hz.5antimeteor GN93hz.2antimeteor c ================================= ================= ================= c i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ---------------- ---------------- -------- -------- -------- -------- c C .062096387323045 .034055950767625 .3096329 .2428995 .2728055 .2011308 c N .004396103132102 .002811584920288 .0856148 .0783222 .0735314 .0632201 c O .606837084080657 .443326132928943 .4801523 .5017450 .4989998 .4900612 c Ne .000000000215357 .000000000198429 .1122968 .1480020 .0955898 .1184016 c Na .005283859474681 .005546683967014 .0001500 .0002252 .0009138 .0012895 c Mg .093987679773822 .104307149947153 .0026495 .0042059 .0162384 .0242262 c Al .007295227181013 .008987793491910 .0002060 .0003631 .0012607 .0020880 c Si .087714215091835 .112486310445815 .0024732 .0045368 .0151550 .0261267 c P .000696654916553 .000985278857158 .0000197 .0000399 .0001204 .0002289 c S .040091598026506 .058690042443895 .0011309 .0023680 .0069273 .0136324 c Cl .000782397036934 .001266565623746 .0000219 .0000507 .0001351 .0002939 c Ar .000000000877017 .000000001599745 .0030924 .0080685 .0026323 .0064548 c K .000325105632923 .000580403334678 .0000097 .0000248 .0000566 .0001359 c Ca .005666126529857 .010369588461345 .0001590 .0004162 .0009783 .0024069 c Ti .000267944210671 .000586040222841 .0000075 .0000235 .0000463 .0001360 c Cr .001175381889649 .002790592585741 .0000330 .0001122 .0002030 .0006479 c Mn .000607340179662 .001523534791034 .0000168 .0000602 .0001046 .0003529 c Fe .078157536632930 .199305017419850 .0022038 .0080385 .0135039 .0462918 c Ni .004619357794785 .012381327992788 .0001298 .0004978 .0007978 .0028745 c -- ---------------- ---------------- -------- -------- -------- -------- c h> .326670425248838 .519806331184714 .0123032 .0290313 .0590735 .1271863 c ================================= ================= ================= c (NOTE: some abundances would go negative beyond GN93hz.561743antimeteor) c c GS98hz.meteor GS98hz.5antimeteor GS98hz.2antimeteor c ================================= ================= ================= c i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ---------------- ---------------- -------- -------- -------- -------- c C .061833419528987 .033847976603222 .3108195 .2408300 .2734442 .1994336 c N .004377442231746 .002794386850040 .0820144 .0741053 .0703603 .0598431 c O .604274480285562 .440624098408040 .4657653 .4807222 .4865568 .4727025 c Ne .000000000214427 .000000000197201 .1207976 .1572465 .1026646 .1257972 c Na .005179390157206 .005426796827570 .0002843 .0004216 .0010191 .0014226 c Mg .093587138052187 .103667372071604 .0051357 .0080523 .0184132 .0271753 c Al .007606607490520 .009353799223261 .0004180 .0007276 .0014971 .0024528 c Si .089375982574740 .114401914525715 .0049037 .0088845 .0175839 .0299880 c P .000779229621820 .001099992396139 .0000423 .0000845 .0001529 .0002876 c S .041786601600009 .061056356041069 .0022925 .0047413 .0082210 .0160043 c Cl .000467537763442 .000755439983010 .0000264 .0000603 .0000926 .0001993 c Ar .000000000873527 .000000001590383 .0025233 .0065025 .0021445 .0052020 c K .000331587065415 .000590861589288 .0000185 .0000466 .0000655 .0001554 c Ca .005537504221631 .010115144589889 .0003042 .0007864 .0010898 .0026522 c Ti .000232110957854 .000506712319369 .0000127 .0000391 .0000456 .0001327 c Cr .001223556258112 .002899506965060 .0000673 .0002257 .0002409 .0007605 c Mn .000809072444438 .002025771911462 .0000439 .0001556 .0001588 .0005296 c Fe .077979330676706 .198476752244634 .0042777 .0154111 .0153411 .0520243 c Ni .004619007981672 .012357115663043 .0002527 .0009569 .0009081 .0032370 c -- ---------------- ---------------- -------- -------- -------- -------- c h> .329514657739278 .522733537941497 .0206032 .0470960 .0669741 .1422236 c ================================= ================= ================= c (NOTE: some abundances would go negative beyond GS98hz.624814antimeteor) c c AGS04hz.meteor AGS04hz.5antimeteor AGS04hz.2antimeteor c ================================= ================= ================= c i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ---------------- ---------------- -------- -------- -------- -------- c C .064274208429525 .036009888957169 .3303785 .2470271 .2883952 .2048236 c N .004550290959465 .002972903901491 .0853040 .0743805 .0725636 .0600990 c O .628110449385059 .468754671183736 .4247136 .4230127 .4568036 .4321613 c Ne .000000000222945 .000000000209847 .0999372 .1255395 .0841701 .1004316 c Na .004764660515098 .005109430493010 .0009033 .0012928 .0015125 .0020561 c Mg .086704154588141 .098297263764627 .0164453 .0248824 .0275300 .0395653 c Al .006886347278212 .008666855488115 .0013066 .0021946 .0021869 .0034890 c Si .082801809933137 .108474558443967 .0157052 .0274587 .0262910 .0436619 c P .000643083014308 .000929109426030 .0001216 .0002344 .0002039 .0003734 c S .036987017004729 .055311919937648 .0070150 .0140005 .0117437 .0222628 c Cl .000433593850556 .000717037689513 .0000829 .0001830 .0001382 .0002898 c Ar .000000000907947 .000000001691848 .0021853 .0054345 .0018405 .0043476 c K .000294746381558 .000537541819713 .0000553 .0001347 .0000931 .0002153 c Ca .004993637042920 .009335779714580 .0009463 .0023611 .0015848 .0037560 c Ti .000199745481717 .000446291259625 .0000374 .0001114 .0000630 .0001783 c Cr .001115651593004 .002705854260520 .0002113 .0006841 .0003540 .0010884 c Mn .000755135357710 .001935100559721 .0001434 .0004904 .0002399 .0007794 c Fe .072337095427584 .188437270946424 .0137206 .0477009 .0229685 .0758481 c Ni .004148372626387 .011358520252416 .0007872 .0028767 .0013175 .0045731 c -- ---------------- ---------------- -------- -------- -------- -------- c h> .303065051003006 .492262535747757 .0596667 .1300402 .0980675 .2024845 c ================================= ================= ================= c (NOTE: some abundances would go negative beyond AGS04hz.998696antimeteor) c c Since the solar C, N, and O abundances have been reduced more-or-less in c concert from one abundance paper to the next, it is not unreasonable to c consider them NOT to be independent, and to vary all of them together by c their quoted uncertainties (or by double this amount) to get mixes with c shifted C, N, and O that can still be considered "reasonable" (note that Ne c and Ar should be shifted by the same amount as O, since it is their ratios c Ne/O and Ar/O that are measured). The shifted-CNO mixes would have the same c meteoritic abundances as "AGS04" above, but different "anti-meteor" mixes: c c Z/X = 0.01809864 AGS04hiCNONe_OFe.5_W95 AGS04hiCNONe.2antimeteor c AGS04hiCNONe || AGS04hiCNONe.5antimeteor || c ==================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C +0.05 .261002 .181349 .117585 .082019 .3333123 .2540186 .2915434 .2104168 c N +0.06 .065561 .053122 .029536 .024025 .0879866 .0781965 .0750329 .0631518 c O +0.05 .486005 .449821 .692380 .643323 .4337738 .4403542 .4639452 .4460345 c Ne +0.05 .073584 .085897 .064632 .075741 .1006317 .1288455 .0850084 .1030764 c Na 0.00 .001765 .002347 .000795 .001061 .0006621 .0009658 .0012990 .0017945 c Mg 0.00 .032110 .045147 .036336 .051288 .0120428 .0185719 .0236341 .0345169 c Al 0.00 .002551 .003981 .001149 .001800 .0009568 .0016381 .0018774 .0030438 c Si 0.00 .030665 .049822 .027564 .044958 .0115013 .0204957 .0225709 .0380915 c P 0.00 .000238 .000427 .000107 .000192 .0000895 .0001759 .0001755 .0003266 c S 0.00 .013698 .025404 .013194 .024565 .0051371 .0104500 .0100819 .0194224 c Cl 0.00 .000161 .000330 .000072 .000148 .0000607 .0001365 .0001186 .0002526 c Ar +0.05 .001609 .003719 .000725 .001682 .0022008 .0055785 .0018591 .0044628 c K 0.00 .000109 .000246 .000049 .000111 .0000404 .0001002 .0000799 .0001877 c Ca 0.00 .001849 .004287 .002634 .006131 .0006931 .0017626 .0013607 .0032772 c Ti 0.00 .000074 .000204 .000138 .000384 .0000273 .0000829 .0000540 .0001555 c Cr 0.00 .000413 .001242 .000186 .000562 .0001546 .0005101 .0003038 .0009492 c Mn 0.00 .000280 .000889 .000126 .000402 .0001050 .0003659 .0002059 .0006798 c Fe 0.00 .026789 .086548 .012069 .039143 .0100475 .0356034 .0197181 .0661701 c Ni 0.00 .001537 .005218 .000723 .002465 .0005766 .0021477 .0011312 .0039899 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .113848 .229811 .095867 .174892 .0442956 .0985852 .0844701 .1773205 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04hiCNONe.841962amet) c c Z/X = 0.01983278 AGS04vhCNONe_OFe.5_W95 AGS04vhCNONe.2antimeteor c AGS04vhCNONe || AGS04vhCNONe.5antimeteor || c ==================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C +0.10 .263820 .185686 .118732 .083546 .3358885 .2605241 .2943424 .2156212 c N +0.12 .067812 .055659 .030518 .025042 .0906599 .0820020 .0774886 .0661962 c O +0.10 .491254 .460576 .699138 .655310 .4418255 .4564867 .4703199 .4589405 c Ne +0.10 .074376 .087948 .065260 .077148 .1012381 .1319220 .0857528 .1055376 c Na 0.00 .001590 .002142 .000716 .000964 .0004434 .0006583 .0011044 .0015485 c Mg 0.00 .028927 .041200 .032700 .046561 .0080606 .0126514 .0200899 .0297805 c Al 0.00 .002298 .003633 .001034 .001634 .0006406 .0011161 .0015959 .0026262 c Si 0.00 .027625 .045465 .024806 .040815 .0076973 .0139602 .0191852 .0328631 c P 0.00 .000214 .000389 .000096 .000174 .0000594 .0001189 .0001487 .0002810 c S 0.00 .012340 .023183 .011874 .022302 .0034384 .0071185 .0085700 .0167572 c Cl 0.00 .000145 .000301 .000065 .000135 .0000406 .0000930 .0001007 .0002178 c Ar +0.10 .001627 .003808 .000732 .001713 .0022142 .0057120 .0018755 .0045696 c K 0.00 .000098 .000225 .000044 .000101 .0000272 .0000687 .0000681 .0001625 c Ca 0.00 .001666 .003912 .002370 .005565 .0004637 .0012001 .0011566 .0028272 c Ti 0.00 .000066 .000186 .000123 .000345 .0000181 .0000559 .0000458 .0001339 c Cr 0.00 .000372 .001133 .000167 .000509 .0001032 .0003466 .0002581 .0008184 c Mn 0.00 .000252 .000811 .000114 .000367 .0000702 .0002489 .0001749 .0005862 c Fe 0.00 .024134 .078981 .010861 .035534 .0067250 .0242529 .0167609 .0570897 c Ni 0.00 .001384 .004762 .000650 .002235 .0003861 .0014637 .0009616 .0034427 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .102738 .210131 .086352 .158954 .0303880 .0690652 .0720963 .1537045 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04vhCNONe.714584amet) c c------------------------------------------------------------------------------ c c The components of the metallicity for the CNO-varied mixes are given below. c Note that burning C to N increases Z slightly, burning O to N decreases Z c slightly, and burning CNO to Ne increases Z significantly; thus, although c the mass fraction of elements heavier than Ne does not change, the c ratio = /Z differs between these CNO-varied mixes: c c 'GN93hz' 'GN93hz.CtoN' 'GN93hz.COtoN' 'GN93hz.CNOtoNe' c -------------------- --------------- --------------- ---------------- c solar CNO most C --> N most C,O --> N all C,N,O --> Ne c ==================== =============== =============== ================ c i Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ---- ------- ------- ------- ------- ------- ------- ------- ------- c C 8.55 .245518 .173285 .000246 .000169 .000246 .000179 .000000 .000000 c N 7.97 .064578 .053152 .309850 .247897 .817686 .694328 .000000 .000000 c O 8.87 .512966 .482273 .512966 .468789 .005130 .004976 .000000 .000000 c Ne 8.08 .083210 .098668 .083210 .095909 .083210 .101793 .906272 .847998 c Na 6.33 .001479 .001999 .001479 .001942 .001479 .002061 .001479 .001577 c Mg 7.58 .026308 .037573 .026308 .036523 .026308 .038764 .026308 .029650 c Al 6.47 .002042 .003238 .002042 .003147 .002042 .003340 .002042 .002555 c Si 7.55 .024552 .040520 .024552 .039387 .024552 .041803 .024552 .031975 c P 5.45 .000195 .000355 .000195 .000345 .000195 .000366 .000195 .000280 c S 7.21 .011222 .021142 .011222 .020550 .011222 .021811 .011222 .016683 c Cl 5.50 .000219 .000456 .000219 .000443 .000219 .000471 .000219 .000360 c Ar 6.52 .002291 .005379 .002291 .005228 .002291 .005548 .002291 .004244 c K 5.12 .000091 .000210 .000091 .000203 .000091 .000216 .000091 .000165 c Ca 6.36 .001586 .003734 .001586 .003631 .001586 .003854 .001586 .002948 c Ti 5.03 .000075 .000211 .000075 .000205 .000075 .000218 .000075 .000167 c Cr 5.68 .000329 .001005 .000329 .000977 .000329 .001037 .000329 .000793 c Mn 5.39 .000170 .000548 .000170 .000533 .000170 .000566 .000170 .000433 c Fe 7.50 .021877 .071794 .021877 .069787 .021877 .074068 .021877 .056653 c Ni 6.25 .001293 .004459 .001293 .004335 .001293 .004601 .001293 .003519 c -- ---- ------- ------- ------- ------- ------- ------- ------- ------- c .093729 .192623 .093729 .187236 .093729 .198724 .093729 .152002 c ==================== =============== =============== ================ c where is the sum of everything heavier than Ne. c c For the GS98 mix, the corresponding CNO-varied metallicity components are: c c 'GS98hz' 'GS98hz.CtoN' 'GS98hz.COtoN' 'GS98hz.CNOtoNe' c -------------------- --------------- --------------- ---------------- c solar CNO most C --> N most C,O --> N all C,N,O --> Ne c ==================== =============== =============== ================ c i Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ---- ------- ------- ------- ------- ------- ------- ------- ------- c C 8.52 .245825 .171836 .000246 .000167 .000246 .000177 .000000 .000000 c N 7.92 .061748 .050335 .307327 .243574 .804230 .675229 .000000 .000000 c O 8.83 .501922 .467356 .501922 .454393 .005019 .004813 .000000 .000000 c Ne 8.08 .089265 .104831 .089265 .101924 .089265 .107973 .898760 .836936 c Na 6.32 .001562 .002090 .001562 .002032 .001562 .002153 .001562 .001657 c Mg 7.58 .028224 .039924 .028224 .038816 .028224 .041120 .028224 .031657 c Al 6.49 .002294 .003603 .002294 .003502 .002294 .003710 .002294 .002856 c Si 7.56 .026954 .044057 .026954 .042835 .026954 .045377 .026954 .034935 c P 5.56 .000235 .000423 .000235 .000412 .000235 .000436 .000235 .000336 c S 7.20 .012602 .023513 .012602 .022861 .012602 .024218 .012602 .018645 c Cl 5.28 .000141 .000292 .000141 .000283 .000141 .000300 .000141 .000231 c Ar 6.40 .001865 .004335 .001865 .004216 .001865 .004466 .001865 .003438 c K 5.13 .000100 .000228 .000100 .000221 .000100 .000234 .000100 .000180 c Ca 6.35 .001670 .003896 .001670 .003787 .001670 .004012 .001670 .003089 c Ti 4.94 .000070 .000195 .000070 .000190 .000070 .000201 .000070 .000155 c Cr 5.69 .000369 .001117 .000369 .001086 .000369 .001150 .000369 .000885 c Mn 5.53 .000244 .000779 .000244 .000759 .000244 .000804 .000244 .000619 c Fe 7.50 .023517 .076433 .023517 .074315 .023517 .078726 .023517 .060608 c Ni 6.25 .001393 .004757 .001393 .004627 .001393 .004901 .001393 .003773 c -- ---- ------- ------- ------- ------- ------- ------- ------- ------- c .101240 .205642 .101240 .199942 .101240 .211808 .101240 .163064 c ==================== =============== =============== ================ c where is the sum of everything heavier than Ne. c c For the AGS04 mix, the corresponding CNO-varied metallicity components are: c c 'AGS04hz' 'AGS04hz.CtoN' 'AGS04hz.COtoN' 'AGS04hz.CNOtoNe' c -------------------- --------------- --------------- ---------------- c solar CNO most C --> N most C,O --> N all C,N,O --> Ne c ==================== =============== =============== ================ c i Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ---- ------- ------- ------- ------- ------- ------- ------- ------- c C 8.39 .257854 .176688 .002579 .001717 .002579 .001812 .000000 .000000 c N 7.78 .063296 .050578 .318571 .247373 .793915 .650653 .000000 .000000 c O 8.66 .480145 .438260 .480145 .425880 .004801 .004494 .000000 .000000 c Ne 7.84 .072700 .083693 .072700 .081329 .072700 .085836 .873995 .800479 c Na 6.27 .001956 .002565 .001956 .002493 .001956 .002631 .001956 .002041 c Mg 7.53 .035594 .049354 .035594 .047960 .035594 .050618 .035594 .039266 c Al 6.43 .002827 .004352 .002827 .004229 .002827 .004463 .002827 .003462 c Si 7.51 .033992 .054464 .033992 .052926 .033992 .055859 .033992 .043331 c P 5.40 .000264 .000466 .000264 .000453 .000264 .000478 .000264 .000371 c S 7.16 .015184 .027771 .015184 .026987 .015184 .028483 .015184 .022095 c Cl 5.23 .000178 .000361 .000178 .000350 .000178 .000369 .000178 .000286 c Ar 6.18 .001590 .003623 .001590 .003521 .001590 .003716 .001590 .002883 c K 5.06 .000121 .000269 .000121 .000262 .000121 .000277 .000121 .000215 c Ca 6.29 .002050 .004686 .002050 .004555 .002050 .004807 .002050 .003729 c Ti 4.89 .000082 .000223 .000082 .000218 .000082 .000230 .000082 .000178 c Cr 5.63 .000458 .001358 .000458 .001320 .000458 .001393 .000458 .001081 c Mn 5.47 .000310 .000972 .000310 .000944 .000310 .000996 .000310 .000773 c Fe 7.45 .029696 .094613 .029696 .091941 .029696 .097036 .029696 .075273 c Ni 6.19 .001703 .005704 .001703 .005542 .001703 .005849 .001703 .004537 c -- ---- ------- ------- ------- ------- ------- ------- ------- ------- c .126005 .250781 .126005 .243701 .126005 .257205 .126005 .199521 c ==================== =============== =============== ================ c where is the sum of everything heavier than Ne. c c For the high-C,N,O,Ne version of the "AGS04" mix: c c 'AGS04hiCNONe.CtoN' 'AGS04hiCNONe.CNOtoNe' c 'AGS04hiCNONe' || 'AGS04hiCNONe.COtoN' || c -------------------- --------------- --------------- ---------------- c solar CNO most C --> N most C,O --> N all C,N,O --> Ne c ==================== =============== =============== ================ c i Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ---- ------- ------- ------- ------- ------- ------- ------- ------- c C 8.44 .261002 .181349 .002610 .001761 .002610 .001861 .000000 .000000 c N 7.84 .065561 .053122 .323953 .254885 .805098 .669508 .000000 .000000 c O 8.71 .486005 .449821 .486005 .436791 .004860 .004616 .000000 .000000 c Ne 7.89 .073584 .085897 .073584 .083408 .073584 .088156 .886152 .818221 c Na 6.27 .001765 .002347 .001765 .002279 .001765 .002409 .001765 .001857 c Mg 7.53 .032110 .045147 .032110 .043839 .032110 .046335 .032110 .035711 c Al 6.43 .002551 .003981 .002551 .003866 .002551 .004086 .002551 .003149 c Si 7.51 .030665 .049822 .030665 .048378 .030665 .051132 .030665 .039408 c P 5.40 .000238 .000427 .000238 .000414 .000238 .000438 .000238 .000337 c S 7.16 .013698 .025404 .013698 .024669 .013698 .026073 .013698 .020095 c Cl 5.23 .000161 .000330 .000161 .000321 .000161 .000339 .000161 .000261 c Ar 6.23 .001609 .003719 .001609 .003611 .001609 .003816 .001609 .002941 c K 5.06 .000109 .000246 .000109 .000239 .000109 .000253 .000109 .000195 c Ca 6.29 .001849 .004287 .001849 .004163 .001849 .004400 .001849 .003391 c Ti 4.89 .000074 .000204 .000074 .000199 .000074 .000210 .000074 .000162 c Cr 5.63 .000413 .001242 .000413 .001206 .000413 .001275 .000413 .000983 c Mn 5.47 .000280 .000889 .000280 .000864 .000280 .000913 .000280 .000704 c Fe 7.45 .026789 .086548 .026789 .084039 .026789 .088823 .026789 .068457 c Ni 6.19 .001537 .005218 .001537 .005068 .001537 .005357 .001537 .004128 c -- ---- ------- ------- ------- ------- ------- ------- ------- ------- c .113848 .229811 .113848 .223155 .113848 .235859 .113848 .181779 c ==================== =============== =============== ================ c where is the sum of everything heavier than Ne. c c For the very-high-C,N,O,Ne version of the "AGS04" mix: c c 'AGS04vhCNONe.CtoN' 'AGS04vhCNONe.CNOtoNe' c 'AGS04vhCNONe' || 'AGS04vhCNONe.COtoN' || c -------------------- --------------- --------------- ---------------- c solar CNO most C --> N most C,O --> N all C,N,O --> Ne c ==================== =============== =============== ================ c i Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ---- ------- ------- ------- ------- ------- ------- ------- ------- c C 8.49 .263820 .185686 .002638 .001802 .002638 .001907 .000000 .000000 c N 7.90 .067812 .055659 .328994 .262029 .815335 .687252 .000000 .000000 c O 8.76 .491254 .460576 .491254 .446925 .004913 .004730 .000000 .000000 c Ne 7.94 .074376 .087948 .074376 .085341 .074376 .090318 .897262 .834689 c Na 6.27 .001590 .002142 .001590 .002079 .001590 .002200 .001590 .001685 c Mg 7.53 .028927 .041200 .028927 .039978 .028927 .042310 .028927 .032412 c Al 6.43 .002298 .003633 .002298 .003526 .002298 .003731 .002298 .002858 c Si 7.51 .027625 .045465 .027625 .044117 .027625 .046690 .027625 .035768 c P 5.40 .000214 .000389 .000214 .000377 .000214 .000399 .000214 .000306 c S 7.16 .012340 .023183 .012340 .022496 .012340 .023808 .012340 .018238 c Cl 5.23 .000145 .000301 .000145 .000292 .000145 .000309 .000145 .000237 c Ar 6.28 .001627 .003808 .001627 .003696 .001627 .003911 .001627 .002996 c K 5.06 .000098 .000225 .000098 .000218 .000098 .000231 .000098 .000177 c Ca 6.29 .001666 .003912 .001666 .003797 .001666 .004018 .001666 .003078 c Ti 4.89 .000066 .000186 .000066 .000180 .000066 .000190 .000066 .000146 c Cr 5.63 .000372 .001133 .000372 .001100 .000372 .001164 .000372 .000892 c Mn 5.47 .000252 .000811 .000252 .000787 .000252 .000833 .000252 .000638 c Fe 7.45 .024134 .078981 .024134 .076640 .024134 .081110 .024134 .062135 c Ni 6.19 .001384 .004762 .001384 .004620 .001384 .004889 .001384 .003745 c -- ---- ------- ------- ------- ------- ------- ------- ------- ------- c .102738 .210131 .102738 .203903 .102738 .215793 .102738 .165311 c ==================== =============== =============== ================ c where is the sum of everything heavier than Ne. c c------------------------------------------------------------------------------ c c There are indications that Ne might have an abundance up to 3 times that c inferred from the observed Solar coronal Ne/O ratios, although there are c arguments against this too; at the very least, the Ne abundance may be quite c uncertain, so here are AGS04 mixes with Ne * 1.5, 2.0, 2.5, and 3.0: c c Z/X = 0.01724878 AGS04x15Ne_OFe.5_W95 c AGS04x15Ne || AGS04x15Ne.5amet AGS04x15Ne.2amet c ===================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C 0.000 .248810 .169591 .112709 .077488 .3184504 .2363816 .2781026 .1963072 c N 0.000 .061076 .048547 .027666 .022181 .0824077 .0713340 .0700487 .0576618 c O 0.000 .463305 .420657 .663672 .607789 .4011116 .3966082 .4371453 .4110377 c Ne +.176 .105225 .120496 .092932 .107340 .1449344 .1807440 .1219276 .1445952 c Na 0.000 .001887 .002462 .000855 .001125 .0008012 .0011383 .0014303 .0019325 c Mg 0.000 .034345 .047372 .039079 .054367 .0145862 .0219094 .0260341 .0371869 c Al 0.000 .002728 .004177 .001236 .001909 .0011587 .0019321 .0020679 .0032790 c Si 0.000 .032800 .052277 .029646 .047659 .0139299 .0241782 .0248626 .0410375 c P 0.000 .000255 .000448 .000116 .000206 .0001083 .0002074 .0001933 .0003518 c S 0.000 .014651 .026656 .014190 .026040 .0062221 .0123280 .0111057 .0209248 c Cl 0.000 .000172 .000346 .000077 .000156 .0000733 .0001605 .0001305 .0002718 c Ar 0.000 .001534 .003478 .000695 .001589 .0021132 .0052170 .0017777 .0041736 c K 0.000 .000116 .000258 .000052 .000116 .0000489 .0001182 .0000880 .0002021 c Ca 0.000 .001978 .004498 .002833 .006499 .0008394 .0020791 .0014988 .0035304 c Ti 0.000 .000079 .000214 .000148 .000406 .0000331 .0000979 .0000595 .0001675 c Cr 0.000 .000442 .001303 .000200 .000595 .0001872 .0006016 .0003346 .0010224 c Mn 0.000 .000299 .000933 .000136 .000428 .0001272 .0004319 .0002269 .0007326 c Fe 0.000 .028654 .090812 .012980 .041493 .0121689 .0419994 .0217199 .0712869 c Ni 0.000 .001644 .005475 .000778 .002614 .0006983 .0025332 .0012460 .0042983 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .121584 .240709 .103021 .185202 .0530959 .1149322 .0927758 .1903981 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04x15Ne.921257amet) c c Z/X = 0.01794158 AGS04x2Ne_OFe.5_W95 c AGS04x2Ne || AGS04x2Ne.5amet AGS04x2Ne.2amet c ===================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C 0.000 .240379 .163043 .109323 .074812 .3072900 .2265596 .2684938 .1884496 c N 0.000 .059006 .046672 .026835 .021415 .0796959 .0685215 .0676994 .0554118 c O 0.000 .447605 .404412 .643730 .586793 .3790228 .3722407 .4187884 .3915437 c Ne +.301 .135546 .154458 .120186 .138176 .1870455 .2316870 .1571847 .1853496 c Na 0.000 .001823 .002367 .000829 .001086 .0007056 .0009958 .0013536 .0018185 c Mg 0.000 .033182 .045543 .037906 .052491 .0128463 .0191659 .0246373 .0349921 c Al 0.000 .002636 .004016 .001199 .001843 .0010207 .0016906 .0019571 .0030858 c Si 0.000 .031688 .050258 .028755 .046012 .0122678 .0211497 .0235282 .0386147 c P 0.000 .000246 .000430 .000112 .000198 .0000949 .0001804 .0001824 .0003302 c S 0.000 .014155 .025626 .013764 .025141 .0054793 .0107830 .0105093 .0196888 c Cl 0.000 .000166 .000333 .000075 .000151 .0000648 .0001410 .0001237 .0002562 c Ar 0.000 .001482 .003344 .000674 .001534 .0020455 .0050160 .0017190 .0040128 c K 0.000 .000112 .000248 .000051 .000114 .0000430 .0001032 .0000832 .0001901 c Ca 0.000 .001911 .004324 .002748 .006275 .0007390 .0018181 .0014182 .0033216 c Ti 0.000 .000076 .000206 .000143 .000390 .0000292 .0000859 .0000564 .0001579 c Cr 0.000 .000427 .001253 .000194 .000575 .0001650 .0005266 .0003167 .0009624 c Mn 0.000 .000289 .000897 .000132 .000413 .0001121 .0003779 .0002147 .0006894 c Fe 0.000 .027683 .087306 .012590 .040059 .0107174 .0367404 .0205546 .0670797 c Ni 0.000 .001588 .005264 .000754 .002522 .0006152 .0022167 .0011793 .0040451 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .117464 .231415 .099926 .178804 .0469458 .1009912 .0878337 .1792453 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04x2Ne.856526amet) c c Z/X = 0.01863439 AGS04x25Ne_OFe.5_W95 c AGS04x25Ne || AGS04x25Ne.5amet AGS04x25Ne.2amet c ===================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C 0.000 .232500 .156981 .106134 .072313 .2968211 .2174666 .2594992 .1811752 c N 0.000 .057072 .044937 .026052 .020700 .0771536 .0659190 .0655014 .0533298 c O 0.000 .432932 .389378 .624950 .567196 .3583114 .3496897 .4016121 .3735029 c Ne +.398 .163879 .185894 .145851 .166953 .2265366 .2788410 .1901794 .2230728 c Na 0.000 .001764 .002279 .000805 .001050 .0006160 .0008638 .0012818 .0017129 c Mg 0.000 .032094 .043849 .036800 .050737 .0112136 .0166249 .0233291 .0329593 c Al 0.000 .002549 .003867 .001164 .001782 .0008914 .0014671 .0018535 .0029070 c Si 0.000 .030650 .048389 .027916 .044475 .0107089 .0183462 .0222792 .0363719 c P 0.000 .000238 .000414 .000109 .000192 .0000828 .0001564 .0001727 .0003110 c S 0.000 .013691 .024674 .013362 .024301 .0047837 .0093550 .0099520 .0185464 c Cl 0.000 .000161 .000321 .000073 .000147 .0000569 .0001230 .0001173 .0002418 c Ar 0.000 .001434 .003219 .000655 .001484 .0019815 .0048285 .0016635 .0038628 c K 0.000 .000109 .000239 .000050 .000111 .0000376 .0000897 .0000789 .0001793 c Ca 0.000 .001848 .004164 .002667 .006064 .0006455 .0015781 .0013433 .0031296 c Ti 0.000 .000074 .000198 .000140 .000380 .0000253 .0000739 .0000533 .0001483 c Cr 0.000 .000413 .001206 .000189 .000557 .0001438 .0004561 .0002998 .0009060 c Mn 0.000 .000280 .000863 .000128 .000399 .0000975 .0003269 .0002031 .0006486 c Fe 0.000 .026776 .084060 .012223 .038722 .0093558 .0318714 .0194638 .0631845 c Ni 0.000 .001536 .005068 .000732 .002437 .0005370 .0019227 .0011166 .0038099 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .113617 .222810 .097013 .172838 .0411773 .0880837 .0832079 .1689193 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04x25Ne.797451amet) c c Z/X = 0.01932720 AGS04x3Ne_OFe.5_W95 c AGS04x3Ne || AGS04x3Ne.5amet AGS04x3Ne.2amet c ===================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C 0.000 .225122 .151354 .103126 .069977 .2869847 .2090261 .2510645 .1744228 c N 0.000 .055261 .043326 .025314 .020031 .0747640 .0635025 .0634395 .0513966 c O 0.000 .419197 .375420 .607243 .548880 .3388465 .3287527 .3855011 .3567533 c Ne +.477 .190413 .215077 .170059 .193870 .2636471 .3226155 .2211244 .2580924 c Na 0.000 .001708 .002198 .000783 .001017 .0005325 .0007423 .0012150 .0016157 c Mg 0.000 .031075 .042278 .035756 .049097 .0096809 .0142684 .0221037 .0310741 c Al 0.000 .002468 .003728 .001131 .001724 .0007692 .0012586 .0017558 .0027402 c Si 0.000 .029677 .046655 .027125 .043039 .0092449 .0157452 .0211086 .0342911 c P 0.000 .000230 .000399 .000105 .000184 .0000713 .0001339 .0001635 .0002930 c S 0.000 .013256 .023789 .012983 .023515 .0041291 .0080275 .0094286 .0174844 c Cl 0.000 .000156 .000309 .000071 .000142 .0000488 .0001050 .0001109 .0002274 c Ar 0.000 .001388 .003104 .000636 .001435 .0019220 .0046560 .0016120 .0037248 c K 0.000 .000105 .000230 .000048 .000106 .0000321 .0000762 .0000745 .0001685 c Ca 0.000 .001789 .004014 .002591 .005867 .0005567 .0013531 .0012723 .0029496 c Ti 0.000 .000071 .000191 .000135 .000365 .0000218 .0000634 .0000505 .0001399 c Cr 0.000 .000400 .001163 .000183 .000538 .0001242 .0003916 .0002841 .0008544 c Mn 0.000 .000271 .000832 .000124 .000385 .0000842 .0002804 .0001924 .0006114 c Fe 0.000 .025926 .081047 .011876 .037470 .0080765 .0273519 .0184408 .0595689 c Ni 0.000 .001487 .004886 .000711 .002358 .0004635 .0016497 .0010578 .0035915 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .110007 .214823 .094258 .167242 .0357577 .0761032 .0788705 .1593349 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04x3Ne.747866amet) c c Z/X = 0.01887595 AGS04hiCNOx15Ne_OFe.5_W95 AGS04hiCNOx15Ne.2amet c AGS04hiCNOx15Ne || AGS04hiCNOx15Ne.5amet || c ===================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C +.050 .251740 .173881 .113904 .079026 .3212059 .2428166 .2810428 .2014552 c N +.060 .063234 .050934 .028611 .023148 .0849795 .0749145 .0724070 .0605262 c O +.050 .468761 .431300 .670709 .619856 .4097142 .4125727 .4438537 .4238093 c Ne +.226 .106459 .123540 .093912 .109465 .1459095 .1853100 .1231012 .1482480 c Na 0.000 .001702 .002250 .000770 .001023 .0005669 .0008203 .0012231 .0016781 c Mg 0.000 .030971 .043288 .035199 .049417 .0103179 .0157834 .0222584 .0322861 c Al 0.000 .002460 .003817 .001113 .001735 .0008198 .0013921 .0017680 .0028470 c Si 0.000 .029577 .047770 .026702 .043319 .0098536 .0174177 .0212567 .0356291 c P 0.000 .000230 .000409 .000104 .000186 .0000764 .0001489 .0001650 .0003050 c S 0.000 .013211 .024358 .012780 .023667 .0044013 .0088810 .0094951 .0181672 c Cl 0.000 .000155 .000316 .000070 .000143 .0000518 .0001155 .0001114 .0002358 c Ar +.050 .001552 .003566 .000702 .001620 .0021275 .0053490 .0017949 .0042792 c K 0.000 .000105 .000236 .000047 .000106 .0000346 .0000852 .0000753 .0001757 c Ca 0.000 .001783 .004110 .002551 .005906 .0005935 .0014971 .0012813 .0030648 c Ti 0.000 .000071 .000195 .000133 .000368 .0000230 .0000694 .0000506 .0001447 c Cr 0.000 .000398 .001191 .000180 .000541 .0001325 .0004336 .0002862 .0008880 c Mn 0.000 .000270 .000852 .000122 .000387 .0000898 .0003104 .0001938 .0006354 c Fe 0.000 .025839 .082984 .011691 .037714 .0086083 .0302574 .0185702 .0618933 c Ni 0.000 .001482 .005003 .000700 .002373 .0004940 .0018252 .0010653 .0037319 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .109806 .220345 .092864 .168505 .0381909 .0843862 .0795953 .1659613 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04hiCNOx15Ne.775992amet) c c Z/X = 0.01965326 AGS04hiCNOx2Ne_OFe.5_W95 AGS04hiCNOx2Ne.2amet c AGS04hiCNOx2Ne || AGS04hiCNOx2Ne.5amet || c ===================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C +.050 .243112 .167004 .110446 .076243 .3098835 .2325011 .2712458 .1932028 c N +.060 .061067 .048920 .027742 .022333 .0821687 .0718935 .0699583 .0581094 c O +.050 .452697 .414238 .650349 .598029 .3872014 .3869797 .4250999 .4033349 c Ne +.351 .137081 .158205 .121416 .140815 .1882627 .2373075 .1586465 .1898460 c Na 0.000 .001644 .002161 .000747 .000987 .0004782 .0006868 .0011525 .0015713 c Mg 0.000 .029909 .041576 .034130 .047677 .0087044 .0132154 .0209747 .0302317 c Al 0.000 .002376 .003666 .001079 .001673 .0006916 .0011656 .0016661 .0026658 c Si 0.000 .028563 .045881 .025891 .041793 .0083129 .0145842 .0200310 .0333623 c P 0.000 .000222 .000393 .000101 .000180 .0000646 .0001249 .0001556 .0002858 c S 0.000 .012759 .023394 .012393 .022836 .0037125 .0074350 .0089470 .0170104 c Cl 0.000 .000150 .000304 .000068 .000139 .0000440 .0000975 .0001053 .0002214 c Ar +.050 .001499 .003425 .000681 .001564 .0020588 .0051375 .0017349 .0041100 c K 0.000 .000101 .000227 .000046 .000103 .0000294 .0000717 .0000711 .0001649 c Ca 0.000 .001722 .003948 .002473 .005697 .0005009 .0012541 .0012077 .0028704 c Ti 0.000 .000069 .000188 .000130 .000358 .0000197 .0000589 .0000480 .0001363 c Cr 0.000 .000385 .001144 .000175 .000523 .0001118 .0003631 .0002697 .0008316 c Mn 0.000 .000260 .000819 .000118 .000373 .0000760 .0002609 .0001829 .0005958 c Fe 0.000 .024953 .079702 .011336 .036386 .0072621 .0253344 .0174992 .0579549 c Ni 0.000 .001431 .004805 .000679 .002291 .0004168 .0015282 .0010038 .0034943 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .106043 .211633 .090047 .162580 .0324837 .0713182 .0750495 .1555069 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04hiCNOx2Ne.727860amet) c c Z/X = 0.02043057 AGS04hiCNOx25Ne_OFe.5_W95 AGS04hiCNOx25Ne.2amet c AGS04hiCNOx25Ne || AGS04hiCNOx25Ne.5amet || c ===================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C +.050 .235057 .160650 .107192 .073650 .2992678 .2229701 .2620815 .1855780 c N +.060 .059044 .047059 .026925 .021574 .0795330 .0691020 .0676675 .0558762 c O +.050 .437697 .398479 .631190 .577693 .3661031 .3633412 .4075643 .3844241 c Ne +.448 .165674 .190232 .147299 .170033 .2279647 .2853480 .1918908 .2282784 c Na 0.000 .001589 .002079 .000725 .000953 .0003954 .0005638 .0010867 .0014729 c Mg 0.000 .028918 .039994 .033124 .046055 .0071915 .0108424 .0197738 .0283333 c Al 0.000 .002297 .003527 .001047 .001616 .0005719 .0009571 .0015710 .0024990 c Si 0.000 .027617 .044135 .025128 .040371 .0068680 .0119652 .0188840 .0312671 c P 0.000 .000214 .000378 .000098 .000174 .0000533 .0001024 .0001467 .0002678 c S 0.000 .012336 .022504 .012028 .022059 .0030673 .0061000 .0084349 .0159424 c Cl 0.000 .000145 .000292 .000066 .000134 .0000361 .0000795 .0000990 .0002070 c Ar +.050 .001449 .003295 .000661 .001511 .0019945 .0049425 .0016789 .0039540 c K 0.000 .000098 .000218 .000045 .000101 .0000240 .0000582 .0000669 .0001541 c Ca 0.000 .001665 .003798 .002401 .005505 .0004139 .0010291 .0011386 .0026904 c Ti 0.000 .000066 .000181 .000125 .000343 .0000163 .0000484 .0000453 .0001279 c Cr 0.000 .000372 .001100 .000170 .000506 .0000921 .0002971 .0002541 .0007788 c Mn 0.000 .000252 .000787 .000115 .000361 .0000625 .0002129 .0001721 .0005574 c Fe 0.000 .024126 .076670 .011002 .035148 .0060003 .0207864 .0164976 .0543165 c Ni 0.000 .001384 .004622 .000659 .002213 .0003443 .0012537 .0009463 .0032747 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .102528 .203580 .087394 .157050 .0271314 .0592387 .0707959 .1458433 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04hiCNOx25Ne.682227amet) c c Z/X = 0.02120788 AGS04hiCNOx3Ne_OFe.5_W95 AGS04hiCNOx3Ne.2amet c AGS04hiCNOx3Ne || AGS04hiCNOx3Ne.5amet || c ===================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C +.050 .227518 .154762 .104125 .071229 .2892973 .2141381 .2534926 .1785124 c N +.060 .057150 .045334 .026155 .020865 .0770566 .0665145 .0655198 .0538062 c O +.050 .423658 .383873 .613128 .558696 .3462824 .3414322 .3911257 .3668969 c Ne +.527 .192433 .219912 .171701 .197330 .2652590 .3298680 .2230522 .2638944 c Na 0.000 .001538 .002003 .000704 .000922 .0003175 .0004498 .0010251 .0013817 c Mg 0.000 .027991 .038528 .032177 .044541 .0057706 .0086434 .0186483 .0265741 c Al 0.000 .002223 .003397 .001017 .001563 .0004583 .0007621 .0014811 .0023430 c Si 0.000 .026731 .042518 .024409 .039044 .0055117 .0095397 .0178097 .0293267 c P 0.000 .000207 .000364 .000095 .000168 .0000426 .0000814 .0001382 .0002510 c S 0.000 .011940 .021679 .011683 .021332 .0024611 .0048625 .0079547 .0149524 c Cl 0.000 .000140 .000282 .000064 .000129 .0000295 .0000645 .0000938 .0001950 c Ar +.050 .001403 .003174 .000642 .001461 .0019339 .0047610 .0016262 .0038088 c K 0.000 .000095 .000210 .000043 .000096 .0000192 .0000462 .0000630 .0001445 c Ca 0.000 .001612 .003658 .002332 .005323 .0003316 .0008191 .0010734 .0025224 c Ti 0.000 .000064 .000174 .000121 .000330 .0000128 .0000379 .0000426 .0001195 c Cr 0.000 .000360 .001060 .000165 .000489 .0000740 .0002371 .0002397 .0007308 c Mn 0.000 .000244 .000759 .000112 .000350 .0000505 .0001709 .0001626 .0005238 c Fe 0.000 .023353 .073860 .010687 .033992 .0048149 .0165714 .0155587 .0509445 c Ni 0.000 .001340 .004453 .000640 .002140 .0002765 .0010002 .0008926 .0030719 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .099241 .196119 .084891 .151880 .0221047 .0480472 .0668097 .1368901 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04hiCNOx3Ne.639022amet) c c Z/X = 0.02070490 AGS04vhCNOx15Ne_OFe.5_W95 AGS04vhCNOx15Ne.2amet c AGS04vhCNOx15Ne || AGS04vhCNOx15Ne.5amet || c ===================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C +.100 .254360 .177864 .114980 .080443 .3236246 .2487911 .2836549 .2062348 c N +.120 .065381 .053315 .029554 .024112 .0875472 .0784860 .0747562 .0633834 c O +.100 .473639 .441177 .677043 .630963 .4173540 .4273882 .4498350 .4356617 c Ne +.276 .107564 .126365 .094797 .111424 .1467589 .1895475 .1241412 .1516380 c Na 0.000 .001533 .002051 .000693 .000928 .0003546 .0005218 .0010342 .0014393 c Mg 0.000 .027890 .039464 .031667 .044832 .0064587 .0100474 .0188256 .0276973 c Al 0.000 .002215 .003480 .001001 .001573 .0005134 .0008866 .0014955 .0024426 c Si 0.000 .026635 .043550 .024023 .039300 .0061680 .0110877 .0179784 .0305651 c P 0.000 .000207 .000373 .000094 .000170 .0000479 .0000949 .0001396 .0002618 c S 0.000 .011897 .022206 .011498 .021472 .0027549 .0056530 .0080305 .0155848 c Cl 0.000 .000140 .000289 .000063 .000130 .0000331 .0000750 .0000948 .0002034 c Ar +.100 .001568 .003648 .000709 .001650 .0021401 .0054720 .0018103 .0043776 c K 0.000 .000095 .000215 .000043 .000098 .0000215 .0000537 .0000636 .0001505 c Ca 0.000 .001606 .003747 .002295 .005358 .0003713 .0009526 .0010837 .0026292 c Ti 0.000 .000064 .000178 .000120 .000335 .0000143 .0000439 .0000429 .0001243 c Cr 0.000 .000359 .001086 .000162 .000491 .0000830 .0002761 .0002421 .0007620 c Mn 0.000 .000243 .000777 .000110 .000352 .0000563 .0001979 .0001640 .0005454 c Fe 0.000 .023269 .075654 .010518 .034215 .0053889 .0192624 .0157065 .0530973 c Ni 0.000 .001335 .004561 .000630 .002154 .0003093 .0011622 .0009010 .0032015 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .099056 .201279 .083626 .153058 .0247153 .0557872 .0676127 .1430821 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04vhCNOx15Ne.663458amet) c c Z/X = 0.02157703 AGS04vhCNOx2Ne_OFe.5_W95 AGS04vhCNOx2Ne.2amet c AGS04vhCNOx2Ne || AGS04vhCNOx2Ne.5amet || c ===================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C +.100 .245556 .170675 .111458 .077562 .3121591 .2380076 .2736893 .1976080 c N +.120 .063118 .051160 .028649 .023249 .0846360 .0752535 .0722074 .0607974 c O +.100 .457245 .423344 .656303 .608366 .3944695 .4006387 .4307287 .4142621 c Ne +.401 .138454 .161677 .122524 .143245 .1893233 .2425155 .1599419 .1940124 c Na 0.000 .001480 .001968 .000672 .000895 .0002722 .0003973 .0009694 .0013397 c Mg 0.000 .026925 .037869 .030698 .043228 .0049614 .0076549 .0176472 .0257833 c Al 0.000 .002139 .003339 .000971 .001518 .0003942 .0006751 .0014017 .0022734 c Si 0.000 .025713 .041790 .023287 .037893 .0047383 .0084477 .0168531 .0284531 c P 0.000 .000200 .000358 .000091 .000163 .0000368 .0000724 .0001309 .0002438 c S 0.000 .011486 .021309 .011147 .020705 .0021165 .0043075 .0075282 .0145084 c Cl 0.000 .000135 .000277 .000061 .000125 .0000253 .0000570 .0000887 .0001890 c Ar +.100 .001514 .003500 .000687 .001590 .0020703 .0052500 .0017490 .0042000 c K 0.000 .000091 .000206 .000041 .000093 .0000162 .0000402 .0000594 .0001397 c Ca 0.000 .001550 .003596 .002224 .005164 .0002854 .0007261 .0010161 .0024480 c Ti 0.000 .000062 .000171 .000117 .000325 .0000110 .0000334 .0000403 .0001159 c Cr 0.000 .000346 .001042 .000157 .000473 .0000637 .0002101 .0002269 .0007092 c Mn 0.000 .000235 .000746 .000107 .000341 .0000434 .0001514 .0001539 .0005082 c Fe 0.000 .022463 .072596 .010196 .032990 .0041396 .0146754 .0147232 .0494277 c Ni 0.000 .001288 .004377 .000610 .002075 .0002378 .0008862 .0008447 .0029807 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .095627 .193144 .081066 .147578 .0194121 .0435847 .0634327 .1333201 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04vhCNOx2Ne.621160amet) c c Z/X = 0.02244915 AGS04vhCNOx25Ne_OFe.5_W95 AGS04vhCNOx25Ne.2amet c AGS04vhCNOx25Ne || AGS04vhCNOx25Ne.5amet || c ===================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C +.100 .237341 .164045 .108145 .074880 .3014154 .2280626 .2643742 .1896520 c N +.120 .061006 .049172 .027797 .022445 .0819071 .0722715 .0698241 .0584118 c O +.100 .441949 .406897 .636799 .587335 .3730252 .3759682 .4128692 .3945257 c Ne +.498 .167278 .194245 .148603 .172865 .2292092 .2913675 .1934070 .2330940 c Na 0.000 .001430 .001892 .000652 .000864 .0001956 .0002833 .0009093 .0012485 c Mg 0.000 .026024 .036398 .029785 .041732 .0035585 .0054484 .0165456 .0240181 c Al 0.000 .002067 .003210 .000942 .001465 .0002833 .0004816 .0013147 .0021186 c Si 0.000 .024853 .040167 .022595 .036583 .0033987 .0060132 .0158014 .0265055 c P 0.000 .000193 .000344 .000088 .000157 .0000263 .0000514 .0001227 .0002270 c S 0.000 .011101 .020481 .010815 .019988 .0015178 .0030655 .0070581 .0135148 c Cl 0.000 .000130 .000266 .000059 .000121 .0000181 .0000405 .0000830 .0001758 c Ar +.100 .001463 .003364 .000667 .001536 .0020051 .0050460 .0016919 .0040368 c K 0.000 .000088 .000198 .000040 .000090 .0000114 .0000282 .0000557 .0001301 c Ca 0.000 .001498 .003456 .002158 .004986 .0002044 .0005161 .0009525 .0022800 c Ti 0.000 .000060 .000164 .000113 .000312 .0000076 .0000229 .0000376 .0001075 c Cr 0.000 .000335 .001001 .000153 .000459 .0000454 .0001486 .0002125 .0006600 c Mn 0.000 .000227 .000717 .000104 .000329 .0000312 .0001079 .0001443 .0004734 c Fe 0.000 .021712 .069776 .009893 .031850 .0029690 .0104454 .0138042 .0460437 c Ni 0.000 .001245 .004207 .000592 .002003 .0001707 .0006312 .0007920 .0027767 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .092426 .185641 .078656 .142475 .0144431 .0323302 .0595255 .1243165 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04vhCNOx25Ne.580960amet) c c Z/X = 0.02332128 AGS04vhCNOx3Ne_OFe.5_W95 AGS04vhCNOx3Ne.2amet c AGS04vhCNOx3Ne || AGS04vhCNOx3Ne.5amet || c ===================== =============== ================= ================= c i d:Ab_i Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z Ni/Nz Xi/Z c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c C +.100 .229658 .157910 .105024 .072378 .2913253 .2188601 .2556460 .1822900 c N +.120 .059031 .047333 .026995 .021695 .0793452 .0695130 .0675919 .0562050 c O +.100 .427642 .391682 .618420 .567711 .3528913 .3531457 .3961398 .3762677 c Ne +.577 .194235 .224377 .173177 .200507 .2666617 .3365655 .2247580 .2692524 c Na 0.000 .001384 .001821 .000633 .000835 .0001230 .0001768 .0008523 .0011633 c Mg 0.000 .025181 .035037 .028925 .040337 .0022411 .0034069 .0155137 .0223849 c Al 0.000 .002000 .003090 .000915 .001417 .0001787 .0003016 .0012327 .0019746 c Si 0.000 .024048 .038665 .021942 .035359 .0021405 .0037602 .0148158 .0247031 c P 0.000 .000187 .000331 .000086 .000153 .0000165 .0000319 .0001150 .0002114 c S 0.000 .010742 .019715 .010503 .019320 .0009557 .0019165 .0066178 .0125956 c Cl 0.000 .000126 .000256 .000057 .000116 .0000115 .0000255 .0000778 .0001638 c Ar +.100 .001416 .003238 .000648 .001485 .0019439 .0048570 .0016384 .0038856 c K 0.000 .000085 .000191 .000039 .000087 .0000072 .0000177 .0000524 .0001217 c Ca 0.000 .001450 .003327 .002096 .004820 .0001287 .0003226 .0008932 .0021252 c Ti 0.000 .000058 .000158 .000110 .000302 .0000046 .0000139 .0000353 .0001003 c Cr 0.000 .000324 .000964 .000148 .000442 .0000286 .0000931 .0001994 .0006156 c Mn 0.000 .000219 .000690 .000100 .000315 .0000196 .0000674 .0001352 .0004410 c Fe 0.000 .021009 .067166 .009607 .030784 .0018695 .0065304 .0129429 .0429117 c Ni 0.000 .001205 .004049 .000575 .001937 .0001074 .0003942 .0007424 .0025871 c -- ----- ------- ------- ------- ------- -------- -------- -------- -------- c h> .089434 .178698 .076384 .137709 .0097765 .0219157 .0558643 .1159849 c ==================== =============== ================= ================= c (NOTE: some abundances would go negative beyond AGS04vhCNOx3Ne.548057amet) c c------------------------------------------------------------------------------ c OPAL ATOMIC MASSES: We list the OPAL atomic masses (atomic weights) used c to convert number fractions (Ni) to mass fractions (X, Y, Z, Xi). c c Element Mass (a.u.) Element Mass (a.u.) Element Mass (a.u.) c ------- ----------- ------- ----------- ------- ----------- c 1 H 1.00790 12 Mg 24.30500 19 K 39.09830 c 2 He 4.00260 13 Al 26.98154 20 Ca 40.08000 c 6 C 12.01100 14 Si 28.08550 22 Ti 47.90000 c 7 N 14.00670 15 P 30.97376 24 Cr 51.99600 c 8 O 15.99940 16 S 32.06000 25 Mn 54.93800 c 10 Ne 20.17900 17 Cl 35.45300 26 Fe 55.84700 c 11 Na 22.98977 18 Ar 39.94800 28 Ni 58.70000 c------------------------------------------------------------------------------ c c c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c Details of the accuracy of the X-, Z-, and CO-interpolation c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c Z-interpolation errors if 'GN93hz' file not used: c ================================================= c c For the non-CO-rich mixes (C=O=0.0), one can check the accuracy of the c Z-interpolation among the 'Gz???.x??' files when opacities are read in, by c looking at the 'GN93hz' opacities. Where the Z values are in both files, c the opacities are identical. When only 'GN93hz' (or only the 'Gz???.x??' c files) contains the Z value, errors in interpolation among 'Gz???.x??' files c are shown below; the largest, the mean, and the rms error in logKappa are c given (at T6 of 0.01 or higher, and all log R values). Note that the c 'Gz???.x??' files contain Z = 0.05, but 'GN93hz' does not; for this case, c interpolation in 'GN93hz' is tested, rather than interpolation among c 'Gz???.x??' files. Note that the Z-interpolation errors tend to be quite c small, with an rms error of less than 4% even in the worst case; applying c the 'GN93hz' opacity-shifts (as is the default) when interpolating in Z c should significantly reduce these errors (note: T6 < 0.01 omitted): c c Z-interpolation errors if 'GN93hz' file not used (if khighz=0 in READZEXCO): c ---------------------------------------------------------------------------- c c dLogKappa(X=0.00) dLogKappa(X=0.10) dLogKappa(X=0.35) dLogKappa(X=0.70) c ================= ================= ================= ================= c Z max mean rms max mean rms max mean rms max mean rms c ----- ---- ----- ----- ---- ----- ----- ---- ----- ----- ---- ----- ----- c .0001 .128 .0078 .0169 .042 .0047 .0084 .040 .0041 .0077 .039 .0040 .0078 c .0003 .112 .0072 .0151 .045 .0046 .0084 .043 .0041 .0079 .046 .0040 .0081 c .002 -.036-.0018 .0038 -.012-.0012 .0023 -.012-.0011 .0022 -.013-.0010 .0025 c .04 -.003 .0000 .0003 -.001 .0000 .0002 .001 .0000 .0002 .001 .0000 .0002 c .05 * -.003 .0000 .0003 .001 .0000 .0002 .001 .0000 .0002 .001 .0000 .0002 c .06 -.004 .0000 .0004 -.001 .0000 .0003 .001 .0000 .0003 -.001 .0000 .0003 c .08 -.003 .0000 .0004 -.001 .0000 .0003 .001 .0000 .0003 -.001 .0000 .0003 c c It is clear from the following table that X-interpolation errors in the file c 'GN93hz' (to get X=0.03) would be much larger than any Z-interpolation error c in the files Gz???.x03 ; thus any opacity shifts for X=0.03 are interpolated c from the X=0, X=0.1, and X=0.35 opacity shifts (unless only a single mix is c being read in, which is NOT the default case). The size of the error in c these X-interpolated opacity shifts is presumably somewhat smaller than the c opacity shifts themselves, which in turn are smaller than the errors shown c below that would result if the 'GN93hz' opacities were interpolated in X to c get the X=0.03 opacities. c c c X-interpolation errors at X=0.03 if ONLY the 'GN93hz' file were used: c ===================================================================== c c X interpolation errors, for X = 0.03, interpolating in X = 0.0, 0.1, 0.2 c in the file 'GN93hz' (note that a value of Xdel = 0.005 was used for this c interpolation, and all T6 < 0.01 opacities were omitted): c c X-interpolation errors that would occur if 'Gz???.x??' files were not used: c --------------------------------------------------------------------------- c c Z: 0. 0.001 0.004 0.01 0.02 0.03 0.1 (at X=0.03) c ------ ------ ------ ------ ------ ------ ------ c max -.3514 -.2971 -.2454 -.1913 -.1396 -.1062 -.0614 (dLogKappa) c mean -.0159 -.0149 -.0141 -.0132 -.0124 -.0118 -.0103 c rms .0399 .0350 .0305 .0259 .0219 .0196 .0158 c c c X-interpolation/extrapolation errors if 'GN93hz' file not used: c =============================================================== c c The file 'GN93hz' contains (non-CO-rich) opacities at X-values not available c from the 'Gz???.x??' files, namely, X = 0.2, 0.5, 0.8, 0.9, 0.95, and 1-Z. c If one sets khighz = 0 in the call to READZEXCO that reads the opacities, c then the 'GN93hz' file is not read in and X-interpolation is less accurate c [or alternatively, if one turns off "accurate-X" by calling SET_XHI( 0 ) ]. c For X < 0.75 or so, the errors are comparable to or smaller than the errors c from the original OPAL opacity computation; but for extrapolation to larger c X-values, the error grows very rapidly, and can become as large as an order c of magnitude as X approaches 1-Z: c c X-interpolation/extrapolation errors if 'GN93hz' file not used (khighz=0): c -------------------------------------------------------------------------- c c ***Interpolation (dLogKappa): c Z: 0. 0.0001 0.001 0.004 0.01 0.02 0.03 0.05 0.08 0.1 c X=0.2: ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ c max -.0146 .0375 -.0153 -.0147 -.0139 -.0137 -.0142 -.0129 -.0124 -.0126 c mean -.0023 -.0017 -.0021 -.0018 -.0016 -.0014 -.0013 -.0012 -.0010 -.0010 c rms .0044 .0051 .0040 .0036 .0033 .0031 .0029 .0027 .0025 .0024 c X=0.5: ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ c max .0291 .0291 .0284 .0269 .0260 .0249 .0244 .0243 .0234 .0234 c mean .0028 .0027 .0023 .0019 .0016 .0013 .0011 .0010 .0008 .0008 c rms .0076 .0073 .0066 .0059 .0053 .0048 .0045 .0042 .0039 .0038 c ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ c ***Extrapolation (dLogKappa): c Z: 0. 0.0001 0.001 0.004 0.01 0.02 0.03 0.05 0.08 0.1 c X=0.8: ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ c max -.0732 -.0721 -.0706 -.0680 -.0637 -.0620 -.0597 -.0578 -.0557 -.0565 c mean -.0071 -.0068 -.0059 -.0049 -.0041 -.0035 -.0031 -.0027 -.0024 -.0023 c rms .0178 .0172 .0153 .0134 .0119 .0107 .0100 .0092 .0086 .0084 c X=0.9: ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ c max -.2415 -.2405 -.2328 -.2220 -.2063 -.1980 -.1914 -.1854 -.1828 -.1860 c mean -.0226 -.0216 -.0186 -.0154 -.0129 -.0110 -.0099 -.0088 -.0082 -.0085 c rms .0565 .0544 .0480 .0416 .0366 .0328 .0306 .0284 .0273 .0281 c X=0.95: ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ c max -.4256 -.4189 -.4025 -.3805 -.3555 -.3321 -.3264 -.3213 c mean -.0377 -.0360 -.0307 -.0253 -.0212 -.0181 -.0165 -.0154 c rms .0950 .0910 .0797 .0684 .0600 .0537 .0505 .0486 c X=1-Z: ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ c max -.9901 -.9632 -.8694 -.7293 -.6045 -.4773 -.4059 -.3213 -.2219 -.1860 c mean -.0818 -.0758 -.0609 -.0468 -.0370 -.0306 -.0279 -.0154 -.0175 -.0085 c rms .2079 .1941 .1592 .1249 .0982 .0769 .0645 .0486 .0356 .0281 c ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ c c c CO-interpolation errors: c ======================== c c Note that there are six cases (at three different metallicities) where c mixes on the line C+O = 1-X-Z, with identical compositions, are interpolated c in two different ways when being read into two different positions in the c matrix CO; since these cases all have X > 0, they do not correspond to mixes c that are likely to be encountered by investigators, but they do give another c estimate of interpolation errors for some CO-rich mixes. (Note that there c are several other cases where mixes with identical compositions appear at c two different places in the matrix CO, but these occur at tabulated Z-values c and thus have identical opacity values.) Differences for the CO-rich cases c with identical compositions (note that T6 < 0.01 were omitted): c c Differences for CO-rich mixes interpolated in two different ways: c ----------------------------------------------------------------- c c case: Z=0.04 X=0.35 Z=0.07 X=0.7 Z=0.09 X=0.7 c ============== ============== ============== c C & O: .01 .6 .6 .01 .03 .2 .2 .03 .01 .2 .2 .01 c ------ ------ ------ ------ ------ ------ c max -.0333 -.0026 -.0491 -.0110 -.0422 -.0084 (dLogKappa) c mean -.0029 -.0002 -.0046 -.0014 -.0041 -.0011 c rms .0061 .0008 .0091 .0029 .0081 .0023 c c These errors are still quite small, with an rms of 1% or less, smaller than c the estimated error in the opacity computations quoted above or than the c largest of the Z-interpolation errors at C=O=0.0 (though larger than the c errors for the C=O=0.0 mix for the same metallicity Z). The maximum error c is less than 12% (note that the maximum errors tend to lie at fairly low c temperatures, where CO-rich opacities are less likely to be needed). c c The above tables of errors were obtained by considering Z-interpolation as c the opacities were read in. One may also compare opacities where the only c Z-interpolation was performed on input (i.e., Nzin = 1 in READZEXCO) with c opacities interpolated in Z by the call to OPAC or OPAL (i.e., which had had c Z > 4 in READZEXCO). These are interpolated among somewhat different grid c points, and thus give some idea of the Z-interpolation and CO-interpolation c errors. NOTE THAT USE OF COINTERP WILL LEAD TO SIGNIFICANTLY LARGER ERRORS, c as discussed further below. For several Z-values, the number of points c compared and the maximum and rms differences in log10(Kappa) are given below c both at and between (X,T6,R,C,O) gridpoints, for low (46) temperatures (T6 < 0.01 are omitted; table Z-values are also c omitted, since opacity differences are zero there, as expected). Note that c rms differences are always small, less than 0.3%, but this may be misleading c as many comparison points will interpolate between the same gridpoints, just c in a different order, and thus will have identical interpolated log10(Kappa) c values. For C = O = 0.0, the maximum differences are small, less than 1%; c however, the CO-interpolation can induce somewhat larger errors in opacities c of CO-rich mixes at low metallicity: for logT > 6 at X = 0.0 (where CO-rich c opacities are likely to be needed), the maximum differences do not exceed c 1% for Z > 0.001, but they can be as high as 8% for 0.0001 < Z < 0.001, and c can reach 11% for Z < 0.0001. c c "max" gives some indications of combined Z- and CO-interpolation errors: c ------------------------------------------------------------------------ c c dLogKappa for: <-------- max{C,O} > 0.0 ---------> c <------ C = O = 0.0 , all X ------> <----On-Grid----> <----Off-Grid---> c <----On-Grid----> <----Off-Grid---> all X X = 0.0 all X X = 0.0 c Z 46 46 logT>4 logT>6 logT>4 logT>6 c ===== -------- -------- -------- -------- -------- -------- -------- -------- c .00001:N= 3895 2075 27695 15375 273426 21580 7185558 315535 c max -.000038 .000067 -.000069 .000121 -.066377 .009322 -.093110 .012053 c rms .000003 .000004 .000004 .000004 .000178 .000103 .000174 .000074 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c .00005:N= 3895 2075 27695 15375 279396 21995 7228628 314790 c max -.000080 .000171 -.000156 .000310 .046540 .039973 -.118741 .046853 c rms .000008 .000009 .000010 .000010 .000401 .000363 .000352 .000230 c .0002:-------- -------- -------- -------- -------- -------- -------- -------- c max -.000214 .000447 -.000404 .000828 -.041788 .028401 -.058897 -.035296 c rms .000010 .000015 .000012 .000016 .000365 .000267 .000317 .000197 c .0005:-------- -------- -------- -------- -------- -------- -------- -------- c max -.000316 -.000304 -.000512 .000854 -.044971 .017734 -.061407 .020958 c rms .000025 .000025 .000032 .000030 .000357 .000155 .000271 .000121 c .0015:-------- -------- -------- -------- -------- -------- -------- -------- c max .001481 -.000494 .002325 .001390 -.019924 .001625 -.025380 .001904 c rms .000086 .000033 .000111 .000042 .000202 .000062 .000165 .000059 c .0030:-------- -------- -------- -------- -------- -------- -------- -------- c max -.001855 -.000593 -.002934 -.001971 -.006332 -.001797 .006585 -.002046 c rms .000107 .000032 .000138 .000049 .000181 .000076 .000158 .000072 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c .0070: N= 3895 2075 27695 15375 279396 21995 7218820 314790 c max .000882 .000475 .001406 -.001663 -.005493 .001000 -.008853 .001083 c rms .000054 .000026 .000070 .000041 .000098 .000044 .000111 .000043 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c .0150: N= 3895 2075 27695 15375 279396 21995 7199204 314790 c max -.000052 -.000111 -.000136 -.000213 -.009724 -.000550 .038904 -.001056 c rms .000002 .000010 .000003 .000009 .000087 .000019 .000482 .000019 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c .0250: N= 3895 2075 27695 15375 277008 21995 7137840 314790 c max .000087 -.000088 .000233 -.000140 -.003307 .000414 .036001 -.000738 c rms .000006 .000009 .000009 .000009 .000049 .000025 .000439 .000023 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c .0350: N= 3895 2075 27695 15375 277008 21995 7059376 314790 c max -.000253 -.000406 .002127 .000610 -.005123 -.000655 -.041995 -.000777 c rms .000024 .000031 .000032 .000033 .000099 .000046 .000626 .000050 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c .0450: N= 3895 2075 27695 15375 274620 21995 7022532 314790 c max .000980 .000782 .001798 .003339 .009452 .000765 .054504 .001237 c rms .000061 .000076 .000069 .000090 .000149 .000065 .000921 .000080 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c .0550: N= 3895 2075 27695 15375 268650 21995 6940230 311300 c max .000457 -.000596 .001611 -.001637 .004770 -.000654 .006170 .001523 c rms .000043 .000055 .000047 .000060 .000081 .000045 .000108 .000041 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c .0700: N= 3895 2075 27695 15375 266262 21995 6844538 311300 c max -.000404 -.000476 .001360 -.001767 .007161 -.000599 .042980 -.001666 c rms .000027 .000038 .000032 .000046 .000175 .000036 .000708 .000097 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c .0900: N= 3895 2075 27695 15375 263874 21995 6665478 311300 c max -.000236 .000500 -.001106 .002409 .008298 .000866 -.045470 .004078 c rms .000022 .000042 .000034 .000066 .000221 .000029 .000966 .000140 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c c c Z-interpolation errors when one uses linear Z-interpolation (Nzin = 2): c ======================================================================= c c If, for example, diffusion leads to relatively small Z-variations in a star c (say, of order 10%), then one might wish to use linear interpolation in logZ c by setting nZin = 2 in READZEXCO. (Note that opacity interpolation with c nZin = 2 will usually be significantly faster than nZin = 3 , which will c in general be faster than nZin = 4 ; however, all values of nZin > 4 take c the same amount of time as the nZin = 4 case, except for the slight added c start-up time to read in the extra opacity files). The size of the errors c introduced by nZin = 2 linear interpolation are easily estimated, e.g., by c comparing { nZin = 2, Zlo = .019, Zhi = .021 } opacities at Z = 0.02 with c the Z=0.02 opacity tables themselves. Such errors for the nZin = 2 case c are tabulated below for several values of Z, for two different cases with c Z-ranges of +/- 10% and of +/- 20%, respectively (referred to as cases "1" c and "2" in the table headings on the left). The mean errors are given as c well as the maximum and rms errors, since it is not unreasonable to expect c a systematic tendency from linear interpolation of a curve; however, they c turn out to be negligible (always < 0.04%) for a Z-range of +/- 10%. The c rms error in the Z-interpolation is likewise negligible (always < 0.2%) for c a Z-range of +/- 10%; the maximum errors are less than 1% for C = O = 0.0, c and also for Z > 0.001 at logT > 6 with X = 0.0, max{C,O} > 0.0, although c for Z < 0.001 the CO-interpolation can result in errors up to 9% in a few c places for CO-rich mixes. Even for a Z-range of +/- 20%, the mean errors c are always < 0.14%; the C = O = 0.0 case has rms errors < 0.2% and maximum c errors < 1.7%, while { Z > 0.001, logT > 6, X = 0.0, max{C,O} > 0.0 } has c rms errors < 0.21% and maximum errors < 1.4% (up to 9% for Z < 0.001). c c Errors if linear Z-interpolation is used, with Z-ranges +/-10% and +/-20%: c -------------------------------------------------------------------------- c c Z= 0.0001 0.001 0.004 0.01 0.02 0.03 0.05 0.08 c ======== ======== ======== ======== ======== ======== ======== ======== c Zlo1= 0.00009 0.0009 0.0036 0.009 0.018 0.027 0.045 0.072 c Zhi1= 0.00011 0.0011 0.0044 0.011 0.022 0.033 0.055 0.088 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c Zlo2= 0.00008 0.0008 0.0032 0.008 0.016 0.024 0.040 0.064 c Zhi2= 0.00012 0.0012 0.0048 0.012 0.024 0.036 0.060 0.096 c ======== ======== ======== ======== ======== ======== ======== ======== c C=O=0.0, OnGrid, logT>4 dLogKappa: c max1 -.000703 .001008 .001107 .000764 .000989 .000925 -.001984 .001149 c mean1 -.000026 .000017 .000065 .000103 .000133 .000145 .000150 .000149 c rms1 .000056 .000064 .000109 .000146 .000183 .000199 .000241 .000214 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c max2 -.002772 .001246 -.002859 .003076 .003924 .003731 .004402 .004059 c mean2 -.000103 .000043 .000238 .000416 .000537 .000583 .000612 .000609 c rms2 .000219 .000145 .000375 .000587 .000733 .000793 .000857 .000853 c ======== ======== ======== ======== ======== ======== ======== ======== c C=O=0.0, OffGrid, logT>4 dLogKappa: c max1 -.000707 -.002721 .003203 .001427 .002620 .002294 .003412 .002120 c mean1 -.000024 .000015 .000065 .000100 .000130 .000143 .000149 .000149 c rms1 .000051 .000076 .000119 .000141 .000178 .000197 .000245 .000213 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c max2 -.002806 -.002473 -.005426 .005459 .005472 .003856 .006457 .007094 c mean2 -.000095 .000041 .000232 .000405 .000524 .000573 .000606 .000605 c rms2 .000198 .000153 .000367 .000568 .000713 .000780 .000848 .000849 c ======== ======== ======== ======== ======== ======== ======== ======== c max{C,O}>0.0, X=0.0, OnGrid, logT>6 dLogKappa: c max1 -.032688 .000776 .000689 -.000687 .000569 .000581 -.001612 .000677 c mean1 -.000003 .000007 .000030 .000065 .000098 .000115 .000148 .000147 c rms1 .000221 .000024 .000063 .000117 .000163 .000190 .000248 .000219 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c max2 -.032967 .000873 .001402 .001871 .002107 .002235 .002763 .002591 c mean2 -.000005 .000027 .000122 .000262 .000395 .000464 .000589 .000593 c rms2 .000223 .000071 .000247 .000468 .000651 .000749 .000905 .000875 c ======== ======== ======== ======== ======== ======== ======== ======== c max{C,O}>0.0, X=0.0, OffGrid, logT>6 dLogKappa: c max1 -.038349 .001053 .000879 -.001188 -.000875 -.001059 -.002342 -.002052 c mean1 -.000002 .000007 .000029 .000064 .000097 .000114 .000148 .000148 c rms1 .000140 .000023 .000060 .000114 .000160 .000187 .000244 .000222 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c max2 -.038750 -.001171 .001398 .002108 .002854 -.003313 -.004253 -.006058 c mean2 -.000004 .000027 .000118 .000257 .000390 .000458 .000586 .000594 c rms2 .000156 .000071 .000239 .000458 .000641 .000740 .000898 .000881 c ======== ======== ======== ======== ======== ======== ======== ======== c max{C,O}>0.0, all-X, OnGrid, logT>4 dLogKappa: c max1 -.032688 -.025873 -.001446 .001413 -.003337 .003056 -.009148 .001397 c mean1 -.000017 .000015 .000039 .000078 .000106 .000121 .000134 .000137 c rms1 .000111 .000135 .000075 .000118 .000159 .000179 .000261 .000198 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c max2 -.036713 -.025350 .005615 .005444 .007725 -.008038 -.007972 .007035 c mean2 -.000058 .000047 .000154 .000320 .000439 .000495 .000567 .000569 c rms2 .000237 .000228 .000250 .000463 .000615 .000697 .000813 .000804 c ======== ======== ======== ======== ======== ======== ======== ======== c max{C,O}>0.0, all-X, OffGrid, logT>4 dLogKappa: c max1 -.038349 -.034450 -.004328 -.004072 -.028706 -.028234 -.047400 .041999 c mean1 -.000015 .000016 .000039 .000078 .000102 .000116 .000119 .000143 c rms1 .000073 .000101 .000075 .000116 .000377 .000375 .000776 .000729 c ----- -------- -------- -------- -------- -------- -------- -------- -------- c max2 -.050575 -.032346 .005371 .008759 -.027245 .052397 -.045954 .042481 c mean2 -.000056 .000050 .000152 .000318 .000432 .000494 .000546 .000576 c rms2 .000193 .000174 .000245 .000461 .000692 .000952 .001109 .001302 c ======== ======== ======== ======== ======== ======== ======== ======== c c c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c Details of opacity shifts from initial smoothing when opacities are read in c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c The opacity tables to be interpolated among (i.e., the OPAL files) are known c to have somewhat random numerical errors of a few percent. Consequently, c adjusting the data prior to performing the interpolation is justified at c this level. The code first reads the original (unsmoothed) tabular data; c this data is then passed through a smoothing filter, using a set of routines c developed by Mike Seaton (see M.J. Seaton, MNRAS 265, L25, 1993). It is the c adjusted data that is actually used in carrying out the interpolations in c OPAC or OPAL. The initial adjustment step helps improve the smoothness of c the OPAC output, particularly at the smallest values of R. The medium to c large R output is only slightly affected by this step. It takes only a c few seconds to carry out the initial data smoothing step, but this initial c smoothing can be skipped by calling the subroutine SET_SMOOTH (described c further above) with a value of initsmooth = 0 . c In addition, a few opacities in the mixes adjacent to the C=O=0.0 mix c (i.e., in the three mixes with C or O = 0.01, and C+O no more than 0.02) c are smoothed in the C-O direction, if opacity changes between mixes with c C,O = 0.0, 0.03, 0.1 are monotonic but the opacity at C,O = 0.01 does not c fit the trend; the resulting adjustments are small, and only occur at a c small minority of the (T6,R) points, but this smoothing can also be skipped, c by calling SET_SMOOTH (described further above) with lowCOsmooth = 0 . c c Maximum and rms differences between smoothed and unsmoothed opacity tables c for selected metallicities Z, for non-CO-rich mixes ("CO=0") and CO-rich c mixes ("CO>0") of each hydrogen abundance X, at intermediate temperatures c ("46"); note: T6 < 0.01 was omitted: c c Opacity shifts resulting from initial smoothing when they are read in: c ---------------------------------------------------------------------- c c dLogKappa for: c X = 0.00 0.03 0.10 0.35 0.70 c ------------ ------------ ------------ ------------ ------------ c max rms max rms max rms max rms max rms c Z=0.0: CO=0: ====== ===== ====== ===== ====== ===== ====== ===== ====== ===== c 46 .0172 .0023 .0175 .0022 .0160 .0021 .0125 .0016 -.0038 .0006 c CO>0: ------ ----- ------ ----- ------ ----- ------ ----- ------ ----- c 46 .0767 .0025 .0771 .0026 .0776 .0026 .0782 .0027 .0757 .0017 c Z=.001:CO=0: ====== ===== ====== ===== ====== ===== ====== ===== ====== ===== c 46 -.0149 .0022 -.0148 .0021 -.0145 .0020 -.0124 .0016 .0059 .0011 c CO>0: ------ ----- ------ ----- ------ ----- ------ ----- ------ ----- c 46 -.0324 .0023 -.0341 .0023 -.0362 .0024 -.0369 .0024 -.0153 .0015 c Z=.02: CO=0: ====== ===== ====== ===== ====== ===== ====== ===== ====== ===== c 46 -.0108 .0021 -.0113 .0021 -.0110 .0021 -.0107 .0020 -.0083 .0017 c CO>0: ------ ----- ------ ----- ------ ----- ------ ----- ------ ----- c 46 -.0303 .0023 -.0320 .0023 -.0345 .0024 -.0343 .0024 -.0140 .0016 c Z=.10: CO=0: ====== ===== ====== ===== ====== ===== ====== ===== ====== ===== c 46 -.0093 .0021 -.0096 .0021 -.0097 .0021 -.0096 .0021 -.0087 .0018 c CO>0: ------ ----- ------ ----- ------ ----- ------ ----- ------ ----- c 46 -.0246 .0023 -.0262 .0023 -.0273 .0024 -.0259 .0023 -.0095 .0017 c c For T6 > 0.01, the rms effect of the smoothing is always less than 2%, i.e., c comparable to the Z-interpolation errors found for the CO-rich mixes above, c and smaller than the estimated opacity computation errors. c c c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c Details of differences in CO-rich opacities from COINTSMO vs. COINTERP c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c Use of the smoother CO-interpolation routine COINTSMO (rather than the old c routine COINTERP) yields opacities that differ at only a few grid-points c (those which COINTERP ignores when interpolating opacities), but that differ c over a significant area of the CO-plane between grid-points. Opacities c were compared at points chosen randomly in log T, log RHO, C, and O (always c with C+O > 0, and with some excess probability of having either C=0, O=0, c or C+O=1-X-Z). Opacity differences are tabulated below for selected c metallicities Z, for X = 0 and for two ranges of non-zero X, at intermediate c temperatures ("46"); note that very c low temperatures (T6 < 0.01) were omitted: c c CO-interpolation differences: from using subroutines COINTSMO vs. COINTERP: c --------------------------------------------------------------------------- c c dLogKappa for: X = 0.0 0.0 < X < 0.35 0.35 < X < 0.8 c ------------------- ------------------- ------------------- c N max rms N max rms N max rms c Z=0.0: ====== ====== ===== ====== ====== ===== ====== ====== ===== c 46 252334 -.0198 .0009 109760 -.0575 .0045 142313 .1272 .0062 c Z=0.001: ====== ====== ===== ====== ====== ===== ====== ====== ===== c 46 251965 -.0195 .0008 109603 -.0568 .0045 142087 .1259 .0061 c Z=0.02: ====== ====== ===== ====== ====== ===== ====== ====== ===== c 46 251235 -.0161 .0006 109266 .0538 .0039 141670 .1031 .0051 c Z=0.1: ====== ====== ===== ====== ====== ===== ====== ====== ===== c 46 250923 -.0104 .0003 109122 .0452 .0029 141482 .0812 .0039 c c The routine COINTERP may have opacity discontinuities of the same order as c the opacity differences (up to 5%, for X=0 and logT > 6; larger elsewhere), c at those points where it switches over from interpolation in one direction c to interpolation in another direction, interpolating among a different set c of gridpoints (this generally occurs somewhere in the region O = C +/- 0.2). c c c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c Details of the individual OPAL opacity tables and program storage space c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c Each of the individual tables in a file Gz???.x?? covers 70 temperatures c in the range logT=3.75 [T6=0.0056341325] (referred to as temperature 1) to c logT=8.7 [T6=501.187] (note that the logT step size is 0.05 below logT=6.0, c 0.10 below logT=8.1, and 0.20 above that), and covers 19 values of log R in c the range logR=-8.0 (referred to as 1) to logR=+1.0, at half-integer steps. c (NOTE: earlier tables were explicitly in terms of T6. For convenience the c present tables tabulate log Kappa vs logT. The interpolation however still c uses logT6 for the temperature variable, not logT.) Values of Z from 0.0 c to 0.1 are available (at up to 14 values of Z). Type 2 OPAL tables have c 8 Z-values from Z = 0.0 to Z = 0.1 and 5 X-values from X = 0.0 to X = 0.7 c (plus 8 each of excess-C and excess-O values from 0.0 to 1 - X - Z), while c Type 1 OPAL tables have 13 Z-values from Z = 0.0 to Z = 0.1 and 10 X-values c from X = 0.0 to X = 1 - Z (but with less-good X-interpolation at low X); c combining these tables allows accurate X-interpolation at all X, and more c accurate Z-interpolation among 14 Z-values. c The sizes of the matrices (holding the input opacities) are set by the c constant values in parameter statements. The number NZ of available c Z-storage values was mentioned above (in the discussion of the inputs to the c subroutine READZEXCO); its value in the parameter statements can be changed c to any value between 1 and 14 (provided that it is the same everywhere!) and c the program recompiled. Smaller values of NZ yield smaller ranges where c Z can be interpolated (or less accurate interpolation over a wide range), c but also save storage space; NZ = 5 is a reasonable compromise. Low values c (NZ = 2 or 3) yield less accurate interpolation, but reduce both the storage c space and the typical amount of CPU-time per opacity interpolation, since c fewer Z-grid values need to be computed in general. For NZ = 1, only a c constant Z can be accomodated. Other than NZ, no size parameter of the OPAL c matrices should be changed. c The molecular and conductive opacity matrix sizes are independent of NZ, c taking up about 1 Mb; their sizes should never be changed. The Ferguson et c al. (2005) molecular opacity tables have the same range in logR as the OPAL c tables, but with 2.7 < logT < 4.5 (or possibly 2.8 < logT < 4.5 for some c cases); they are available at 16 Z-values from Z = 0.0 to Z = 0.1, and at c 10 X-values from X = 0.0 to X = 1 - Z. For low X, their X-interpolation is c less accurate (but at low temperatures where molecular opacities are needed c one seldom will encounter X values close to zero). c c Roughly (1.1 Mb) + NZ * (1.63 Mb) of storage space is required in total. c c c****************************************************************************** c block data opal_opac_data c ========================= c parameter ( small_1m6=1.e-6 ) c c COMMON BLOCK DATA INITIALIZATIONS: c ---------------------------------- c c PARAMETERS defining the matrices used to hold the opacity values: c nz = 14 = maximum number of Z-tabulation values (see arrays zavail, zsto) c mx = 5 = number of X-tabulation values (see array xa) c mc = mo = 8 = number of C- and O-tabulation values (see arrays xcs and xos) c nrm = 19 = maximum number of R-tabulation values (see array alrf) c nrb = 1 = index of lowest R-value to be stored \ default: store c nre = 19 = index of highest R-value to be stored } all 19 R-values c nr = nre-nrb+1 = 19 = number of R-values to be stored / c ntm = 70 = maximum number of T-tabulation values (see array flogtin) c ntb = 1 = index of lowest T-value to be stored \ default: store c nt = ntm-ntb+1 = 70 = number of T-values to be stored / all 70 T-values c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c c PARAMETERS nrdel and ntdel give matrix position differences that result from c any reduction of nr or nt due to increased nrb or ntb values, respectively c parameter ( nrdel=nrb-1, ntdel=ntb-1 ) c c PARAMETERS: c zdel = 0.001 = offset for Z, Z+C, and Z+O, to make log interpolation behave c reasonably at small Z values: Z-interpolation is performed c using log(Z+zdel), while the CO-interpolation is performed c using log(C+Z+zdel) and log(O+Z+zdel) c xdel = 0.03 = usual (high-T) offset for X, to make log interpolation behave c reasonably at small X; note that 0.03 works better than 0.005 c xdelmin = 0.001 = lowest value of X offset ever used (at low temperatures) c parameter ( zdel=0.001, xdel=0.03, xdelmin=0.001 ) c c PARAMETERS defining the storage for the additional X-values from 'GN93hz': c mx_hi = 10 = number of X-values contained in 'GN93hz'. c mo_m1 = mo - 1 = 7 : used for the position in the matrix co() below where c some of the 'GN93hz' opacity-shifts will be stored c (see COMMON /a_opal_z/ below, for this matrix) c mx_hi_nz = mx_hi * nz : the number of initialization values requred for the c matrix xhi_use() in COMMON /xhi_opal_z/ below. c parameter ( mx_hi=2*mx, mo_m1=mo-1, mx_hi_nz=mx_hi*nz ) c c COMMON /xhi_opal_z/ : auxiliary matrices for additional 'GN93hz' X-values: c xhi_in(mx_hi) = { 0.0, 0.1, 0.2, 0.35, 0.5, 0.7, 0.8, 0.9, 0.95, 1.0 }, c the X-values contained in 'GN93hz' (for the case Z=0.0) c xcno_use(mx_hi,nz) = the 'GN93hz' X-values available for each stored Z-value c (indexed by kz = 1, ..., numz); note that for each c value of kz the highest X-value is 1 - Z(kz) c xhi_use(mx_hi,nz) = the 'GN93hz' X-values same as xcno_use(mx_hi,nz), except c that xhi_use(1,kz) = 0.03 (from 'Gz???.x03' files) c xxx_cno(mx_hi) = log10( xhi_in() + xdel ) = logarithmic 'GN93hz' X-values c xxx_hi(mx_hi) = logarithmic 'GN93hz' X-values same as xxx_cno(mx_hi), except c that xxx_hi(1) = log10( 0.03 + xdel ) c nx_hi(nz) = number of 'GN93hz' X-values in xhi_use() at each stored Z-value c ireq_hi(mx_hi) = flags to tell whether the corresponding 'GN93hz' X-values c are unavailable from the 'Gz???.x??' files c khighx(nz) = flag to tell whether the 'GN93hz' opacities were read in, for c each of the stored Z-values c kavail_xhi = flag to tell whether the 'GN93hz' opacities are available c kuse_xhi = flag to tell whether the 'GN93hz' X-values should be used for c X-interpolation (see description of subroutine SET_XHI above) c kdo_xhi = internal flag controlling use of the 'GN93hz' X-values c kavail_cno = flag to tell whether the CNO-interpolation deltas are available c kuse_cno = flag to tell whether CNO-interpolation should be performed c kdo_cno = internal flag controlling use of CNO-interpolation c kavail_user = flag to tell whether user-interpolation deltas are available c kuse_user = flag to tell whether user-interpolation should be performed c kdo_user = internal flag controlling use of user-interpolation c c /xhi_opal_z/: --> data{ALL} common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c c COMMON /a_opal_z/ : matrices for opacity storage and interpolation: c indx(101) is used to get tabulation-index from excess C or O values: INDX c (see data) refers to the index i of abundance grid points xc(i) c or xo(i): e.g., i = indx( int( 100. * max( C , 0. ) + 1. ) ) c t6list(nt) = stored-grid T6 values (obtained from logT values) c alr(nr) = stored-grid log(R) values (at log(R)-intervals of 0.5) c n(mx,mo,nz) = the number of different C-tables present at each X-tabulation, c O-tabulation, and Z-tabulation value (see also array nofz c in common/zinter_opal_z/ ) c alt(nt) = stored-grid log(T6) values; note log(T6) = log(T) - 6. c dfs(nt) = stored-grid inverse log(T6)-spacing: dfs(i) = 1./[alt(i)-alt(i-1)] c (note that dfs(1) = dfs(2), for convenience) c dfsr(nr) = stored-grid inverse log(R)-spacing (unlike dfs, the dfsr values c are all equal): dfsr(i) = 1./[alr(i)-alr(i-1)] = 2. c b(3) is used to hold intermediate values during C-O interpolation c m = the index of the current X-table c mf = the lowest (first) index of the X-table(s) needed for X-interpolation c xa(8) = the tabulated X-values: actually there are only five (see "data"), c namely, xa(1:5) = { 0.0, 0.03, 0.1, 0.35, 0.7 } c alrf(nrm) = opacity-file-grid log(R) values (note that this grid, with nrm c log(R) values, may be larger than the stored-grid, with nr) c flogtin(ntm) = opacity-file-grid log(T) values (again, ntm may be > nt) c dfsx(mx) = inverse logarithmic-X-grid spacings: dfsx(i) = 1./[xx(i)-xx(i-1)] c oxf(mx,mc,nz) = logarithmic-O-grid tabulation values for a given C value: c for each X-table index m and Z-table index k, oxf(m,i,k) = c log10[ min{ xos(i) , 1-xa(m)-zsto(k) } + zsto(k) + 0.001 ] c cxf(mx,mo,nz) = logarithmic-C-grid tabulation values similarly c xcdf(mx,mo,nz) = maximum possible C value for a given O value: c for each X-table index m and Z-table index kz, c xcdf(m,i,kz) = 1 - xa(m) - zsto(kz) - xo(i) c xodf(mx,mc,nz) = maximum possible O value for a given C value, similarly c itime = "opacities available" flag (initially 0): itime is set to 12345678 c when all opacities have been read in. c cxdf(mx,mo,nz) = logarithmic maximum C value for a given O value: c for each X-table index m and Z-table index kz, c cxdf(m,i,kz) = log10[ xcdf(m,i,kz) + zsto(kz) + 0.001 ] c oxdf(mx,mc,nz) = logarithmic maximum O value for a given C value, similarly c q(4) = temporary: opacity-derivative at each T, in T-R interpolation c h(4) = temporary: opacities log10(Kappa) at each T, in T-R interpolation c xcd(mc) = maximum possible C at present m and kz: xcd(i) = xcdf(m,i,kz) c xod(mc) = maximum possible O at present m and kz: xod(i) = xodf(m,i,kz) c xc(mc) = C-tabulation at present m and kz: xc(i) = min{ xcs(i) , 1-xa(m)-Z } c xo(mo) = O-tabulation at present m and kz: xo(i) = min{ xos(i) , 1-xa(m)-Z } c xcs(mc) = C-tabulation values: see "data" c xos(mo) = O-tabulation values: see "data" c cxd(mc) = logarithmic maximum C value for a given O value at present X-table c index m and Z-table index kz: cxd(i) = cxdf(m,i,kz) c oxd(mo) = logarithmic maximum O value for a given C value, similarly c cx(mc) = logarithmic-C-grid tabulation values at present X-table index m and c Z-table index kz: cx(i) = cxf(m,i,kz) c ox(mo) = logarithmic-O-grid tabulation values at present m, similarly c zzz(nz) = shifted Z-value (for logarithmic interpolation purposes): c for each Z-table index kz, zzz(kz) = zsto(kz) + 0.001 c xxh = xh = stored value of desired X value (xxh is never actually used) c xx(mx) = logarithmic-X-grid tabulation values: xx(i) = log10[ xa(i) + 0.03 ] c (note that previous program versions added 0.005 rather than 0.03; c the latter works better for X near zero at log(T) > 5.) c nc = n(m,1,kz) = number of C-grid values available at X,Z-table indices m,kz c no = nc = number of O-grid values, similarly c zsto(nz) = stored Z-values available for Z-interpolation c zvint(nz) = logartihmic stored Z-values: zvint(i) = log10[ zsto(i) + 0.001 ] c dfsz(nz) = inverse log-Z-grid spacings: dfsz(i) = 1./[zvint(i)-zvint(i-1)] c zacc(nz) = accuracy with which Z must match the corresponding stored Z-value c in order to be considered equal to it c zlow,zmiddle,zhigh = lowest, "typical", and highest stored Z-values c zlo_ex,zhi_ex = extreme Z-limits for Z-extrapolation c numz = number of stored Z-values available for Z-interpolation c c-SIZE 4*(101+3*nt+ntm+2*nr+nrm+10*mc+mx+3+2+8+1+2*4+1+2+6) c + nz * 4*(7*mx*mc+5) = 0.002 + (nz/14) * 0.015 Mb c c /a_opal_z/: --> data{indx,xcs,xos,xa,itime} common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c c COMMON /a_co_opal_z/ : matrix for actual opacity storage (was in /a_opal_z/): c co(mx,mc,mo,nt,nr,nz) = stored opacities log10(Kappa): co(m,i,j,k,l,kz) = c log10[ Kappa(X_m,C_i,O_j,T_k,R_l,Z_kz) ] , where c X_m = xa(m), C_i = min{xcs(i),1-xa(m)-Z-xos(j)}, c O_j = xos(j), T_k = alt(k), R_l = alr(l), and c Z_kz = zsto(kz); except that, for j = mo, the c "diagonal" tables are stored, with C_i = xcs(i) and c O_j = 1-xa(m)-zsto(kz)-xcs(i). Note that not quite c all (m,i,j) locations are used; unused locations c (m,mc,mo,...) and (m,mc,mo-1,...) are used for c temporary storage for opacities from 'GN93hz' and c the file with non-zero [O/Fe], if these are used. c****************************************************************************** c Note that the old arrays "diag" & "diago" are not needed; here: c co(m,n(m,i,kz),i,it,ir,kz) = diag(m,i,it,ir,kz) and c co(m,i,mo,it,ir,kz) = diago(m,n(m,1,kz)-i,it,ir,kz) = diago(m,no-i,it,ir,kz) c****************************************************************************** c opk(mx,4) = temporary: for each X-table index m used in the X-interpolation, c opk(m,1:4) holds the log10(Kappa) value and the derivatives c with respect to T (at constant R), to R (at constant T), and to c T (at constant density), for that m value (already interpolated c in C, O, Z, T, and R) c opl(nt,nr,nz) = temporary: for each stored-grid (T_k,R_l,Z_kz) value used in c the T-R-Z interpolation, opl(k,l,kz) holds the opacity c log10(Kappa) at that T_k, R_l, and Z_kz (already c interpolated in C and O); the Z-interpolated values at each c (T_k,R_l) are subsequently stored in opl(k,l,1) c cof(nt,nr) = temporary: in the subroutine READEXCO, cof is used temporarily c to hold the opacities for non-zero [O/Fe] where they will not c be overwritten when reading in the 'GN93hz' opacities; in the c subroutine COINTSMO, cof is used temporarily to hold some c logarithmic C and O grid-values c c-SIZE 4*(nt*nr+mx*4) + nz * 4*(mx*mc*mo+1)*nt*nr = 0.005 + (nz/14) * 22.800 Mb c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c c COMMON /b_opal_z/ : high and low logT6 and logR limits, and mix Z-values: c nta(0:nrm+1) = maximum T-index where opacity values exist for each R-index; c if nre < nrm, then nta(nre+1:nrm) will be set to -99, to c indicate that no opacities are present there (values at c positions < nrb are NOT reset, however); see "data" c ntax0(0:nrm) = minimum T-index where opacity values exist in the X=0.0 (m=1) c tables; if nrb > 1, then ntax0(0:nrb-1) will be set to 999, c to indicate that no opacities are present there (values at c positions > nre are NOT reset, however). The worst-case c values given below (see "data") are reset to the actual c values when the opacities are read in by READEXCO c ntax03(0:nrm) = minimum T-index in the X=0.03 (m=2) tables, similarly c sltlo, slthi = low and high logT6 limits: a logT6 value outside this range c is considered to require extrapolation (by default these c these limits lie at the boundaries of the matrix; they may c be reset to lie inside it, but not outside it) c dltlo_inv, dlthi_inv = (inverse of) allowed extrapolation delta_logT6 beyond c the above limits sltlo, slthi: by default, one grid c spacing beyond the edge of the matrix (they can be c reset, but in no case will extrapolation be allowed c more than one grid spacing beyond the matrix edge) c slrlo, slrhi = low and high logR limits (handled similarly to logT6 limits) c dlrlo_inv, dlrhi_inv = (inverse of) allowed extrapolation delta_logR c c /b_opal_z/: --> data{ALL} common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c c COMMON /bb_opal_z/ : some indices & abundances for T6,R and C,O interpolation c c /bb_opal_z/: --> data{ALL} common/bb_opal_z/ xodp,xcdp,xxco,cxx,oxx, $ l1,l2,l3,l4,k1,k2,k3,k4,ip,iq(4),kzf,kzg,kzh,kzf2 save /bb_opal_z/ c c COMMON /c_pot_indices/ : indices for Potekhin 2006 conductive opacities c c /c_pot_indices/: --> data{ALL} common /c_pot_indices/ zkpot(0:3,0:3), zlg_pot_p, i1pot_p, $ i4pot_p, j1pot_p, j4pot_p, i1pot, i2pot, i3pot, i4pot, $ j1pot, j2pot, j3pot, j4pot, k1pot, k2pot, k3pot, k4pot save /c_pot_indices/ c c COMMON /e_opal_z/ : variables returning opacity values, as described above c c /e_opal_z/: --> data{ALL} common/e_opal_z/ opact,dopact,dopacr,dopactd,fedge,ftredge,fzedge save /e_opal_z/ c c COMMON /x_opal_z/ : variables containing stored OPAL_F_CNOU input values c c /x_opal_z/: --> data{ALL} common /x_opal_z/ z_opal, x_opal, xc_opal, xo_opal, slt_opal, $ slr_opal, fcn_opal, fcon_opal, fcnone_opal, fu_opal save /x_opal_z/ c c COMMON /recoin_opal_z/ : c itimeco = 12345678 after initializations have been carried out (init-flag) c mxzero = 1 is set to the X-index of the mix with X=0 c mx03 = 2 is set to the X-index of the mix with X=0.03 c kope is the length of the directory-name (where the opacity files are) c igznotgx is a flag to tell whether the OPAL opacity file names are in the c new form Gz???.x?? rather than the old form Gx??z* c (initially, igznotgx = 0 meaning "look for either") c c /recoin_opal_z/: --> data{ALL} common/recoin_opal_z/ itimeco,mxzero,mx03,kope,igznotgx save /recoin_opal_z/ c c COMMON /alt_change_opal_z/ : c main_alt_change = 0 unless a new file has been set to replace 'GS98hz' c iulow = 23 (by default) = the beginning Fortran unit number for reading c opacity files; Fortran units iulow through iulow + 3 may be used. c khighz_in = khighz value used when reading opacities. c ofebrack_in = [O/Fe] value used when reading opacities. c c /alt_change_opal_z/: --> data{ALL} common /alt_change_opal_z/ main_alt_change, iulow, khighz_in, $ ofebrack_in save /alt_change_opal_z/ c c PARAMETERS defining the matrices used to hold the mix compositions: c nel_zmix = 19 = number of heavy elements in the opacity mixture (C thru Ni) c n_zmixes = 5 = number of "hz" opacity files available (the fifth one is for c a user-supplied "hz" opacity file, with non-zero [O/Fe]) c kel_o = 3 = position of oxygen (O) in the list of mix-elements c kel_fe = nel_zmix-1 = 18 = position of iron (Fe) in the list of mix-elements c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c c COMMON /opalmixes/ : makeup of Z in opacity mixtures (described above): c c-SIZE 4*((2*nel_zmix+2)*n_zmixes+3*nel_zmix)+2*nel_zmix+8*n_zmixes = 0.001 Mb c c /opalmixes/: --> data{ALL BUT xofe_opalmixes} c-implicit; real*4 xiz_mix,fninz_mix,bracketife_mix,bracketofe_opalmixes, c-implicit; $ xofe_opalmixes,xiz_opalmixes,fninz_opalmixes character*2 cel_opalmixes(nel_zmix) character*8 cfile_opalmixes(n_zmixes) common/opalmixes/ xiz_mix(nel_zmix),fninz_mix(nel_zmix), $ bracketife_mix(nel_zmix),bracketofe_opalmixes(n_zmixes), $ xofe_opalmixes(n_zmixes),xiz_opalmixes(nel_zmix,n_zmixes), $ fninz_opalmixes(nel_zmix,n_zmixes), $ cel_opalmixes,cfile_opalmixes save /opalmixes/ c c n_totmix = 10 = n_zmixes + 5 = number of "GS98hz" opacity files available, c plus 5 more files for CNO-interpolation and c user-specified interpolation. c n_cnobeg = 6 = n_zmixes + 1 = position of first CNO-interpolation filename, c usually the same as the default mix used c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c c COMMON /opalGS98mixes/ : makeup of Z in GS98 opacity mixtures (see above): c c-SIZE 4*(2*(n_totmix+1)*(nel_zmix+1)+nel_zmix) + 255*(n_totmix+1) = 0.004 Mb c c /opalGS98mixes/: --> data{ALL BUT xofe_opalGS98} c-implicit; real*4 bracketofe_opalGS98, xofe_opalGS98, xiz_opalGS98, c-implicit; $ fninz_opalGS98, atwt_opalGS98 character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c c COMMON /c_meteor_mix_opal_z/ : meteoritic mixes for GN93, GS98, AGS04 c c-SIZE 4*(2*nel_zmix*n_mix_meteor+nel_zmix) + 255*n_mix_meteor = 0.001 Mb c c /c_meteor_mix_opal_z/: --> data{ALL} parameter ( n_mix_meteor = 3 ) double precision xiz_meteor, fninz_meteor character*255 cfile_meteor(n_mix_meteor) common /c_meteor_mix_opal_z/ xiz_meteor(nel_zmix,n_mix_meteor), $ fninz_meteor(nel_zmix,n_mix_meteor), $ nuc_charge_opalmixes(nel_zmix), cfile_meteor save /c_meteor_mix_opal_z/ c c COMMON /c_mixfiles_used_opal_z/ : meteoritic mixes for GN93, GS98, AGS04 c c-SIZE 255*(n_totmix+2) = 0.003 Mb c c /c_mixfiles_used_opal_z/: --> data{ALL} character*255 cfile_opal_used(-1:n_totmix) common /c_mixfiles_used_opal_z/ cfile_opal_used save /c_mixfiles_used_opal_z/ c c COMMON /ext_CNO_opal_z/ : default extensions for CNO-interpolation files: c c-SIZE (80+4)*(n_totmix-n_cnobeg+1) = 0.0004 Mb c c /ext_CNO_opal_z/: --> data{ALL} character*80 cdef_CNO_ext(n_cnobeg:n_totmix) common /ext_CNO_opal_z/ len_def_CNO_ext(n_cnobeg:n_totmix), $ cdef_CNO_ext save /ext_CNO_opal_z/ c c PARAMETERS defining the matrices used for the Z-interpolation: c mz = 8 = number of metallicities Z available in the 'Gz???.x??' files c mzhi = 11 = number of Z-indices for the mix-number matrix nofz (see below) c mzal = 13 = number of metallicities Z available in the 'GN93hz' file c nzm = 14 = combined total number of metallicities Z available in files c nadd_zavail = 6 = number of metallicities Z besides those in 'Gz???.x??' c parameter ( mz=8, mz_m1=mz-1, mz_m2=mz-2, mzhi=11, mzal=13, $ nzm=mzal+1, nadd_zavail=nzm-mz ) c c COMMON /zinter_opal_z/ : values used in Z-interpolation: c zvalhi(mzhi) = Z-range limits for the mix-number matrix nofz (see below) c nofz(mzhi,5,mo) = the number of different C-tables at each O-tabulation and c X-tabulation value, for each relevant range of Z c mnofz(mx) = X-table m-index in nofz corresponding to the m-index in xa(mx): c if the X-table abundances in xa are unchanged, mnofz(i) = i c zval(mz) = Z-tabulation values available in the 'Gz???.x??' files c zalval(mzal) = Z-tabulation values available in the 'GN93hz' file c zavail(nzm) = combined Z-tabulation values available in the files c iadd_zavail(nadd_zavail) = best order in which to reduce the intervals in c zval() by adding metallicities from zavail() c c /zinter_opal_z/: --> data{ALL} common/zinter_opal_z/ zvalhi(mzhi),nofz(mzhi,5,mo),mnofz(mx), $ zval(mz),zalval(mzal),zavail(nzm),iadd_zavail(nadd_zavail) save /zinter_opal_z/ c c COMMON /czinte_opal_z/ : the X- and Z- parts of the 'Gx??z*' file names; c also used to specify the 'Gz???.x??' file names: c c /czinte_opal_z/: --> data{ALL} character*4 cxfil(5),czfil(mz) common/czinte_opal_z/ cxfil,czfil save /czinte_opal_z/ c c COMMON /c_opal_ctrl_smooth/ : flags to control the opacity smoothing: c init_smo = 0 : do not smooth the opacities on input c = 1 : on input, subroutine OPALTAB smooths the opacities, but do c NOT smooth the CNO-interpolation opacity deltas c = 2 (default): on input, subroutine OPALTAB smooths the opacities, c including those used to get the CNO-interpolation deltas c low_CO_smo = 0 : do not perform this CO-direction smoothing c = 1 (default): on input, a few opacities in the 3 mixes adjacent c to the C=O=0.0 mix (i.e., the 3 mixes with C or O = 0.01, c C+O no more than 0.02) are smoothed in the C-O direction, c if opacity changes between mixes with C,O = 0.0, 0.03, 0.1 c are monotonic but the opacity at C,O = 0.01 does not fit c the trend; the resulting adjustments are small, and only c occur at a small minority of the (T6,R) points c interp_CO_smo = 0 : use the old subroutine COINTERP for interpolating among c CO-rich opacities when OPAC or OPAL is called c = 1 (default): use the new subroutine COINTSMO instead, for c smoother interpolation among CO-rich opacities c c /c_opal_ctrl_smooth/: --> data{ALL} common/c_opal_ctrl_smooth/ init_smo, low_CO_smo, interp_CO_smo save /c_opal_ctrl_smooth/ c c COMMON /opdir/ : copdir = the name of the directory holding opacitythe files; c here it is initialized to be blank, meaning "use the current directory". c c /opdir/: --> data{copdir} character*255 copdir common/opdir/ copdir save /opdir/ c c PARAMETERS defining storage for the molecular opacities c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c c COMMON /mat_alex_ferg/ : storage for molecular opacities c flk_ferg(nr_ferg,nt_ferg,nz_ferg,nx_ferg) : storage for Ferguson et al. 2005 c molecular opacities c flk_alex(nrlo_alex:nr_alex,nt_alex,nzp1_alex,nx_alex) : alternatively, this c equivalenced matrix c holds Alexander & Ferguson 1994 molecular opacities c c-SIZE 4*nr_ferg*nt_ferg*nz_ferg*nx_ferg = 0.986 Mb c common /mat_alex_ferg/ flk_ferg(nr_ferg,nt_ferg,nz_ferg,nx_ferg) save /mat_alex_ferg/ dimension flk_alex(nrlo_alex:nr_alex,nt_alex,nzp1_alex,nx_alex) equivalence (flk_alex(nrlo_alex,1,1,1),flk_ferg(1,1,1,1)) c c COMMON /opac_alex/ : logX,logZ for Alexander 1994 molecular opacities c common /opac_alex/ zlog_alex(nzp1_alex),xlog_alex(nx_alex), $ dzinvlog_alex(nzp1_alex),dxinvlog_alex(nx_alex) save /opac_alex/ c c COMMON /opac_ferg/ : logZ,logX,logT6,logR for Ferguson et al. 2005 opacities c c-SIZE 4*(nzp1_ferg+3*nx_ferg+2*nz_ferg+2*nt_ferg+2*nr_ferg+3) = 0.001 Mb c common /opac_ferg/ zlog_ferg(nzp1_ferg), xlog_ferg(nx_ferg), $ dzinvlog_ferg(nz_ferg), dzinv_ferg(nz_ferg), $ dxinvlog_ferg(nx_ferg), dxinv_ferg(nx_ferg), $ t6log_ferg(nt_ferg), rlog_ferg(nr_ferg), $ dt6inv_ferg(nt_ferg), drinv_ferg(nr_ferg), $ modt_ferg, modz0_ferg, ntuferg save /opac_ferg/ c c COMMON /c_ini_ferg/ : Z, X, logT, and logR grids for Ferguson 2005 opacities c z_ferg(nz_ferg) = the 16 Z-values, for each Z-index c x_ferg(nx_ferg) = the 10 X-values, for each X-index c iacc_ferg = 1 (default): handle big opacity-jumps at low T better, 0: don't c igot_t_ferg = 0: logT-values have not yet been read in, 1: they have been c igot_r_ferg = 0: logR-values have not yet been read in, 1: they have been c itype_ferg = index of Ferguson 2005 opacity type that was last read in: c 1 = case specified by CFILE_ALEX (see SET_ALEX_FILE), c 2 = GN93 case, 3 = GS98 case, 4 = L03 case, c 5 = AGS04 case, 6 = S92 case, 7 = S92AE case, c 8 = GS98-.2 case, 9 = GS98+.2 case, 10 = GS98+.4 case, c 11 = GS98+.4 case, 12 = GS98+.8 case, c 99 = user-specified case (see SET_FERG_USER). c lsep_ferg = length of Ferguson 2005 separator string csep_ferg (default 1) c lext_ferg = length of Ferguson 2005 extension string cext_ferg (default 4) c ltype_ferg(ntyp1_ferg) = lengths of typenames in ctype_ferg() c itype_def_ferg(ntyp1_ferg) = indices to try if cannot match OPAL opacities c ione_ferg(ntyp1_ferg) = 1 if .one.tron exists, 0 if .10.0.tron, c -1 if this is not known c lz_ferg(nz_ferg) = lengths of Z-specifications in cz_ferg() c lx_ferg(nx_ferg) = lengths of X-specifications in cx_ferg() c cz_ferg(nz_ferg) = Z-specifications in filename for each Z-index c cx_ferg(nx_ferg) = X-specifications in filename for each X-index c ctype_ferg(ntyp1_ferg) = Ferguson 2005 typenames for indices 2 to ntype_ferg c csub_ferg(ntyp1_ferg) = subdirectories to check for corresponding files c csep_ferg = Ferguson 2005 separator string (default '.') c cext_ferg = Ferguson 2005 extension string (default 'tron') c c-SIZE 4*(3*ntyp1_ferg+2*nz_ferg+2*nx_ferg+6) + 80*(2*ntyp1_ferg+2) c + 5*(nz_ferg+nx_ferg) = 0.002 Mb c c /c_ini_ferg/: --> data{ALL} character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c c COMMON /c_ofe_in_ferg/ : For Ferguson et al. 2005 opacities: non-zero [O/Fe] c and its mix-index, and mix-index for corresponding c mix with [O/Fe] = 0 (for 's92ae' and 's92') c Note: if g98 gs98-.2 gs98+.2 gs98+.4 ... are found, they will be used instead c c /c_ofe_in_ferg/: --> data{ALL} common /c_ofe_in_ferg/ ofein_ferg, i_ofe_ferg, i_ofe0_ferg save /c_ofe_in_ferg/ c c COMMON /c_prev_ferg/ : specifications for cached Z,X-interpolated Ferguson et c al. 2005 opacities (Z, X, T-range, and R-range) c /c_prev_ferg/: --> data{ALL} common /c_prev_ferg/ zlogp_ferg, xp_ferg, zlp1_ferg, xp1_ferg, $ zlp2_ferg, xp2_ferg, i1p_ferg, i4p_ferg, j1p_ferg, j4p_ferg save /c_prev_ferg/ c c COMMON /c_tsw_ferg/ : switchover factors OPAL <--> Ferguson et al. 2005 c default: logT6 values corresponding to flt_max_ferg = 4.5 , c fltswlo_ferg_def = 4.2 , fltswhi_ferg_def = 4.4 c c /c_tsw_ferg/: --> data{ALL} common /c_tsw_ferg/ slt_max_ferg, sltswlo_ferg_def, $ sltswhi_ferg_def, sltswlo_ferg, sltswhi_ferg, $ sltswmid_ferg, dltsw2inv_ferg save /c_tsw_ferg/ c c COMMON /c_ini_alex/ : Z, X, logT, and logRHO grids for Alexander opacities c c /c_ini_alex/: --> data{ALL} common /c_ini_alex/ z_alex(nzp1_alex),x_alex(nx_alex), $ flt_alex(nt_alex),flro_alex(nrlo_alex:nr_alex) save /c_ini_alex/ c c COMMON /c_filename_alex/ : c need_alex_dir = 1 if directory in copdir should be prepended, 0 if not c cfile_alex = filename (possibly including directory) from which to read c molecular opacities (DEFAULT: blank); for Ferguson 2005 case, c any characters following the directory specification are c interpreted as the beginning of the Ferguson filename c (e.g., 'g', 'g98.', 'l03.', 'ags04.', 's92.', or 's92ae.'), c unless overridden by input flag ktype_ferg in subroutine c read_add_ferg (in which case these characters are ignored) c c /c_filename_alex/: --> data{ALL} character*255 cfile_alex common /c_filename_alex/ need_alex_dir, cfile_alex save /c_filename_alex/ c c COMMON /c_got_alex/ : c kavail_alex = 0 (default) if molecular opacities have not been read in; c = 1 if Alexander 1994 opacities have been read in (e.g., by the c user calling the subroutine READALEX) and are available, c = 2 if Ferguson et al. 2005 opacities have been read in. c kuse_alex = 0 or less if Alexander opacities should NOT be used by the OPAL c opacity-calculating routines, even if they are read in; c = 1 : (DEFAULT) For the Ferguson et al. 2005 opacities, the Z-edge c factor FZKAEDGE is unity for XZCO < 0.10 at all X, and c goes to zero for XZCO > 0.12; but for the Alexander 1994 c opacities, FZKAEDGE is unity for X = 0 at all XZCO and for c XZCO < 0.10 at all X, and it goes to zero at XZCO > 0.15 c and X > 0.03 (note that XZCO = 1 - X - Y = Z + exC + exO). c = 2 : For Ferguson et al. 2005, same as kuse_alex = 1; but for c Alexander 1994, FZKAEDGE goes to zero for XZCO > 0.15 at c all X. c = 3 : For Ferguson et al. 2005, same as kuse_alex = 1; but for c Alexander 1994, restrict to the regions where tables were c available (not extrapolated or otherwise created): c FZKAEDGE = 1.0 for 0.0001 < XZCO < 0.03, and goes to c FZKAEDGE = 0.0 for XZCO < 0.00005 or XZCO > 0.05 . c = 4 : FOR THE OPAL-OPACITY-CALCULATING SUBROUTINES and KAPFERG: c for BOTH the Ferguson et al. 2005 and the Alexander 1994 c cases: multiply the FZKAEDGE value from case 3 above by a c factor that is unity if exC and exO are both zero, c and which goes to zero if abs(exC) + abs(exO) > CO_lim c for CO_lim = 0.2 * max( Z , 0.0001 , Z + exC + exO ) . c [Note that this constraint cannot be applied in KAPALEX, c which does not know the separate values of Z, exC, exO c (but only their sum XZCO); thus, for calls to KAPALEX c itself, KALEX = 4 has the same effect as KALEX = 3.] c = -1 thru -4 : molecular opacities should NOT be used by the OPAL c opacity-calculating routines, even if they are read in; c same as 1 thru 4 when KAPFERG is called explicitly; c same as 1 thru 3 when KAPALEX is called explicitly. c kdo_alex = kuse_alex * min{1,kavail_alex}, i.e., "should they be used now?": c = 0 or less if molecular opacities should not be used "now"; c = 1 or more if molecular opacities should be used "now". c iualex = Fortran unit number (default 23) for reading Alexander opacities c c /c_got_alex/: --> data{ALL} common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c c COMMON /c_trho_sw_alex/ : c fltswlo_alex_def THRU fltswhi_r_alex_def : storage for default values c fltswlo_alex, fltswhi_alex = logT boundaries of Alexander/OPAL switchover c (default logT = 3.87, 3.97) c fltswmid_alex = ( fltswhi_alex + fltswlo_alex ) / 2.0 = logT midpoint c dltsw2inv_alex = 4.0 / ( fltswhi_alex - fltswlo_alex )**2 c sltswhi_alex = fltswhi_alex - 6.0 c flrhoswlo_alex, flrhoswhi_alex = logRHO boundaries of switchover at high RHO c (default logRHO = -6.25, -5.75) c flrhoswmid_alex = ( flrhoswhi_alex + flrhoswlo_alex ) / 2. = logRHO midpoint c dlrhosw2inv_alex = 4.0 / ( flrhoswhi_alex - flrhoswlo_alex )**2 c fltswlo_r_alex, fltswhi_r_alex = logT boundaries of high-RHO switch-off c (default logT = 3.70, 3.80) c fltswmid_r_alex = ( fltswhi_r_alex + fltswlo_r_alex ) / 2.0 = logT midpoint c dltsw2inv_r_alex = 4.0 / ( fltswhi_r_alex - fltswlo_r_alex )**2 c sltswlo_alex = fltswlo_alex - 6.0 c isw_rho_alex = flag to tell whether to do the switchover to OPAL at high RHO c c /c_trho_sw_alex/: --> data{ALL} common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c c COMMON /c_edge_alex/ : c common /c_edge_alex/ fkaedgelo, fkaedgehi, fzkaedge save /c_edge_alex/ c c PARAMETERS defining storage for Potekhin et al 2006/2007 conductive opacities c c nT_KcPot = 19 : number of T-values c nR_KcPot = 64 : number of RHO-values c nZ_KcPot = 15 : number of Zion values c parameter ( nT_KcPot=19, nR_KcPot=64, nZ_KcPot=15 ) c c PARAMETERS defining storage for the Hubbard & Lampe 1969 conductive opacities c c nthikc = 90 - ntlokcm1 = 90 - (37-1) = 54 : number of T-values c nrhikc = 24 - nrlokcm1 = 24 - (-23-1) = 48 : number of RHO-values c nkc= 3 : number of elements (H, He, and C) c parameter ( ntlokc=37, ntlokcm1=ntlokc-1, nthikc=90-ntlokcm1, $ nrlokc=-23, nrlokcm1=nrlokc-1, nrhikc=24-nrlokcm1, nkc=3, $ nthikcm1=nthikc-1, nrhikcm1=nrhikc-1, nkcp1=nkc+1 ) parameter ( dlt_kc=.1, dlr_kc=.25, dltinv_kc=10., dlrinv_kc=4. ) c c COMMON /c_flkcond_hlpot/ : storage for H&L or Potekhin conductive opacities c c-SIZE 4*(nT_KcPot*nR_KcPot*nZ_KcPot+3*nrhikc*nkc+nkc) + 2*nkc = 0.071 Mb c character*2 celkc_hl(nkc) common /c_flkcond_hlpot/ flkc_pot(nT_KcPot,nR_KcPot,nZ_KcPot), $ AT_pot(nT_KcPot), AR_pot(nR_KcPot), AZ_pot(nZ_KcPot), $ sigconlog_pot, itlo_hl(nrhikc,nkc), ithi_hl(nrhikc,nkc), $ irhi_hl(nkc), itlo_ok_hl(nrhikc,nkc), $ irjump_hl(nkc), celkc_hl save /c_flkcond_hlpot/ c dimension flkc_hl(nthikc,nrhikc,nkc), $ flrolo_hl(nkc), flrohi_hl(nkc), $ fltlo_hl(nkc), flthi_hl(nkc), $ flRlo_hl(nkc), flRhi_hl(nkc), kZ_pot(nZ_KcPot) equivalence (flkc_pot(1,1,1),flkc_hl(1,1,1)), $ (AR_pot(1),flrolo_hl(1)), (AR_pot(nkcp1),flrohi_hl(1)), $ (AT_pot(1),fltlo_hl(1)), (AT_pot(nkcp1),flthi_hl(1)), $ (AZ_pot(1),flRlo_hl(1)), (AZ_pot(nkcp1),flRhi_hl(1)), $ (itlo_hl(1,1),kZ_pot(1)) c c COMMON /c_got_cond/ : flags for availability of conductive opacities c c If itoh_gap = 1 (default) in data statement below, then high-density Itoh c conductive opacities are used in the mid-RHO,low-T "gap" to improve the H&L c opacities there (beyond the edge of the H&L tables) in order to improve the c H&L-to-Itoh switchover at increasing density and low temperature (note that c no input H&L values are modified, only the extrapolation region). c If itoh_gap = 0, this is not done: the H&L tables are just extrapolated. c If ifix_h_cond > 0 (default), then remove an anomalously low Hydrogen c conductive opacity value (at logT = 5.4, logRHO = -0.5). c If kavail_cond = 0, NO conductive opacities were read in; c If kavail_cond = 1, 'Condopac' was read in (H&L, can be extended by Itoh); c If kavail_cond = 2, 'condall06.d' was read in (Potekhin et al. 2006) c Note that itoh_replace (default 99) is set via SET_COND_USE. c itoh_replace_max = max useful value of itoh_replace (presently 0 or 2). c c /c_got_cond/ : --> data{ALL} common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c c COMMON /c_filename_cond/ : filename containing conductive opacities c parameter ( ndef_cond = 3 ) c c /c_filename_cond/ : --> data{ALL} character*255 cfile_cond character*80 cdef_cond(ndef_cond) common /c_filename_cond/ need_cond_dir, cfile_cond, cdef_cond save /c_filename_cond/ c c COMMON /c_kcond_itoh/ : parameters of Itoh conductive opacity formulae c c /c_kcond_itoh/ : --> data{ALL} parameter ( nitoh=5, nhl=4 ) common /c_kcond_itoh/ ai_kc(nitoh), ax_kc(0:3,nitoh,3), $ bx_kc(0:2,nitoh,3), cx_kc(0:2,nitoh,3) save /c_kcond_itoh/ c c COMMON /alink_opal_z/ : contains data needed for smoothing routine OPALTAB c c-SIZE 4*((nrm+1)*100+5) = 0.008 Mb c common/alink_opal_z/ NTEMP,NSM,nrlow,nrhigh,RLE,t6arr(100), $ coff(100,nrm) save /alink_opal_z/ c c COMMON /d_opal_z/ : c dkap = derivative of value returned by quadratic interpolation function QDER c c /d_opal_z/: --> data{dkap} common/d_opal_z/ dkap save /d_opal_z/ c c COMMON /c_level_err_opal_z/ : c level_err = error-checking level, set by SET_ERR_CHECK; allowed values are: c 0 : Do not check input Nzin, Zlo, Z, Zhi in READZEXCO. c 1 : (Default): Do check these; fatal error if checks fail. c 2 : In this case, it is also a fatal error if FEDGE = 0. c 3 : In this case, it is also a fatal error if CNO-interp files c have been read in and you call OPAL_X_CNO_U with a metal c composition array of size other than 19. c c /c_level_err_opal_z/: --> data{level_err} common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c c COMMON /c_level_list_opal_z/ : c iu_list = 6 by default: Fortran unit to which to list opacity file names. c level_list = 0 : (default) do not list the names of opacity files read in; c = 1 : Output each Type 1 OPAL, conductive, or Alexander opacity c file read in, and one of each case of Type 2 OPAL or c Ferguson opacity file read in; c = N > 1 : same as 1, except output N of each case of Type 2 OPAL c or Ferguson opacity file read in. c list_mult : counter for Type 2 OPAL (Gz???.x?? files), Ferguson, conductive, c or Alexander opacity file listings. c list_gn(-n_zmixes:n_totmix) : counters for Type 1 OPAL file listings. c c /c_level_list_opal_z/: --> data{all} common /c_level_list_opal_z/ iu_list, level_list, list_mult, $ list_gn(-n_zmixes:n_totmix) save /c_level_list_opal_z/ c c COMMON /c_ctab/ c ctab = character*1 variable containing a tab character: needed only in order c to allow tabs in input files (and in character string argumentss) c to be interpreted as whitespace c c /c_ctab/: --> data{ctab} character*1 ctab common /c_ctab/ ctab save /c_ctab/ c c COMMON /chkpoc/ : c cb = character(s) allowed to terminate a directory name [cb(1) and cb(2)], c and non-alphanumeric characters allowed in a filename [cb(3) thru 6]. c DEFAULT (sun/iris/linux): cb(1:2) = '/', cb(3:6) = '_', '~', '+', '-' c VMS (must edit data statement): cb(1:2) = ':', ']', cb(3:6) = ';' c c /chkpoc/: --> data{cb} character*1 cb(6) common /chkpoc/ cb save /chkpoc/ c c COMMON /outdeb/ : controls the extent of error and debugging output, if the c debug statements are un-commented by removing "c-debug;" c at the beginning of the relevant lines c if a log10(opacity) value is > oudebl, then the relevant debug output is c performed (provided that it is not commented out) c else if ioudeb > 0 , then debug output is performed; higher values of c ioudeb yield more output (unless it is commented out) c koudeb counts how many debug outputs have been performed (e.g., so that c you can set ioudeb = -1 or increase oudebl after a given number c of debug outputs have been performed) c-debug[ common/outdeb/ ioudeb,oudebl,koudeb c-debug;c data ioudeb/-1/,oudebl/15./,koudeb/0/ c-debug] c c NOTE that any lines commented out with "c-debug-chk;" correspond to cases c where output is NOT controlled by the variables in common/outdeb/ ; if c these statements are un-commented by removing "c-debug-chk;" then the c relevant output will occur whenever the subroutine READZEXCO is called. c c NOTE that lines commented out with "c-test-xdel;" correspond to code which c tests the effect of changing the value of xdel, the offset for logarithmic c X-interpolation. There are some such cases in the subroutine OPAL, for c tests of interpolation among the mixes with X-values xa(m), and some in c the subroutine READZEXCO, for tests of interpolation among the 'GN93hz' c mixes with X = 0.0, 0.1, and 0.2 in order to get the mix with X = 0.03 c (the latter produce output similar to that from "c-debug-chk;" lines). c c--- c c /xhi_opal_z/ data: c data xhi_in / 0., 0.1, 0.2, 0.35, 0.5, 0.7, 0.8, 0.9, 0.95, 1. / data xcno_use / mx_hi_nz * -1.0 /, xhi_use / mx_hi_nz * -1.0 / data xxx_cno / mx_hi * -9.0 /, xxx_hi / mx_hi * -9.0 / data nx_hi / nz * 0 / data ireq_hi / 0, 0, 1, 0, 1, 0, 1, 1, 1, 1 / data khighx / nz * 0 / data kavail_xhi / 0 /, kuse_xhi / 2 /, kdo_xhi / 0 / data kavail_cno / 0 /, kuse_cno / 1 /, kdo_cno / 0 / data kavail_user / 0 /, kuse_user / 1 /, kdo_user / 0 / c c /a_opal_z/ data: c ! indx(1:101) data indx/1,2,2,3,3,3,3,3,3,3,4,4,4,4,4,4, $ 4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,6,6,6,6,6, $ 6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, $ 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7/ c ! X(1:mx) mx=5 data xa/ 0.0, 0.03, 0.1, 0.35, 0.7, 3 * 0.0 / c ! C,O(1:mc) data xcs/0.0,0.01,0.03,0.1,0.2,0.4,0.6,1.0/ data xos/0.0,0.01,0.03,0.1,0.2,0.4,0.6,1.0/ c ! init-flag data itime / 0 / c c /b_opal_z/ data: c ! nta(0:nrm_p1) data nta/57, 70,70,70,70,70, 70,70,70,70,70, $ 70,70,70,70,69, 64,60,58,57, -99/ c ! ntax0(0:nrm) data ntax0/999, 6,5,5,5,4, 4,4,3,1,1, 1,1,1,1,1, 1,1,1,1/ c ! ntax03(0:nrm) data ntax03/999, 5,1,1,1,1, 1,1,1,1,1, 1,1,1,1,1, 1,1,1,1/ c data sltlo/-99./, slthi/-99./, dltlo_inv/-99./, dlthi_inv/-99./ data slrlo/-99./, slrhi/-99./, dlrlo_inv/-99./, dlrhi_inv/-99./ data init_trvals/0/ c c /bb_opal_z/ data: c data xodp / 0.0 /, xcdp / 0.0 /, xxco / 0.0 / data cxx / 0.0 /, oxx / 0.0 / data l1 / 1 /, l2 / 2 /, l3 / 3 /, l4 / 4 / data k1 / 1 /, k2 / 2 /, k3 / 3 /, k4 / 4 / data ip / 3 /, iq / 4 * 3 / data kzf / 1 /, kzg / 1 /, kzh / 1 /, kzf2 / 1 / c c /c_pot_indices/ : c data zkpot / 16 * 0.0 /, zlg_pot_p / -1.e30 / data i1pot_p / 0 /, i4pot_p / -1 /, j1pot_p / 0 /, j4pot_p / -1 / data i1pot / 1 /, i2pot / 2 /, i3pot / 3 /, i4pot / 4 / data j1pot / 1 /, j2pot / 2 /, j3pot / 3 /, j4pot / 4 / data k1pot / 1 /, k2pot / 2 /, k3pot / 3 /, k4pot / 4 / c c /e_opal_z/ data: c data opact/1.e35/, dopact/0./, dopacr/0./, dopactd/0./, $ fedge/0./, ftredge/0./, fzedge/0./ c c /x_opal_z/ data: c data z_opal / -1.0 /, x_opal / -1.0 /, xc_opal / -1.0 / data xo_opal / -1.0 /, slt_opal / -99.0 /, slr_opal / -99.0 / data fcn_opal / 0.0 /, fcon_opal / 0.0 /, fcnone_opal / 0.0 / data fu_opal / 0.0 / c c /recoin_opal_z/ data: c data itimeco/0/, mxzero/1/, mx03/2/, kope/0/, igznotgx/0/ c c /alt_change_opal_z/ data: c data main_alt_change / 0 /, iulow / 23 /, khighz_in / 0 /, $ ofebrack_in / 0.0 / c c /opalmixes/ data: c data cfile_opalmixes/'GN93hz ','Alrd96a2','C95hz ','W95hz ', $ 'W95hz '/ data cel_opalmixes/'C ','N ','O ','Ne','Na','Mg','Al','Si', $ 'P ','S ','Cl','Ar','K ','Ca','Ti','Cr','Mn','Fe','Ni'/ data xiz_opalmixes/ $ 0.173285,0.053152,0.482273,0.098668,0.001999, $ 0.037573,0.003238,0.040520,0.000355,0.021142, $ 0.000456,0.005379,0.000210,0.003734,0.000211, $ 0.001005,0.000548,0.071794,0.004459, $ 0.102693,0.031499,0.570253,0.116656,0.002363, $ 0.044428,0.000962,0.047912,0.000420,0.024999, $ 0.000539,0.006360,0.000124,0.004415,0.000245, $ 0.000595,0.000230,0.042538,0.002769, $ 0.091924,0.028196,0.642620,0.052341,0.001060, $ 0.050066,0.001718,0.053992,0.000188,0.028172, $ 0.000242,0.002853,0.000279,0.004975,0.000275, $ 0.000533,0.000116,0.038085,0.002365, $ 0.076451,0.023450,0.672836,0.084869,0.000882, $ 0.041639,0.001428,0.035669,0.000157,0.019942, $ 0.000201,0.002373,0.000092,0.005209,0.000387, $ 0.000443,0.000242,0.031675,0.002056, $ 0.173285,0.053152,0.482273,0.098668,0.001999, $ 0.037573,0.003238,0.040520,0.000355,0.021142, $ 0.000456,0.005379,0.000210,0.003734,0.000211, $ 0.001005,0.000548,0.071794,0.004459/ data xiz_mix/ $ 0.173285,0.053152,0.482273,0.098668,0.001999, $ 0.037573,0.003238,0.040520,0.000355,0.021142, $ 0.000456,0.005379,0.000210,0.003734,0.000211, $ 0.001005,0.000548,0.071794,0.004459/ data fninz_opalmixes/ $ 0.245518,0.064578,0.512966,0.083210,0.001479, $ 0.026308,0.002042,0.024552,0.000195,0.011222, $ 0.000219,0.002291,0.000091,0.001586,0.000075, $ 0.000329,0.000170,0.021877,0.001293, $ 0.147909,0.038904,0.616594,0.100010,0.001778, $ 0.031622,0.000617,0.029512,0.000234,0.013490, $ 0.000263,0.002754,0.000055,0.001906,0.000089, $ 0.000198,0.000072,0.013177,0.000816, $ 0.131157,0.034498,0.688325,0.044451,0.000790, $ 0.035301,0.001091,0.032945,0.000104,0.015059, $ 0.000117,0.001224,0.000122,0.002127,0.000099, $ 0.000176,0.000036,0.011687,0.000691, $ 0.108211,0.028462,0.714945,0.071502,0.000652, $ 0.029125,0.000900,0.021591,0.000086,0.010575, $ 0.000096,0.001010,0.000040,0.002210,0.000137, $ 0.000145,0.000075,0.009642,0.000595, $ 0.245518,0.064578,0.512966,0.083210,0.001479, $ 0.026308,0.002042,0.024552,0.000195,0.011222, $ 0.000219,0.002291,0.000091,0.001586,0.000075, $ 0.000329,0.000170,0.021877,0.001293/ data fninz_mix/ $ 0.245518,0.064578,0.512966,0.083210,0.001479, $ 0.026308,0.002042,0.024552,0.000195,0.011222, $ 0.000219,0.002291,0.000091,0.001586,0.000075, $ 0.000329,0.000170,0.021877,0.001293/ data bracketife_mix/nel_zmix*0.0/ data bracketofe_opalmixes/0.0,0.3,0.4,0.5,0.0/ c c /opalGS98mixes/ data (note input-meteor abundances are initialized to zero): c data bracketofe_opalGS98 / -0.48, 0.0, 0.3, 0.4, 0.5, 6 * 0.0 / data xiz_opalGS98 / nel_zmix * 0.0, $ 0.171836, 0.050335, 0.467356, 0.104831, 0.002090, $ 0.039924, 0.003603, 0.044057, 0.000423, 0.023513, $ 0.000292, 0.004335, 0.000228, 0.003896, 0.000195, $ 0.001117, 0.000779, 0.076433, 0.004757, $ 0.101930, 0.029858, 0.553139, 0.124072, 0.002473, $ 0.047252, 0.001071, 0.052144, 0.000501, 0.027829, $ 0.000346, 0.005131, 0.000135, 0.004611, 0.000226, $ 0.000663, 0.000327, 0.045339, 0.002955, $ 0.091638, 0.026843, 0.626052, 0.055905, 0.001114, $ 0.053480, 0.001921, 0.059017, 0.000226, 0.031497, $ 0.000156, 0.002312, 0.000305, 0.005218, 0.000256, $ 0.000596, 0.000165, 0.040761, 0.002537, $ 0.076359, 0.022368, 0.656744, 0.090832, 0.000929, $ 0.044563, 0.001601, 0.039063, 0.000188, 0.022339, $ 0.000130, 0.001927, 0.000101, 0.005474, 0.000362, $ 0.000496, 0.000346, 0.033965, 0.002214, $ 0.171836, 0.050335, 0.467356, 0.104831, 0.002090, $ 0.039924, 0.003603, 0.044057, 0.000423, 0.023513, $ 0.000292, 0.004335, 0.000228, 0.003896, 0.000195, $ 0.001117, 0.000779, 0.076433, 0.004757, $ nel_zmix * 0.0, nel_zmix * 0.0, nel_zmix * 0.0, $ nel_zmix * 0.0, nel_zmix * 0.0 / data fninz_opalGS98 / $ .062096387, .0043961031, .60683708, 2.15357e-10, $ .0052838595, .09398768, .0072952272, .087714215, $ .00069665492, .040091598, .00078239704, 8.77017e-10, $ .00032510563, .0056661265, .00026794421, .0011753819, $ .00060734018, .078157537, .0046193578, $ 0.245825, 0.061748, 0.501922, 0.089265, 0.001562, $ 0.028224, 0.002294, 0.026954, 0.000235, 0.012602, $ 0.000141, 0.001865, 0.000100, 0.001670, 0.000070, $ 0.000369, 0.000244, 0.023517, 0.001393, $ 0.148069, 0.037193, 0.603216, 0.107280, 0.001877, $ 0.033921, 0.000693, 0.032394, 0.000282, 0.015145, $ 0.000170, 0.002241, 0.000060, 0.002007, 0.000082, $ 0.000222, 0.000104, 0.014165, 0.000878, $ 0.131883, 0.033128, 0.676395, 0.047890, 0.000838, $ 0.038036, 0.001231, 0.036324, 0.000126, 0.016982, $ 0.000076, 0.001000, 0.000135, 0.002251, 0.000092, $ 0.000198, 0.000052, 0.012616, 0.000747, $ 0.108877, 0.027349, 0.702986, 0.077089, 0.000692, $ 0.031401, 0.001016, 0.023820, 0.000104, 0.011933, $ 0.000063, 0.000826, 0.000044, 0.002339, 0.000129, $ 0.000163, 0.000108, 0.010416, 0.000646, $ 0.245825, 0.061748, 0.501922, 0.089265, 0.001562, $ 0.028224, 0.002294, 0.026954, 0.000235, 0.012602, $ 0.000141, 0.001865, 0.000100, 0.001670, 0.000070, $ 0.000369, 0.000244, 0.023517, 0.001393, $ nel_zmix * 0.0, nel_zmix * 0.0, nel_zmix * 0.0, $ nel_zmix * 0.0, nel_zmix * 0.0 / data atwt_opalGS98 / $ 12.01100, 14.00670, 15.99940, 20.17900, 22.98977, $ 24.30500, 26.98154, 28.08550, 30.97376, 32.06000, $ 35.45300, 39.94800, 39.09830, 40.08000, 47.90000, $ 51.99600, 54.93800, 55.84700, 58.70000 / data cfile_opalGS98 / ' ', 'GS98hz', 'GS98hz_OFe.3_Alrd96a2', $ 'GS98hz_OFe.4_C95', 'GS98hz_OFe.5_W95', 6 * ' ' / c c /c_meteor_mix_opal_z/ data: c data xiz_meteor / $ .034055950767625d0, .002811584920288d0, .443326132928943d0, $ .000000000198429d0, .005546683967014d0, .104307149947153d0, $ .008987793491910d0, .112486310445815d0, .000985278857158d0, $ .058690042443895d0, .001266565623746d0, .000000001599745d0, $ .000580403334678d0, .010369588461345d0, .000586040222841d0, $ .002790592585741d0, .001523534791034d0, .199305017419850d0, $ .012381327992788d0, $ .033847976603222d0, .002794386850040d0, .440624098408040d0, $ .000000000197201d0, .005426796827570d0, .103667372071604d0, $ .009353799223261d0, .114401914525715d0, .001099992396139d0, $ .061056356041069d0, .000755439983010d0, .000000001590383d0, $ .000590861589288d0, .010115144589889d0, .000506712319369d0, $ .002899506965060d0, .002025771911462d0, .198476752244634d0, $ .012357115663043d0, $ .036009888957169d0, .002972903901491d0, .468754671183736d0, $ .000000000209847d0, .005109430493010d0, .098297263764627d0, $ .008666855488115d0, .108474558443967d0, .000929109426030d0, $ .055311919937648d0, .000717037689513d0, .000000001691848d0, $ .000537541819713d0, .009335779714580d0, .000446291259625d0, $ .002705854260520d0, .001935100559721d0, .188437270946424d0, $ .011358520252416d0 / data fninz_meteor / $ .062096387323045d0, .004396103132102d0, .606837084080657d0, $ .000000000215357d0, .005283859474681d0, .093987679773822d0, $ .007295227181013d0, .087714215091835d0, .000696654916553d0, $ .040091598026506d0, .000782397036934d0, .000000000877017d0, $ .000325105632923d0, .005666126529857d0, .000267944210671d0, $ .001175381889649d0, .000607340179662d0, .078157536632930d0, $ .004619357794785d0, $ .061833419528987d0, .004377442231746d0, .604274480285562d0, $ .000000000214427d0, .005179390157206d0, .093587138052187d0, $ .007606607490520d0, .089375982574740d0, .000779229621820d0, $ .041786601600009d0, .000467537763442d0, .000000000873527d0, $ .000331587065415d0, .005537504221631d0, .000232110957854d0, $ .001223556258112d0, .000809072444438d0, .077979330676706d0, $ .004619007981672d0, $ .064274208429525d0, .004550290959465d0, .628110449385059d0, $ .000000000222945d0, .004764660515098d0, .086704154588141d0, $ .006886347278212d0, .082801809933137d0, .000643083014308d0, $ .036987017004729d0, .000433593850556d0, .000000000907947d0, $ .000294746381558d0, .004993637042920d0, .000199745481717d0, $ .001115651593004d0, .000755135357710d0, .072337095427584d0, $ .004148372626387d0 / data nuc_charge_opalmixes / 6, 7, 8, 10, 11, 12, 13, 14, 15, 16, $ 17, 18, 19, 20, 22, 24, 25, 26, 28 / data cfile_meteor / 'GN93hz.meteor', $ 'GS98hz.meteor', 'AGS04hz.meteor' / c c /c_mixfiles_used_opal_z/ data: c data cfile_opal_used / ' ', ' ', n_totmix * ' ' / c c /ext_CNO_opal_z/ data: c data len_def_CNO_ext / 0, 5, 6, 8, 5 / data cdef_CNO_ext / ' ', '.CtoN', '.COtoN', '.CNOtoNe', '.user' / c c /zinter_opal_z/ data: (note: zavail, iadd_zavail are computed in get_zavail) c data zavail / nzm * 0.0 /, iadd_zavail / nadd_zavail * 0 / c data zvalhi /0.,0.01,0.02,0.03,0.04,0.05,0.06,0.07,0.08,0.09,0.1/ c data zval / 0.,0.001,0.004,0.01,0.02,0.03,0.05,0.1 / c data zalval / 0.,0.0001,0.0003,0.001,0.002,0.004,0.01,0.02, $ 0.03,0.04,0.06,0.08,0.1 / c data (mnofz(i),i=1,mx) / 1, 2, 3, 4, 5 / c data nofz / $ 8,8,8,8,8,8,8,8,8,8,8, 8,8,8,8,8,8,8,8,8,8,8, $ 8,8,8,8,8,8,8,8,8,8,8, 8,8,8,8,8,7,7,7,7,7,7, $ 6,6,6,6,6,6,6,6,6,6,5, $ 8,8,8,8,8,8,8,8,8,8,8, 8,8,8,8,8,8,8,8,8,8,8, $ 8,8,8,8,8,8,8,8,8,8,8, 8,8,8,8,7,7,7,7,7,7,7, $ 6,6,6,6,6,6,6,6,6,5,5, $ 8,8,8,8,8,8,8,8,8,8,8, 8,8,8,8,8,8,8,8,8,8,8, $ 8,8,8,8,8,8,8,8,8,8,8, 8,8,7,7,7,7,7,7,7,7,7, $ 6,6,6,6,6,6,6,5,5,5,5, $ 8,8,8,8,8,8,8,8,8,8,8, 8,8,8,8,8,8,8,8,8,8,8, $ 8,8,8,8,8,8,8,8,8,8,8, 7,7,7,7,7,7,7,7,7,7,7, $ 5,5,5,5,5,5,5,5,5,5,4, $ 8,8,8,8,8,8,8,8,8,8,8, 8,8,8,8,8,8,8,8,8,8,8, $ 8,8,8,8,8,8,8,8,8,8,7, 7,7,7,7,7,6,6,6,6,6,6, $ 4,4,4,4,4,4,4,3,3,2,1, $ 7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7, $ 7,7,7,7,7,7,7,7,7,7,6, 6,6,6,6,6,5,5,5,5,5,5, $ 0,0,0,0,0,0,0,0,0,0,0, $ 6,6,6,6,6,6,6,6,6,6,6, 6,6,6,6,6,6,6,6,6,6,6, $ 6,6,6,6,6,6,6,6,6,6,5, 4,4,3,3,2,1,0,0,0,0,0, $ 0,0,0,0,0,0,0,0,0,0,0, $ 0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0, $ 0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0, $ 0,0,0,0,0,0,0,0,0,0,0 / c c /czinte_opal_z/ data: c data cxfil / 'Gx00', 'Gx03', 'Gx10', 'Gx35', 'Gx70' / data czfil / 'z0 ', 'z001', 'z004', 'z01 ', $ 'z02 ', 'z03 ', 'z05 ', 'z10 '/ c c /c_opal_ctrl_smooth/ data: c data init_smo / 2 /, low_CO_smo / 1 /, interp_CO_smo / 1 / c c /opdir/ data: c data copdir / ' ' / c c /c_ini_ferg/ data: c data z_ferg / 0.0, 0.00001, 0.00003, 0.0001, 0.0003, 0.001, $ 0.002, 0.004, 0.01, 0.02, 0.03, 0.04, 0.05, 0.06, 0.08, $ 0.1 / data x_ferg / 0.0, 0.1, 0.2, 0.35, 0.5, 0.7, 0.8, 0.9, 0.95, $ 1.0 / data iacc_ferg / 1 /, igot_t_ferg / 0 /, igot_r_ferg / 0 / data itype_ferg / 0 /, lsep_ferg / 1 /, lext_ferg / 4 / data ltype_ferg / 8, 1, 4, 4, 6, 4, 6, $ 8, 8, 8, 8, 8, -1 / data itype_def_ferg / ntyp1_ferg, 1, 5, 4, 3, 2, $ 6, 7, 8, 9, 10, 11, 12 / data ione_ferg / -1, 0, 0, 0, 1, 1, 1, $ 1, 1, 1, 1, 1, -1 / data lz_ferg / 1,5,5,4,4, 3,3,3,2,2,2, 2,2,2,2,1 / data lx_ferg / 1,1,1,2,1, 1,1,1,2,2 / data cz_ferg / '0 ', '00001', '00003', '0001 ', '0003 ', $ '001 ', '002 ', '004 ', '01 ', '02 ', '03 ', $ '04 ', '05 ', '06 ', '08 ', '1 ' / data cx_ferg / '0 ', '1 ', '2 ', '35 ', '5 ', $ '7 ', '8 ', '9 ', '95 ', '10 ' / data ctype_ferg/ 'Alexopac', 'g', 'g98.', 'l03.', 'ags04.', $ 's92.', 's92ae.', 'gs98-.2.', 'gs98+.2.', 'gs98+.4.', $ 'gs98+.6.', 'gs98+.8.', ' ' / data csub_ferg/ ' ', 'f05_g93', 'f05_gs98', 'f05_l03', $ 'f05_ags04', 'f05_s92', 'f05_s92ae', 'f05_gs98-.2', $ 'f05_gs98+.2', 'f05_gs98+.4', 'f05_gs98+.6', 'f05_gs98+.8', $ 'f05_user' / data csep_ferg / '.' /, cext_ferg / 'tron' / c c /c_ofe_in_ferg/ data: Assume that [O/Fe] = 0.3 in the s92ae mix of the c Ferguson et al. 2005 molecular opacities: c data ofein_ferg / 0.3 /, i_ofe_ferg / 7 /, i_ofe0_ferg / 6 / c c /c_prev_ferg/ data: c data zlogp_ferg / -9.0 /, xp_ferg / -9.0 / data zlp1_ferg / -9.0 /, xp1_ferg / -9.0 / data zlp2_ferg / -9.0 /, xp2_ferg / -9.0 / data i1p_ferg / -1 /, i4p_ferg / -9 / data j1p_ferg / -1 /, j4p_ferg / -9 / c c /c_tsw_ferg/ data: i.e., flt_max_ferg = 4.5 , fltswlo_ferg_def = 4.2 , c fltswhi_ferg_def = 4.4 data slt_max_ferg / -1.5 / data sltswlo_ferg_def / -1.8 /, sltswhi_ferg_def / -1.6 / data sltswlo_ferg / -1.8 /, sltswhi_ferg / -1.6 / data sltswmid_ferg / -1.7 /, dltsw2inv_ferg / 100. / c c /c_ini_alex/ data: c data z_alex / 0.0,0.0001,0.0003,0.001,0.002, $ 0.004,0.01,0.02,0.03,0.05, 0.1,1.0 / data x_alex / 0.0,0.03,0.1,0.35,0.7,0.8 / data flt_alex / 3.00,3.05,3.10,3.15,3.20, $ 3.25,3.30,3.35,3.40,3.45, 3.50,3.55,3.60,3.65,3.70, $ 3.75,3.80,3.85,3.90,3.95, 4.0,4.05,4.1 / data flro_alex / -14.,-13.75, -13.5,-13.25,-13.0,-12.75,-12.5, $ -12.25, -12.,-11.75,-11.5,-11.25,-11., $ -10.75,-10.5,-10.25,-10.,-9.75, -9.5,-9.25,-9.,-8.75,-8.5, $ -8.25,-8.,-7.75,-7.5,-7.25, -7.,-6.75,-6.5,-6.25,-6. / c c /c_filename_alex/ data: c data need_alex_dir / 1 / data cfile_alex / ' ' / c c /c_got_alex/ data: c data kavail_alex / 0 /, kuse_alex / 1 /, kdo_alex / 0 / data iualex / 23 / c c /c_trho_sw_alex/ data: c data fltswlo_alex_def / 3.87 /, fltswhi_alex_def / 3.97 / data flrhoswlo_alex_def / -6.25 /, flrhoswhi_alex_def / -5.75 / data fltswlo_r_alex_def / 3.7 /, fltswhi_r_alex_def / 3.8 / data fltswlo_alex / 3.87 /, fltswhi_alex / 3.97 / data fltswmid_alex / 3.92 /, dltsw2inv_alex / 400. / data sltswhi_alex / -2.03 /, flrhoswlo_alex / -6.25 / data flrhoswhi_alex / -5.75 /, flrhoswmid_alex / -6.00 / data dlrhosw2inv_alex / 16. /, fltswlo_r_alex / 3.7 / data fltswhi_r_alex / 3.8 /, fltswmid_r_alex / 3.75 / data dltsw2inv_r_alex / 400. /, sltswlo_alex / -2.13 / data isw_rho_alex / 1 / c c /c_got_cond/ data: c data kavail_cond / 0 /, kuse_cond / 1 /, kdo_cond / 0 / data iucond / 23 /, ifix_h_cond / 1 /, itoh_gap / 1 / data itoh_replace / 99 /, ifix_h_cond_next / 1 / data itoh_gap_next / 1 /, itoh_replace_max / 99, 0, 2 / c c /c_filename_cond/ data: c data need_cond_dir / 1 / data cfile_cond / ' ' / data cdef_cond / 'Condopac', 'condall06', 'condall06.d' / c c /c_kcond_itoh/ data: c data ai_kc / 1.007825,4.002603,12.0,15.994915,21.99138 / data ax_kc / .34542,-.28157,.09184,-.03734, $ .62199,-.16110,.15574,-.02893, .9896,-.1851,.1019,-.0360, $ 1.0779,-.1838,.1059,-.0290, 1.1480,-.1779,.1115,-.0233, $ .25152,-.10843,-.00596,-.00950, .36090,.02576,.05061,.00015, $ .4406,-.0161,-.0093,-.0028, .4486,-.0160,-.0014,.0039, $ .4557,-.0096,.0063,.0065, $ .1580,-.0607,-.0188,0., .2486,.0564,.0366,0., $ .2510,-.0114,-.0160,0., .2481,-.0066,-.0050,0., $ .2511,0.,0.,0. / data bx_kc / -.61919,.40004,-.16585, -.65222,.48601,-.18266, $ -.8825,.6675,-.3798, -.9743,.6955,-.3966, $ -1.0553,.7336,-.4147, $ -.36667,.14040,-.04588, -.40559,.15316,-.04058, $ -.4821,.0826,-.0557, -.5193,.0822,-.0467, $ -.5463,.0848,-.0395, $ -.2698,.0537,-.0059, -.2948,.0456,-.0026, $ .3964,-.0080,-.0193, -.4094,-.0015,-.0047, $ -.1030,0.,0. / data cx_kc/ $ .35742,-.41151,.21552, .36580,-.52176,.26240, $ -.0915,-1.5848,1.1882, -.1040,-1.7692,1.3546, $ -.0548,-2.0486,1.550, $ .10493,-.09537,.04682, .12140,-.11621,.04939, $ -.5193,-.0830,.0147, -.5403,-.1022,.0416, $ -.5448,-.1146,.0664, $ 0.,0.,0., 0.,0.,0., $ 0.,0.,0., 0.,0.,0., $ 0.,0.,0./ c c /d_opal_z/ data: c data dkap / 0.0 / c c /c_level_err_opal_z/ data: c data level_err / 1 / c c /c_level_list_opal_z/ data: c data iu_list / 6 /, level_list / 0 /, list_mult / 0 / data list_gn / n_zmixes * 0, 0, n_totmix * 0 / c c /c_ctab/ data: c data ctab / ' ' / c c /chkpoc/ data: c c-vms[ ! For VMS: c-vms; data cb / ':', ']', ';', ';', ';', ';' / c-vms] c-sun-iris-linux[ ! For UNIX: data cb / '/', '/', '_', '~', '+', '-' / c-sun-iris-linux] c end c c****************************************************************************** c subroutine opalinit( khighz, ofebrack, z, kz, kmet ) c ==================================================== c c INITIALIZATIONS AND OPACITY FILE SETUP: c c This subroutine performs some initializations that would otherwise be done c at the beginning of subroutine READZEXCO. These do some grid set-up, look c for the user-supplied non-zero [O/Fe] file if khighz = 5 or -5, calculate c [O/Fe] values for each of the possible mixes, and find the OPAL-opacity-file c directory name. c parameter ( small_1m6=1.e-6 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( nrdel=nrb-1, ntdel=ntb-1 ) c c PARAMETERS: c zdel = 0.001 = offset for Z, Z+C, and Z+O, to make log interpolation behave c reasonably at small Z values: Z-interpolation is performed c using log(Z+zdel), while the CO-interpolation is performed c using log(C+Z+zdel) and log(O+Z+zdel) c xdel = 0.03 = usual (high-T) offset for X, to make log interpolation behave c reasonably at small X; note that 0.03 works better than 0.005 c xdelmin = 0.001 = lowest value of X offset ever used (at low temperatures) c parameter ( zdel=0.001, xdel=0.03, xdelmin=0.001 ) c c PARAMETERS: value used for "bad" (missing) logKappa values: c parameter ( badlogkval=1.e+35, badlogklim=20. ) c parameter ( mx_hi=2*mx, mo_m1=mo-1, mx_hi_nz=mx_hi*nz ) c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c common/e_opal_z/ opact,dopact,dopacr,dopactd,fedge,ftredge,fzedge save /e_opal_z/ c common /x_opal_z/ z_opal, x_opal, xc_opal, xo_opal, slt_opal, $ slr_opal, fcn_opal, fcon_opal, fcnone_opal, fu_opal save /x_opal_z/ c common/recoin_opal_z/ itimeco,mxzero,mx03,kope,igznotgx save /recoin_opal_z/ c common /alt_change_opal_z/ main_alt_change, iulow, khighz_in, $ ofebrack_in save /alt_change_opal_z/ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c c-implicit; real*4 xiz_mix,fninz_mix,bracketife_mix,bracketofe_opalmixes, c-implicit; $ xofe_opalmixes,xiz_opalmixes,fninz_opalmixes character*2 cel_opalmixes(nel_zmix) character*8 cfile_opalmixes(n_zmixes) common/opalmixes/ xiz_mix(nel_zmix),fninz_mix(nel_zmix), $ bracketife_mix(nel_zmix),bracketofe_opalmixes(n_zmixes), $ xofe_opalmixes(n_zmixes),xiz_opalmixes(nel_zmix,n_zmixes), $ fninz_opalmixes(nel_zmix,n_zmixes), $ cel_opalmixes,cfile_opalmixes save /opalmixes/ c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c common /c_level_list_opal_z/ iu_list, level_list, list_mult, $ list_gn(-n_zmixes:n_totmix) save /c_level_list_opal_z/ c c-implicit; real*4 bracketofe_opalGS98, xofe_opalGS98, xiz_opalGS98, c-implicit; $ fninz_opalGS98, atwt_opalGS98 character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c parameter ( n_mix_meteor = 3 ) double precision xiz_meteor, fninz_meteor character*255 cfile_meteor(n_mix_meteor) common /c_meteor_mix_opal_z/ xiz_meteor(nel_zmix,n_mix_meteor), $ fninz_meteor(nel_zmix,n_mix_meteor), $ nuc_charge_opalmixes(nel_zmix), cfile_meteor save /c_meteor_mix_opal_z/ c character*255 cfile_opal_used(-1:n_totmix) common /c_mixfiles_used_opal_z/ cfile_opal_used save /c_mixfiles_used_opal_z/ c character*80 cdef_CNO_ext(n_cnobeg:n_totmix) common /ext_CNO_opal_z/ len_def_CNO_ext(n_cnobeg:n_totmix), $ cdef_CNO_ext save /ext_CNO_opal_z/ c parameter ( mz=8, mz_m1=mz-1, mz_m2=mz-2, mzhi=11, mzal=13, $ nzm=mzal+1, nadd_zavail=nzm-mz ) c common/zinter_opal_z/ zvalhi(mzhi),nofz(mzhi,5,mo),mnofz(mx), $ zval(mz),zalval(mzal),zavail(nzm),iadd_zavail(nadd_zavail) save /zinter_opal_z/ c character*4 cxfil(5),czfil(mz) common/czinte_opal_z/ cxfil,czfil save /czinte_opal_z/ c common/c_opal_ctrl_smooth/ init_smo, low_CO_smo, interp_CO_smo save /c_opal_ctrl_smooth/ c character*255 copdir common/opdir/ copdir save /opdir/ c character*1 cb(6) common /chkpoc/ cb save /chkpoc/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c___ logical lxst c c COMMON /outdeb/ : controls the extent of error and debugging output, if the c debug statements are un-commented by removing "c-debug;" c at the beginning of the relevant lines c if a log10(opacity) value is > oudebl, then the relevant debug output is c performed (provided that it is not commented out) c else if ioudeb > 5 , then all debug output controlled by ioudeb is always c performed (provided that it has not been commented out), c i.e., initial-call, CO-, Z-, R-, T-, and X-interp output c else if ioudeb > 4 , then initial-call, Z-, R-, T-, and X-interp output c else if ioudeb > 3 , then initial-call, R-, T-, and X-interp output c else if ioudeb > 2 , then initial-call, T-, and X-interp output c else if ioudeb > 1 , then initial-call and X-interp output c else if ioudeb > 0 , then initial-call output is performed c koudeb counts how many debug outputs have been performed (e.g., so that c you can set ioudeb = -1 or increase oudebl after a given number c of debug outputs have been performed) c-debug[ c-debug; common/outdeb/ ioudeb,oudebl,koudeb c-debug] c c=== c ! These initializations only done once: if ( itimeco .ne. 12345678 ) then c ! check some parameters if ( nrm .ne. 19 .or. ntm .ne. 70 ) stop $ ' STOP -- OPAL CONST ERROR: NRM .ne. 19 or NTM .ne. 70 ' if ( nrb .le. 0 .or. nrb .gt. 12 ) stop $ ' STOP -- OPAL CONST ERROR: NRB < 1 or NRB > 12 ' if ( nr .lt. 6 ) stop $ ' STOP -- OPAL CONST ERROR: Too few R values: NR < 6 ' if ( nre .gt. nrm ) stop $ ' STOP -- OPAL CONST ERROR: NRE > NTM ' if ( mc .ne. mo .or. mc .ne. 8 ) stop $ ' STOP -- OPAL CONST ERROR: MC .ne. MO or MC .ne. 8 ' if ( nt .lt. 8 .or. ntb .le. 0 ) stop $ ' STOP -- OPAL CONST ERROR: NT < 8 or NTB < 1 ' if ( ntb .gt. nta(nre) - 3 ) stop $ ' STOP -- OPAL CONST ERROR: NTB > NTA(NRE) - 3 ' if ( mx .le. 0 .or. mx .gt. 5 ) stop $ ' STOP -- OPAL CONST ERROR: MX < 1 or MX > 5 ' if ( nz .le. 0 .or. nz .gt. nzm ) stop $ ' STOP -- OPAL CONST ERROR: NZ < 1 or NZ > 14 ' c ! initialize T,R values if ( init_trvals .le. 0 ) call get_trvals c c ! get combined Z-tabulation values available in files call get_zavail c ! get log10( X_GH93hz + xdel ) values do ix = 1, mx_hi xxx_cno(ix) = log10( xhi_in(ix) + xdel ) xxx_hi(ix) = xxx_cno(ix) enddo xxx_hi(1) = log10( 0.03 + xdel ) c c ! have now done once-only initializations itimeco = 12345678 c ! end of initializations that are done only once endif c ! initialize "files that were actually used" cfile_opal_used(-1) = copdir cfile_opal_used(0) = ' ' cfile_opal_used(1) = ' ' do i = 4, n_totmix cfile_opal_used(i) = ' ' enddo c ! obtain the directory specification for the Gz???.x?? files c kope = lnblnk(copdir) c ! check for error in directory name if ( kope .gt. 0 ) then c if ( copdir(kope:kope) .ne. cb(1) .and. $ copdir(kope:kope) .ne. cb(2) ) then write(6,5) cb(1), cb(2), copdir(:kope) 5 format(' OPAL Error: directory name does not end in "',a1, $ '" or "',a1,'":'/' ',a) stop ' STOP -- OPAL Error: directory name bad last char. ' endif c endif c if ( kope .gt. 246 ) then write(6,10) copdir(:kope) 10 format(' OPAL Error: directory name > 246 characters:'/ $ ' ',a) stop ' STOP -- OPAL Error: directory name > 246 characters' endif c c NOTE that some systems return FALSE for the existence of a directory, so c one cannot check for the directory's existence. c c-dir; if ( kope .gt. 0 ) then c-dir; call inqfil( copdir, lxst ) c-dir; if ( .not. lxst ) then c-dir; write(6,20) copdir(:kope) c-dir; 20 format(' STOP -- READCO: OPAL directory does not exist:'/ c-dir; $ ' ',a) c-dir; stop c-dir; endif c-dir; endif c ! just in case mx = 1 (i.e., if there is only one X-value) dfsx(2) = 1. c itime = 0 igznotgx = 0 mxzero = 0 mx03 = 0 c ! indices of X=0 and X=.03 mixes, and X-part of file names do i = 1, mx c ! loop over X-index (i, not m, here!) if ( xa(i) .eq. 0.0 ) then mxzero = i cxfil(i) = 'Gx00' mnofz(i) = 1 else if ( abs(xa(i)-0.03) .lt. small_1m6 ) then xa(i) = 0.03 mx03 = i cxfil(i) = 'Gx03' mnofz(i) = 2 else if ( abs(xa(i)-0.1) .lt. small_1m6 ) then xa(i) = 0.1 cxfil(i) = 'Gx10' mnofz(i) = 3 else if ( abs(xa(i)-0.35) .lt. small_1m6 ) then xa(i) = 0.35 cxfil(i) = 'Gx35' mnofz(i) = 4 else if ( abs(xa(i)-0.7) .lt. small_1m6 ) then xa(i) = 0.7 cxfil(i) = 'Gx70' mnofz(i) = 5 else stop ' STOP -- OPAL Error: bad X value in array xa(mx) ' endif c ! initialize xx, for X-interpolations xx(i) = log10(xdel+xa(i)) if ( i .ge. 2 ) then dfsx(i) = 1./(xx(i)-xx(i-1)) if ( dfsx(i) .le. 0. ) stop $ ' STOP -- OPAL Error: bad X order in array xa(mx) ' endif c ! have not yet read any opacities for this Z-value: c if ( kz .gt. 0 .and. kz .le. nz ) then do mq = 1, nr do il = 1, nt do k = 1, mo do j = 1, mc co(i,j,k,il,mq,kz) = badlogkval enddo enddo enddo enddo endif c ! end of X-loop enddo c dfsx(1) = dfsx(2) c ! set khizat, as in READEXCO kzbelo = mz do while( kzbelo .gt. 1 .and. z .le. zval(kzbelo) - small_1m6 ) kzbelo = kzbelo-1 enddo c if ( z .eq. 0. ) then khizat = 0 klozat = 0 else if ( khighz .lt. 0 ) then khizat = 1 if ( ofebrack .eq. 0. ) then klozat = 1 else klozat = min( mod( abs(khighz), 10 ) , n_zmixes ) endif else klozat = 0 khizat = min( mod( khighz, 10 ) , n_zmixes ) if ( ofebrack .eq. 0. ) khizat = min(khizat,1) if ( khizat .eq. 1 .and. $ ( ( z .ge. 0.01 .and. z .le. 0.02 ) .or. $ ( abs(zval(kzbelo)-z) .le. small_1m6 .and. $ z .ge. 1.e-5 ) ) ) khizat = 0 endif c ! check length of GS98 filenames to be used if ( klozat .gt. 0 ) then do k = 1, klozat, max( klozat - 1 , 1 ) if ( kope + lnblnk( cfile_opalGS98(k) ) .gt. 255 ) stop $ ' STOP -- READCO: alt-main-file name too long. ' enddo endif c ! should use the input [O/Fe] filename? if ( khizat .ge. n_zmixes ) then c ! it exists? if ( cfile_opalmixes(n_zmixes) .eq. ' ' ) stop $ ' STOP -- READCO: no user-specified [O/Fe]-file. ' c c ! obtain mix specifications for the input [O/Fe] file igetzxi = 9 i_rewind = 0 itab_dum = 0 line = 0 c ! use copdir temporarily copdir(kope+1:) = cfile_opalmixes(n_zmixes) cfile_opal_used(n_zmixes) = cfile_opalmixes(n_zmixes) call open_chk_zip( iulow, copdir, i_gzip, $ 'READCO Error: user-specified [O/Fe]-file not found.' ) ifound = mixfind(iulow,n_zmixes,igetzxi,i_rewind,itab_dum, $ line,0.0,0.0,0.0,0.0) if ( ifound .eq. 0 ) stop $ ' STOP -- READCO: bad user-specified [O/Fe]-file. ' call close_chk_zip( iulow, copdir, i_gzip ) c c ! remove filename from directory name copdir(kope+1:) = ' ' c ! or use GS98 input [O/Fe] filename? else if ( klozat .ge. n_zmixes ) then c call chk_ofe_alt_file( n_zmixes ) c ! it exists? if ( cfile_opal_used(n_zmixes) .eq. ' ' ) stop $ ' STOP -- READCO: no user alt-[O/Fe]-file. ' c ! length? if ( kope + lnblnk( cfile_opal_used(n_zmixes) ) .gt. 255 ) $ stop $ ' STOP -- READCO: user alt-[O/Fe]-file name too long. ' c c ! obtain mix specifications for the input [O/Fe] file igetzxi = 9 i_rewind = 0 itab_dum = 0 line = 0 c ! use copdir temporarily copdir(kope+1:) = cfile_opal_used(n_zmixes) call open_chk_zip( iulow, copdir, i_gzip, $ 'READCO Error: user alt-[O/Fe]-file not found.' ) ifound = mixfind(iulow,-n_zmixes,igetzxi,i_rewind,itab_dum, $ line,0.0,0.0,0.0,0.0) if ( ifound .eq. 0 ) stop $ ' STOP -- READCO: bad user-specified alt-[O/Fe]-file. ' call close_chk_zip( iulow, copdir, i_gzip ) c c ! remove filename from directory name copdir(kope+1:) = ' ' c endif c ! changed 'GS98hz' if ( khighz .lt. 0 .and. main_alt_change .gt. 0 ) then c ! it exists? if ( cfile_opalGS98(1) .eq. ' ' ) stop $ ' STOP -- READCO: no main alternate [O/Fe]=0.0 file. ' c ! length? if ( kope + lnblnk( cfile_opalGS98(1) ) .gt. 255 ) stop $ ' STOP -- READCO: alternate [O/Fe]=0.0 name too long. ' c c ! obtain mix specifications for input [O/Fe]=0 file igetzxi = 9 i_rewind = 0 itab_dum = 0 line = 0 c ! use copdir temporarily copdir(kope+1:) = cfile_opalGS98(1) cfile_opal_used(1) = cfile_opalGS98(1) call open_chk_zip( iulow, copdir, i_gzip, $ 'READCO Error: alternate [O/Fe]=0.0 file not found.' ) ifound = mixfind(iulow,-1,igetzxi,i_rewind,itab_dum, $ line,0.0,0.0,0.0,0.0) if ( ifound .eq. 0 ) stop $ ' STOP -- READCO: bad alternate [O/Fe]=0.0 file. ' call close_chk_zip( iulow, copdir, i_gzip ) c ! have read it now main_alt_change = main_alt_change - 2 c c ! remove filename from directory name copdir(kope+1:) = ' ' c endif c ! get mix Z-composition specifications (these c ! will be recomputed for any mix read in later) do i = 1, n_zmixes xofe_opalGS98(i) = fninz_opalGS98(kel_o,i) $ / max( fninz_opalGS98(kel_fe,i) , 1.e-36 ) bracketofe_opalGS98(i) = log10( xofe_opalGS98(i) $ / xofe_opalGS98(1) ) xofe_opalmixes(i) = fninz_opalmixes(kel_o,i) $ / max( fninz_opalmixes(kel_fe,i) , 1.e-36 ) bracketofe_opalmixes(i) = log10( xofe_opalmixes(i) $ / xofe_opalmixes(1) ) enddo c ! Reset current-mix data. If GS98 [O/Fe] shift: if ( klozat .gt. 1 ) then c ! get interpolation factors fofe (for GS98hz) & c ! omfofe=1-fofe (other file) xofe = 10.**ofebrack * xofe_opalGS98(1) fofe = ( fninz_opalGS98(kel_o,klozat) $ - xofe * fninz_opalGS98(kel_fe,klozat) ) $ / ( ( fninz_opalGS98(kel_fe,1) $ - fninz_opalGS98(kel_fe,klozat) ) * xofe $ + fninz_opalGS98(kel_o,klozat) $ - fninz_opalGS98(kel_o,1) ) omfofe = 1. - fofe c ! get Z-composition of interpolated mix sum_niai = 0.0 do i = 1, nel_zmix fninz_mix(i) = fofe * fninz_opalGS98(i,1) $ + omfofe * fninz_opalGS98(i,klozat) xiz_mix(i) = fninz_mix(i) * atwt_opalGS98(i) sum_niai = sum_niai + xiz_mix(i) enddo do i = 1, nel_zmix xiz_mix(i) = xiz_mix(i) / sum_niai bracketife_mix(i) = log10( ( max( fninz_mix(i) , 1.e-36 ) $ * fninz_opalGS98(kel_fe,1) ) $ / ( max( fninz_mix(kel_fe) , 1.e-36 ) $ * fninz_opalGS98(i,1) ) ) enddo c ! Else, if use GS98 but no [O/Fe] shift: else if ( khighz .lt. 0 ) then c do i = 1,nel_zmix xiz_mix(i) = xiz_opalGS98(i,1) fninz_mix(i) = fninz_opalGS98(i,1) bracketife_mix(i) = 0. enddo c ! Else, if there is no GN93 [O/Fe] shift: else if ( khizat .le. 1 ) then c do i = 1,nel_zmix xiz_mix(i) = xiz_opalmixes(i,1) fninz_mix(i) = fninz_opalmixes(i,1) bracketife_mix(i) = 0. enddo c ! Else, if there is the [O/Fe] shift (also done in READEXCO): else c ! get interpolation factors fofe (for GN93hz) and omfofe=1-fofe c xofe = 10.**ofebrack * xofe_opalmixes(1) fofe = ( fninz_opalmixes(kel_o,khizat) $ - xofe * fninz_opalmixes(kel_fe,khizat) ) $ / ( ( fninz_opalmixes(kel_fe,1) $ - fninz_opalmixes(kel_fe,khizat) ) * xofe $ + fninz_opalmixes(kel_o,khizat) $ - fninz_opalmixes(kel_o,1) ) omfofe = 1. - fofe c ! get Z-composition of interpolated mix sum_niai = 0.0 do i = 1, nel_zmix fninz_mix(i) = fofe * fninz_opalmixes(i,1) $ + omfofe * fninz_opalmixes(i,khizat) xiz_mix(i) = fninz_mix(i) * atwt_opalGS98(i) sum_niai = sum_niai + xiz_mix(i) enddo do i = 1, nel_zmix xiz_mix(i) = xiz_mix(i) / sum_niai bracketife_mix(i) = log10( ( max( fninz_mix(i) , 1.e-36 ) $ * fninz_opalmixes(kel_fe,1) ) $ / ( max( fninz_mix(kel_fe) , 1.e-36 ) $ * fninz_opalmixes(i,1) ) ) enddo endif c imet = iabs( kmet ) if ( imet .gt. n_mix_meteor ) imet = 0 c if ( imet .eq. 0 .and. cfile_opalGS98(0) .eq. ' ' ) then if ( khighz .ge. 0 ) then if ( cfile_meteor(1)(1:4) .eq. cfile_opalmixes(1)(1:4) ) $ imet = 1 else do i = 1, n_mix_meteor j = ( i / 3 ) + 4 if ( cfile_meteor(i)(1:j) .eq. cfile_opalGS98(1)(1:j) ) $ imet = i enddo endif endif c ! initialize meteoritic mix if ( imet .eq. 0 ) then c if ( cfile_opalGS98(0) .eq. ' ' ) then if ( khighz .gt. 0 ) then cfile_opalGS98(0) = cfile_opalmixes(1) else cfile_opalGS98(0) = cfile_opalGS98(1) if ( cfile_opalGS98(0) .eq. ' ' ) $ cfile_opalGS98(0) = cfile_opalmixes(1) endif i = lnblnk( cfile_opalGS98(0) ) cfile_opalGS98(0)(i+1:) = '.meteor' endif c ! use copdir temporarily copdir(kope+1:) = cfile_opalGS98(0) c call inqfil( copdir, lxst ) if ( .not. lxst ) then i = lnblnk( copdir ) copdir(i+1:) = '.gz' call inqfil( copdir, lxst ) if ( .not. lxst ) then copdir(i+1:) = '.Z ' call inqfil( copdir, lxst ) endif copdir(i+1:) = ' ' endif c if ( .not. lxst ) then c imet = n_mix_meteor c else c ! obtain meteoritic mix from file igetzxi = 8 i_rewind = 0 itab_dum = 0 line = 0 call open_chk_zip( -iulow, copdir, i_gzip, $ 'Meteoritic-file not found; use AGS04 meteor-mix.' ) if ( i_gzip .le. -99999 ) then imet = n_mix_meteor else c-dont; if ( list_gn(0) .gt. 0 ) then c-dont; if ( iu_list .eq. iulow ) then c-dont; write(6,4) iu_list c-dont; 4 format(/' ***OPAL WARNING: READCO:', c-dont; $ ' bad LIST_IU =',i3, c-dont; $ ', reset to 6 (standard output)'/) c-dont; iu_list = 6 c-dont; endif c-dont; write(iu_list,1) copdir(:lnblnk(copdir)) c-dont; 1 format(' ***OPAL/Type_1 (ONLY read X_meteor): ',a) c-dont; list_gn(0) = 0 c-dont; endif cfile_opal_used(0) = cfile_opalGS98(0) ifound = mixfind(iulow,0,igetzxi,i_rewind,itab_dum, $ line,0.0,0.0,0.0,0.0) if ( ifound .eq. 0 ) imet = n_mix_meteor call close_chk_zip( iulow, copdir, i_gzip ) endif c endif c ! remove filename from directory name copdir(kope+1:) = ' ' c endif c if ( imet .gt. 0 ) then c cfile_opalGS98(0) = cfile_meteor(imet) cfile_opal_used(0) = cfile_opalGS98(0) c do i = 1, nel_zmix fninz_opalGS98(i,0) = fninz_meteor(i,imet) xiz_opalGS98(i,0) = xiz_meteor(i,imet) enddo c xofe_opalGS98(0) = fninz_opalGS98(kel_o,0) $ / max( fninz_opalGS98(kel_fe,0) , 1.e-36 ) c endif c bracketofe_opalGS98(0) = log10( max( 1.e-36 , $ xofe_opalGS98(0) * fninz_mix(kel_fe) $ / max( 1.e-36 , fninz_mix(kel_o) ) ) ) c ! end of initializations return end c c****************************************************************************** c subroutine get_zavail c ===================== c c Obtain combined Z-tabulation values available in the files, and best order c in which to enhance the 'Gz???.x??' metallicity table. c parameter ( small_1m6=1.e-6 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( zdel=0.001, xdel=0.03, xdelmin=0.001 ) c parameter ( mz=8, mz_m1=mz-1, mz_m2=mz-2, mzhi=11, mzal=13, $ nzm=mzal+1, nadd_zavail=nzm-mz ) c common/zinter_opal_z/ zvalhi(mzhi),nofz(mzhi,5,mo),mnofz(mx), $ zval(mz),zalval(mzal),zavail(nzm),iadd_zavail(nadd_zavail) save /zinter_opal_z/ c common/recoin_opal_z/ itimeco,mxzero,mx03,kope,igznotgx save /recoin_opal_z/ c___ dimension z_l(nzm), idz(nzm) c=== ! (if it has not already been done): if ( iadd_zavail(1) .eq. 0 ) then c c Get the combined Z-array zavail() by combining zval() and zalval(); this c should be the same as just adding the value Z=0.05 to the array zalval(): c k_l = 1 k_h = 1 k_o = 0 k_a = 0 c do while ( k_l .le. mz .or. k_h .le. mzal ) c k_a = k_a + 1 if ( k_a .gt. nzm ) stop $ ' STOP -- READCO: combined files have > 14 Z-values. ' if ( k_l .gt. mz ) then zavail(k_a) = zalval(k_h) else if ( k_h .gt. mzal ) then zavail(k_a) = zval(k_l) else zavail(k_a) = min( zval(k_l) , zalval(k_h) ) endif z_l(k_a) = log10( zavail(k_a) + zdel ) idz(k_a) = 0 if ( k_l .le. mz ) then if ( zval(k_l) .lt. zavail(k_a) + small_1m6 ) then idz(k_a) = k_a - k_o k_o = k_a k_l = k_l + 1 endif endif if ( k_h .le. mzal ) then if ( zalval(k_h) .lt. zavail(k_a) + small_1m6 ) $ k_h = k_h + 1 endif c enddo c if ( k_a .lt. nzm ) stop $ ' STOP -- READCO: combined files have < 14 Z-values. ' c c Get the best order to add values from zavail() to those of zval(), in order c to minimize the size of the largest interval at each step; this should c result in array values in iadd_zavail() of 5, 3, 13, 10, 12, 2: c k_a = 0 c do while ( k_a .lt. nadd_zavail ) c ! next step: k_a = k_a + 1 c ! handle special cases where Z-range endpoints c ! differ (this should never occur!!!): if ( idz(1) .eq. 0 ) then c ! extend range to low Z, if necessary iadd_zavail(k_a) = 1 k_h = 2 do while ( k_h .lt. nzm .and. idz(k_h) .eq. 0 ) k_h = k_h + 1 enddo if ( idz(k_h) .eq. 0 ) $ stop ' STOP -- READCO: mz = 0 cannot happen. ' idz(k_h) = k_h - 1 idz(1) = 1 c else if ( idz(nzm) .eq. 0 ) then c ! or extend to high Z if necessary iadd_zavail(k_a) = nzm k_h = nzm - 1 do while ( k_h .gt. 1 .and. idz(k_h) .eq. 0 ) k_h = k_h - 1 enddo if ( idz(k_h) .eq. 0 ) $ stop ' STOP -- READCO: this REALLY cannot happen. ' idz(nzm) = nzm - k_h c else c ! GENERALLY: find largest remaining subdividable interval k_h = 0 dz_max = 0. do i = 2, nzm if ( idz(i) .gt. 1 ) then d_z = z_l(i) - z_l(i-idz(i)) if ( d_z .gt. dz_max ) then dz_max = d_z k_h = i endif endif enddo if ( k_h .eq. 0 ) $ stop ' STOP -- READCO: k_h = 0 cannot happen. ' c c ! find best subdivision of interval if ( idz(k_h) .eq. 2 ) then k_l = k_h - 2 k_o = k_h - 1 else k_l = k_h - idz(k_h) dz_max = 0. k_o = 0 do i = k_l + 1, k_h - 1 d_z = ( z_l(k_h) - z_l(i) ) $ / ( z_l(i) - z_l(k_l) ) if ( d_z .gt. 1. ) d_z = 1. / d_z if ( d_z .gt. dz_max ) then dz_max = d_z k_o = i endif enddo if ( k_o .eq. 0 ) $ stop ' STOP -- READCO: k_o = 0 cannot happen. ' endif c ! store this subdivision iadd_zavail(k_a) = k_o idz(k_o) = k_o - k_l idz(k_h) = k_h - k_o c endif c enddo c endif c return end c c****************************************************************************** c subroutine get_trvals c ===================== c parameter ( small_1m6=1.e-6, small_5m6=5.e-6 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( nrdel=nrb-1, ntdel=ntb-1 ) c c PARAMETERS: positions of DlogT-change in table, low logT and logR values: c parameter ( ks81=ntm-3, ks83=ks81+1, ks60=ks81-21, ks61=ks60+1, $ alrlo=-8.0, flogtlo=3.75, flogt60=6.0, flogt81=8.1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c c COMMON /b_opal_z/ : high and low logT6 and logR limits, and mix Z-values: c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c c COMMON /alink_opal_z/ : contains data needed for smoothing routine OPALTAB c common/alink_opal_z/ NTEMP,NSM,nrlow,nrhigh,RLE,t6arr(100), $ coff(100,nrm) save /alink_opal_z/ c=== ! only initialize once if ( init_trvals .gt. 0 ) return c init_trvals = 1 c ! intialize logR and 1/delta(logR) values do i = 1,nrm alrf(i) = (i-1)*0.5+alrlo enddo do i = 1,nr alr(i) = alrf(i+nrdel) dfsr(i) = 2. enddo c ! intialize logT, logT6, T6, and 1/delta(logT6) flogtin(1) = flogtlo do i = 2,ks60 flogtin(i) = (i-1)*0.05+flogtlo if ( i .ge. ntb ) dfs(i-ntdel) = 20. enddo if ( abs(flogtin(ks60)-flogt60) .gt. small_5m6 ) stop $ ' STOP -- READCO: initialization error. ' flogtin(ks60) = flogt60 do i = ks61,ks81 flogtin(i) = (i-ks60)*0.1+flogt60 if ( i .ge. ntb ) dfs(i-ntdel) = 10. enddo if ( abs(flogtin(ks81)-flogt81) .gt. small_5m6 ) stop $ ' STOP -- READCO: initialization error. ' flogtin(ks81) = flogt81 do i = ks83,ntm flogtin(i) = (i-ks81)*0.2+flogt81 if ( i .ge. ntb ) dfs(i-ntdel) = 5. enddo do i=1,ntm t6arr(i) = 10.**(flogtin(i)-6.0) enddo do i=1,nt alt(i) = flogtin(i+ntdel)-6.0 t6list(i) = t6arr(i+ntdel) enddo c c-done-above; do i = 2,nt c-done-above; dfs(i) = 1./(alt(i)-alt(i-1)) c-done-above; enddo c-done-above; do i = 2,nr c-done-above; dfsr(i) = 1./(alr(i)-alr(i-1)) c-done-above; enddo c ! For extrapolation at low R and T6 dfsr(1) = dfsr(2) dfs(1) = dfs(2) c ! R-extrapolation limits slrlo = alr(1) slrhi = alr(nr) c ! make 1-grid-pt extrap just within limits dlrlo_inv = dfsr(1) * 0.999999 dlrhi_inv = dfsr(nr) * 0.999999 c ! T-extrapolation limits sltlo = alt(1) slthi = alt(nt) c ! make 1-grid-pt extrap just within limits dltlo_inv = dfs(1) * 0.999999 dlthi_inv = dfs(nt) * 0.999999 c return end c c****************************************************************************** c subroutine opac(z,xh,exC,exO,t6,r) c ================================== c c.....This is just an alternate interface to OPAL_F_CNOU below, which it calls c after taking the log of T6 and R and setting "NO CNO/user interpolation"; c temperature-input T6 = temperature in millions of degrees kelvin c density-parameter-input R = density(g/cm**3) / T6**3 c=== if ( t6 .le. 0. .or. r .le. 0. ) then write(6,8437) t6,r 8437 format(' '/' STOP -- OPAC: non-positive value of T6=', $ 1p,e11.3,' or R=',e11.3) stop endif c slt = log10(t6) slr = log10(r) c call opal_f_cnou(z,xh,exC,exO,slt,slr,0.0,0.0,0.0,0.0) c return end c c****************************************************************************** c subroutine opal(z,xh,exC,exO,slt,slr) c ===================================== c c.....This is just an alternate interface to OPAL_F_CNOU below, which it calls c after setting "NO CNO/user interpolation": c=== call opal_f_cnou(z,xh,exC,exO,slt,slr,0.0,0.0,0.0,0.0) c return end c c****************************************************************************** c subroutine opal_x_cno_fu(xh,slt,slr,xmet,nmet,fu) c ================================================= c c.....This is an alternate interface to OPAL_F_XCON_CNOU below c dimension xmet(nmet) c=== c c Get the CNO-interpolation factors, the metallicity Z, and the excess C,O: c call z_fcno(xh,xmet,nmet,fu,z,exC,exO,y,xCN,xON,xNeHeavy,fmuainv, $ fmueinv,zsqbar,fcn,fcon,fcnone,fuse) c c Get the opacities by calling OPAL_F_XCON_CNOU: c call opal_f_xcon_cnou(z,xh,exC,exO,y,xCN,xON,xNeHeavy,fmuainv, $ fmueinv,zsqbar,slt,slr,fcn,fcon,fcnone,fuse) c return end c c****************************************************************************** c subroutine opal_f_cnou(z,xh,exC,exO,slt,slr,fcn,fcon,fcnone,fu) c =============================================================== c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c c /opalmixes/: --> data{ALL BUT xofe_opalmixes} character*2 cel_opalmixes(nel_zmix) character*8 cfile_opalmixes(n_zmixes) common/opalmixes/ xiz_mix(nel_zmix),fninz_mix(nel_zmix), $ bracketife_mix(nel_zmix),bracketofe_opalmixes(n_zmixes), $ xofe_opalmixes(n_zmixes),xiz_opalmixes(nel_zmix,n_zmixes), $ fninz_opalmixes(nel_zmix,n_zmixes), $ cel_opalmixes,cfile_opalmixes save /opalmixes/ c c Get approximate values for composition input to conductive opacities c y = max( 0.0 , 1.0 - xh - z - exC - exO ) xcn = ( xiz_mix(1) + 0.5 * xiz_mix(2) ) * z + exC xon = ( xiz_mix(3) + 0.5 * xiz_mix(2) ) * z + exO xneheavy = 1. - xh - y - xcn - xon if ( xneheavy .lt. 0. ) then xon = xon + xneheavy xneheavy = 0. endif if ( xcn .lt. 0. ) then xon = xon + xcn xcn = 0. endif if ( xon .lt. 0. ) then xcn = xcn + xon xon = 0. if ( xcn .lt. 0. ) then xneheavy = xneheavy + xcn xcn = 0. endif endif c c Get the opacities by calling OPAL_F_XCON_CNOU: c call opal_f_xcon_cnou(z,xh,exC,exO,y,xcn,xon,xneheavy, $ -1.,-1.,-1.,slt,slr,fcn,fcon,fcnone,fu) c return end c c****************************************************************************** c subroutine opal_f_xcon_cnou(z,xh,exC,exO,y,xCN,xON,xNeHeavy, $ fmuainv,fmueinv,zsqbar,slt,slr,fcn,fcon,fcnone,fu) c ================================================================= c parameter ( small_1m6=1.e-6 ) c parameter ( fln10 = 2.302585, floge = .4342945 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /x_opal_z/ z_opal, x_opal, xc_opal, xo_opal, slt_opal, $ slr_opal, fcn_opal, fcon_opal, fcnone_opal, fu_opal c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c c /opalmixes/: --> data{ALL BUT xofe_opalmixes} c-implicit; real*4 xiz_mix,fninz_mix,bracketife_mix,bracketofe_opalmixes, c-implicit; $ xofe_opalmixes,xiz_opalmixes,fninz_opalmixes character*2 cel_opalmixes(nel_zmix) character*8 cfile_opalmixes(n_zmixes) common/opalmixes/ xiz_mix(nel_zmix),fninz_mix(nel_zmix), $ bracketife_mix(nel_zmix),bracketofe_opalmixes(n_zmixes), $ xofe_opalmixes(n_zmixes),xiz_opalmixes(nel_zmix,n_zmixes), $ fninz_opalmixes(nel_zmix,n_zmixes), $ cel_opalmixes,cfile_opalmixes save /opalmixes/ c common /e_opal_z/ opact,dopact,dopacr,dopactd, $ fedge,ftredge,fzedge save /e_opal_z/ c common /tredges_opal_z/ ftlo_edge, fthi_edge, frlo_edge, $ frhi_edge, ftcut_edge, frcut_edge, ftr_cut_edge save /tredges_opal_z/ c parameter ( rcondswlo = -6.0, rcondswdel = 0.5 ) c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c common /c_edge_alex/ fkaedgelo, fkaedgehi, fzkaedge save /c_edge_alex/ c common /c_switch_used_alex/ fopal, falex, dt_fopal, fr_opal, $ dr_fr_opal, ft_opal, dt_ft_opal, ftr_opal, ftr_alex, $ ialex, iswrho save /c_switch_used_alex/ c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c common /c_ini_alex/ z_alex(nzp1_alex),x_alex(nx_alex), $ flt_alex(nt_alex),flro_alex(nrlo_alex:nr_alex) save /c_ini_alex/ c common /c_tsw_ferg/ slt_max_ferg, sltswlo_ferg_def, $ sltswhi_ferg_def, sltswlo_ferg, sltswhi_ferg, $ sltswmid_ferg, dltsw2inv_ferg save /c_tsw_ferg/ c parameter ( badlogkval=1.e+35, badlogklim=20. ) c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c-debug[ c-debug; common /c_debug_kcond/ i_debug_kcond c-debug; save /c_debug_kcond/ c-debug] c=== ! we have not yet gotten a good opacity opact = badlogkval dopact = 0. dopacr = 0. dopactd = 0. fedge = 0. ftredge = 1. fzedge = 1. flkc = badlogkval c z_opal = z x_opal = xh xc_opal = exC xo_opal = exO slt_opal = slt slr_opal = slr c fcn_opal = fcn fcon_opal = fcon fcnone_opal = fcnone fu_opal = fu c flt = slt + 6. flrho = slr + 3. * slt c if ( kavail_alex .eq. 1 ) then sltsw_con = max( sltswhi_alex , -2.0 ) sltswhi_mol = sltswhi_alex else sltsw_con = -2.0 sltswhi_mol = sltswhi_ferg endif c ! OPAL only if ( kdo_alex .le. 0 .or. slt .ge. sltswhi_mol ) then c ialex = 0 falex = 0. fopal = 1. c ! or possibly partial or completely Alexander else c iswrho = 0 ialex = -1 c ! check for switchover region if ( kavail_alex .gt. 1 ) then if ( slt .le. sltswlo_ferg ) then ialex = 1 falex = 1. fopal = 0. dt_fopal = 0. else if ( slt .le. sltswmid_ferg ) then dt_fopal = ( slt - sltswlo_ferg ) * dltsw2inv_ferg fopal = ( slt - sltswlo_ferg ) * dt_fopal * 0.5 falex = 1. - fopal else dt_fopal = ( sltswhi_ferg - slt ) * dltsw2inv_ferg falex = ( sltswhi_ferg - slt ) * dt_fopal * 0.5 fopal = 1. - falex endif else if ( flt .le. fltswlo_alex ) then ialex = 1 falex = 1. fopal = 0. dt_fopal = 0. else if ( flt .le. fltswmid_alex ) then dt_fopal = ( flt - fltswlo_alex ) * dltsw2inv_alex fopal = ( flt - fltswlo_alex ) * dt_fopal * 0.5 falex = 1. - fopal else dt_fopal = ( fltswhi_alex - flt ) * dltsw2inv_alex falex = ( fltswhi_alex - flt ) * dt_fopal * 0.5 fopal = 1. - falex endif c ! if there is a density switchover: if ( kavail_alex .eq. 1 .and. isw_rho_alex .gt. 0 ) then c ! highest-RHO: OPAL only: if ( flrho .ge. flrhoswhi_alex ) then c ialex = 0 c ! else: if RHO-switchover to OPAL (i.e., if high-RHO c ! but not too low-T): else if ( flrho .gt. flrhoswlo_alex .and. $ flt .gt. fltswlo_r_alex ) then c iswrho = 1 ialex = -1 c ! get RHO-switch factors if ( flrho .le. flrhoswmid_alex ) then dr_fr_opal = ( flrho - flrhoswlo_alex ) $ * dlrhosw2inv_alex fr_opal = ( flrho - flrhoswlo_alex ) $ * dr_fr_opal * 0.5 else dr_fr_opal = ( flrhoswhi_alex - flrho ) $ * dlrhosw2inv_alex fr_opal = ( flrhoswhi_alex - flrho ) $ * dr_fr_opal * 0.5 endif c ! very low T: switch to Alex if ( flt .ge. fltswhi_r_alex ) then dt_ft_opal = 0. ft_opal = 1. else if ( flt .le. fltswmid_r_alex ) then dt_ft_opal = ( flt - fltswlo_r_alex ) $ * dltsw2inv_r_alex ft_opal = ( flt - fltswlo_r_alex ) $ * dt_ft_opal * 0.5 else dt_ft_opal = ( fltswhi_r_alex - flt ) $ * dltsw2inv_r_alex ft_opal = ( fltswhi_r_alex - flt ) $ * dt_ft_opal * 0.5 endif c ftr_opal = ft_opal * fr_opal ftr_alex = 1. - ftr_opal c endif c endif c endif c c If OPAL opacities are needed, get them c if ( ialex .le. 0 ) then c call opal_k_only(z,xh,exC,exO,slt,slr,fcn,fcon,fcnone,fu) c if ( fedge .le. 0.0 ) then c if ( level_err .ge. 2 ) then c if ( fzedge .le. 0.0 ) then write(6,10) z 10 format(' '/' OPAL: Z=',f11.8, $ ' is outside extreme Z-extrapolation range') stop ' STOP -- OPAL Error: bad Z value. ' else if ( ftredge .gt. 0.0 .and. xh .ge. 0.8 ) then write(6,30) xh 30 format(' '/' OPAL: X=',f10.6, $ ' > 0.8, but GN93hz X-values unavailable') stop ' STOP -- OPAL Error: X too large. ' else if ( ( ialex .eq. 0 .or. $ slt .ge. sltswhi_mol ) .and. $ ( kdo_cond .le. 0 .or. slt .lt. sltsw_con .or. $ frlo_edge .le. 0.0 .or. ftlo_edge .le. 0.0 .or. $ ( ( fthi_edge .le. 0.0 .or. $ frhi_edge .le. 0.0 ) .and. $ slr .le. rcondswlo ) ) ) then write(6,20) flt, slr, flrho 20 format(' '/' OPAL: logT=',f9.6,', logR=',f11.6, $ ' [logRHO=',f11.6,']: beyond matrix edge') stop ' STOP -- OPAL Error: bad T or R value. ' endif c else if ( fzedge .le. 0.0 ) then c return c else if ( ftredge .le. 0.0 .and. $ ( ialex .eq. 0 .or. slt .ge. sltswhi_mol ) .and. $ ( kdo_cond .le. 0 .or. slt .lt. sltsw_con .or. $ frlo_edge .le. 0.0 .or. ftlo_edge .le. 0.0 .or. $ ( ( fthi_edge .le. 0.0 .or. $ frhi_edge .le. 0.0 ) .and. $ slr .le. rcondswlo ) ) ) then c return c endif c endif c endif c c If Alexander opacities are needed, get them c if ( ialex .ne. 0 ) then c if ( kavail_alex .ne. 1 ) then c call kapferg( slt, slr, xh, z, exC, exO, $ flka, dlkatr, dlkaro, dlkat, fkaedge ) c else c call kapalex( flt, flrho, xh, z + exC + exO, $ flka, dlkat, dlkaro, fkaedge ) c dlkatr = dlkat + 3.0 * dlkaro c if ( kuse_alex .ge. 4 ) then tmp = max( 0.0 , 1.0 - ( abs(exC) + abs(exO) ) * 5.0 $ / max( z , 0.0001 , z + exC + exO ) ) fzkaedge = fzkaedge * tmp fkaedge = fkaedge * tmp endif c endif c if ( ialex .gt. 0 ) then c opact = flka dopact = dlkatr dopacr = dlkaro dopactd = dlkat fedge = fkaedge ftredge = min( fkaedgelo , fkaedgehi ) fzedge = fzkaedge c else if ( fkaedge .gt. 0.0 .or. flka .le. badlogklim ) then c c ! combine molecular, OPAL opacities c if ( iswrho .le. 0 .or. kavail_alex .gt. 1 ) then c fedge = fedge * fopal + fkaedge * falex ftredge = ftredge * fopal $ + min( fkaedgelo , fkaedgehi ) * falex fzedge = fzedge * fopal + fzkaedge * falex if ( fedge .le. 0.0 .and. opact .gt. badlogklim ) then opact = flka dopact = dlkatr dopacr = dlkaro dopactd = dlkat else opact = opact * fopal + flka * falex dopact = dopact * fopal + dlkatr * falex $ + ( opact - flka ) * dt_fopal dopacr = dopacr * fopal + dlkaro * falex dopactd = dopactd * fopal + dlkat * falex $ + ( opact - flka ) * dt_fopal endif c else c if ( fedge .le. 0.0 .and. opact .gt. badlogklim ) then opact = flka dopacr = dlkaro dopactd = dlkat else flka = opact * fopal + flka * falex dlkaro = dopacr * fopal + dlkaro * falex dlkat = dopactd * fopal + dlkat * falex $ + ( opact - flka ) * dt_fopal opact = opact * ftr_opal + flka * ftr_alex dopacr = dopacr * ftr_opal + dlkaro * ftr_alex $ + ( opact - flka ) * ft_opal * dr_fr_opal dopactd = dopactd * ftr_opal + dlkat * ftr_alex $ + ( opact - flka ) * fr_opal * dt_ft_opal endif c fzedge = ( fzedge * fopal + fzkaedge * falex ) $ * ftr_opal + fzkaedge * ftr_alex ftredge = ftredge * ftr_opal + fkaedgelo * ftr_alex fedge = max( 0.0 , fzedge * ftredge ) c dopact = dopactd + 3. * dopacr c endif c endif c ! low-T: conductive opacities cannot extend if ( fedge .le. 0.0 ) then if ( level_err .ge. 2 ) then if ( fzedge .le. 0.0 ) then write(6,10) z stop ' STOP -- OPAL Error: bad Z value. ' else if ( ftredge .le. 0.0 ) then write(6,20) flt, slr, flrho stop ' STOP -- OPAL Error: bad T or R value. ' else if ( xh .ge. 0.8 ) then write(6,30) xh stop ' STOP -- OPAL Error: X too large. ' endif stop ' STOP -- OPAL Error: beyond matrix edge. ' endif return endif c endif c c If conductive opacities are needed, get them and combine them with the c radiative opacities: 1/Kappa = 1/Kappa_rad + 1/Kappa_cond c if ( kdo_cond .gt. 0 ) then c ! set flag IDER : from ITOH_REPLACE if ( kavail_cond .le. 1 ) then if ( itoh_replace .lt. 0 ) then ider = -4 else ider = 1 endif else if ( itoh_replace .gt. 1 ) then ider = 1 else if ( itoh_replace .eq. 0 ) then ider = -2 else if ( itoh_replace .eq. 1 ) then ider = -1 else ider = -4 endif c call kapcond( flrho, flt, xh, y, xcn, xon, xneheavy, $ fmuainv, fmueinv, zsqbar, ider, $ flkc, flkct, flkcro, fkcedge, fkcok ) c fkcok = max( 0.0 , fkcok ) fkcedge = max( 0.0 , fkcedge ) c-debug[ c-debug; if ( i_debug_kcond .gt. 0 ) then c-debug; write(6,'(/"FROM kapcond(",10f11.6," 1 ...):")') c-debug; $ flrho, flt, xh, y, xcn, xon, xneheavy, c-debug; $ fmuainv, fmueinv, zsqbar c-debug; write(6,'(" fkcedge=",f10.7," fkcok=",f10.7,$)') c-debug; $ fkcedge, fkcok c-debug; endif c-debug] c c Conductive opacities cannot extend the Alexander opacity region: c if ( slt .lt. sltsw_con + 0.1 ) fkcok = min( fkcok , $ max( ftredge , ( slt - sltsw_con ) * 10.0 ) ) c c At high T, conductive opacities cannot extend OPAL opacities to logR < -6 c (where T-extrapolation of OPAL opacities may not be reasonable and is not c performed) [note that this constraint may have no effect]: c if ( slr - rcondswdel .lt. rcondswlo .and. slt .gt. 2.0 ) $ fkcok = min( fkcok , max( ftredge , $ ( slr - rcondswlo ) / rcondswdel ) ) c-debug[ c-debug; if ( i_debug_kcond .gt. 0 ) write(6, c-debug; $ '(" -->",f10.7," ; fedge=",f10.7," ftredge=",f10.7,$)' c-debug; $ ) fkcok, fedge, ftredge c-debug] c c Set FTREDGE = 1.0 in the radiative-to-conductive switchover density region, c even if, strictly speaking, the radiative and conductive opacities do not c overlap enough (as long as log T > 4.1). c ftr_use = max( ftredge , min( 1.0 , fkcok , $ ( alt(nt) - slt ) * dfs(nt) + 1.0 , $ ( alr(nr) + 2.0 - slr ) * dfsr(nr) + 1.0 , $ ( slt - sltsw_con ) * 10.0 ) ) c-debug[ c-debug; if ( i_debug_kcond .gt. 0 ) write(6,'(" -->",f10.7)') ftr_use c-debug] c if ( flkc .lt. opact - 7.0 ) then c opact = flkc dopactd = flkct dopacr = flkcro fedge = fkcedge ftredge = fkcok fzedge = 1.0 c else if ( flkc .lt. opact ) then c fac = 10.**(flkc-opact) opact = flkc-log10(1.+fac) dopactd = (flkct+dopactd*fac)/(1.+fac) dopacr = (flkcro+dopacr*fac)/(1.+fac) c if ( fac .gt. 0.01 ) then fac = ( fac - 0.01 ) / 1.98 fedge = fkcedge * (1.-fac) + fedge * fac ftredge = fkcok * (1.-fac) + ftr_use * fac fzedge = 1. + ( fzedge - 1. ) * fac else fedge = fkcedge ftredge = fkcok fzedge = 1.0 endif c else if ( flkc .lt. opact + 7.0 ) then c fac = 10.**(opact-flkc) opact = opact-log10(1.+fac) dopactd = (dopactd+flkct*fac)/(1.+fac) dopacr = (dopacr+flkcro*fac)/(1.+fac) c if ( fac .gt. 0.01 ) then fac = ( fac - 0.01 ) / 1.98 fedge = fedge * (1.-fac) + fkcedge * fac ftredge = ftr_use * (1.-fac) + fkcok * fac fzedge = fzedge * (1.-fac) + fac else if ( fac .gt. 0.001 .and. ftr_use .ne. ftredge ) then fac = ( fac - 0.001 ) / 0.009 ftredge = ftredge * (1.-fac) + ftr_use * fac endif c endif c dopact = dopactd + 3. * dopacr c-debug[ c-debug; if ( i_debug_kcond .gt. 0 ) write(6, c-debug; $ '(" ==> fedge=",f10.7," ftredge=",f10.7)') c-debug; $ fedge, ftredge c-debug] c endif c if ( fedge .le. 0.0 .and. level_err .ge. 2 ) then if ( fzedge .le. 0.0 ) then write(6,10) z stop ' STOP -- OPAL Error: bad Z value. ' else if ( ftredge .le. 0.0 ) then write(6,20) flt, slr, flrho stop ' STOP -- OPAL Error: bad T or R value. ' else write(6,40) flt, slr, z, xh 40 format(' '/' OPAL: logT',f9.6,' logR',f11.6,' Z',f11.9, $ ' or X',f10.7,' is beyond edge') stop ' STOP -- OPAL Error: beyond matrix edge. ' endif endif c return end c c****************************************************************************** c subroutine z_fcno( x,xmet,nmet,fu, z,exC,exO, y,xCN,xON,xNeHeavy, $ fmuainv,fmueinv,zsqbar, fcn,fcon,fcnone,fuse ) c ================================================================= c c.....Given X, XMET(NMET), and FU : calculates and returns the values of c Z = metallicity, EXC = exC, EXO = exO, FCN, FCON, FCNONE, FUSE (opacity c shift factors used by subroutines OPAL_X_CNO_FU and OPAL_F_XCON_CNOU c below); also Y, XCN = C + N/2, XON = O + N/2, XNEHEAVY = 1-X-Y-XCN-XON, c FMUAINV = 1/mu_A = sum{Xi/Ai}. FMUEINV = 1/mu_e = sum{Xi*Zi/Ai}, c ZSQBAR = sum{Xi*Zi^2/Ai} (needed only for conductive opacities). c dimension xmet(nmet) c parameter ( small_1m6=1.e-6, small_1m8=1.e-8 ) c parameter ( small_1m5=1.e-5, small_1m4=1.e-4 ) c parameter ( small_m1m6=-1.e-6, small_m1m8=-1.e-8 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( mx_hi=2*mx, mo_m1=mo-1, mo_m2=mo-2 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c character*2 cel_opalmixes(nel_zmix) character*8 cfile_opalmixes(n_zmixes) common/opalmixes/ xiz_mix(nel_zmix),fninz_mix(nel_zmix), $ bracketife_mix(nel_zmix),bracketofe_opalmixes(n_zmixes), $ xofe_opalmixes(n_zmixes),xiz_opalmixes(nel_zmix,n_zmixes), $ fninz_opalmixes(nel_zmix,n_zmixes), $ cel_opalmixes,cfile_opalmixes save /opalmixes/ c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c parameter ( n_mix_meteor = 3 ) double precision xiz_meteor, fninz_meteor character*255 cfile_meteor(n_mix_meteor) common /c_meteor_mix_opal_z/ xiz_meteor(nel_zmix,n_mix_meteor), $ fninz_meteor(nel_zmix,n_mix_meteor), $ nuc_charge_opalmixes(nel_zmix), cfile_meteor save /c_meteor_mix_opal_z/ c common /cno_delta_opal_z/ fcno_mul(4), fninz_cno(nel_zmix,5), $ xiz_cno(nel_zmix,5), d_fninz_user(nel_zmix), $ fcno_fac(0:3,4), fninz_heavy, xiz_heavy, d_fninz_u_heavy, $ s_ninzai_mix, ds_ninzai_u, fn_o_over_cno, fninz_co_mix save /cno_delta_opal_z/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c___ parameter ( atwt_H = 1.0079, atwt_He = 4.0026 ) c dimension fninz_u(nel_zmix), xiz_u(nel_zmix), fninz(nel_zmix) c c PARAMETERS: for use in call to READZEXCO, if it is called from here: c k_hz = 1 = khighz value for READZEXCO ("use 'GN93hz' in Z-interpolation, c but no CNO-interpolation") c ofe_brack = 0.0 = [O/Fe] value for READZEXCO c parameter ( k_hz=1, ofe_brack=0.0 ) c=== c c Perform checks on the inputs, and compute total mass Ztot of metals. c if ( nmet .lt. 5 ) then write(6,10) nmet 10 format(' '/' OPAL_X_CNO_FU Error: metals array', $ ' Xmet(Nmet): size too small: Nmet =',i2,' < 5') stop ' STOP -- OPAL Error: bad composition (Xmet array size) ' else if ( level_err .gt. 2 .and. $ nmet .ne. nel_zmix .and. kdo_cno .gt. 0 ) then write(6,15) nmet, nel_zmix 15 format(' '/' OPAL_X_CNO_FU Error: metals array', $ ' Xmet(Nmet): Nmet =',i5,', but nel_zmix =',i3) stop ' STOP -- OPAL Error: bad composition (Xmet array size) ' endif c ximin = min( x , xmet(1) , xmet(2) , xmet(3) , xmet(4) ) Zheavy = 0.0 do i = 5, nmet Zheavy = Zheavy + xmet(i) ximin = min( ximin , xmet(i) ) enddo Ztot = Zheavy + xmet(1) + xmet(2) + xmet(3) + xmet(4) c xCN = xmet(1) + 0.5 * xmet(2) xON = xmet(3) + 0.5 * xmet(2) xNeHeavy = Zheavy + xmet(4) y = 1. - x - Ztot c if ( min( Ztot , ximin , y , xCN , xON , xNeHeavy ) .lt. $ small_m1m6 .or. Zheavy .lt. small_m1m8 ) then write(6,20) x, Ztot, Zheavy, ( xmet(i), i = 1, nmet ) 20 format(' '/' OPAL_X_CNO_FU Error: bad X',f10.7, $ ' Ztot',f10.7,' Zheavy',f11.8,' ... Xmet'/6f12.8) stop ' STOP -- OPAL Error: bad composition. ' endif c c..... If necessary, read data files and do initializations, using READZEXCO c (this performs initializations necessary for calculating quantities c further below); note that xiz_mix is initialized by a data statement c to 'GN93hz' relative-metal-abundance values c if ( itime .ne. 12345678 ) then c ! first get approximate Z using the c ! 'GN93hz' relative metal abundances if ( Ztot .le. small_1m6 ) then z = max( Ztot , 0.0 ) else xiz_heavy_u = 0.0 do i = 5, nel_zmix xiz_heavy_u = xiz_heavy_u + xiz_mix(i) enddo z = max( Zheavy / xiz_heavy_u , small_1m6 ) endif c ! read opacities: use 'GN93hz', but no CNO-interpolation c ! will be possible: call readzexco(nz,-1.,z,-1.,k_hz,-1,ofe_brack) c endif c fmuainv = x / atwt_h + y / atwt_he fmueinv = x / atwt_h + y * 2. / atwt_he zsqbar = x / atwt_h + y * 4. / atwt_he c c If there are essentially no metals (except perhaps C,N,O,Ne), there is no c point in trying to do anything fancy with interpolation in the make-up of Z. c if ( Ztot .le. small_1m6 .or. Zheavy .le. small_1m8 ) then c fuse = 0.0 fcn = 0.0 fcon = 0.0 fcnone = 0.0 c ! for very small Z, this is good enough: if ( Ztot .le. small_1m6 ) then z = max( Ztot , 0.0 ) else z = max( Zheavy / xiz_heavy , small_1m6 ) endif c ! any excess C,N,O,Ne --> EXC, EXO: exC = xmet(1) - z * xiz_mix(1) $ + 0.5 * ( xmet(2) - z * xiz_mix(2) ) exO = xmet(3) + xmet(4) $ - z * ( xiz_mix(3) + xiz_mix(4) ) $ + 0.5 * ( xmet(2) - z * xiz_mix(2) ) c fmuainv = fmuainv + xmet(1) / atwt_opalGS98(1) $ + xmet(2) / atwt_opalGS98(2) + xmet(3) / atwt_opalGS98(3) $ + xmet(4) / atwt_opalGS98(4) + Zheavy / 40. fmueinv = fmueinv + xmet(1) * 6. / atwt_opalGS98(1) $ + xmet(2) * 7. / atwt_opalGS98(2) $ + xmet(3) * 8. / atwt_opalGS98(3) $ + xmet(4) * 10. / atwt_opalGS98(4) + Zheavy * 0.5 zsqbar = zsqbar + xmet(1) * 36. / atwt_opalGS98(1) $ + xmet(2) * 49. / atwt_opalGS98(2) $ + xmet(3) * 64. / atwt_opalGS98(3) $ + xmet(4) * 100. / atwt_opalGS98(4) + Zheavy * 10. c c OTHERWISE: if the total amount of metals is not insignificant: c else c c First get a mix to use for FMUAINV, FMUEINV, ZSQBAR c do i = 1, min( nmet , nel_zmix ) xiz_u(i) = xmet(i) enddo if ( nmet .gt. nel_zmix ) then do i = nel_zmix + 1, nmet xiz_u(kel_fe) = xiz_u(kel_fe) + xmet(i) enddo else xiz_heavy_u = 0.0 do i = nmet, nel_zmix xiz_heavy_u = xiz_heavy_u + xiz_mix(i) xiz_u(i) = xmet(nmet) * xiz_mix(i) enddo if ( xiz_heavy_u .gt. 0.0 ) then do i = nmet, nel_zmix xiz_u(i) = xiz_u(i) / xiz_heavy_u enddo endif endif c do i = 1, nel_zmix fmuainv = fmuainv + xiz_u(i) / atwt_opalGS98(i) fmueinv = fmueinv + xiz_u(i) * nuc_charge_opalmixes(i) $ / atwt_opalGS98(i) zsqbar = zsqbar + xiz_u(i) * nuc_charge_opalmixes(i)**2 $ / atwt_opalGS98(i) enddo c c Obtain the OPAL reference mix (relative to Z) in both number and mass c fractions, and the fraction of these that correspond to elements heavier c than Ne; note that this reference mix can be affected by the composition c of the user-specified opacity-shift file, if this is being used. c if ( kdo_user .le. 0 .or. abs(fu) .lt. small_1m6 ) then c ! no fu effect: fuse = 0.0 do i = 1, nel_zmix fninz_u(i) = fninz_mix(i) xiz_u(i) = xiz_mix(i) enddo fninz_heavy_u = fninz_heavy xiz_heavy_u = xiz_heavy c ! else: include fu effect, if it is non-zero else c ! don't allow too much heavy-element reduction from fu c fuse = max( -2.0 , min( 2.0 , fu ) ) fninz_heavy_u = fninz_heavy + fuse * d_fninz_u_heavy if ( fninz_heavy_u .lt. 0.5 * fninz_heavy ) then if ( fu .lt. -0.2 ) then fuse = min( -0.2 , $ -0.5 * fninz_heavy / d_fninz_u_heavy ) fninz_heavy_u = fninz_heavy + fuse * d_fninz_u_heavy else if ( fu .gt. 1.2 ) then fuse = max( 1.2 , $ -0.5 * fninz_heavy / d_fninz_u_heavy ) fninz_heavy_u = fninz_heavy + fuse * d_fninz_u_heavy endif endif c ! get shifted composition using fu-factor fuse sum_niai = 0.0 do i = 1, nel_zmix fninz_u(i) = fninz_mix(i) + fuse * d_fninz_user(i) xiz_u(i) = fninz_u(i) * atwt_opalGS98(i) sum_niai = sum_niai + xiz_u(i) enddo c xiz_u(1) = xiz_u(1) / sum_niai xiz_u(2) = xiz_u(2) / sum_niai xiz_u(3) = xiz_u(3) / sum_niai xiz_u(4) = xiz_u(4) / sum_niai c xiz_heavy_u = 0.0 do i = 5, nel_zmix xiz_u(i) = xiz_u(i) / sum_niai xiz_heavy_u = xiz_heavy_u + xiz_u(i) enddo c endif c c If CNO-interpolation is not available, then all we have to do now is to c compute the metallicity Z and the excess C and O amounts: c if ( kdo_cno .le. 0 ) then c ! no CNO-interpolation: factors are 0.0 fcn = 0.0 fcon = 0.0 fcnone = 0.0 c ! heavies give metallicity Z z = max( Zheavy / xiz_heavy_u , 0.0 ) c ! excess C,N,O,Ne --> EXC, EXO exC = xmet(1) - z * xiz_u(1) $ + 0.5 * ( xmet(2) - z * xiz_u(2) ) exO = xmet(3) + xmet(4) $ - z * ( xiz_u(3) + xiz_u(4) ) $ + 0.5 * ( xmet(2) - z * xiz_u(2) ) c c ELSE, if CNO-interpolation is available: determine the CNO-interpolation c factors as well as the metallicity Z and the excess C and O amounts: c else c c.....Get the factor f_nz that converts fractions of Z to the actual mass c fractions, and use it to convert the input mass fractions to adjusted c number fractions of Z (the CNO-mix) --- if the user-fraction fu is c non-zero, subtract off the effects of the difference in composition c between the user-opacity-file and the OPAL mix (multiplied by fu). c c NOTE: for OPAL-mix(Z): SUM_z{ Xmix_i } = Z, SUM_z{ fninz_mix(i) } = 1.0, c c SUM_h{ Xmix_i } = Zheavy, SUM_h{ fninz_mix(i) } = fninz_heavy c c where fninz_mix(i) = ( Xmix_i / A_i ) / SUM_z{ Xmix_j / A_j } so c c fninz_heavy = SUM_h{ Xmix_i / A_i } / SUM_z{ Xmix_j / A_j } . c c ! If user supplies OPAL-element Xi: if ( nmet .eq. nel_zmix ) then c c For input-mix with same number of elements as OPAL-mix, assume that c SUM_h{ fninz(i) } = fninz_heavy is what determines Z, i.e., c fninz_heavy = SUM_h{ X_i / A_i } / SUM_z{ Xmix_j / A_j } c i.e., assume SUM_h{ X_i / A_i } = SUM_h{ Xmix_i / A_i } . c But SUM_z{ fninz(i) } is NOT necessarily equal to 1.0, since c there may be excess C and O. We therefore set c f_nz = SUM_h{ X_i / A_i } / fninz_heavy c = SUM_h{ X_i / A_i } c / [ SUM_h{ Xmix_i / A_i } / SUM_z{ Xmix_j / A_j } ] c = SUM_z{ Xmix_j / A_j } c due to our assumption SUM_h{ X_i / A_i } = SUM_h{ Xmix_i / A_i } c and thus we set c fninz(i) = X_i / ( f_nz * A_i ) c = ( X_i / A_i ) / SUM_z{ Xmix_i / A_i } c which is what we want. c ! get metallicity factor f_nz f_nz = 0.0 do i = 5, nel_zmix f_nz = f_nz + xmet(i) / atwt_opalGS98(i) enddo f_nz = f_nz / fninz_heavy_u c ! and use it to get CNO-mix do i = 1, nel_zmix fninz(i) = xmet(i) / ( f_nz * atwt_opalGS98(i) ) $ - fuse * d_fninz_user(i) enddo c ! Else: non-OPAL-Xi, but fu = 0.0: else if ( fuse .eq. 0.0 ) then c c For input-mix with different number of elements from OPAL-mix, assume c SUM_h{ X_i } = SUM_h{ Xmix_i } = Zheavy . c But xiz_heavy = SUM_h{ Xmix_i / Z } = Zheavy / Z , and c s_ninzai_mix = SUM_z{ fninz_mix(i) * A_i } c = SUM_z{ Xmix_i } / SUM_z{ Xmix_j / A_j } c = Z / SUM_z{ Xmix_j / A_j } c We therefore set c f_nz = Zheavy / ( xiz_heavy * s_ninzai_mix ) c = Zheavy c / ( [ Zheavy / Z ] * [ Z / SUM_z{ Xmix_j / A_j } ] ) c = SUM_z{ Xmix_j / A_j } c and thus for the non-heavies we set c fninz(i) = X_i / ( f_nz * A_i ) c = ( X_i / A_i ) / SUM_z{ Xmix_i / A_i } c which is what we want (for the heavies, we assume that they are c distributed as in the OPAL-mix). c ! get f_nz f_nz = Zheavy / ( xiz_heavy_u * s_ninzai_mix ) c ! and CNO-mix do i = 1, 4 fninz(i) = xmet(i) / ( f_nz * atwt_opalGS98(i) ) enddo do i = 5, nel_zmix fninz(i) = fninz_mix(i) enddo c ! Else: non-OPAL-Xi and non-zero fu: else c ! get f_nz f_nz = Zheavy / ( xiz_heavy_u $ * ( s_ninzai_mix + fuse * ds_ninzai_u ) ) c ! and CNO-mix do i = 1, 4 fninz(i) = xmet(i) / ( f_nz * atwt_opalGS98(i) ) $ - fuse * d_fninz_user(i) enddo do i = 5, nel_zmix fninz(i) = fninz_mix(i) enddo c endif c c.....Get the number fraction differences between the adjusted CNO-mix and the c original OPAL-mix. Any excess in the sum of N + Ne abundances must come c from C and/or O depletion, so use the former to get these latter amounts. c Note that any Ne increase is expected to come from both C and O, so set c a preliminary O depletion to be the amount of the Ne increase multiplied c by the initial ratio of O to the sum of C,N,O. If this is larger than c the initial O abundance, reduce the excess O depletion (i.e., the amount c of O-depletion beyond the initial O abundance) by a factor of 10 (this c is equivalent to assuming that the third dredge-up yields an order of c magnitude larger C increase than the O increase). Most or all of the c difference between the total N + Ne increase and this (prelimiary) O c depletion should be assigned to C depletion (but the O depletion may need c a slight readjustment). Adjust the excess C and O amounts according to c these C and O depletions; but if the total excess CO is positive, do not c allow either of the C excess or the O excess to be negative --- note that c this condition may cause a readjustment of the C and O depletions. c c ! get CNO-mix - OPAL-mix differences dn_c = fninz(1) - fninz_mix(1) dn_n = fninz(2) - fninz_mix(2) dn_o = fninz(3) - fninz_mix(3) dn_ne = fninz(4) - fninz_mix(4) c ! total increase in N + Ne deln_nne = dn_ne + dn_n c ! total excess CO (by number) fn_co_ex = dn_c + dn_o + deln_nne c ! If have negligible excess CO: if ( fn_co_ex .lt. small_1m4 ) then c ! just divide it equally in C,O fn_c_ex = 0.5 * fn_co_ex fn_o_ex = fn_c_ex deln_c = fn_c_ex - dn_c deln_o = fn_o_ex - dn_o c ! Else: have some excess CO: else c ! If negligible N+Ne increase: if ( deln_nne .lt. small_1m5 ) then c ! divide it equally in C,O deln_c = 0.5 * deln_nne deln_o = deln_c c ! Else: both C,O --> N,Ne and excess CO: else c ! any Ne increase is partly from O if ( dn_ne .gt. 0.0 ) then deln_o = fn_o_over_cno * dn_ne if ( deln_o .gt. fninz_mix(3) ) $ deln_o = fninz_mix(3) $ + 0.1 * ( deln_o - fninz_mix(3) ) deln_rem = deln_nne - deln_o else deln_o = 0.0 deln_rem = deln_nne endif c ! If not much (more) N+Ne: c if ( deln_rem .le. fninz_mix(1) ) then c ! assign it to C deln_c = deln_rem c ! Else if N+Ne increase is < initial C+O: c else if ( deln_nne .le. fninz_co_mix ) then c ! divide it deln_o = max( deln_nne - fninz_mix(1) , deln_o ) deln_c = deln_nne - deln_o c ! Else if large N+Ne increase: else c ! most is from C deln_o = max( fninz_mix(3) , deln_o ) deln_c = deln_nne - deln_o c endif c endif c ! adjust the excess C and O amounts according c ! to the above C and O depletions fn_c_ex = dn_c + deln_c fn_o_ex = dn_o + deln_o c ! but total excess CO is > 0, so do not c ! allow negative excess C or O if ( fn_c_ex .lt. 0.0 ) then deln_c = deln_c - fn_c_ex deln_o = deln_o + fn_c_ex fn_o_ex = fn_o_ex + fn_c_ex fn_c_ex = 0.0 else if ( fn_o_ex .lt. 0.0 ) then deln_c = deln_c + fn_o_ex deln_o = deln_o - fn_o_ex fn_c_ex = fn_c_ex + fn_o_ex fn_o_ex = 0.0 endif c endif c c.....The excess C and O are not part of Z: subtract them off, then use the c previously-computed f_nz factor to calculate the metallicity Z. Obtain c the excess C and O mass fractions EXC and EXO from the excess C and O c number fractions. Use pre-calculated interpolation factors to get the c CNO-interpolation factors FCN, FCON, FCNONE from the C, N, and O number c fractions (relative to Z) that have just been computed (if all three of c these CNO-interpolation factors are very small, set them to zero). c c ! subtract off excess C, O by number fninz(1) = fninz(1) - fn_c_ex fninz(3) = fninz(3) - fn_o_ex c ! compute metallicity mass fraction Z z = 0.0 do i = 1, nel_zmix z = z + ( fninz(i) + fuse * d_fninz_user(i) ) $ * atwt_opalGS98(i) enddo z = max( z * f_nz , 0.0 ) c ! excess C,O mass fractions exC = fn_c_ex * atwt_opalGS98(1) * f_nz exO = fn_o_ex * atwt_opalGS98(3) * f_nz c ! for CNO-interp: fcn = ( fcno_fac(0,2) + fcno_fac(1,2) * fninz(1) $ + fcno_fac(2,2) * fninz(2) $ + fcno_fac(3,2) * fninz(3) ) * fcno_mul(2) fcon = ( fcno_fac(0,3) + fcno_fac(1,3) * fninz(1) $ + fcno_fac(2,3) * fninz(2) $ + fcno_fac(3,3) * fninz(3) ) * fcno_mul(3) fcnone = ( fcno_fac(0,4) + fcno_fac(1,4) * fninz(1) $ + fcno_fac(2,4) * fninz(2) $ + fcno_fac(3,4) * fninz(3) ) * fcno_mul(4) c ! very small? if ( max( abs(fcn) , abs(fcon) , abs(fcnone) ) .lt. $ small_1m5 .or. z .lt. small_1m6 ) then fcn = 0.0 fcon = 0.0 fcnone = 0.0 endif c endif c endif c c Check for exC, exO too large or too negative. c del_sum = ( x + z + exC + exO - 1.0 ) * 0.5d0 if ( del_sum .gt. 0.0 ) then exC = exC - del_sum exO = exO - del_sum endif c if ( exC .lt. -0.5 * z ) then exO = max( -0.5 * z , exO + ( exC + 0.5 * z ) ) exC = -0.5 * z else if ( exO .lt. -0.5 * z ) then exC = max( -0.5 * z , exC + ( exO + 0.5 * z ) ) exO = -0.5 * z endif c return end c c****************************************************************************** c subroutine kapferg( slt, slr, xh, z, exC, exO, $ flka, dlkatr, dlkaro, dlkat, fkaedge ) c ========================================================== c parameter ( small_1m6=1.e-6, small_m1m6=-1.e-6, small_5m7=5.e-7 ) c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c common /mat_alex_ferg/ flk_ferg(nr_ferg,nt_ferg,nz_ferg,nx_ferg) save /mat_alex_ferg/ c common /opac_ferg/ zlog_ferg(nzp1_ferg), xlog_ferg(nx_ferg), $ dzinvlog_ferg(nz_ferg), dzinv_ferg(nz_ferg), $ dxinvlog_ferg(nx_ferg), dxinv_ferg(nx_ferg), $ t6log_ferg(nt_ferg), rlog_ferg(nr_ferg), $ dt6inv_ferg(nt_ferg), drinv_ferg(nr_ferg), $ modt_ferg, modz0_ferg, ntuferg save /opac_ferg/ c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c common /c_prev_ferg/ zlogp_ferg, xp_ferg, zlp1_ferg, xp1_ferg, $ zlp2_ferg, xp2_ferg, i1p_ferg, i4p_ferg, j1p_ferg, j4p_ferg save /c_prev_ferg/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_edge_alex/ fkaedgelo, fkaedgehi, fzkaedge save /c_edge_alex/ c c Note that the following are initialized to valid values when Ferguson et al. c molecular opacities are read in, whether from ASCII file or binary dumpfile: c common /c_ferg_indices/ mf, mg, mh, mf2, kf, kg, kh, kf2, $ i1, i2, i3, i4, j1, j2, j3, j4 save /c_ferg_indices/ c common/d_opal_z/ dkap save /d_opal_z/ c parameter ( badlogkval=1.e+35 ) c parameter ( nzm1_ferg=nz_ferg-1, nzm2_ferg=nz_ferg-2, $ nrm1_ferg=nr_ferg-1 ) c dimension h(nx_ferg), g(4), dg(4), needt(4), needr(4) c logical lacc_t, lacc_zf, lacc_xf, lnozlo c-debug[ c-debug; common /c_debug_ferg/ i_debug_ferg c-debug; save /c_debug_ferg/ c-debug] c=== c-debug[ c-debug; if ( i_debug_ferg .gt. 1 ) write(6,'(" ")') c-debug; if ( i_debug_ferg .gt. 0 ) write(6, c-debug; $ '(" ***** kapferg(",2(a,f11.6),4(a,f11.7),a," ):")') c-debug; $ ' slt', slt, ' slr', slr, ' xh', xh, ' z', z, c-debug; $ ' exC', exC, ' exC', exO, c-debug; $ ' flka, dlkatr, dlkaro, dlkat, fkaedge' c-debug] flka = badlogkval dlkatr = 0.0 dlkaro = 0.0 dlkat = 0.0 fkaedge = 0.0 fkaedgelo = 1.0 fkaedgehi = 1.0 fzkaedge = 1.0 c ! have Ferguson et al. 2005 opacities? if ( kavail_alex .le. 1 ) return c xzco = z + exC + exO zpxc = min( 1.0 , max( xzco , 0.0 ) ) y = 1.0 - xh - zpxc c ! check composition if ( min( xh , xzco , y ) .le. small_m1m6 ) then write(6,10) xh, y, xzco 10 format(' '/' KAPFERG Error: bad X=',1p,e13.6, $ ' Y=1-X-Z-CO=',e13.6,' Z+CO=',e13.6) stop ' STOP - KAPFERG: bad { X , Z + exCO } composition . ' endif c ! check bounds fthi = ( slt - t6log_ferg(1) ) * dt6inv_ferg(1) + 1.0 ftlo = ( t6log_ferg(ntuferg) - slt ) * dt6inv_ferg(ntuferg) + 1.0 c fkaedgelo = max( 0.0 , min( 1.0 , ftlo , $ ( slr - rlog_ferg(1) ) * drinv_ferg(1) + 1.0 ) ) fkaedgehi = max( 0.0 , min( 1.0 , fthi , $ ( rlog_ferg(nr_ferg) - slr ) * drinv_ferg(nr_ferg) + 1.0 ) ) c if ( zpxc .gt. z_ferg(nz_ferg) ) fzkaedge = max( 0.0 , $ ( z_ferg(nz_ferg) - zpxc ) * dzinv_ferg(nz_ferg) + 1.0 ) c izchk_alex = iabs( kuse_alex ) c if ( izchk_alex .ge. 4 ) fzkaedge = fzkaedge $ * max( 0.0 , 1.0 - ( abs(exC) + abs(exO) ) * 5.0 $ / max( z , 0.0001 , z + exC + exO ) ) c fkaedge = fzkaedge * min( fkaedgelo, fkaedgehi ) c if ( min( fzkaedge , ftlo , fthi ) .le. 0.0 ) return c fzlo = 1.0 c ! these just prevent compiler warnings: fzhi = 0.0 fxlo = 1.0 fxhi = 0.0 ftlo = 1.0 fthi = 0.0 frlo = 1.0 frhi = 0.0 c-noXlog; xlogat = xh zlogat = zpxc c ! get X-indices if ( xh .lt. small_1m6 ) then c mf = 1 mf2 = 1 mg = 1 mh = 1 c else if ( y .lt. small_1m6 ) then c mf = nx_ferg mf2 = nx_ferg mg = nx_ferg mh = nx_ferg c else c if ( zpxc .ge. z_ferg(nz_ferg) ) then ixhi = nxm2_ferg else if ( zpxc .ge. z_ferg(n2_ferg) ) then ixhi = nxm1_ferg else ixhi = nx_ferg endif c ihi = max( 3 , min( ixhi , mh ) ) ilo = ihi - 1 iat = 1 do while ( ilo .gt. 2 .and. xh .lt. x_ferg(ilo) ) ihi = ilo ilo = max( 2 , ilo - iat ) iat = iat + iat enddo do while ( ihi .lt. ixhi .and. xh .gt. x_ferg(ihi) ) ilo = ihi ihi = min( ixhi , ihi + iat ) iat = iat + iat enddo do while ( ihi - ilo .gt. 1 ) iat = ( ihi + ilo ) / 2 if ( xh .ge. x_ferg(iat) ) then ilo = iat else ihi = iat endif enddo c if ( abs( x_ferg(ilo) - xh ) .lt. small_1m6 ) then mf = ilo mf2 = ilo mg = ilo mh = ilo else if ( abs( x_ferg(ihi) - xh ) .lt. small_1m6 ) then mf = ihi mf2 = ihi mg = ihi mh = ihi else x_ferg(nx_ferg) = 1.0 - zpxc if ( xh .gt. x_ferg(ilo) ) then mf2 = min( ihi + 1 , ixhi ) else mf2 = ihi endif if ( mf2 .eq. ihi .or. xh .lt. x_ferg(ihi) ) then mf = ilo - 1 mg = ilo mh = ihi else mf = ilo mg = ihi mh = mf2 endif endif c if ( ixhi .lt. nx_ferg ) then if ( mf2 .eq. ixhi ) mf2 = nx_ferg if ( mh .eq. ixhi ) mh = nx_ferg if ( mg .eq. ixhi ) mg = nx_ferg if ( mf .eq. ixhi ) mf = nx_ferg endif c c-noXlog; if ( mf .le. 2 .and. mf2 .gt. mf ) c-noXlog; $ xlogat = log10( xh + xdel_ferg ) c if ( mf2 .gt. mh ) then c-noXlog; if ( mg .eq. 2 ) then c-noXlog; fxlo = max( 0.0 , min( 1.0 , c-noXlog; $ ( xlog_ferg(mh) - xlogat ) * dxinvlog_ferg(mh) ) ) c-noXlog; else fxlo = max( 0.0 , min( 1.0 , $ ( x_ferg(mh) - xh ) * dxinv_ferg(mh) ) ) c-noXlog; endif fxhi = 1.0 - fxlo endif c endif c ! get Z-indices if ( zpxc .lt. z0_ferg ) then c kf = 1 kg = 1 kh = 1 kf2 = 1 zlogat = zlog_ferg(1) c else c ihi = max( 3 , min( nz_ferg , kh ) ) ilo = ihi - 1 iat = 1 do while ( ilo .gt. 2 .and. zpxc .lt. z_ferg(ilo) ) ihi = ilo ilo = max( 2 , ilo - iat ) iat = iat + iat enddo do while ( ihi .lt. nz_ferg .and. zpxc .gt. z_ferg(ihi) ) ilo = ihi ihi = min( nz_ferg , ihi + iat ) iat = iat + iat enddo do while ( ihi - ilo .gt. 1 ) iat = ( ihi + ilo ) / 2 if ( zpxc .ge. z_ferg(iat) ) then ilo = iat else ihi = iat endif enddo c if ( abs( z_ferg(ilo) - zpxc ) .lt. small_1m6 * zpxc ) then kf = ilo kg = ilo kh = ilo kf2 = ilo zlogat = zlog_ferg(ilo) else if ( abs( z_ferg(ihi) - zpxc ) .lt. $ small_1m6 * zpxc ) then kf = ihi kg = ihi kh = ihi kf2 = ihi zlogat = zlog_ferg(ihi) else kf = ilo - 1 kg = ilo kh = ihi zlogat = log10( zpxc + zdel_ferg ) if ( ihi .ge. nz_ferg .or. zpxc .le. z_ferg(ilo) ) then kf2 = ihi if ( iacc_ferg .gt. 0 .and. ihi .eq. nz_ferg ) then kf2 = nzp1_ferg fzlo = max( 0.0 , min( 1.0 , $ ( zlog_ferg(nz_ferg) - zlogat ) $ * dzinvlog_ferg(nz_ferg) ) ) fzhi = 1.0 - fzlo endif else kf2 = ihi + 1 fzlo = max( 0.0 , min( 1.0 , $ ( zlog_ferg(kh) - zlogat ) * dzinvlog_ferg(kh) ) ) fzhi = 1.0 - fzlo endif endif c endif c if ( fzlo .le. 0.0 ) then lnozlo = .true. else lnozlo = .false. endif c ! get T-indices: note: from previous: 1 < i2 = i3 - 1 < ntuferg iat = 1 do while ( i3 .lt. ntuferg .and. slt .lt. t6log_ferg(i3) ) i2 = i3 i3 = min( ntuferg , i3 + iat ) iat = iat + iat enddo do while ( i2 .gt. 2 .and. slt .gt. t6log_ferg(i2) ) i3 = i2 i2 = max( 2 , i2 - iat ) iat = iat + iat enddo do while ( i3 - i2 .gt. 1 ) iat = ( i2 + i3 ) / 2 if ( slt .le. t6log_ferg(iat) ) then i2 = iat else i3 = iat endif enddo c i1 = i2 - 1 if ( i3 .ge. ntuferg .or. slt .ge. t6log_ferg(i2) ) then i4 = i3 else i4 = i3 + 1 ftlo = max( 0.0 , min( 1.0 , $ ( t6log_ferg(i3) - slt ) * dt6inv_ferg(i3) ) ) fthi = 1.0 - ftlo endif c ! get R-indices: note: from previous: 0 < j2 = j3 - 1 < nr_ferg iat = 1 do while ( j2 .gt. 1 .and. slr .lt. rlog_ferg(j2) ) j3 = j2 j2 = max( 1 , j2 - iat ) iat = iat + iat enddo do while ( j3 .lt. nr_ferg .and. slr .gt. rlog_ferg(j3) ) j2 = j3 j3 = min( nr_ferg , j3 + iat ) iat = iat + iat enddo do while ( j3 - j2 .gt. 1 ) iat = ( j2 + j3 ) / 2 if ( slr .ge. rlog_ferg(iat) ) then j2 = iat else j3 = iat endif enddo c ! note: may have j1 = 0 or j4 = nr_ferg + 1 j1 = j2 - 1 if ( slr .le. rlog_ferg(j2) ) then j4 = j3 else j4 = j3 + 1 frlo = max( 0.0 , min( 1.0 , $ ( rlog_ferg(j3) - slr ) * drinv_ferg(j3) ) ) frhi = 1.0 - frlo if ( frhi .le. 0.0 ) j4 = j3 endif c ! by default, Z,X-interp is needed at each T-value needt(1) = 1 needt(2) = 1 needt(3) = 1 needt(4) = 1 c ! by default, Z,X-interp is needed at each R-value needr(1) = 1 needr(2) = 1 needr(3) = 1 needr(4) = 1 c nzp_sto = nz_ferg c ! if first full-T-R-cache (of stored c ! Z,X-interp values) was computed and c ! matches X,Z, use it: if ( abs( zlogat - zlp1_ferg ) .le. small_1m6 .and. $ abs( xh - xp1_ferg ) .le. small_5m7 ) then c nzp_sto = nzm1_ferg needall = 0 c ! else if second full-T-R-cache c ! matches X,Z: else if ( abs( zlogat - zlp2_ferg ) .le. small_1m6 .and. $ abs( xh - xp2_ferg ) .le. small_5m7 ) then c nzp_sto = nzm2_ferg needall = 0 c ! else if NO stored Z,X-interp values are O.K. for use c ! (i.e., Z or X has changed, or there is no T-overlap c ! or no R-overlap): else if ( i1 .gt. i4p_ferg .or. i4 .lt. i1p_ferg .or. $ j1 .gt. j4p_ferg .or. j4 .lt. j1p_ferg .or. $ abs( zlogat - zlogp_ferg ) .gt. small_1m6 .or. $ abs( xh - xp_ferg ) .gt. small_5m7 ) then c needall = 1 c ! else if stored Z,X-interp values suffice (no new c ! ones needed): else if ( i1 .ge. i1p_ferg .and. i4 .le. i4p_ferg .and. $ max( 1 , j1 ) .ge. j1p_ferg .and. $ min( nr_ferg , j4 ) .le. j4p_ferg ) then c needall = 0 c ! else (if some new Z,X-interp values must be stored): else c needall = -1 c ! find T-overlap i0 = i1 - 1 do i = max( i1, i1p_ferg ), min( i4, i4p_ferg ) needt(i-i0) = 0 enddo c ! find R-overlap i0 = j1 - 1 do i = max( j1, j1p_ferg ), min( j4, j4p_ferg ) needr(i-i0) = 0 enddo c endif c-debug[ c-debug; if ( i_debug_ferg .gt. 1 ) then c-debug; write(6,'(2(a,f11.7),4(a,f11.7),a,i3)') c-debug; $ ' zpxc=', zpxc, ' y=', y, ' fkaedgelo=', fkaedgelo, c-debug; $ ' fkaedgehi=', fkaedgehi, ' fzkaedge=', fzkaedge, c-debug; $ ' fkaedge=', fkaedge, ' iacc_ferg=', iacc_ferg c-debug; write(6,'(a,4i3,a,f11.6,a,4f11.6)') c-debug; $ ' kf,g,h,f2=', kf, kg, kh, kf2, ' zlogat=', zlogat, c-debug; $ ' zlog_ferg(kf:kf2)', c-debug; $ ( zlog_ferg(i), i = kf, min(kf2,nz_ferg) ) c-debug; if ( mf2 .le. mh ) then c-debug; write(6,'(a,4i3,a,f11.7,a,4f11.7)') c-debug; $ ' mf,g,h,f2=', mf, mg, mh, mf2, ' x=', xh, c-debug; $ ' x_ferg(mf:mf2)', ( x_ferg(i), i = mf, mh ) c-debug; else c-debug; write(6,'(a,4i3,a,f11.7,a,4f11.7)') c-debug; $ ' mf,g,h,f2=', mf, mg, mh, mf2, ' x=', xh, c-debug; $ ' x_ferg(mf:mf2)', ( x_ferg(i), i = mf, mh ), c-debug; $ x_ferg(mf2) c-debug; endif c-debug; write(6,'(2(a,4i3),a,f11.6,a,4f11.6)') c-debug; $ ' j1:4=', j1, j2, j3, j4, c-debug; $ ' needr(1:4)=', (needr(i),i=1,4), c-debug; $ ' logR=', slr, ' logR_ferg(j1:j4)=', c-debug; $ ( rlog_ferg(i), i = max(1,j1), min(nr_ferg,j4) ) c-debug; write(6,'(2(a,4i3),a,f11.7,a,4f11.7)') c-debug; $ ' i1:4=', i1, i2, i3, i4, c-debug; $ ' needt(1:4)=', (needt(i),i=1,4), c-debug; $ ' logT=', slt + 6.0, ' logT_ferg(i1:i4)=', c-debug; $ ( t6log_ferg(i) + 6.0, i = i1, i4 ) c-debug; write(6,'(4(a,2f10.6),a,i3)') c-debug; $ ' fzlo,hi=', fzlo, fzhi, ' fxlo,hi=', fxlo, fxhi, c-debug; $ ' frlo,hi=', frlo, frhi, ' ftlo,hi=', ftlo, fthi, c-debug; $ ' needall', needall c-debug; endif c-debug] c if ( iacc_ferg .gt. 0 ) then modt_use = modt_ferg else modt_use = nt_ferg + 10 endif c icr = 0 iar = 0 icr2 = 0 iar2 = 0 c ! IF any Z,X-interpolation is needed : if ( needall .ne. 0 ) then c icz = 0 icx = 0 iaz = 0 iax = 0 icz2 = 0 icx2 = 0 iaz2 = 0 iax2 = 0 c if ( kf .ne. kf2 .and. lnozlo .and. $ kf2 .gt. nz_ferg .and. i1 .lt. modt_ferg ) $ call quadsto( 1, zlogat, zlog_ferg(nzm2_ferg), $ zlog_ferg(nzm1_ferg), zlog_ferg(nz_ferg) ) c i0 = 0 lacc_xf = .true. lacc_t = .false. c ! for each T-value: do it = i1, i4 c if ( it .ge. modt_use ) lacc_t = .true. c if ( mf .ne. 1 ) lacc_xf = lacc_t c if ( it .ge. modz0_ferg .and. kf .eq. 1 ) then lacc_zf = .true. else lacc_zf = lacc_t endif c if ( kf .ne. kf2 ) then if ( .not. lnozlo ) then if ( lacc_zf ) then if ( iaz .eq. 0 ) call quadslsto( 1, zlogat, $ zlog_ferg(kf), zlog_ferg(kg), zlog_ferg(kh) ) iaz = 1 else if ( icz .eq. 0 ) then call quadsto( 1, zlogat, zlog_ferg(kf), $ zlog_ferg(kg), zlog_ferg(kh) ) icz = 1 endif endif if ( kf2 .gt. nz_ferg ) then if ( iaz2 .eq. 0 .and. it .ge. modt_ferg ) then call quadslsto( 3, zlogat, zlog_ferg(nzm1_ferg), $ zlog_ferg(nz_ferg), zlog_ferg(nzp1_ferg) ) iaz2 = 1 endif else if ( kf2 .gt. kh ) then if ( lacc_t ) then if ( iaz2 .eq. 0 ) call quadslsto( 3, zlogat, $ zlog_ferg(kg), zlog_ferg(kh), $ zlog_ferg(kf2) ) iaz2 = 1 else if ( icz2 .eq. 0 ) then call quadsto( 3, zlogat, zlog_ferg(kg), $ zlog_ferg(kh), zlog_ferg(kf2) ) icz2 = 1 endif endif endif c if ( mf .ne. mf2 ) then if ( mh .lt. nx_ferg ) then if ( lacc_xf ) then if ( iax .eq. 0 ) call quadslsto( 2, xh, $ x_ferg(mf), x_ferg(mg), x_ferg(mh) ) iax = 1 else if ( icx .eq. 0 ) then call quadsto( 2, xh, x_ferg(mf), $ x_ferg(mg), x_ferg(mh) ) icx = 1 endif else if ( lacc_xf ) then if ( iax .eq. 0 ) call qchkslsto( 2, xh, $ x_ferg(mf), x_ferg(mg), x_ferg(mh) ) iax = 1 else call qchksto( 2, xh, x_ferg(mf), $ x_ferg(mg), x_ferg(mh) ) icx = 1 endif if ( mf2 .gt. mh ) then if ( mf2 .lt. nx_ferg ) then if ( lacc_t ) then if ( iax2 .eq. 0 ) call quadslsto( 4, xh, $ x_ferg(mg), x_ferg(mh), x_ferg(mf2) ) iax2 = 1 else if ( icx2 .eq. 0 ) then call quadsto( 4, xh, x_ferg(mg), $ x_ferg(mh), x_ferg(mf2) ) icx2 = 1 endif else if ( lacc_t ) then if ( iax2 .eq. 0 ) call qchkslsto( 4, xh, $ x_ferg(mg), x_ferg(mh), x_ferg(mf2) ) iax2 = 1 else if ( icx2 .eq. 0 ) then call qchksto( 4, xh, x_ferg(mg), $ x_ferg(mh), x_ferg(mf2) ) icx2 = 1 endif endif endif c if ( j1 .gt. 0 .and. frlo .gt. 0.0 ) then if ( lacc_t ) then if ( iar .eq. 0 ) call qderslsto( 5, slr, $ rlog_ferg(j1), rlog_ferg(j2), rlog_ferg(j3) ) iar = 1 else if ( icr .eq. 0 ) then call qdersto( 5, slr, rlog_ferg(j1), rlog_ferg(j2), $ rlog_ferg(j3) ) icr = 1 endif endif if ( j4 .gt. j3 .and. j4 .le. nr_ferg ) then if ( lacc_t ) then if ( iar2 .eq. 0 ) call qderslsto( 6, slr, $ rlog_ferg(j2), rlog_ferg(j3), rlog_ferg(j4) ) iar2 = 1 else if ( icr2 .eq. 0 ) then call qdersto( 6, slr, rlog_ferg(j2), rlog_ferg(j3), $ rlog_ferg(j4) ) icr2 = 1 endif endif c i0 = i0 + 1 j0 = max( 0 , 1 - j1 ) c ! for each R-value at that T: c do ir = max( 1 , j1 ), min( nr_ferg , j4 ) c c ! check whether Z,X-interp is needed at (T,R) j0 = j0 + 1 c ! if needed: if ( needt(i0) .gt. 0 .or. needr(j0) .gt. 0 ) then c ! for each X do ix = mf, mf2 c ! that is needed if ( ix .le. mh .or. ix .eq. mf2 ) then c ! do Z-interp: if ( kf .eq. kf2 ) then h(ix) = flk_ferg(ir,it,kf,ix) else if ( lnozlo ) then if ( kf2 .le. nz_ferg .or. $ it .ge. modt_ferg ) then h(ix) = flk_ferg(ir,it,kh,ix) else h(ix) = quadget( 1, $ flk_ferg(ir,it,kf,ix), $ flk_ferg(ir,it,kg,ix), $ flk_ferg(ir,it,kh,ix) ) endif else if ( lacc_zf ) then h(ix) = quadslget( 1, $ flk_ferg(ir,it,kf,ix), $ flk_ferg(ir,it,kg,ix), $ flk_ferg(ir,it,kh,ix) ) else h(ix) = quadget( 1, $ flk_ferg(ir,it,kf,ix), $ flk_ferg(ir,it,kg,ix), $ flk_ferg(ir,it,kh,ix) ) endif if ( kf2 .gt. nz_ferg ) then if ( it .ge. modt_ferg ) then val = flk_ferg(ir,it,nz_ferg,ix) $ - flk_ferg(ir,it,nzm1_ferg,ix) vm2 = flk_ferg(ir,it,nzm1_ferg,ix) $ - flk_ferg(ir,it,nzm2_ferg,ix) if ( abs(val) .le. abs(vm2) ) then val = flk_ferg(ir,it,nz_ferg,ix) $ + val else val = flk_ferg(ir,it,nz_ferg,ix) $ + vm2 endif h(ix) = fzlo * h(ix) + fzhi $ * quadslget( 3, $ flk_ferg(ir,it,nzm1_ferg,ix), $ flk_ferg(ir,it,nz_ferg,ix), $ val ) endif else if ( kf2 .gt. kh .and. $ ( ix .ne. nxm1_ferg .or. $ kf2 .le. n2_ferg ) ) then if ( lacc_t ) then h(ix) = fzlo * h(ix) + fzhi $ * quadslget( 3, $ flk_ferg(ir,it,kg,ix), $ flk_ferg(ir,it,kh,ix), $ flk_ferg(ir,it,kf2,ix) ) else h(ix) = fzlo * h(ix) + fzhi $ * quadget( 3, $ flk_ferg(ir,it,kg,ix), $ flk_ferg(ir,it,kh,ix), $ flk_ferg(ir,it,kf2,ix) ) icz2 = 1 endif endif endif c-debug[ c-debug; if ( i_debug_ferg .gt. 8 ) write(6, c-debug; $ '(3(a,i3),a,f11.6,a,4(i3,":",f11.6))') c-debug; $ ' it=', it, ' ir=', ir, c-debug; $ ' ix=', ix, ' h(ix)=', h(ix), ' <--Z', c-debug; $ ( i, flk_ferg(ir,it,i,ix), c-debug; $ i = kf, min(kf2,nz_ferg) ) c-debug] c endif c ! end of X-loop enddo c ! do X-interp: if ( mf .eq. mf2 ) then flk_ferg(ir,it,nzp_sto,nxm1_ferg) = h(mf) else if ( mh .lt. nx_ferg ) then if ( lacc_xf ) then val = quadslget( 2, h(mf), h(mg), h(mh) ) else val = quadget( 2, h(mf), h(mg), h(mh) ) endif else if ( lacc_xf ) then val = qchkslget( 2, h(mf), h(mg), h(mh) ) else val = qchkget( 2, h(mf), h(mg), h(mh) ) endif if ( mf2 .gt. mh ) then if ( mf2 .lt. nx_ferg ) then if ( lacc_t ) then val = fxlo * val + fxhi * quadslget( 4, $ h(mg), h(mh), h(mf2) ) else val = fxlo * val + fxhi $ * quadget( 4, h(mg), h(mh), h(mf2) ) endif else if ( lacc_t ) then val = fxlo * val + fxhi $ * qchkslget( 4, h(mg), h(mh), h(mf2) ) else val = fxlo * val + fxhi $ * qchkget( 4, h(mg), h(mh), h(mf2) ) endif endif flk_ferg(ir,it,nzp_sto,nxm1_ferg) = val endif c-debug[ c-debug; if ( i_debug_ferg .gt. 7 ) then c-debug; if ( mf2 .gt. mh + 1 ) then c-debug; write(6, c-debug; $ '(2(a,i3),a,f11.6,a,3(i3,":",f11.6),$)') c-debug; $ ' it=', it, ' ir=', ir, c-debug; $ ' flk_ferg(ir,it,nzp_sto,nxm1_ferg)=', c-debug; $ flk_ferg(ir,it,nzp_sto,nxm1_ferg), c-debug; $ ' <--X', ( i, h(i), i = mf, mh ) c-debug; write(6,'(i3,":",f11.6)') mf2, h(mf2) c-debug; else c-debug; write(6, c-debug; $ '(2(a,i3),a,f11.6,a,4(i3,":",f11.6))') c-debug; $ ' it=', it, ' ir=', ir, c-debug; $ ' flk_ferg(ir,it,nzp_sto,nxm1_ferg)=', c-debug; $ flk_ferg(ir,it,nzp_sto,nxm1_ferg), c-debug; $ ' <--X', ( i, h(i), i = mf, mf2 ) c-debug; endif c-debug; endif c-debug] c endif c ! end of R-loop enddo c ! do R-interp, with RHO-derivatives if ( frlo .gt. 0.0 ) then if ( j1 .le. 0 ) then dg(i0) = ( flk_ferg(2,it,nzp_sto,nxm1_ferg) $ - flk_ferg(1,it,nzp_sto,nxm1_ferg) ) $ * drinv_ferg(2) g(i0) = ( slr - rlog_ferg(1) ) * dg(i0) $ + flk_ferg(1,it,nzp_sto,nxm1_ferg) else if ( lacc_t ) then call qderslget( 5, flk_ferg(j1,it,nzp_sto,nxm1_ferg), $ flk_ferg(j2,it,nzp_sto,nxm1_ferg), $ flk_ferg(j3,it,nzp_sto,nxm1_ferg), $ g(i0), dg(i0) ) else call qderget( 5, flk_ferg(j1,it,nzp_sto,nxm1_ferg), $ flk_ferg(j2,it,nzp_sto,nxm1_ferg), $ flk_ferg(j3,it,nzp_sto,nxm1_ferg), $ g(i0), dg(i0) ) endif endif if ( j4 .gt. j3 ) then if ( j4 .gt. nr_ferg ) then dkap = ( flk_ferg(nr_ferg,it,nzp_sto,nxm1_ferg) $ - flk_ferg(nrm1_ferg,it,nzp_sto,nxm1_ferg) ) $ * drinv_ferg(nr_ferg) val = ( slr - rlog_ferg(nr_ferg) ) * dkap $ + flk_ferg(nr_ferg,it,nzp_sto,nxm1_ferg) else if ( lacc_t ) then call qderslget( 6, flk_ferg(j2,it,nzp_sto,nxm1_ferg), $ flk_ferg(j3,it,nzp_sto,nxm1_ferg), $ flk_ferg(j4,it,nzp_sto,nxm1_ferg), $ val, dkap ) else call qderget( 6, flk_ferg(j2,it,nzp_sto,nxm1_ferg), $ flk_ferg(j3,it,nzp_sto,nxm1_ferg), $ flk_ferg(j4,it,nzp_sto,nxm1_ferg), $ val, dkap ) endif if ( frlo .gt. 0.0 ) then dg(i0) = frlo * dg(i0) + frhi * dkap $ + drinv_ferg(j3) * ( val - g(i0) ) g(i0) = frlo * g(i0) + frhi * val else dg(i0) = dkap g(i0) = val endif endif c-debug[ c-debug; if ( i_debug_ferg .gt. 6 ) c-debug; $ write(6,'(a,i3,2(a,i1,a,f11.6),a,4(i4,":",f11.6))') c-debug; $ ' it=', it, ' g(', i0,')=', g(i0), c-debug; $ ' dg(', i0,')=', dg(i0), ' <--R', c-debug; $ ( i, flk_ferg(i,it,nzp_sto,nxm1_ferg), c-debug; $ i = max(1,j1), min(nr_ferg,j4) ) c-debug] c ! end of T-loop enddo c ! do T-interp, with T-deriv at const R if ( i2 .ge. modt_use ) then call qderslsto( 7, slt, t6log_ferg(i1), $ t6log_ferg(i2), t6log_ferg(i3) ) call qderslget( 7, g(1), g(2), g(3), flka, dlkatr ) dlkaro = quadslget( 7, dg(1), dg(2), dg(3) ) else call qdersto( 7, slt, t6log_ferg(i1), $ t6log_ferg(i2), t6log_ferg(i3) ) call qderget( 7, g(1), g(2), g(3), flka, dlkatr ) dlkaro = quadget( 7, dg(1), dg(2), dg(3) ) endif if ( i4 .gt. i3 ) then if ( i3 .ge. modt_use ) then call qderslsto( 8, slt, t6log_ferg(i2), $ t6log_ferg(i3), t6log_ferg(i4) ) call qderslget( 8, g(2), g(3), g(4), val, dkap ) dlkaro = ftlo * dlkaro + fthi $ * quadslget( 8, dg(2), dg(3), dg(4) ) else call qdersto( 8, slt, t6log_ferg(i2), $ t6log_ferg(i3), t6log_ferg(i4) ) call qderget( 8, g(2), g(3), g(4), val, dkap ) dlkaro = ftlo * dlkaro + fthi $ * quadget( 8, dg(2), dg(3), dg(4) ) endif dlkatr = ftlo * dlkatr + fthi * dkap $ + dt6inv_ferg(i3) * ( val - flka ) flka = ftlo * flka + fthi * val endif c-debug[ c-debug; if ( i_debug_ferg .gt. 5 ) then c-debug; write(6,'(2(a,f11.6),a,4(i4,":",f11.6))') c-debug; $ ' flka=', flka, ' dlkatr=', dlkatr, ' <--T', c-debug; $ ( i, g(i), i = 1, i4 - i1 + 1 ) c-debug; write(6,'(a,f11.6,a,4(i4,":",f11.6))') c-debug; $ ' dlkaro=', dlkaro, ' <--T', c-debug; $ ( i, dg(i), i = 1, i4 - i1 + 1 ) c-debug; endif c-debug] c ! ELSE: if no Z,X-interpolation is needed (use stored values) : else c ! do R-interp (same as further above) i0 = 0 lacc_t = .false. c do it = i1, i4 c i0 = i0 + 1 if ( it .ge. modt_use ) lacc_t = .true. c if ( frlo .gt. 0.0 ) then if ( j1 .le. 0 ) then dg(i0) = ( flk_ferg(2,it,nzp_sto,nxm1_ferg) $ - flk_ferg(1,it,nzp_sto,nxm1_ferg) ) $ * drinv_ferg(2) g(i0) = ( slr - rlog_ferg(1) ) * dg(i0) $ + flk_ferg(1,it,nzp_sto,nxm1_ferg) else if ( lacc_t ) then if ( iar .eq. 0 ) call qderslsto( 5, slr, $ rlog_ferg(j1), rlog_ferg(j2), rlog_ferg(j3) ) call qderslget( 5, flk_ferg(j1,it,nzp_sto,nxm1_ferg), $ flk_ferg(j2,it,nzp_sto,nxm1_ferg), $ flk_ferg(j3,it,nzp_sto,nxm1_ferg), $ g(i0), dg(i0) ) iar = 1 else if ( icr .eq. 0 ) call qdersto( 5, slr, $ rlog_ferg(j1), rlog_ferg(j2), rlog_ferg(j3) ) call qderget( 5, flk_ferg(j1,it,nzp_sto,nxm1_ferg), $ flk_ferg(j2,it,nzp_sto,nxm1_ferg), $ flk_ferg(j3,it,nzp_sto,nxm1_ferg), $ g(i0), dg(i0) ) icr = 1 endif endif if ( j4 .gt. j3 ) then if ( j4 .gt. nr_ferg ) then dkap = ( flk_ferg(nr_ferg,it,nzp_sto,nxm1_ferg) $ - flk_ferg(nrm1_ferg,it,nzp_sto,nxm1_ferg) ) $ * drinv_ferg(nr_ferg) val = ( slr - rlog_ferg(nr_ferg) ) * dkap $ + flk_ferg(nr_ferg,it,nzp_sto,nxm1_ferg) else if ( lacc_t ) then if ( iar2 .eq. 0 ) call qderslsto( 6, slr, $ rlog_ferg(j2), rlog_ferg(j3), rlog_ferg(j4) ) call qderslget( 6, flk_ferg(j2,it,nzp_sto,nxm1_ferg), $ flk_ferg(j3,it,nzp_sto,nxm1_ferg), $ flk_ferg(j4,it,nzp_sto,nxm1_ferg), $ val, dkap ) iar2 = 1 else if ( icr2 .eq. 0 ) call qdersto( 6, slr, $ rlog_ferg(j2), rlog_ferg(j3), rlog_ferg(j4) ) call qderget( 6, flk_ferg(j2,it,nzp_sto,nxm1_ferg), $ flk_ferg(j3,it,nzp_sto,nxm1_ferg), $ flk_ferg(j4,it,nzp_sto,nxm1_ferg), $ val, dkap ) icr2 = 1 endif if ( frlo .gt. 0.0 ) then dg(i0) = frlo * dg(i0) + frhi * dkap $ + drinv_ferg(j3) * ( val - g(i0) ) g(i0) = frlo * g(i0) + frhi * val else dg(i0) = dkap g(i0) = val endif endif c-debug[ c-debug; if ( i_debug_ferg .gt. 6 ) c-debug; $ write(6,'(a,i3,2(a,i1,a,f11.6),a,4(i3,":",f11.6))') c-debug; $ ' ----it=', it, ' g(', i0,')=', g(i0), c-debug; $ ' dg(', i0,')=', dg(i0), ' <--R', c-debug; $ ( i, flk_ferg(i,it,nzp_sto,nxm1_ferg), c-debug; $ i = max( 1 , j1 ), min( nr_ferg , j4 ) ) c-debug] c enddo c ! do T-interp, with T-deriv at const R if ( i2 .ge. modt_use ) then call qderslsto( 7, slt, t6log_ferg(i1), $ t6log_ferg(i2), t6log_ferg(i3) ) call qderslget( 7, g(1), g(2), g(3), flka, dlkatr ) dlkaro = quadslget( 7, dg(1), dg(2), dg(3) ) else call qdersto( 7, slt, t6log_ferg(i1), $ t6log_ferg(i2), t6log_ferg(i3) ) call qderget( 7, g(1), g(2), g(3), flka, dlkatr ) dlkaro = quadget( 7, dg(1), dg(2), dg(3) ) endif if ( i4 .gt. i3 ) then if ( i3 .ge. modt_use ) then call qderslsto( 8, slt, t6log_ferg(i2), $ t6log_ferg(i3), t6log_ferg(i4) ) call qderslget( 8, g(2), g(3), g(4), val, dkap ) dlkaro = ftlo * dlkaro + fthi $ * quadslget( 8, dg(2), dg(3), dg(4) ) else call qdersto( 8, slt, t6log_ferg(i2), $ t6log_ferg(i3), t6log_ferg(i4) ) call qderget( 8, g(2), g(3), g(4), val, dkap ) dlkaro = ftlo * dlkaro + fthi $ * quadget( 8, dg(2), dg(3), dg(4) ) endif dlkatr = ftlo * dlkatr + fthi * dkap $ + dt6inv_ferg(i3) * ( val - flka ) flka = ftlo * flka + fthi * val endif c-debug[ c-debug; if ( i_debug_ferg .gt. 5 ) then c-debug; write(6,'(2(a,f11.6),a,4(i3,":",f11.6))') c-debug; $ ' flka=', flka, ' dlkatr=', dlkatr, ' <--T', c-debug; $ ( i, g(i), i = 1, i4 - i1 + 1 ) c-debug; write(6,'(a,f11.6,a,4(i3,":",f11.6))') c-debug; $ ' dlkaro=', dlkaro, ' <--T', c-debug; $ ( i, dg(i), i = 1, i4 - i1 + 1 ) c-debug; endif c-debug] c endif c ! get T-derivative at constant density dlkat = dlkatr - 3.0 * dlkaro c ! restore possibly-changed max X-value x_ferg(nx_ferg) = 1.0 c ! if any new Z,X-interp values were computed: if ( needall .ne. 0 ) then c ! store the available (T,R) range for these i1p_ferg = i1 i4p_ferg = i4 j1p_ferg = max( 1 , j1 ) j4p_ferg = min( nr_ferg , j4 ) c ! if ALL are new, store Z and X values if ( needall .gt. 0 ) then zlogp_ferg = zlogat xp_ferg = xh endif c endif c-debug[ c-debug; if ( i_debug_ferg .gt. 1 ) write(6,'(5(a,f11.6))') c-debug; $ ' END kapferg: RETURN flka=', flka, ' dlkatr=', dlkatr, c-debug; $ ' dlkaro=', dlkaro, ' dlkat=', dlkat, ' fkaedge=', fkaedge c-debug] c return end c c****************************************************************************** c subroutine cacheferg( ksto, xh, xzco ) c -------------------------------------- c parameter ( small_1m6=1.e-6 ) c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c common /mat_alex_ferg/ flk_ferg(nr_ferg,nt_ferg,nz_ferg,nx_ferg) save /mat_alex_ferg/ c common /opac_ferg/ zlog_ferg(nzp1_ferg), xlog_ferg(nx_ferg), $ dzinvlog_ferg(nz_ferg), dzinv_ferg(nz_ferg), $ dxinvlog_ferg(nx_ferg), dxinv_ferg(nx_ferg), $ t6log_ferg(nt_ferg), rlog_ferg(nr_ferg), $ dt6inv_ferg(nt_ferg), drinv_ferg(nr_ferg), $ modt_ferg, modz0_ferg, ntuferg save /opac_ferg/ c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c common /c_prev_ferg/ zlogp_ferg, xp_ferg, zlp1_ferg, xp1_ferg, $ zlp2_ferg, xp2_ferg, i1p_ferg, i4p_ferg, j1p_ferg, j4p_ferg save /c_prev_ferg/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c parameter ( nzm1_ferg=nz_ferg-1, nzm2_ferg=nz_ferg-2 ) c logical lacc_t, lacc_zf, lacc_xf, lnozlo c dimension h(nx_ferg) c ! have Ferguson et al. 2005 opacities? if ( kavail_alex .le. 1 ) return c zpxc = min( 1.0 , max( xzco , 0.0 ) ) y = 1.0 - xh - zpxc c ! check composition if ( min( xh , xzco , y ) .le. -1.e-6 .or. $ zpxc .gt. 0.12 ) return c fzlo = 1.0 c ! these just prevent compiler warnings: fzhi = 0.0 fxlo = 1.0 fxhi = 0.0 c-noXlog; xlogat = xh zlogat = zpxc c ! index to store values at nzp_sto = max( 1 , min( 2, ksto ) ) c ! get X-indices if ( xh .lt. 1.e-6 ) then c mf = 1 mf2 = 1 mg = 1 mh = 1 c else if ( y .lt. 1.e-6 ) then c mf = nx_ferg mf2 = nx_ferg mg = nx_ferg mh = nx_ferg c else c if ( zpxc .ge. z_ferg(nz_ferg) ) then ixhi = nxm2_ferg else if ( zpxc .ge. z_ferg(n2_ferg) ) then ixhi = nxm1_ferg else ixhi = nx_ferg endif c ilo = 2 ihi = ixhi do while ( ihi - ilo .gt. 1 ) iat = ( ihi + ilo ) / 2 if ( xh .ge. x_ferg(iat) ) then ilo = iat else ihi = iat endif enddo c if ( abs( x_ferg(ilo) - xh ) .lt. 1.e-6 ) then mf = ilo mf2 = ilo mg = ilo mh = ilo else if ( abs( x_ferg(ihi) - xh ) .lt. 1.e-6 ) then mf = ihi mf2 = ihi mg = ihi mh = ihi else x_ferg(nx_ferg) = 1.0 - zpxc if ( xh .gt. x_ferg(ilo) ) then mf2 = min( ihi + 1 , ixhi ) else mf2 = ihi endif if ( mf2 .eq. ihi .or. xh .lt. x_ferg(ihi) ) then mf = ilo - 1 mg = ilo mh = ihi else mf = ilo mg = ihi mh = mf2 endif endif c if ( ixhi .lt. nx_ferg ) then if ( mf2 .eq. ixhi ) mf2 = nx_ferg if ( mh .eq. ixhi ) mh = nx_ferg if ( mg .eq. ixhi ) mg = nx_ferg if ( mf .eq. ixhi ) mf = nx_ferg endif c c-noXlog; if ( mf .le. 2 .and. mf2 .gt. mf ) c-noXlog; $ xlogat = log10( xh + xdel_ferg ) c if ( mf2 .gt. mh ) then c-noXlog; if ( mg .eq. 2 ) then c-noXlog; fxlo = max( 0.0 , min( 1.0 , c-noXlog; $ ( xlog_ferg(mh) - xlogat ) * dxinvlog_ferg(mh) ) ) c-noXlog; else fxlo = max( 0.0 , min( 1.0 , $ ( x_ferg(mh) - xh ) * dxinv_ferg(mh) ) ) c-noXlog; endif fxhi = 1.0 - fxlo endif c endif c ! get Z-indices if ( zpxc .lt. z0_ferg ) then c kf = 1 kg = 1 kh = 1 kf2 = 1 zlogat = zlog_ferg(1) c else c ilo = 2 ihi = nz_ferg do while ( ihi - ilo .gt. 1 ) iat = ( ihi + ilo ) / 2 if ( zpxc .ge. z_ferg(iat) ) then ilo = iat else ihi = iat endif enddo c if ( abs( z_ferg(ilo) - zpxc ) .lt. 1.e-6 * zpxc ) then kf = ilo kg = ilo kh = ilo kf2 = ilo zlogat = zlog_ferg(ilo) else if ( abs( z_ferg(ihi) - zpxc ) .lt. 1.e-6 * zpxc ) then kf = ihi kg = ihi kh = ihi kf2 = ihi zlogat = zlog_ferg(ihi) else kf = ilo - 1 kg = ilo kh = ihi zlogat = log10( zpxc + zdel_ferg ) if ( ihi .ge. nz_ferg .or. zpxc .le. z_ferg(ilo) ) then kf2 = ihi if ( iacc_ferg .gt. 0 .and. ihi .eq. nz_ferg ) then kf2 = nzp1_ferg fzlo = max( 0.0 , min( 1.0 , $ ( zlog_ferg(nz_ferg) - zlogat ) $ * dzinvlog_ferg(nz_ferg) ) ) fzhi = 1.0 - fzlo endif else kf2 = ihi + 1 fzlo = max( 0.0 , min( 1.0 , $ ( zlog_ferg(kh) - zlogat ) * dzinvlog_ferg(kh) ) ) fzhi = 1.0 - fzlo endif endif c endif c if ( fzlo .le. 0.0 ) then lnozlo = .true. else lnozlo = .false. endif c if ( iacc_ferg .gt. 0 ) then modt_use = modt_ferg else modt_use = nt_ferg + 10 endif c if ( kf .ne. kf2 ) then if ( lnozlo ) then call quadsto( 1, zlogat, zlog_ferg(nzm2_ferg), $ zlog_ferg(nzm1_ferg), zlog_ferg(nz_ferg) ) else if ( ( modt_use .gt. 0 .and. ntuferg .ge. modt_use ) .or. $ ( ntuferg .ge. modz0_ferg .and. kf .eq. 1 ) ) $ call quadslsto( 1, zlogat, zlog_ferg(kf), $ zlog_ferg(kg), zlog_ferg(kh) ) call quadsto( 1, zlogat, zlog_ferg(kf), $ zlog_ferg(kg), zlog_ferg(kh) ) endif if ( kf2 .gt. nz_ferg ) then if ( ntuferg .ge. modt_ferg ) $ call quadslsto( 3, zlogat, zlog_ferg(nzm1_ferg), $ zlog_ferg(nz_ferg), zlog_ferg(nzp1_ferg) ) else if ( kf2 .gt. kh ) then if ( modt_use .gt. 0 .and. ntuferg .ge. modt_use ) $ call quadslsto( 3, zlogat, zlog_ferg(kg), $ zlog_ferg(kh), zlog_ferg(kf2) ) call quadsto( 3, zlogat, zlog_ferg(kg), $ zlog_ferg(kh), zlog_ferg(kf2) ) endif endif c if ( mf .ne. mf2 ) then if ( mh .lt. nx_ferg ) then if ( mf .eq. 1 .or. ( modt_use .gt. 0 .and. $ ntuferg .ge. modt_use ) ) call quadslsto( 2, xh, $ x_ferg(mf), x_ferg(mg), x_ferg(mh) ) call quadsto( 2, xh, x_ferg(mf), x_ferg(mg), x_ferg(mh) ) else if ( mf .eq. 1 .or. ( modt_use .gt. 0 .and. $ ntuferg .ge. modt_use ) ) call qchkslsto( 2, xh, $ x_ferg(mf), x_ferg(mg), x_ferg(mh) ) if ( mf .ne. 1 .and. modt_use .ne. 1 ) call qchksto( 2, xh, $ x_ferg(mf), x_ferg(mg), x_ferg(mh) ) endif if ( mf2 .gt. mh ) then if ( mf2 .lt. nx_ferg ) then if ( modt_use .gt. 0 .and. ntuferg .ge. modt_use ) $ call quadslsto( 4, xh, x_ferg(mg), $ x_ferg(mh), x_ferg(mf2) ) call quadsto( 4, xh, x_ferg(mg), $ x_ferg(mh), x_ferg(mf2) ) else if ( modt_use .gt. 0 .and. ntuferg .ge. modt_use ) $ call qchkslsto( 4, xh, x_ferg(mg), $ x_ferg(mh), x_ferg(mf2) ) if ( modt_use .ne. 1 ) call qchksto( 4, xh, x_ferg(mg), $ x_ferg(mh), x_ferg(mf2) ) endif endif endif c lacc_t = .false. lacc_xf = .true. c ! for each T-value: do it = 1, ntuferg c if ( it .eq. modt_use ) lacc_t = .true. c if ( mf .ne. 1 ) lacc_xf = lacc_t c if ( it .ge. modz0_ferg .and. kf .eq. 1 ) then lacc_zf = .true. else lacc_zf = lacc_t endif c ! for each R-value at that T: do ir = 1, nr_ferg c ! for each X do ix = mf, mf2 c ! that is needed if ( ix .le. mh .or. ix .eq. mf2 ) then c ! do Z-interp: if ( kf .eq. kf2 ) then h(ix) = flk_ferg(ir,it,kf,ix) else if ( lnozlo ) then if ( kf2 .le. nz_ferg .or. $ it .ge. modt_ferg ) then h(ix) = flk_ferg(ir,it,kh,ix) else h(ix) = quadget( 1, flk_ferg(ir,it,kf,ix), $ flk_ferg(ir,it,kg,ix), $ flk_ferg(ir,it,kh,ix) ) endif else if ( lacc_zf ) then h(ix) = quadslget( 1, flk_ferg(ir,it,kf,ix), $ flk_ferg(ir,it,kg,ix), $ flk_ferg(ir,it,kh,ix) ) else h(ix) = quadget( 1, flk_ferg(ir,it,kf,ix), $ flk_ferg(ir,it,kg,ix), $ flk_ferg(ir,it,kh,ix) ) endif if ( kf2 .gt. nz_ferg ) then if ( it .ge. modt_ferg ) then val = flk_ferg(ir,it,nz_ferg,ix) $ - flk_ferg(ir,it,nzm1_ferg,ix) vm2 = flk_ferg(ir,it,nzm1_ferg,ix) $ - flk_ferg(ir,it,nzm2_ferg,ix) if ( abs(val) .le. abs(vm2) ) then val = flk_ferg(ir,it,nz_ferg,ix) + val else val = flk_ferg(ir,it,nz_ferg,ix) + vm2 endif h(ix) = fzlo * h(ix) + fzhi $ * quadslget( 3, $ flk_ferg(ir,it,nzm1_ferg,ix), $ flk_ferg(ir,it,nz_ferg,ix), $ val ) endif else if ( kf2 .gt. kh .and. $ ( ix .ne. nxm1_ferg .or. $ kf2 .le. n2_ferg ) ) then if ( lacc_t ) then h(ix) = fzlo * h(ix) + fzhi $ * quadslget( 3, flk_ferg(ir,it,kg,ix), $ flk_ferg(ir,it,kh,ix), $ flk_ferg(ir,it,kf2,ix) ) else h(ix) = fzlo * h(ix) + fzhi $ * quadget( 3, flk_ferg(ir,it,kg,ix), $ flk_ferg(ir,it,kh,ix), $ flk_ferg(ir,it,kf2,ix) ) endif endif endif c endif c ! end of X-loop enddo c ! do X-interp: if ( mf .eq. mf2 ) then flk_ferg(ir,it,nzp_sto,nxm1_ferg) = h(mf) else if ( mh .lt. nx_ferg ) then if ( lacc_xf ) then val = quadslget( 2, h(mf), h(mg), h(mh) ) else val = quadget( 2, h(mf), h(mg), h(mh) ) endif else if ( lacc_xf ) then val = qchkslget( 2, h(mf), h(mg), h(mh) ) else val = qchkget( 2, h(mf), h(mg), h(mh) ) endif if ( mf2 .gt. mh ) then if ( mf2 .lt. nx_ferg ) then if ( lacc_t ) then val = fxlo * val + fxhi $ * quadslget( 4, h(mg), h(mh), h(mf2) ) else val = fxlo * val + fxhi $ * quadget( 4, h(mg), h(mh), h(mf2) ) endif else if ( lacc_t ) then val = fxlo * val + fxhi $ * qchkslget( 4, h(mg), h(mh), h(mf2) ) else val = fxlo * val + fxhi $ * qchkget( 4, h(mg), h(mh), h(mf2) ) endif endif flk_ferg(ir,it,nzp_sto,nxm1_ferg) = val endif c ! end of R-loop enddo c ! end of T-loop enddo c if ( ksto .le. 1 ) then zlp1_ferg = zlogat xp1_ferg = xh else zlp2_ferg = zlogat xp2_ferg = xh endif c return end c c****************************************************************************** c subroutine kap_mol( slt, slr, xh, z, exC, exO, $ flka, dlkatr, dlkaro, dlkat, fkaedge ) c ========================================================== c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_edge_alex/ fkaedgelo, fkaedgehi, fzkaedge save /c_edge_alex/ c if ( kavail_alex .ne. 1 ) then c call kapferg( slt, slr, xh, z, exC, exO, $ flka, dlkatr, dlkaro, dlkat, fkaedge ) c else c flt = slt + 6. flrho = slr + 3. * slt c call kapalex( flt, flrho, xh, z + exC + exO, $ flka, dlkat, dlkaro, fkaedge ) c dlkatr = dlkat + 3.0 * dlkaro c if ( kuse_alex .ge. 4 ) then tmp = max( 0.0 , 1.0 - ( abs(exC) + abs(exO) ) * 5.0 $ / max( z , 0.0001 , z + exC + exO ) ) fzkaedge = fzkaedge * tmp fkaedge = fkaedge * tmp endif c endif c return end c c****************************************************************************** c subroutine kapalex(flt,flro,x,xzco,flka,dlkat,dlkaro,fkaedge) c ============================================================= c c Given flt = log T , flro = log rho , x = X , xzco = Z + exCO (where exCO is c excess-CO mass fraction above what is contained in Z), the subroutine KAPALEX c returns flka = log10 Kappa(Alexander1994) , dlkat = (dLogKappa/dLogT)_rho , c dlkaro = (dLogKappa/dLogRHO)_T , and the edge-of-matrix indicator variable c fkaedge = 1.0 inside the matrix: 3.0 < logT < 4.1 , -12 < log rho < -6 , c and either Z+Xc < 0.1 or X = 0.0 . c fkaedge = 0.0 for more than one grid-spacing of extrapolation beyond the c edge of the matrix; (in this case, no opacities are computed) c 1 > fkaedge > 0 gives extent of extrapolation (from 1 = no extrap, to c very small value = extrap by nearly one grid spacing). c parameter ( small_1m6=1.e-6, small_m1m6=-1.e-6 ) c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c common /mat_alex_ferg/ flk_ferg(nr_ferg,nt_ferg,nz_ferg,nx_ferg) save /mat_alex_ferg/ dimension flk_alex(nrlo_alex:nr_alex,nt_alex,nzp1_alex,nx_alex) equivalence (flk_alex(nrlo_alex,1,1,1),flk_ferg(1,1,1,1)) c common /opac_alex/ zlog_alex(nzp1_alex),xlog_alex(nx_alex), $ dzinvlog_alex(nzp1_alex),dxinvlog_alex(nx_alex) save /opac_alex/ c common /c_ini_alex/ z_alex(nzp1_alex),x_alex(nx_alex), $ flt_alex(nt_alex),flro_alex(nrlo_alex:nr_alex) save /c_ini_alex/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_edge_alex/ fkaedgelo, fkaedgehi, fzkaedge save /c_edge_alex/ c common/d_opal_z/ dkap save /d_opal_z/ c parameter ( badlogkval=1.e+35 ) c=== flka = badlogkval dlkat = 0.0 dlkaro = 0.0 fkaedge = 0.0 fkaedgelo = 1.0 fkaedgehi = 1.0 fzkaedge = 1.0 c ! must have Alexander 1994 opacities if ( kavail_alex .ne. 1 ) return c ! zpxc=Z+exC+exO is interp. variable zpxc = min( 1.0 , max( xzco , 0.0 ) ) c ! check composition if ( min(x,xzco,1.-x-zpxc) .le. small_m1m6 ) then write(6,10) x, 1.-x-zpxc, xzco 10 format(' '/' KAPALEX Error: bad X=',1p,e13.6, $ ' Y=1-X-Z-CO=',e13.6,' Z+CO=',e13.6) stop ' STOP - KAPALEX: bad { X , Z + exCO } composition . ' endif c ! check bounds fkaedgelo = max( 0. , 1. + min( 0. , $ (flt-flt_alex(1))*dtinv_alex , $ (flro-flro_alex(nrlo_alex))*droinv_alex ) ) fkaedgehi = max( 0. , 1. + min( 0. , $ (flt_alex(nt_alex)-flt)*dtinv_alex , $ (flro_alex(nr_alex)-flro)*droinv_alex ) ) c izchk_alex = iabs( kuse_alex ) c if ( izchk_alex .ge. 3 ) then fzkaedge = max( 0.0 , min( 1.0 , ( 0.05 - zpxc ) * 50.0 , $ zpxc * 2.0 / z_alex(2) - 1.0 ) ) fkaedge = fzkaedge * min( fkaedgelo, fkaedgehi ) else fkaedge = min( fkaedgelo, fkaedgehi ) endif c if ( fkaedge .le. 0.0 ) return c ! may be needed for X < 0.1: xdelminat = xdelmin_alex c ! these just prevent compiler warnings: fxlo = 1.0 fxhi = 0.0 c ! get X-indices if ( x .lt. small_1m6 ) then c mf = 1 mf2 = 1 mg = 1 mh = 1 ihiz = nzp1_alex c else c ilo = 2 ihi = nx_alex do while ( ihi-ilo .gt. 1 ) iat = (ihi+ilo)/2 if ( x .ge. x_alex(iat) ) then ilo = iat else ihi = iat endif enddo c if ( abs(x_alex(ilo)-x) .lt. small_1m6 ) then mf = ilo mf2 = ilo mg = ilo mh = ilo else if ( abs(x_alex(ihi)-x) .lt. small_1m6 ) then mf = ihi mf2 = ihi mg = ihi mh = ihi else mf = ilo - 1 mf2 = ihi if ( x .gt. x_alex(ilo) ) mf2 = min(ihi+1,nx_alex) mg = ilo mh = ihi xlogat = log10(x+xdel_alex) c ! for double-quadratic if ( mf2 .gt. mh ) then fxlo = max( min( $ (xlog_alex(mh)-xlogat)*dxinvlog_alex(mh) , $ 1. ) , 0. ) fxhi = 1.-fxlo endif c ! may be needed for X < 0.1: if ( mf .eq. 1 ) then if ( flt .gt. 3.6 ) $ xdelminat = (flt-3.6)*0.002 + xdelmin_alex endif endif c ! for X > 0, require Z+Xc < .15, unless X < 0.03 ihiz = nz_alex if ( mf .eq. 1 .and. x .lt. x_alex(2) ) ihiz = nzp1_alex if ( izchk_alex .le. 2 .and. zpxc .gt. z_alex(nz_alex) ) then fzkaedge = min( 1. , max( 0. , $ 1. + ( z_alex(nz_alex) - zpxc ) / zex_alex ) ) if ( izchk_alex .le. 1 .and. ihiz .eq. nzp1_alex ) $ fzkaedge = max( fzkaedge , 0. , 1. - x / x_alex(2) ) fkaedge = max( 0.0 , fkaedge * fzkaedge ) if ( fkaedge .le. 0. ) return endif c endif c ! get Z-indices ihi = ihiz ilo = 1 do while( ihi-ilo .gt. 1 ) iat = (ihi+ilo)/2 if ( zpxc .ge. z_alex(iat) ) then ilo = iat else ihi = iat endif enddo if ( abs(z_alex(ilo)-zpxc) .lt. small_1m6 .and. $ ( ilo .gt. 1 .or. zpxc .eq. 0. ) ) then kf = ilo kf2 = ilo kg = ilo kh = ilo else if ( abs(z_alex(ihi)-zpxc) .lt. small_1m6 .and. $ ( ihi .le. nz_alex .or. mf2 .eq. 1 ) ) then kf = ihi kf2 = ihi kg = ihi kh = ihi else if ( ilo .eq. 1 ) then kf = 1 kf2 = 2 kg = 2 kh = 2 else if ( ihiz .eq. nzp1_alex .and. $ ihi .ge. nz_alex .and. mf2 .ge. 3 ) then kf2 = nzp1_alex kh = nz_alex kg = kh - 1 kf = kh - 2 else kf = ilo-1 kf2 = ihi if ( zpxc .gt. z_alex(ilo) ) kf2 = min(ihi+1,ihiz) kg = ilo kh = ihi endif c ! get T-indices i2 = max( 2 , min( ntm1_alex , $ int( ( flt - flt_alex(1) ) * dtinv_alex + 1. ) ) ) i1 = i2-1 i3 = i2+1 if ( flt .gt. flt_alex(i2) .and. i3 .lt. nt_alex ) then i4 = i3+1 else i4 = i3 endif c ! rho-indices j2 = max( nrlop1_alex , min( nrm1_alex , int( ( flro $ - flro_alex(nrlo_alex) ) * droinv_alex ) + nrlo_alex ) ) j1 = j2-1 j3 = j2+1 if ( flro .gt. flro_alex(j2) .and. j3 .lt. nr_alex ) then j4 = j3+1 else j4 = j3 endif c ! first interpolate logKappa in logRHO, logT, and log(X+xdel) c call qderNsto( 1, j4 - j1, flro, flro_alex(j1), flro_alex(j2), $ flro_alex(j3), flro_alex(j4) ) c call qderNsto( 3, i4 - i1, flt, flt_alex(i1), flt_alex(i2), $ flt_alex(i3), flt_alex(i4) ) c if ( mf2 .gt. mf ) then call quadsto( 5, xlogat, xlog_alex(mf), $ xlog_alex(mg), xlog_alex(mh) ) if ( mf2 .gt. mh ) call quadsto( 6, xlogat, xlog_alex(mg), $ xlog_alex(mh), xlog_alex(mf2) ) endif c ! loop over metallicities do k = kf, kf2 c ! loop over X-values do m = mf, mf2 c ! Z=1.0 mix is only for X=0 if ( k .le. nz_alex .or. m .eq. 1 ) then c ! loop over T-values do i = i1, i4 c ! RHO-interp: get logK(T,Z,X), {dK/dRHO}(T,Z,X) c ! store in flk_alex(24:25,iT,12,6) [empty] c call qderNget( 1, j4 - j1, flk_alex(j1,i,k,m), $ flk_alex(j2,i,k,m), flk_alex(j3,i,k,m), $ flk_alex(j4,i,k,m), $ flk_alex(nr_alex,i,nzp1_alex,nx_alex), $ flk_alex(nrm1_alex,i,nzp1_alex,nx_alex) ) c ! end loop over T-values enddo c ! T-interp: get logK(Z,X), {dK/dT}(Z,X), {dK/dRHO}(Z,X) c ! store in flk_alex(kf:kf2,mf:mf2,12,4:6) [kf2 < 13] c call qderNget( 3, i4 - i1, $ flk_alex(nr_alex,i1,nzp1_alex,nx_alex), $ flk_alex(nr_alex,i2,nzp1_alex,nx_alex), $ flk_alex(nr_alex,i3,nzp1_alex,nx_alex), $ flk_alex(nr_alex,i4,nzp1_alex,nx_alex), $ flk_alex(k,m,nzp1_alex,nx_alex), $ flk_alex(k,m,nzp1_alex,nxm1_alex) ) flk_alex(k,m,nzp1_alex,nxm2_alex) = $ quadNget( 3, i4 - i1, $ flk_alex(nrm1_alex,i1,nzp1_alex,nx_alex), $ flk_alex(nrm1_alex,i2,nzp1_alex,nx_alex), $ flk_alex(nrm1_alex,i3,nzp1_alex,nx_alex), $ flk_alex(nrm1_alex,i4,nzp1_alex,nx_alex) ) endif c ! end loop over X-values enddo c ! X-interpolation, if needed: get logK(Z), {dK/dT}(Z), {dK/dRHO}(Z) c ! store in flk_alex(kf:kf2,mf,12,4:6): replaces T-interp case at lowest X c if ( mf2 .gt. mf .and. k .le. nz_alex ) then xdelat = xdel_alex if ( mf .eq. 1 ) then delhi = flk_alex(k,mh,nzp1_alex,nx_alex) $ - flk_alex(k,mg,nzp1_alex,nx_alex) dello = flk_alex(k,mg,nzp1_alex,nx_alex) $ - flk_alex(k,mf,nzp1_alex,nx_alex) if ( delhi .lt. dello .and. dello .gt. 0.0 ) then xdelat = max( xdel_alex * abs(delhi/dello)**2 , $ xdelminat ) if ( dello .lt. 0.01 ) xdelat = min( $ ((0.01-dello)*100.)**2 * (xdel_alex-xdelat) $ + xdelat , xdel_alex ) endif endif if ( xdelat .ge. xdel_alex ) then flk_alex(k,mf,nzp1_alex,nx_alex) = quadget( 5, $ flk_alex(k,mf,nzp1_alex,nx_alex), $ flk_alex(k,mg,nzp1_alex,nx_alex), $ flk_alex(k,mh,nzp1_alex,nx_alex) ) flk_alex(k,mf,nzp1_alex,nxm1_alex) = quadget( 5, $ flk_alex(k,mf,nzp1_alex,nxm1_alex), $ flk_alex(k,mg,nzp1_alex,nxm1_alex), $ flk_alex(k,mh,nzp1_alex,nxm1_alex) ) flk_alex(k,mf,nzp1_alex,nxm2_alex) = quadget( 5, $ flk_alex(k,mf,nzp1_alex,nxm2_alex), $ flk_alex(k,mg,nzp1_alex,nxm2_alex), $ flk_alex(k,mh,nzp1_alex,nxm2_alex) ) else flk_alex(k,mf,nzp1_alex,nx_alex) = qzinter(0,9,x,2, $ flk_alex(k,mf,nzp1_alex,nx_alex), $ flk_alex(k,mg,nzp1_alex,nx_alex), $ flk_alex(k,mh,nzp1_alex,nx_alex),0.0, $ x_alex(mf),x_alex(mg),x_alex(mh),0.0,xdelat) flk_alex(k,mf,nzp1_alex,nxm1_alex) = qzinter(1,9,x,2, $ flk_alex(k,mf,nzp1_alex,nxm1_alex), $ flk_alex(k,mg,nzp1_alex,nxm1_alex), $ flk_alex(k,mh,nzp1_alex,nxm1_alex),0.0, $ x_alex(mf),x_alex(mg),x_alex(mh),0.0,xdelat) flk_alex(k,mf,nzp1_alex,nxm2_alex) = qzinter(1,9,x,2, $ flk_alex(k,mf,nzp1_alex,nxm2_alex), $ flk_alex(k,mg,nzp1_alex,nxm2_alex), $ flk_alex(k,mh,nzp1_alex,nxm2_alex),0.0, $ x_alex(mf),x_alex(mg),x_alex(mh),0.0,xdelat) endif if ( mf2 .gt. mh ) then flk_alex(k,mf,nzp1_alex,nx_alex) = $ fxlo * flk_alex(k,mf,nzp1_alex,nx_alex) + fxhi $ * quadget( 6, flk_alex(k,mg,nzp1_alex,nx_alex), $ flk_alex(k,mh,nzp1_alex,nx_alex), $ flk_alex(k,mf2,nzp1_alex,nx_alex) ) flk_alex(k,mf,nzp1_alex,nxm1_alex) = $ fxlo * flk_alex(k,mf,nzp1_alex,nxm1_alex) + fxhi $ * quadget( 6, flk_alex(k,mg,nzp1_alex,nxm1_alex), $ flk_alex(k,mh,nzp1_alex,nxm1_alex), $ flk_alex(k,mf2,nzp1_alex,nxm1_alex) ) flk_alex(k,mf,nzp1_alex,nxm2_alex) = $ fxlo * flk_alex(k,mf,nzp1_alex,nxm2_alex) + fxhi $ * quadget( 6, flk_alex(k,mg,nzp1_alex,nxm2_alex), $ flk_alex(k,mh,nzp1_alex,nxm2_alex), $ flk_alex(k,mf2,nzp1_alex,nxm2_alex) ) endif endif c ! end loop over metallicities enddo c ! interpolate in Z+exCO, if necessary: get logK, dK/dT, dK/dRHO c if ( kf .eq. kf2 ) then flka = flk_alex(kf,mf,nzp1_alex,nx_alex) dlkat = flk_alex(kf,mf,nzp1_alex,nxm1_alex) dlkaro = flk_alex(kf,mf,nzp1_alex,nxm2_alex) c ! Z < 0.0001: interpolate c ! Kappa linearly in Z+Xc else if ( kf2 .eq. 2 ) then fzhi = zpxc / z_alex(2) fzlo = 1.-fzhi fzlo = fzlo * 10.**flk_alex(1,mf,nzp1_alex,nx_alex) fzhi = fzhi * 10.**flk_alex(2,mf,nzp1_alex,nx_alex) flka = fzlo + fzhi dlkat = ( fzlo * flk_alex(1,mf,nzp1_alex,nxm1_alex) $ + fzhi * flk_alex(2,mf,nzp1_alex,nxm1_alex) ) / flka dlkaro = ( fzlo * flk_alex(1,mf,nzp1_alex,nxm2_alex) $ + fzhi * flk_alex(2,mf,nzp1_alex,nxm2_alex) ) / flka flka = log10(flka) c ! else quadratic logKappa in log(Z+Xc+zdel) else zlogat = log10(zpxc+zdel_alex) call quadsto( 1, zlogat, zlog_alex(kf), zlog_alex(kg), $ zlog_alex(kh) ) flka = quadget( 1, flk_alex(kf,mf,nzp1_alex,nx_alex), $ flk_alex(kg,mf,nzp1_alex,nx_alex), $ flk_alex(kh,mf,nzp1_alex,nx_alex) ) dlkat = quadget( 1, flk_alex(kf,mf,nzp1_alex,nxm1_alex), $ flk_alex(kg,mf,nzp1_alex,nxm1_alex), $ flk_alex(kh,mf,nzp1_alex,nxm1_alex) ) dlkaro = quadget( 1, flk_alex(kf,mf,nzp1_alex,nxm2_alex), $ flk_alex(kg,mf,nzp1_alex,nxm2_alex), $ flk_alex(kh,mf,nzp1_alex,nxm2_alex) ) c ! or bi-quadratic if ( kf2 .gt. kh ) then fzlo = max( 0. , min( 1. , $ ( zlog_alex(kh) - zlogat ) * dzinvlog_alex(kh) ) ) if ( kf2 .eq. nzp1_alex .and. mf2 .ge. 3 ) $ fzlo = ( ( xlog_alex(2) - xlogat ) * fzlo $ + xlogat * max( 0. , min( 1. , $ ( z_alex(nzp1_alex) - zpxc ) / ( z_alex(nzp1_alex) $ - z_alex(nz_alex) - zex_alex ) ) ) ) $ * dxinvlog_alex(2) fzhi = 1. - fzlo call quadsto( 1, zlogat, zlog_alex(kg), zlog_alex(kh), $ zlog_alex(kf2) ) flka = fzlo * flka + fzhi * quadget( 1, $ flk_alex(kg,mf,nzp1_alex,nx_alex), $ flk_alex(kh,mf,nzp1_alex,nx_alex), $ flk_alex(kf2,mf,nzp1_alex,nx_alex) ) dlkat = fzlo * dlkat + fzhi * quadget( 1, $ flk_alex(kg,mf,nzp1_alex,nxm1_alex), $ flk_alex(kh,mf,nzp1_alex,nxm1_alex), $ flk_alex(kf2,mf,nzp1_alex,nxm1_alex) ) dlkaro = fzlo * dlkaro + fzhi * quadget( 1, $ flk_alex(kg,mf,nzp1_alex,nxm2_alex), $ flk_alex(kh,mf,nzp1_alex,nxm2_alex), $ flk_alex(kf2,mf,nzp1_alex,nxm2_alex) ) endif endif c return end c c****************************************************************************** c subroutine ask_last_alex_edge( fe_a, fe_tr, fe_lo, fe_hi, fe_z ) c ================================================================ c common /c_edge_alex/ fkaedgelo, fkaedgehi, fzkaedge save /c_edge_alex/ c fe_tr = max( 0.0 , min( fkaedgelo , fkaedgehi ) ) fe_lo = max( 0.0 , fkaedgelo ) fe_hi = max( 0.0 , fkaedgehi ) fe_z = fzkaedge fe_a = fe_tr * fzkaedge c return end c c****************************************************************************** c subroutine kapcond( flro, flt, x, y, xCN, xON, xNeHeavy, fmuainv, $ fmueinv, zsqbar, ider, flkc, flkct, flkcro, fkcedge, fkcok ) c ================================================================= c c flro = log10(RHO), flt = log10(T), x = X, y = Y, xCN = xC + 0.5 * xN, c xON = xO + 0.5 * xN, xNeHeavy = SUM_i{ X_i } for i heavier than oxygen. c fmuainv = 1 / mu_A = SUM_i{ X_i / A_i } \ Non-positive input c fmueinv = 1 / mu_e = SUM_i{ X_i * z_i / A_i } } for any of these c zsqbar = * mu_A = SUM_i{ X_i * (z_i)**2 / A_i } / means "use value c from {x,y,xCN,xON,xNeHeavy}" c....For the Potekhin 2006 ('condall06.d') case: c ider = 1 : use bi-quadratic interp, Zion = (, with derivatives. c -3 : use bi-quadratic interp, Zion = , no derivatives. c -4 : use website formulae, Zion = , with derivatives. c....For the H&L ('Condopac') case: c ider = -4 : get "H&L" only (with derivatives) c -3 : get "Itoh" only (with derivatives) c -2 : get "H&L" only (no derivatives) c -1 : get "Itoh" only (no derivatives) c 0 : combine as necessary (no derivatives): use "H&L" at lower c density, "Itoh" at higher density, with switchover region c 1 : combine the two as necessary, with derivatives c RETURNS: c flkc = logKc = log10( Kappa_cond ) c [if ider > 0]: flkct = dlogKc / dlogT , flkcro = dlogKc / dlogRHO c fkcedge, fkcok (strict and loose edge factors) c c NOTE: Itoh (or post-Itoh) code use is determined by itoh_replace c c NOTE: "H&L" is W.B.Hubbard & M.Lampe 1969, ApJS 163, 297-346 ; c "Itoh" is N.Itoh,S.Mitake,H.Iyetomi,S.Ichimaru 1983, ApJ 273, 774-782 c plus S.Mitake,S.Ichimaru,N.Itoh 1984, ApJ 277, 375-378 . c parameter ( small_1m6=1.e-6, small_m1m6=-1.e-6, small_5m7=5.e-7 ) c parameter ( nT_KcPot=19, nR_KcPot=64, nZ_KcPot=15 ) c parameter ( ntlokc=37, ntlokcm1=ntlokc-1, nthikc=90-ntlokcm1, $ nrlokc=-23, nrlokcm1=nrlokc-1, nrhikc=24-nrlokcm1, nkc=3, $ nthikcm1=nthikc-1, nrhikcm1=nrhikc-1, nkcp1=nkc+1 ) parameter ( dlt_kc=.1, dlr_kc=.25, dltinv_kc=10., dlrinv_kc=4. ) c character*2 celkc_hl(nkc) common /c_flkcond_hlpot/ flkc_pot(nT_KcPot,nR_KcPot,nZ_KcPot), $ AT_pot(nT_KcPot), AR_pot(nR_KcPot), AZ_pot(nZ_KcPot), $ sigconlog_pot, itlo_hl(nrhikc,nkc), ithi_hl(nrhikc,nkc), $ irhi_hl(nkc), itlo_ok_hl(nrhikc,nkc), $ irjump_hl(nkc), celkc_hl save /c_flkcond_hlpot/ c dimension flkc_hl(nthikc,nrhikc,nkc), $ flrolo_hl(nkc), flrohi_hl(nkc), $ fltlo_hl(nkc), flthi_hl(nkc), $ flRlo_hl(nkc), flRhi_hl(nkc), kZ_pot(nZ_KcPot) equivalence (flkc_pot(1,1,1),flkc_hl(1,1,1)), $ (AR_pot(1),flrolo_hl(1)), (AR_pot(nkcp1),flrohi_hl(1)), $ (AT_pot(1),fltlo_hl(1)), (AT_pot(nkcp1),flthi_hl(1)), $ (AZ_pot(1),flRlo_hl(1)), (AZ_pot(nkcp1),flRhi_hl(1)), $ (itlo_hl(1,1),kZ_pot(1)) c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c parameter ( nitoh=5 ) c common /c_kcond_itoh/ ai_kc(nitoh), ax_kc(0:3,nitoh,3), $ bx_kc(0:2,nitoh,3), cx_kc(0:2,nitoh,3) save /c_kcond_itoh/ c common /c_sw_cond/ flro_kc, flt_kc, xi_kc(nitoh), flkh, flkht, $ flkhro, fok_hl, fedge_hl, flki, flkit, flkiro, fok_it, $ fedge_it, flkb, flkbt, flkbro, fedge_ok, fedge_kc, fmuai, $ fmuei, zsq, flin_itoh, f_itoh, f_hl, dlogt_f_itoh, $ dlogro_f_itoh, f_tf, f_rho, f_gam, f_rs, f_rshi, f_gamhi, $ f_yi, gamma_ln, y0_it, rr_it, rs_it, $ foki_hl(nitoh), flk(nitoh), tlk(nitoh), rlk(nitoh), $ kdo_hl, kdo_itoh, k_hl, idus save /c_sw_cond/ c common/d_opal_z/ dkap save /d_opal_z/ c c flogitohcon = log10(1.27984e-7) = -6.892844 c flngammacon = ln(2.275e5) = 12.334906, finvln2 = 1/ln2 = 1.4426950, c flogtfcon = log10(5.930e9) = 9.773055, pi = 3.141593, c pisq = pi**2 = 9.869604, sixopisq = 6./pi**2, fouropisq = 4./pi**2 c gamma_ln_max = ln(171.) = 5.141664, finv2ln2 = 1/2ln2 = .7213475, c xg_max = 0.45641 * gamma_ln_max - 1.31636 = 1.0303467 c parameter ( dlkc_ovsc=0.12, dlkc_nevsc=0.26 ) c parameter ( fln10 = 2.302585, floge = .4342945 ) parameter ( flogitohcon = -6.892844, flngammacon = 12.334906, $ finvln2 = 1.4426950, flogtfcon = 9.773055, $ gamma_ln_max = 5.141664, ratsqo4con = 9.291e-3 / 4., $ xg_max = 0.45641 * gamma_ln_max - 1.31636, $ dlnt_xg = -0.45641, dlnro_xg = 0.45641 / 3., $ finv2ln2 = finvln2 / 2., f13 = 1. / 3., $ fm13 = -1. / 3., f23 = 2. / 3., f16 = 1. / 6. ) parameter ( pi = 3.141593, pisq = pi * pi, sixopisq = 6. / pisq, $ fouropisq = 4. / pisq, fouropisq23 = fouropisq + f23 ) c dimension xi_hl(nitoh), ftfj_kr(0:1) dimension fkoft(0:3), d_fkoft(0:3), sj(3), dxg_sj(3), drs_sj(3) c parameter ( dlt2kc=dlt_kc+dlt_kc, dlt3kc=dlt2kc+dlt_kc ) parameter ( dlr2kc=dlr_kc+dlr_kc, dlr3kc=dlr2kc+dlr_kc ) parameter ( rslope=f13, rslope_mat=rslope*dltinv_kc*dlr_kc, $ id21s=6, finv21s=1./id21s, dlrinv_s=dlrinv_kc/id21s ) c parameter ( badlogkval=1.e+35 ) c-debug[ c-debug; common /c_debug_kcond/ i_debug_kcond c-debug; save /c_debug_kcond/ c-debug;ccc c-debug; data i_debug_kcond / 0 / c-debug] c=== flkc = badlogkval flkct = 0.0 flkcro = 0.0 kdo_hl = 0 kdo_itoh = 0 fedge_kc = -99999. fkcedge = -99999. fedge_ok = -99999. fkcok = -99999. c flro_kc = flro flt_kc = flt c xi_kc(1) = x xi_kc(2) = y xi_kc(3) = xCN xi_kc(4) = xON xi_kc(5) = xNeHeavy c if ( kavail_cond .le. 0 ) return c if ( kavail_cond .le. 1 .or. $ min( fmuainv , fmueinv , zsqbar ) .le. 0.0 ) then if ( abs( x + y + xCN + xON + xNeHeavy - 1. ) .gt. $ small_1m6 ) then write(6,10) flro, flt, 'sum{Xi} is not unity:', $ x, y, xCN, xON, xNeHeavy 10 format(/' KAPCOND Error: At logRHO=',f11.6,' logT=',f10.6, $ ', ',a/' KAPCOND Error: Xi=',5f12.8) stop ' STOP -- KAPCOND Error: sum{Xi} is not unity. ' else if ( min( x , y , xCN , xON , xNeHeavy ) .lt. $ small_m1m6 ) then write(6,10) flro, flt, 'negative Xi value:', $ x, y, xCN, xON, xNeHeavy stop ' STOP -- KAPCOND Error: negative Xi value. ' endif endif c if ( fmuainv .gt. 0.0 ) then fmuai = fmuainv else fmuai = xi_kc(1) / ai_kc(1) + xi_kc(2) / ai_kc(2) $ + xi_kc(3) / ai_kc(3) + xi_kc(4) / ai_kc(4) $ + xi_kc(5) / ai_kc(5) endif c if ( kavail_cond .le. 1 .or. ider .le. -2 ) then c if ( fmueinv .gt. 0.0 ) then fmuei = fmueinv else fmuei = xi_kc(1) / ai_kc(1) + xi_kc(2) * 2. / ai_kc(2) $ + xi_kc(3) * 6. / ai_kc(3) + xi_kc(4) * 8. / ai_kc(4) $ + xi_kc(5) * 10. / ai_kc(5) endif c ! Pothekin 2006, with Zion = if ( kavail_cond .gt. 1 ) then c call kap_cond_pot( flro, flt, fmuei / fmuai, ider + 3, $ flkc, flkct, flkcro, fkcedge, fkcok ) return c endif c endif c if ( zsqbar .gt. 0.0 ) then zsq = zsqbar else zsq = xi_kc(1) / ai_kc(1) + xi_kc(2) * 4. / ai_kc(2) $ + xi_kc(3) * 36. / ai_kc(3) + xi_kc(4) * 64. / ai_kc(4) $ + xi_kc(5) * 100. / ai_kc(5) endif c ! Pothekin 2006, with Zion = ()^0.5 if ( kavail_cond .gt. 1 ) then c call kap_cond_pot( flro, flt, sqrt( zsq / fmuai ), ider, $ flkc, flkct, flkcro, fkcedge, fkcok ) return c endif c c If NOT Pothekin 2006 case, continue, and get H&L/Itoh conductive opacities. c flkc = 0.0 c flkh = 0.0 flkht = 0.0 flkhro = 0.0 flki = 0.0 flkit = 0.0 flkiro = 0.0 flkb = 0.0 flkbt = 0.0 flkbro = 0.0 c ! these initializations just prevent compiler warnings: i1s = 0 tf_1 = 1.0 frs = 1.0 omfrs = 0.0 frj = 1.0 omfrj = 0.0 dlnro_rs = 0.0 dlnt_y0 = 0.0 dlnro_y0 = 0.0 dlnro_rr = 0.0 dlnro_fim1 = 0.0 dlnro_fip1 = 0.0 dlnro_fip3 = 0.0 c if ( ider .ge. -2 ) then idus = ider else idus = 1 endif c fmuei_ln = log( fmuei ) c gamma_ln = flngammacon + fln10 * ( flro * f13 - flt ) $ + log( zsq ) - f23 * log( fmuai ) c rom13 = ( fmuei * 10.**flro )**f13 rom23 = rom13**2 c v_rom23 = 1.018e-4 * rom23 omrr = 1. / ( 1. + v_rom23 ) rr_it = v_rom23 * omrr c rs_it = 1.388 / rom13 c if ( v_rom23 .gt. 0.025 ) then tf_1 = sqrt( 1. + v_rom23 ) tf_arg_log = tf_1 - 1. tf_fac_log = log10( tf_arg_log ) else tf_arg_log = ( ( 0.0625 * v_rom23 - 0.125 ) $ * v_rom23 + 0.5 ) * v_rom23 tf_fac_log = log10( tf_arg_log ) endif f_tf = ( flogtfcon + tf_fac_log - 0.8 - flt ) * 2.5 c f_rho = flro - 6. c f_gam = gamma_ln * finv2ln2 + 0.5 c f_rs = ( flro + floge * fmuei_ln - 1.0803 ) * 2. c f_rshi = ( 12.9272 - flro - floge * fmuei_ln ) * 2. c f_gamhi = 1. - ( gamma_ln - gamma_ln_max ) * finvln2 c y0_it = 165.6 * rom23 * 10.**( -flt ) f_yi = 1.0 do i = 1, nitoh if ( xi_kc(i) .gt. 0.0 ) f_yi = f_yi - xi_kc(i) $ * max( 0. , 1. + log10( y0_it / ai_kc(i) ) * 2. ) enddo c fkcedge = 1. fedge_hl = 1. fedge_it = 1. fok_hl = min( 1. , 1. - f_rho , $ ( 9.2 - flt ) * 5. , ( flt - 2.8 ) * 5. ) fok_it = min( 1. , f_tf , f_gam , f_rs , $ f_rshi , f_gamhi , f_yi ) c flin_itoh = min( 1. , $ max( 0. , f_rho , min( f_tf , f_gam , f_rs ) ) ) c dlogt_f_itoh = 0.0 dlogro_f_itoh = 0.0 kdo_hl = 1 kdo_itoh = 1 c if ( ider .le. -4 .or. ider .eq. -2 .or. $ ( ider .ge. 0 .and. flin_itoh .eq. 0. ) ) then c if ( ider .lt. 0 ) then kdo_itoh = 0 else if ( ider .le. 1 ) then kdo_itoh = -1 endif f_itoh = 0. f_hl = 1. c else if ( ider .lt. 0 .or. flin_itoh .eq. 1. ) then c if ( ider .lt. 0 ) then kdo_hl = 0 else if ( ider .le. 1 ) then kdo_hl = -1 endif f_itoh = 1. f_hl = 0. c else c if ( idus .gt. 0 ) then c if ( flin_itoh .eq. f_rho ) then dlogt_f_itoh = 0.0 dlogro_f_itoh = 1. else if ( flin_itoh .eq. f_rs ) then dlogt_f_itoh = 0.0 dlogro_f_itoh = 2. else if ( flin_itoh .eq. f_gam ) then dlogt_f_itoh = - fln10 * finv2ln2 dlogro_f_itoh = fln10 * finv2ln2 / 3. else if ( flin_itoh .eq. f_tf ) then dlogt_f_itoh = -2.5 if ( v_rom23 .gt. 0.025 ) then dlogro_f_itoh = 1.25 * v_rom23 * f23 $ / ( tf_1 * tf_arg_log ) else dlogro_f_itoh = 2.5 * ( ( 0.1875 * v_rom23 $ - 0.25 ) * v_rom23 + 0.5 ) $ * v_rom23 * f23 / tf_arg_log endif endif c endif c if ( flin_itoh .le. 0.5 ) then f_itoh = 2. * flin_itoh**2 f_hl = 1. - f_itoh dlogt_f_itoh = 4. * flin_itoh * dlogt_f_itoh dlogro_f_itoh = 4. * flin_itoh * dlogro_f_itoh else f_hl = 2. * ( 1. - flin_itoh )**2 f_itoh = 1. - f_hl dlogt_f_itoh = 4. * ( 1. - flin_itoh ) * dlogt_f_itoh dlogro_f_itoh = 4. * ( 1. - flin_itoh ) * dlogro_f_itoh endif c endif c-debug[ c-debug; if ( i_debug_kcond .gt. 0 ) write(6,1733) flt, flro, c-debug; $ (xi_kc(i),i=1,5), f_hl, f_itoh, dlogt_f_itoh, c-debug; $ dlogro_f_itoh, ider, idus c-debug; 1733 format(/' KAPCOND: logT,RHO',f10.6,f11.6,' Xi',5f12.8, c-debug; $ ' f_hl,itoh',2f12.8,' dt,r_f_itoh',2f12.8, c-debug; $ ' ider',i3,' idus',i3) c-debug] c ! get lower-rho Kcond (log rho < 6) from tables c ! W.B.Hubbard & M.Lampe 1969, ApJS 163, 297-346 if ( kdo_hl .gt. 0 ) then c xi_hl(1) = xi_kc(1) xi_hl(2) = xi_kc(2) xi_hl(3) = xi_kc(3) + xi_kc(4) + xi_kc(5) c-debug[ c-debug; if ( i_debug_kcond .gt. 1 ) c-debug; $ write(6,'(" xi_hl=",3f12.8)') c-debug; $ xi_hl(1),xi_hl(2),xi_hl(3) c-debug] c ! get T,RHO position in matrix den = flro * dlrinv_kc - nrlokcm1 fedge_hl = min( fedge_hl , den * 0.5 + 0.5 , $ ( nrhikc + 2 - den ) * 0.5 ) ir = max( 0 , min( nrhikc , int(den) ) ) irf = max( 1 , min( nrhikcm1 , ir - 1 ) ) irf2 = max( 2 , min( nrhikc , ir + 2 ) ) irg = irf + 1 irh = irf + 2 frf = ( den - irf ) * dlr_kc ir1 = max( 1 , min( nrhikcm1 , ir ) ) ir2 = ir1 + 1 fr = den - ir1 omfr = 1. - fr c ! for logRHO < 0, is O.K. up to OPAL high-R if ( flro .gt. 0.5 ) then foki_rmin = 0.0 else foki_rmin = min( 1.0 , max( 0.0 , ( 0.5 - flro ) * 2.0 ) , $ max( 0.0 , ( -5.75 - flro ) * 4.0 , $ ( 1.5 - flro + ( flt - 6.0 ) * 3.0 ) * 2.0 ) ) endif c tem = flt * dltinv_kc - ntlokcm1 it = max( 0 , min( nthikc , int(tem) ) ) itf = max( 1 , min( nthikcm1 , it - 1 ) ) itf2 = max( 2 , min( nthikc , it + 2 ) ) itg = itf + 1 ith = itf + 2 ftf = ( tem - itf ) * dlt_kc it1 = max( 1 , min( nthikcm1 , it ) ) it2 = it1 + 1 ft = tem - it1 omft = 1. - ft c k_hl = 0 do k = 1, nitoh if ( xi_kc(k) .gt. 0.0 ) then if ( k_hl .eq. 0 ) then k_hl = - k else k_hl = k endif endif flk(k) = 0.0 tlk(k) = 0.0 rlk(k) = 0.0 foki_hl(k) = 1.0 enddo c flks = 0.0 tlks = 0.0 rlks = 0.0 c if ( irf2 .eq. 2 .and. fr .lt. 0.0 ) then c islope = 1 if ( fr .gt. -1.0 ) islope = -1 c i1s = 1 i2s = i1s + id21s frj = fr * finv21s omfrj = 1. - frj frs = max( 0. , min( 1. , fr + 1.0 ) ) omfrs = 1. - frs ftfj_kr(0) = -1.e36 ftfj_kr(1) = -1.e36 c else if ( irf .eq. nrhikcm1 .and. fr .gt. 1.0 ) then c islope = 1 if ( fr .lt. 2.0 ) islope = -1 c i2s = nrhikc i1s = i2s - id21s frj = ( fr - 1. ) * finv21s + 1. omfrj = 1. - frj frs = max( 0. , min( 1. , 2.0 - fr ) ) omfrs = 1. - frs ftfj_kr(0) = -1.e36 ftfj_kr(1) = -1.e36 c else c islope = 0 c endif c-debug[ c-debug; if ( i_debug_kcond .gt. 2 ) write(6, c-debug; $ '(" ir,f,g,h,f2,islope=",6i3," den,frf,fr",1p,3e15.7)') c-debug; $ ir,irf,irg,irh,irf2,islope,den,frf,fr c-debug; if ( i_debug_kcond .gt. 2 ) write(6, c-debug; $ '(" it,f,g,h,f2=",i10,4i3," tem,ftf,ft",1p,3e15.7)') c-debug; $ it,itf,itg,ith,itf2,tem,ftf,ft c-debug] c if ( islope .le. 0 ) then call qdersto( 1, frf, 0.0, dlr_kc, dlr2kc ) if ( irf2 .gt. irh ) $ call qdersto( 2, frf, dlr_kc, dlr2kc, dlr3kc ) c if ( itf2 .ge. ith ) then call qdersto( 3, ftf, 0.0, dlt_kc, dlt2kc ) if ( itf2 .gt. ith ) $ call qdersto( 4, ftf, dlt_kc, dlt2kc, dlt3kc ) endif endif c do k = 1, 3 c if ( xi_hl(k) .gt. 0.0 ) then c if ( islope .le. 0 ) then c ! O.K. to be in gap... i = irjump_hl(k) j = i if ( i .lt. ir1 .or. $ itlo_hl(ir1,k) .lt. itlo_hl(i,k) ) i = ir1 if ( j .lt. ir2 .or. $ itlo_hl(ir2,k) .lt. itlo_hl(j,k) ) j = ir2 tmp = max( foki_rmin , $ 1. + tem - omfr * itlo_hl(i,k) $ - fr * itlo_hl(j,k) ) c foki_hl(k) = min( foki_hl(k) , tmp , $ 1. + omfr * ithi_hl(ir1,k) $ + fr * ithi_hl(ir2,k) - tem ) fedge_hl = min( fedge_hl , foki_hl(k) ) if ( i .ne. ir1 .or. j .ne. ir2 .or. $ foki_rmin .gt. 0.0 ) $ fedge_hl = min( fedge_hl , 1. + tem $ - omfr * itlo_hl(ir1,k) - fr * itlo_hl(ir2,k) ) c c-debug[ c-debug; if ( i_debug_kcond .gt. 2 ) write(6, c-debug; $ '(" k=",i1," xi_hl(k)=",1p,e15.7)') c-debug; $ k, xi_hl(k) c-debug] c do kt = itf, itf2 c jt = kt - itf c if ( irf2 .lt. irh ) then fkoft(jt) = omfr * flkc_hl(kt,irf,k) $ + fr * flkc_hl(kt,irf2,k) if ( idus .gt. 0 ) $ d_fkoft(jt) = ( flkc_hl(kt,irf2,k) $ - flkc_hl(kt,irf,k) ) * dlrinv_kc c-debug[ c-debug; if ( i_debug_kcond .gt. 3 ) write(6,1893) c-debug; $ '=2',k,kt,jt,fkoft(jt),d_fkoft(jt), c-debug; $ irf,flkc_hl(kt,irf,k), c-debug; $ irf2,flkc_hl(kt,irf2,k) c-debug; 1893 format(' [',a2,']k,kt,jt',3i3, c-debug; $ ' fkoft(jt),dr',1p,2e15.7, c-debug; $ ' <--',4(i4,e15.7)) c-debug] else call qderget( 1, flkc_hl(kt,irf,k), $ flkc_hl(kt,irg,k), $ flkc_hl(kt,irh,k), $ fkoft(jt), d_fkoft(jt) ) c-debug[ c-debug; if ( i_debug_kcond .gt. 3 ) write(6,1893) c-debug; $ '>2',k,kt,jt,fkoft(jt),d_fkoft(jt), c-debug; $ (i,flkc_hl(kt,i,k),i=irf,irh) c-debug] if ( irf2 .gt. irh ) then if ( idus .gt. 0 ) then call qderget( 2, flkc_hl(kt,irg,k), $ flkc_hl(kt,irh,k), $ flkc_hl(kt,irf2,k), $ tmp, dkap ) d_fkoft(jt) = $ omfr * d_fkoft(jt) + fr * dkap $ + ( tmp - fkoft(jt) ) * dlrinv_kc fkoft(jt) = omfr * fkoft(jt) + fr * tmp else fkoft(jt) = omfr * fkoft(jt) + fr $ * quadget( 2, flkc_hl(kt,irg,k), $ flkc_hl(kt,irh,k), $ flkc_hl(kt,irf2,k) ) endif c-debug[ c-debug; if ( i_debug_kcond .gt. 3 ) write(6,1893) c-debug; $ '=4',k,kt,jt,fkoft(jt),d_fkoft(jt), c-debug; $ (i,flkc_hl(kt,i,k),i=irf,irf2) c-debug] else if ( irf .eq. 1 ) then tmp = omfr * flkc_hl(kt,1,k) $ + fr * flkc_hl(kt,2,k) if ( idus .gt. 0 ) d_fkoft(jt) = $ fr * d_fkoft(jt) + ( fkoft(jt) - tmp $ + omfr * ( flkc_hl(kt,2,k) $ - flkc_hl(kt,1,k) ) ) * dlrinv_kc fkoft(jt) = omfr * tmp + fr * fkoft(jt) c-debug[ c-debug; if ( i_debug_kcond .gt. 3 ) write(6,1893) c-debug; $ '23',k,kt,jt,fkoft(jt),d_fkoft(jt), c-debug; $ (i,flkc_hl(kt,i,k),i=1,2) c-debug] else tmp = omfr * flkc_hl(kt,nrhikcm1,k) $ + fr * flkc_hl(kt,nrhikc,k) if ( idus .gt. 0 ) d_fkoft(jt) = $ omfr * d_fkoft(jt) + ( tmp - fkoft(jt) $ + fr * ( flkc_hl(kt,nrhikc,k) $ - flkc_hl(kt,nrhikcm1,k) ) ) $ * dlrinv_kc fkoft(jt) = omfr * fkoft(jt) + fr * tmp c-debug[ c-debug; if ( i_debug_kcond .gt. 3 ) write(6,1893) c-debug; $ '32',k,kt,jt,fkoft(jt),d_fkoft(jt), c-debug; $ (i,flkc_hl(kt,i,k),i=nrhikcm1,nrhikc) c-debug] endif endif c enddo c if ( itf2 .lt. ith ) then flk(k) = omft * fkoft(0) + ft * fkoft(1) if ( idus .gt. 0 ) then tlk(k) = ( fkoft(1) - fkoft(0) ) * dltinv_kc rlk(k) = omft * d_fkoft(0) + ft * d_fkoft(1) endif c-debug[ c-debug; if ( i_debug_kcond .gt. 2 ) write(6,1894) c-debug; $ '=2',k,flk(k),tlk(k),rlk(k), c-debug; $ 0,fkoft(0),1,fkoft(1), c-debug; $ 0,d_fkoft(0),1,d_fkoft(1) c-debug; 1894 format(' [',a2,']k',i3, c-debug; $ ' flk(k),dt,dr',1p,3e15.7, c-debug; $ ' <--',8(i4,e15.7)) c-debug] else if ( idus .gt. 0 ) then call qderget( 3, fkoft(0), fkoft(1), fkoft(2), $ flk(k), tlk(k) ) rlk(k) = quadget( 3, d_fkoft(0), $ d_fkoft(1), d_fkoft(2) ) else flk(k) = quadget( 3, fkoft(0), $ fkoft(1), fkoft(2) ) endif c-debug[ c-debug; if ( i_debug_kcond .gt. 2 ) write(6,1894) c-debug; $ '>2',k,flk(k),tlk(k),rlk(k), c-debug; $ 0,fkoft(0),1,fkoft(1),2,fkoft(2), c-debug; $ 0,d_fkoft(0),1,d_fkoft(1),2,d_fkoft(2) c-debug] if ( itf2 .gt. ith ) then if ( idus .gt. 0 ) then call qderget( 4, fkoft(1), fkoft(2), $ fkoft(3), tmp, dkap ) tlk(k) = omft * tlk(k) + ft * dkap $ + ( tmp - flk(k) ) * dltinv_kc flk(k) = omft * flk(k) + ft * tmp rlk(k) = omft * rlk(k) + ft * quadget( 4, $ d_fkoft(1), d_fkoft(2), d_fkoft(3) ) else flk(k) = omft * flk(k) + ft * quadget( 4, $ fkoft(1), fkoft(2), fkoft(3) ) endif c-debug[ c-debug; if ( i_debug_kcond .gt. 2 ) write(6,1894) c-debug; $ '=4',k,flk(k),tlk(k),rlk(k), c-debug; $ (i,fkoft(i),i=0,3),(i,d_fkoft(i),i=0,3) c-debug] else if ( itf .eq. 1 ) then tmp = omft * fkoft(0) + ft * fkoft(1) if ( idus .gt. 0 ) then tlk(k) = ft * tlk(k) + ( flk(k) - tmp + omft $ * ( fkoft(1) - fkoft(0) ) ) * dltinv_kc rlk(k) = ft * rlk(k) + omft * ( omft $ * d_fkoft(0) + ft * d_fkoft(1) ) endif flk(k) = omft * tmp + ft * flk(k) c-debug[ c-debug; if ( i_debug_kcond .gt. 2 ) write(6,1894) c-debug; $ '23',k,flk(k),tlk(k),rlk(k), c-debug; $ (i,fkoft(i),i=0,1),(i,d_fkoft(i),i=0,1) c-debug] else tmp = omft * fkoft(1) + ft * fkoft(2) if ( idus .gt. 0 ) then tlk(k) = omft * tlk(k) + ( tmp - flk(k) + ft $ * ( fkoft(2) - fkoft(1) ) ) * dltinv_kc rlk(k) = omft * rlk(k) + ft * ( omft $ * d_fkoft(1) + ft * d_fkoft(2) ) endif flk(k) = omft * flk(k) + ft * tmp c-debug[ c-debug; if ( i_debug_kcond .gt. 2 ) write(6,1894) c-debug; $ '32',k,flk(k),tlk(k),rlk(k), c-debug; $ (i,fkoft(i),i=1,2),(i,d_fkoft(i),i=1,2) c-debug] endif endif c endif c if ( islope .ne. 0 ) then c do kr = 0, 1 c jr = id21s * kr + i1s temj = tem + ( jr - den ) * rslope_mat jt = max( 0 , min( nthikc , int(temj) ) ) jtf = max( 1 , min( nthikcm1 , jt - 1 ) ) jtf2 = max( 2 , min( nthikc , jt + 2 ) ) jtg = jtf + 1 jth = jtf + 2 ftfj = ( temj - jtf ) * dlt_kc ftj = temj - max( 1 , min( nthikcm1 , jt ) ) omftj = 1. - ftj c tmp = 1. + temj - itlo_hl(jr,k) foki_hl(k) = min( foki_hl(k) , $ 1. + ithi_hl(jr,k) - temj , $ max( tmp , foki_rmin ) ) fedge_hl = min( fedge_hl , foki_hl(k) , tmp ) c-debug[ c-debug; if ( i_debug_kcond .gt. 2 ) write(6, c-debug; $ '(" jr,t,f:f2=",6i3," tem,ftf,tj",1p,3e15.7)' c-debug; $ ) jr,jt,jtf,jtg,jth,jtf2,temj,ftfj,ftj c-debug] c if ( jtf2 .lt. jth ) then fkoft(kr) = omftj * flkc_hl(jtf,jr,k) $ + ftj * flkc_hl(jtf2,jr,k) if ( idus .gt. 0 ) $ d_fkoft(kr) = ( flkc_hl(jtf2,jr,k) $ - flkc_hl(jtf,jr,k) ) * dltinv_kc c-debug[ c-debug; if ( i_debug_kcond .gt. 3 ) write(6,1891) c-debug; $ '=2',k,jr,jt,kr,fkoft(kr),d_fkoft(kr), c-debug; $ jtf,flkc_hl(jtf,jr,k), c-debug; $ jtf2,flkc_hl(jtf2,jr,k) c-debug; 1891 format(' [',a2,']k,jr,jt',3i3, c-debug; $ ' fkoft(kr=',i1,'),dt',1p,2e15.7, c-debug; $ ' <--',4(i4,e15.7)) c-debug] else if ( abs( ftfj_kr(kr) - ftfj ) .gt. $ small_5m7 ) then ftfj_kr(kr) = ftfj call qdersto( 5 + kr, ftfj, $ 0.0, dlt_kc, dlt2kc ) if ( jtf2 .gt. jth ) call qdersto( 7 + kr, $ ftfj, dlt_kc, dlt2kc, dlt3kc ) endif call qderget( 5 + kr, flkc_hl(jtf,jr,k), $ flkc_hl(jtg,jr,k), $ flkc_hl(jth,jr,k), $ fkoft(kr), d_fkoft(kr) ) c-debug[ c-debug; if ( i_debug_kcond .gt. 3 ) write(6,1891) c-debug; $ '>2',k,jr,jt,kr,fkoft(kr),d_fkoft(kr), c-debug; $ (i,flkc_hl(i,jr,k),i=jtf,jth) c-debug] if ( jtf2 .gt. jth ) then if ( idus .gt. 0 ) then call qderget( 7 + kr, flkc_hl(jtg,jr,k), $ flkc_hl(jth,jr,k), $ flkc_hl(jtf2,jr,k), $ tmp, dkap ) d_fkoft(kr) = omftj * d_fkoft(kr) $ + ftj * dkap $ + ( tmp - fkoft(kr) ) * dltinv_kc fkoft(kr) = omftj * fkoft(kr) + ftj * tmp else fkoft(kr) = omftj * fkoft(kr) + ftj $ * quadget( 7 + kr, $ flkc_hl(jtg,jr,k), $ flkc_hl(jth,jr,k), $ flkc_hl(jtf2,jr,k) ) endif c-debug[ c-debug; if ( i_debug_kcond .gt. 3 ) write(6,1891) c-debug; $ '=4',k,jr,jt,kr,fkoft(kr),d_fkoft(kr), c-debug; $ (i,flkc_hl(i,jr,k),i=jtf,jtf2) c-debug] else if ( jtf .eq. 1 ) then tmp = omftj * flkc_hl(1,jr,k) $ + ftj * flkc_hl(2,jr,k) if ( idus .gt. 0 ) d_fkoft(kr) = $ ftj * d_fkoft(kr) + ( fkoft(kr) - tmp $ + omftj * ( flkc_hl(2,jr,k) $ - flkc_hl(1,jr,k) ) ) * dltinv_kc fkoft(kr) = omftj * tmp + ftj * fkoft(kr) c-debug[ c-debug; if ( i_debug_kcond .gt. 3 ) write(6,1891) c-debug; $ '23',k,jr,jt,kr,fkoft(kr),d_fkoft(kr), c-debug; $ (i,flkc_hl(i,jr,k),i=1,2) c-debug] else tmp = omftj * flkc_hl(nthikcm1,jr,k) $ + ftj * flkc_hl(nthikc,jr,k) if ( idus .gt. 0 ) d_fkoft(kr) = $ omftj * d_fkoft(kr) + ( tmp - fkoft(kr) $ + ftj * ( flkc_hl(nthikc,jr,k) $ - flkc_hl(nthikcm1,jr,k) ) ) $ * dltinv_kc fkoft(kr) = omftj * fkoft(kr) + ftj * tmp c-debug[ c-debug; if ( i_debug_kcond .gt. 3 ) write(6,1891) c-debug; $ '32',k,jr,jt,kr,fkoft(kr),d_fkoft(kr), c-debug; $ (i,flkc_hl(i,jr,k),i=nthikcm1,nthikc) c-debug] endif c endif c enddo c flks = omfrj * fkoft(0) + frj * fkoft(1) c if ( idus .gt. 0 ) then tlks = omfrj * d_fkoft(0) + frj * d_fkoft(1) rlks = ( fkoft(1) - fkoft(0) ) * dlrinv_s $ - rslope * tlks endif c-debug[ c-debug; if ( i_debug_kcond .gt. 2 ) write(6,1892) c-debug; $ k, frj, flks, tlks, rlks, 0, fkoft(0), c-debug; $ 1, fkoft(1), 0, d_fkoft(0), 1, d_fkoft(1) c-debug; 1892 format(' [=2s]k',i3,' frj',1p,e15.7, c-debug; $ ' flks:k,dt,dr',1p,3e15.7, c-debug; $ ' <--',6(i4,e15.7)) c-debug] c if ( islope .gt. 0 ) then flk(k) = flks tlk(k) = tlks rlk(k) = rlks else c-debug[ c-debug; if ( i_debug_kcond .gt. 2 ) write(6,1899) c-debug; $ k, frs, flks * omfrs + flk(k) * frs, c-debug; $ tlks * omfrs + tlk(k) * frs, c-debug; $ rlks * omfrs + rlk(k) * frs + max(-1,2-irf) c-debug; $ * ( flk(k) - flks ) * dlrinv_kc, c-debug; $ 0, flks, 1, flk(k), 0, tlks, 1, tlk(k), c-debug; $ 0, rlks, 1, rlk(k) c-debug; 1899 format(' [s+2]k',i3,' frs',1p,e15.7, c-debug; $ ' flk(k),dt,dr',1p,3e15.7, c-debug; $ ' <--',6(i4,e15.7)) c-debug] tlk(k) = tlks * omfrs + tlk(k) * frs rlk(k) = rlks * omfrs + rlk(k) * frs if ( irf2 .eq. 2 ) then rlk(k) = rlk(k) + ( flk(k) - flks ) * dlrinv_kc else rlk(k) = rlk(k) + ( flks - flk(k) ) * dlrinv_kc endif flk(k) = flks * omfrs + flk(k) * frs endif c endif c if ( k .eq. 3 ) then c ! get approximate Kc(Oxygen) flk(4) = flk(3) + dlkc_ovsc tlk(4) = tlk(3) rlk(4) = rlk(3) foki_hl(4) = foki_hl(3) c ! get approximate Kc(Ne...) flk(5) = flk(3) + dlkc_nevsc tlk(5) = tlk(3) rlk(5) = rlk(3) foki_hl(5) = foki_hl(3) endif c endif c enddo c ! if there is only one X(i) non-zero: if ( k_hl .lt. 0 ) then c k = iabs(k_hl) c fok_hl = min( fok_hl , foki_hl(k) ) c flkh = flk(k) flkht = tlk(k) flkhro = rlk(k) c ! else: more than one: sum over X(i): else c tmp = 0. ssq = 0. c ! get preliminary flkh = Kc(k_hl) / Kc c ! = SUM_i{ X(i) * Kc(k_hl) / Kc(i) } , c ! flkht = ( Kc(k_hl) / Kc ) * ( d logKc / d logT ) c ! = SUM_i{ ( d logKc(k_hl) / d logT ) c ! * X(i) * Kc(k_hl) / Kc(i) } , c ! flkhro = similar do k = 1, nitoh if ( xi_kc(k) .gt. 0.0 ) then ssq = ssq + sqrt( xi_kc(k) ) tmp = tmp + foki_hl(k) * sqrt( xi_kc(k) ) if ( k .eq. k_hl ) then flkinv = 1.0 flkh = flkh + xi_kc(k) else flkinv = 10.**min( 35. , flk(k_hl) - flk(k) ) flkh = flkh + xi_kc(k) * flkinv endif if ( idus .gt. 0 ) then flkht = flkht + xi_kc(k) * flkinv * tlk(k) flkhro = flkhro + xi_kc(k) * flkinv * rlk(k) endif endif enddo c fok_hl = min( fok_hl , tmp / ssq ) c if ( flkh .le. 0.0 ) stop $ ' STOP -- KAPCOND Error: Kcond(H&L) < 0 cannot be. ' c c ! convert to flkh = logKc , c ! flkht = ( d logKc / d logT ) , c ! flkhro = ( d logKc / d logRHO ) if ( idus .gt. 0 ) then flkht = flkht / flkh flkhro = flkhro / flkh endif flkh = flk(k_hl) - log10( flkh ) c endif c c-debug[ c-debug; if ( i_debug_kcond .gt. 0 ) write(6,1897) flkh,flkht,flkhro, c-debug; $ max( fedge_hl , 0.0 ), max( 0.0 , fok_hl ),k_hl c-debug; 1897 format(' KAPCOND: logKc_hl',f13.8,' dlogT,RHO',2f16.8, c-debug; $ ' fedge,ok',2f11.8,' k_hl',i3) c-debug] if ( kdo_itoh .eq. 0 ) then flkb = flkh flkbt = flkht flkbro = flkhro flkc = flkh flkct = flkht flkcro = flkhro fedge_kc = max( 0.0 , fedge_hl ) fkcedge = fedge_kc fedge_ok = max( 0.0 , fok_hl ) fkcok = fedge_ok return endif c endif c if ( kdo_itoh .gt. 0 ) then c xg = 0.45641 * gamma_ln - 1.31636 c ! if Gamma > 171, will extrapolate c ! linearly in ln(Gamma), i.e., in xg c ! (using the slope at Gamma = 171) if ( xg .le. xg_max ) then idat = idus delta_xg = 0. else idat = 2 delta_xg = xg - xg_max xg = xg_max endif c ratksqo4 = ratsqo4con / sqrt(rr_it) ratsqinva = 1. + 1. / ratksqo4 ratsqinvb = 1. / ( ratksqo4 + 1. ) fimrr = ( log(ratsqinva) - ratsqinvb ) * 0.5 fimrs = 0.0896 * rs_it + 1.0028 fim1 = fimrr * fimrs fip1 = ( 0.3429 * rs_it - 0.4573 ) * rs_it + 0.4893 fip3 = 0.2484 - 0.0953 * rs_it c-debug[ c-debug; if ( i_debug_kcond .gt. 0 ) write(6,1735) fmuainv, fmuai, c-debug; $ fmueinv, fmuei, fmuei_ln, zsqbar, zsq, c-debug; $ rr_it, omrr, rs_it, y0_it, fim1, fip1, fip3 c-debug; 1735 format(' 1/muA',f9.6,' -->',f9.6,' 1/mue',f9.6,' -->',f9.6, c-debug; $ ' ln(1/mue)',f10.6,' ',f10.5,' -->',f10.5, c-debug; $ ' R,1-R,rs,y0',1p,4e15.7,' ',3e15.7) c-debug] c if ( idus .gt. 0 ) then c c_parameter; dlnt_xg = -0.45641 c_parameter; dlnro_xg = 0.45641 * f13 dlnro_rs = fm13 * rs_it dlnt_y0 = - y0_it dlnro_y0 = f23 * y0_it dlnro_rr = f23 * rr_it * omrr c dlnro_fim1 = 0.0896 * fimrr * dlnro_rs $ + fimrs * ratsqinvb**2 * f16 * omrr dlnro_fip1 = ( 0.6858 * rs_it - 0.4573 ) * dlnro_rs dlnro_fip3 = -0.0953 * dlnro_rs c c-debug[ c-debug; if ( i_debug_kcond .gt. 1 ) write(6,1736) dlnt_y0*fln10, c-debug; $ dlnro_rr*fln10, -dlnro_rr*fln10, dlnro_rs*fln10, c-debug; $ dlnro_y0*fln10, dlnro_fim1*fln10, dlnro_fip1*fln10, c-debug; $ dlnro_fip3*fln10 c-debug; 1736 format(' dlgT_y0',1p,e15.7, c-debug; $ ' dlgRHO.....',1p,4e15.7,' ....',3e15.7) c-debug] endif c do i = 1, nitoh c if ( xi_kc(i) .gt. 0.0 ) then c do j = 1, 3 c asum = ( ( ax_kc(3,i,j) * xg + ax_kc(2,i,j) ) * xg $ + ax_kc(1,i,j) ) * xg + ax_kc(0,i,j) bsum = ( bx_kc(2,i,j) * xg + bx_kc(1,i,j) ) * xg $ + bx_kc(0,i,j) csum = ( cx_kc(2,i,j) * xg + cx_kc(1,i,j) ) * xg $ + cx_kc(0,i,j) b_c_rs = ( csum * rs_it + bsum ) * rs_it + 1. sj(j) = b_c_rs * asum c if ( idat .gt. 0 ) then c drs_b_c_rs = 2. * csum * rs_it + bsum c dxg_asum = ( 3. * ax_kc(3,i,j) * xg $ + 2. * ax_kc(2,i,j) ) * xg + ax_kc(1,i,j) dxg_bsum = 2. * bx_kc(2,i,j) * xg + bx_kc(1,i,j) dxg_csum = 2. * cx_kc(2,i,j) * xg + cx_kc(1,i,j) c drs_sj(j) = asum * drs_b_c_rs c dxg_sj(j) = b_c_rs * dxg_asum $ + asum * ( dxg_csum * rs_it $ + dxg_bsum ) * rs_it c ! if Gamma > 171, then c ! extrapolate linearly in ln(Gamma) if ( idat .gt. 1 ) then sj(j) = sj(j) + dxg_sj(j) * delta_xg drs_sj(j) = drs_sj(j) $ + ( drs_b_c_rs * dxg_asum $ + asum * ( 2. * dxg_csum * rs_it $ + dxg_bsum ) ) * delta_xg endif c endif c enddo c dy0_ska = ( sj(3) * rr_it - sj(2) ) * f23 $ - ( sixopisq * rr_it + fouropisq23 ) * fip1 $ + fouropisq23 * rr_it * fip3 + sixopisq * fim1 c ska = dy0_ska * y0_it $ + ( sj(1) - sj(2) * rr_it ) * ai_kc(i) c if ( ska .gt. 1.e-35 ) then c f_xi = xi_kc(i) / ska c if ( idus .gt. 0 ) then c dxg_ska = ( dxg_sj(3) * rr_it - dxg_sj(2) ) $ * f23 * y0_it + ( dxg_sj(1) $ - dxg_sj(2) * rr_it ) * ai_kc(i) c drs_ska = ( drs_sj(3) * rr_it - drs_sj(2) ) $ * f23 * y0_it + ( drs_sj(1) $ - drs_sj(2) * rr_it ) * ai_kc(i) c drr_ska = y0_it * ( sj(3) * f23 - sixopisq * fip1 $ + fouropisq23 * fip3 ) - sj(2) * ai_kc(i) c dlnt_ska = dxg_ska * dlnt_xg + dy0_ska * dlnt_y0 c dlnro_ska = dxg_ska * dlnro_xg $ + drs_ska * dlnro_rs + drr_ska * dlnro_rr $ + dy0_ska * dlnro_y0 $ + y0_it * ( fouropisq23 * rr_it * dlnro_fip3 $ - ( sixopisq * rr_it + fouropisq23 ) $ * dlnro_fip1 + sixopisq * dlnro_fim1 ) c flkit = flkit + f_xi * ( dlnt_ska / ska ) flkiro = flkiro + f_xi * ( dlnro_ska / ska ) c endif c flki = flki + f_xi c else c flki = flki + xi_kc(i) * 1.e35 c endif c-debug[ c-debug; if ( i_debug_kcond .gt. 0 ) write(6,1739) i, xi_kc(i), c-debug; $ exp(gamma_ln), gamma_ln, xg, sj(1), sj(2), sj(3), c-debug; $ ska, ska/omrr, flki c-debug; 1739 format(' KAPCOND: Xi(',i1,')',1p,e14.7, c-debug; $ ' Gamma',0p,f15.6,' lnGamma,xg', c-debug; $ 0p,2f11.6,' ',3f16.8,' A',f16.8, c-debug; $ ' A/(1-R)',f16.8,' sum',f16.8) c-debug; if ( idus .gt. 0 .and. i_debug_kcond .gt. 1 ) then c-debug; write(6,1738) '_xg', dxg_sj(1), dxg_sj(2), c-debug; $ dxg_sj(3), '_xg', dxg_ska c-debug; write(6,1738) '_rs', drs_sj(1), drs_sj(2), c-debug; $ drs_sj(3), '_rs', drs_ska, c-debug; $ ' d_rr:A', drr_ska c-debug; write(6,1738) 'lgt', ( dxg_sj(j) * dlnt_xg * fln10, c-debug; $ j = 1, 3), 'lgt', dlnt_ska * fln10 c-debug; write(6,1738) 'lgr', ( dxg_sj(j) * dlnro_xg * fln10 c-debug; $ + drs_sj(j) * dlnro_rs * fln10, j = 1, 3), c-debug; $ 'lgr', dlnro_ska * fln10 c-debug; 1738 format(15x,14x,6x,15x,11x, c-debug; $ 22x,' d',a,3f16.8,' d',a,f16.8, c-debug; $ a,f16.8) c-debug; endif c-debug] c endif c enddo c fedge_it = min( fedge_it , fok_it ) c if ( flki .le. 0.0 .and. f_itoh .gt. 0.0 ) then flkb = badlogkval flkbt = 0.0 flkbro = 0.0 flkc = badlogkval flkct = 0.0 flkcro = 0.0 fedge_kc = -99. fkcedge = fedge_kc fedge_ok = -99. fkcok = fedge_ok return endif c if ( idus .gt. 0 ) then flkit = flkit / flki + 2. flkiro = flkiro / flki - 2. + dlnro_rr / omrr endif c flki = ( flt - flro ) * 2. - log10( omrr * flki ) $ + flogitohcon c c-debug[ c-debug; if ( i_debug_kcond .gt. 0 ) write(6,1749) flki, c-debug; $ flkit, flkiro, max( 0.0 , fedge_it ), c-debug; $ max( 0.0 , fok_it ), f_tf, f_gam, f_rs, f_yi c-debug; 1749 format(' KAPCOND: logKc_It',f13.8,' dlogT,RHO',2f16.8, c-debug; $ ' fedge,ok',2f11.8,' ftf,gam,rs,yi',4f14.8) c-debug] if ( kdo_hl .eq. 0 ) then flkb = flki flkbt = flkit flkbro = flkiro flkc = flki flkct = flkit flkcro = flkiro fedge_kc = max( 0. , min( fedge_it , fok_it ) ) fkcedge = fedge_kc fedge_ok = max( 0. , fok_it ) fkcok = fedge_ok return endif c endif c if ( idus .gt. 0 ) then flkbt = f_hl * flkht + f_itoh * flkit $ + dlogt_f_itoh * ( flki - flkh ) flkbro = f_hl * flkhro + f_itoh * flkiro $ + dlogro_f_itoh * ( flki - flkh ) endif c flkb = f_hl * flkh + f_itoh * flki c flkc = flkb flkct = flkbt flkcro = flkbro c tmp = min( 1. , f_rshi , f_gamhi , f_yi ) if ( f_rs .le. 0. ) then fedge_ok = max( 0. , min( tmp , fok_hl ) ) else if ( flro .lt. 6. ) then fedge_ok = max( 0. , fok_it , min( tmp , fok_hl ) ) else fedge_ok = max( 0. , $ min( tmp , 1. - f_rho , ( 9.2 - flt ) * 5. ) , $ min( tmp , f_rs , $ max( ( 9.2 - flt ) * 5. , min( f_tf , f_gam ) ) ) ) endif fkcok = fedge_ok c fedge_kc = max( 0. , f_hl * fedge_hl + f_itoh * fedge_it ) fkcedge = fedge_kc c-debug[ c-debug; if ( i_debug_kcond .gt. 0 ) write(6,1748) flkc, flkct, flkcro, c-debug; $ fkcedge, fkcok, f_hl, f_itoh, dlogt_f_itoh, dlogro_f_itoh, c-debug; $ f_rho, f_tf, f_gam, f_rs c-debug; 1748 format(' KAPCOND: logKc',f16.8,' dlogT,RHO',2f16.8, c-debug; $ ' fedge,ok',2f11.8,' f_hl,It',2f12.8,' dT,R:f_It',2f16.8, c-debug; $ ' f_rho,tf,gam,rs',4f14.8) c-debug] return end c c****************************************************************************** c subroutine kap_cond_pot( flro, flt, Zion, ider, $ flkc, flkct, flkcro, fkcedge, fkcok ) c ============================================================== c c flro = log10(RHO), flt = log10(T), Zion = rms (or mean) ionic charge c ider = 1 : use bi-quadratic interpolation, with derivatives. c 0 : use bi-quadratic interpolation, no derivatives. c -1 : use Potekhin website formulae, with derivatives. c RETURNS: c flkc = logKc = log10( Kappa_cond ) c [if ider is not 0]: flkct = dlogKc / dlogT , flkcro = dlogKc / dlogRHO c fkcedge, fkcok (strict and loose edge factors) c parameter ( small_1m6=1.e-6 ) c parameter ( nT_KcPot=19, nR_KcPot=64, nZ_KcPot=15 ) c parameter ( ntlokc=37, ntlokcm1=ntlokc-1, nthikc=90-ntlokcm1, $ nrlokc=-23, nrlokcm1=nrlokc-1, nrhikc=24-nrlokcm1, nkc=3, $ nthikcm1=nthikc-1, nrhikcm1=nrhikc-1, nkcp1=nkc+1 ) parameter ( dlt_kc=.1, dlr_kc=.25, dltinv_kc=10., dlrinv_kc=4. ) c character*2 celkc_hl(nkc) common /c_flkcond_hlpot/ flkc_pot(nT_KcPot,nR_KcPot,nZ_KcPot), $ AT_pot(nT_KcPot), AR_pot(nR_KcPot), AZ_pot(nZ_KcPot), $ sigconlog_pot, itlo_hl(nrhikc,nkc), ithi_hl(nrhikc,nkc), $ irhi_hl(nkc), itlo_ok_hl(nrhikc,nkc), $ irjump_hl(nkc), celkc_hl save /c_flkcond_hlpot/ c dimension flkc_hl(nthikc,nrhikc,nkc), $ flrolo_hl(nkc), flrohi_hl(nkc), $ fltlo_hl(nkc), flthi_hl(nkc), $ flRlo_hl(nkc), flRhi_hl(nkc), kZ_pot(nZ_KcPot) equivalence (flkc_pot(1,1,1),flkc_hl(1,1,1)), $ (AR_pot(1),flrolo_hl(1)), (AR_pot(nkcp1),flrohi_hl(1)), $ (AT_pot(1),fltlo_hl(1)), (AT_pot(nkcp1),flthi_hl(1)), $ (AZ_pot(1),flRlo_hl(1)), (AZ_pot(nkcp1),flRhi_hl(1)), $ (itlo_hl(1,1),kZ_pot(1)) c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c c Note: these are initialized to valid values in BLOCK DATA OPAL_OPAC_DATA: c common /c_pot_indices/ zkpot(0:3,0:3), zlg_pot_p, i1pot_p, $ i4pot_p, j1pot_p, j4pot_p, i1pot, i2pot, i3pot, i4pot, $ j1pot, j2pot, j3pot, j4pot, k1pot, k2pot, k3pot, k4pot save /c_pot_indices/ c common/d_opal_z/ dkap save /d_opal_z/ c parameter ( nTm1_KcPot=nT_KcPot-1, nRm1_KcPot=nR_KcPot-1, $ nTm2_KcPot=nT_KcPot-2, nRm2_KcPot=nR_KcPot-2, $ nZm1_KcPot=nZ_KcPot-1, badlogkval=1.e+35 ) c dimension h(0:3), dh(0:3) c-debug[ c-debug; common/outdeb/ ioudeb,oudebl,koudeb c-debug] c flkc = badlogkval flkct = 0.0 flkcro = 0.0 fkcedge = -99999. fkcok = -99999. c ! Potekhin 2006 opacities unavailable ? if ( kavail_cond .le. 1 ) return c ! unphysical Zion ? if ( Zion .le. 0.1 .or. Zion .gt. 130.0 ) then write(6,10) Zion 10 format(' KAP_COND_POT Error: bad (unphysical)', $ ' value of Zion =',1p,e14.6) stop ' STOP -- KAP_COND_POT Error: bad value of Zion. ' endif c ! get log(Zion) for interpolation purposes zlg = log10( Zion ) c-debug[ c-debug; if ( ioudeb .gt. 5 ) write(6, c-debug; $ '(/" ----- kap_cond_pot( flro",f11.6," flt",f10.6," Zion", c-debug; $ f11.6," ider",i3," ... ) ----- ZLG = log(Zion) =",f11.7)') c-debug; $ flro, flt, Zion, ider, zlg c-debug] c ! edge factors zflo = ( zlg - AZ_pot(1) ) / ( AZ_pot(2) - AZ_pot(1) ) zfhi = ( AZ_pot(nZ_KcPot) - zlg ) $ / ( AZ_pot(nZ_KcPot) - AZ_pot(nZm1_KcPot) ) c tflo = ( flt - AT_pot(1) ) / ( AT_pot(2) - AT_pot(1) ) tfhi = ( AT_pot(nT_KcPot) - flt ) $ / ( AT_pot(nT_KcPot) - AT_pot(nTm1_KcPot) ) c rflo = ( flro - AR_pot(1) ) / ( AR_pot(2) - AR_pot(1) ) rfhi = ( AR_pot(nR_KcPot) - flro ) $ / ( AR_pot(nR_KcPot) - AR_pot(nRm1_KcPot) ) c fkcok = 1.0 + min( 0.0 , $ tflo , tfhi , rflo , rfhi , zflo , zfhi ) c c For the strictly valid region, edge factor fedge_degen goes 1.0 to 0.0 c as one goes from (rather approximately) eta = 4.4 to eta = -2.6 c as estimated from the figures 24.5 and 24.6 (p. 848 and 858) of Cox & Giuli c i.e. as one goes from degenerate to non-degenerate regions: c f_lo = min( 4.842 + 0.6625 * flro , 5.524 + 0.5414 * flro , $ 6.336 + 0.4211 * flro ) f_hi = f_lo + 1.25 fedge_degen = min( 1.0 , ( f_hi - flt ) * 0.8 ) c fkcedge = min( fkcok , fedge_degen ) c-debug[ c-debug; if ( ioudeb .gt. 8 ) write(6, c-debug; $ '(/8x,"zf{lo,hi}",2f11.6," t",2f11.6," r",2f11.6, c-debug; $ " fkcok",f11.6," logTdeg",2f10.6," fedge_degen",f11.6, c-debug; $ " fkcedge",f11.6)') c-debug; $ zflo, zfhi, tflo, tfhi, rflo, rfhi, fkcok, c-debug; $ f_lo, f_hi, fedge_degen, fkcedge c-debug] c ! T-indices imd = 1 do while ( i2pot .gt. 1 .and. flt .lt. AT_pot(i2pot) ) i3pot = i2pot i2pot = max( 1 , i2pot - imd ) imd = imd + imd enddo do while ( i3pot .lt. nT_KcPot .and. flt .gt. AT_pot(i3pot) ) i2pot = i3pot i3pot = min( nT_KcPot , i3pot + imd ) imd = imd + imd enddo do while ( i3pot - i2pot .gt. 1 ) imd = ( i2pot + i3pot ) / 2 if ( flt .ge. AT_pot(imd) ) then i2pot = imd else i3pot = imd endif enddo if ( i2pot .eq. 1 ) then i1pot = 1 if ( ider .ge. 0 .and. tflo .le. -1.0 ) then i4pot = 2 else i4pot = 3 endif else if ( i3pot .eq. nT_KcPot ) then i4pot = nT_KcPot if ( ider .ge. 0 .and. tfhi .le. -1.0 ) then i1pot = nTm1_KcPot else i1pot = nTm2_KcPot endif else i1pot = i2pot - 1 i4pot = i3pot + 1 endif c ! RHO-indices imd = 1 do while ( j2pot .gt. 1 .and. flro .lt. AR_pot(j2pot) ) j3pot = j2pot j2pot = max( 1 , j2pot - imd ) imd = imd + imd enddo do while ( j3pot .lt. nR_KcPot .and. flro .gt. AR_pot(j3pot) ) j2pot = j3pot j3pot = min( nR_KcPot , j3pot + imd ) imd = imd + imd enddo do while ( j3pot - j2pot .gt. 1 ) imd = ( j2pot + j3pot ) / 2 if ( flro .ge. AR_pot(imd) ) then j2pot = imd else j3pot = imd endif enddo if ( j2pot .eq. 1 ) then j1pot = 1 if ( ider .ge. 0 .and. rflo .le. -1.0 ) then j4pot = 2 else j4pot = 3 endif else if ( j3pot .eq. nR_KcPot ) then j4pot = nR_KcPot if ( ider .ge. 0 .and. rfhi .le. -1.0 ) then j1pot = nRm1_KcPot else j1pot = nRm2_KcPot endif else j1pot = j2pot - 1 j4pot = j3pot + 1 endif c ! Zion-indices imd = 1 do while ( k2pot .gt. 1 .and. zlg .lt. AZ_pot(k2pot) ) k3pot = k2pot k2pot = max( 1 , k2pot - imd ) imd = imd + imd enddo do while ( k3pot .lt. nZ_KcPot .and. zlg .gt. AZ_pot(k3pot) ) k2pot = k3pot k3pot = min( nZ_KcPot , k3pot + imd ) imd = imd + imd enddo do while ( k3pot - k2pot .gt. 1 ) imd = ( k2pot + k3pot ) / 2 if ( zlg .ge. AZ_pot(imd) ) then k2pot = imd else k3pot = imd endif enddo c c If we should use bi-quadratic interpolation (rather than cubic): c if ( ider .ge. 0 ) then c dtk = 0.0 drk = 0.0 c need_z = 1 c ! no Zion-interp? if ( i1pot .eq. i1pot_p .and. j1pot .eq. j1pot_p .and. $ i4pot .le. i4pot_p .and. j4pot .le. j4pot_p .and. $ abs( zlg - zlg_pot_p ) .lt. small_1m6 ) then c c-debug[ c-debug; if ( ioudeb .gt. 5 ) write(6, c-debug; $ '(/8x,"logRHO",4i3,f10.6," :",f10.6, c-debug; $ " logT",4i3,f9.6," :",f9.6, c-debug; $ " logZion",f11.7," = logZion_p",f11.7)') c-debug; $ j1pot, j2pot, j3pot, j4pot, c-debug; $ AR_pot(j1pot), AR_pot(j4pot), c-debug; $ i1pot, i2pot, i3pot, i4pot, c-debug; $ AT_pot(i1pot), AT_pot(i4pot), c-debug; $ zlg, zlg_pot_p c-debug] need_z = 0 c else if ( abs( AZ_pot(k2pot) - zlg ) .lt. small_1m6 ) then c c-debug[ c-debug; if ( ioudeb .gt. 5 ) write(6, c-debug; $ '(/8x,"logRHO",4i3,f10.6," :",f10.6, c-debug; $ " logT",4i3,f9.6," :",f9.6, c-debug; $ " logZion @ k2pot=",i3,f10.6)') c-debug; $ j1pot, j2pot, j3pot, j4pot, c-debug; $ AR_pot(j1pot), AR_pot(j4pot), c-debug; $ i1pot, i2pot, i3pot, i4pot, c-debug; $ AT_pot(i1pot), AT_pot(i4pot), c-debug; $ k2pot, AZ_pot(k2pot) c-debug] zlg_pot_p = AZ_pot(k2pot) c do it = i1pot, i4pot kt = it - i1pot do jr = j1pot, j4pot kr = jr - j1pot zkpot(kr,kt) = flkc_pot(it,jr,k2pot) enddo enddo c else if ( abs( AZ_pot(k3pot) - zlg ) .lt. small_1m6 ) then c c-debug[ c-debug; if ( ioudeb .gt. 5 ) write(6, c-debug; $ '(/8x,"logRHO",4i3,f10.6," :",f10.6, c-debug; $ " logT",4i3,f9.6," :",f9.6, c-debug; $ " logZion @ k3pot=",i3,f10.6)') c-debug; $ j1pot, j2pot, j3pot, j4pot, c-debug; $ AR_pot(j1pot), AR_pot(j4pot), c-debug; $ i1pot, i2pot, i3pot, i4pot, c-debug; $ AT_pot(i1pot), AT_pot(i4pot), c-debug; $ k3pot, AZ_pot(k3pot) c-debug] zlg_pot_p = AZ_pot(k3pot) c do it = i1pot, i4pot kt = it - i1pot do jr = j1pot, j4pot kr = jr - j1pot zkpot(kr,kt) = flkc_pot(it,jr,k3pot) enddo enddo c ! else: Zion-interpolation is needed: else c zlg_pot_p = zlg c k1pot = max( 1 , k2pot - 1 ) k4pot = min( nZ_KcPot , k3pot + 1 ) c imd = k4pot - k1pot k2use = k1pot + 1 k3use = min( nZ_KcPot , k1pot + 2 ) c-debug[ c-debug; if ( ioudeb .gt. 6 ) write(6, c-debug; $ '(8x,"logRHO",4i3,f10.6," :",f10.6, c-debug; $ " logT",4i3,f9.6," :",f9.6, c-debug; $ " logZion",4i3," -->(nmore=",i1,")",4i3,4f10.6)') c-debug; $ j1pot, j2pot, j3pot, j4pot, c-debug; $ AR_pot(j1pot), AR_pot(j4pot), c-debug; $ i1pot, i2pot, i3pot, i4pot, c-debug; $ AT_pot(i1pot), AT_pot(i4pot), c-debug; $ k1pot, k2pot, k3pot, k4pot, c-debug; $ imd, k1pot, k2use, k3use, k4pot, c-debug; $ ( AZ_pot(i), i = k1pot, k4pot ) c-debug; if ( ioudeb .gt. 8 ) write(6,'("")') c-debug] c call quadNsto( 1, imd, zlg, AZ_pot(k1pot), AZ_pot(k2use), $ AZ_pot(k3use), AZ_pot(k4pot) ) do it = i1pot, i4pot kt = it - i1pot do jr = j1pot, j4pot zkpot(jr-j1pot,kt) = $ quadNget( 1, imd, flkc_pot(it,jr,k1pot), $ flkc_pot(it,jr,k2use), $ flkc_pot(it,jr,k3use), $ flkc_pot(it,jr,k4pot) ) c-debug[ c-debug; if ( ioudeb .gt. 8 ) write(6, c-debug; $ '(12x,"zkpot(",i1,",",i1,") =", c-debug; $ f11.6," <--",4f11.6)') c-debug; $ jr - j1pot, kt, zkpot(jr-j1pot,kt), c-debug; $ ( flkc_pot(it,jr,i), i = k1pot, k4pot ) c-debug] enddo enddo c endif c ! finished Zion-interpolation; save cache if ( need_z .ne. 0 ) then i1pot_p = i1pot i4pot_p = i4pot j1pot_p = j1pot j4pot_p = j4pot endif c ! do RHO-interpolation: ihi = i4pot - i1pot c c-debug[ c-debug; if ( ioudeb .gt. 7 ) write(6,'("")') c-debug] j2use = j1pot + 1 j3use = min( j1pot + 2 , j4pot ) imd = j4pot - j1pot c ! if no derivatives: if ( ider .eq. 0 ) then c call quadNsto( 1, imd, flro, AR_pot(j1pot), AR_pot(j2use), $ AR_pot(j3use), AR_pot(j4pot) ) c do kt = 0, ihi h(kt) = quadNget( 1, imd, zkpot(0,kt), zkpot(1,kt), $ zkpot(2,kt), zkpot(3,kt) ) c-debug[ c-debug; if ( ioudeb .gt. 7 ) write(6, c-debug; $ '(10x,"h(",i1,") =",f11.6," <--",4f11.6)') c-debug; $ kt, h(kt), ( zkpot(i,kt), i = 0, imd ) c-debug] enddo c ! else: with derivatives: else c call qderNsto( 1, imd, flro, AR_pot(j1pot), AR_pot(j2use), $ AR_pot(j3use), AR_pot(j4pot) ) c do kt = 0, ihi call qderNget( 1, imd, zkpot(0,kt), zkpot(1,kt), $ zkpot(2,kt), zkpot(3,kt), h(kt), dh(kt) ) c-debug[ c-debug; if ( ioudeb .gt. 7 ) write(6, c-debug; $ '(10x,"h,dh(",i1,") =",2f11.6," <--",4f11.6)') c-debug; $ kt, h(kt), dh(kt), ( zkpot(i,kt), i = 0, imd ) c-debug] enddo c endif c ! finished RHO-interpolation; do T-interpolation: i2use = i1pot + 1 i3use = min( i1pot + 2 , i4pot ) imd = i4pot - i1pot c ! if no derivatives: if ( ider .eq. 0 ) then c call quadNsto( 1, imd, flt, AT_pot(i1pot), AT_pot(i2use), $ AT_pot(i3use), AT_pot(i4pot) ) c ck = quadNget( 1, imd, h(0), h(1), h(2), h(3) ) c-debug[ c-debug; if ( ioudeb .gt. 6 ) then c-debug; write(6,'(/8x,"ck =",f11.6," <--",4f11.6)') c-debug; $ ck, ( h(i), i = 0, imd ) c-debug; write(6,'("")') c-debug; endif c-debug] c ! else: with derivatives: else c call qderNsto( 1, imd, flt, AT_pot(i1pot), AT_pot(i2use), $ AT_pot(i3use), AT_pot(i4pot) ) c call qderNget( 1, imd, h(0), h(1), h(2), h(3), ck, dtk ) c drk = quadNget( 1, imd, dh(0), dh(1), dh(2), dh(3) ) c-debug[ c-debug; if ( ioudeb .gt. 6 ) then c-debug; write(6,'(/8x,"ck,dtk =",2f11.6," <--",4f11.6)') c-debug; $ ck, dtk, ( h(i), i = 0, imd ) c-debug; write(6,'(8x," drk =",f22.6," <--",4f11.6)') c-debug; $ drk, ( dh(i), i = 0, imd ) c-debug; write(6,'("")') c-debug; endif c-debug] c endif c c Alternatively: use cubic formulae from Potekhin-website program condint.f : c else c c Cubic interpolation in RLG: c Z0: call sngl_cinterp3( AR_pot(j1pot), AR_pot(j2pot), $ AR_pot(j3pot), AR_pot(j4pot), flro, j2pot, nR_KcPot, $ flkc_pot(i1pot,j1pot,k2pot), flkc_pot(i1pot,j2pot,k2pot), $ flkc_pot(i1pot,j3pot,k2pot), flkc_pot(i1pot,j4pot,k2pot), $ CKTMZ0, DRKTMZ0, DR2KTMZ0, XR ) call sngl_cinterp3( AR_pot(j1pot), AR_pot(j2pot), $ AR_pot(j3pot), AR_pot(j4pot), flro, j2pot, nR_KcPot, $ flkc_pot(i2pot,j1pot,k2pot), flkc_pot(i2pot,j2pot,k2pot), $ flkc_pot(i2pot,j3pot,k2pot), flkc_pot(i2pot,j4pot,k2pot), $ CKT0Z0, DRKT0Z0, DR2KT0Z0, XR ) call sngl_cinterp3( AR_pot(j1pot), AR_pot(j2pot), $ AR_pot(j3pot), AR_pot(j4pot), flro, j2pot, nR_KcPot, $ flkc_pot(i3pot,j1pot,k2pot), flkc_pot(i3pot,j2pot,k2pot), $ flkc_pot(i3pot,j3pot,k2pot), flkc_pot(i3pot,j4pot,k2pot), $ CKT1Z0, DRKT1Z0, DR2KT1Z0, XR ) call sngl_cinterp3( AR_pot(j1pot), AR_pot(j2pot), $ AR_pot(j3pot), AR_pot(j4pot), flro, j2pot, nR_KcPot, $ flkc_pot(i4pot,j1pot,k2pot), flkc_pot(i4pot,j2pot,k2pot), $ flkc_pot(i4pot,j3pot,k2pot), flkc_pot(i4pot,j4pot,k2pot), $ CKTPZ0, DRKTPZ0, DR2KTPZ0, XR ) c Z1: call sngl_cinterp3( AR_pot(j1pot), AR_pot(j2pot), $ AR_pot(j3pot), AR_pot(j4pot), flro, j2pot, nR_KcPot, $ flkc_pot(i1pot,j1pot,k3pot), flkc_pot(i1pot,j2pot,k3pot), $ flkc_pot(i1pot,j3pot,k3pot), flkc_pot(i1pot,j4pot,k3pot), $ CKTMZ1, DRKTMZ1, DR2KTMZ1, XR ) call sngl_cinterp3( AR_pot(j1pot), AR_pot(j2pot), $ AR_pot(j3pot), AR_pot(j4pot), flro, j2pot, nR_KcPot, $ flkc_pot(i2pot,j1pot,k3pot), flkc_pot(i2pot,j2pot,k3pot), $ flkc_pot(i2pot,j3pot,k3pot), flkc_pot(i2pot,j4pot,k3pot), $ CKT0Z1, DRKT0Z1, DR2KT0Z1, XR ) call sngl_cinterp3( AR_pot(j1pot), AR_pot(j2pot), $ AR_pot(j3pot), AR_pot(j4pot), flro, j2pot, nR_KcPot, $ flkc_pot(i3pot,j1pot,k3pot), flkc_pot(i3pot,j2pot,k3pot), $ flkc_pot(i3pot,j3pot,k3pot), flkc_pot(i3pot,j4pot,k3pot), $ CKT1Z1, DRKT1Z1, DR2KT1Z1, XR ) call sngl_cinterp3( AR_pot(j1pot), AR_pot(j2pot), $ AR_pot(j3pot), AR_pot(j4pot), flro, j2pot, nR_KcPot, $ flkc_pot(i4pot,j1pot,k3pot), flkc_pot(i4pot,j2pot,k3pot), $ flkc_pot(i4pot,j3pot,k3pot), flkc_pot(i4pot,j4pot,k3pot), $ CKTPZ1, DRKTPZ1, DR2KTPZ1, XR ) c Linear interpolation in ZLG: XZ1 = (zlg-AZ_pot(k2pot))/(AZ_pot(k3pot)-AZ_pot(k2pot)) XZ0 = 1.-XZ1 CKTM = XZ0*CKTMZ0+XZ1*CKTMZ1 DRKTM = XZ0*DRKTMZ0+XZ1*DRKTMZ1 DR2KTM = XZ0*DR2KTMZ0+XZ1*DR2KTMZ1 CKT0 = XZ0*CKT0Z0+XZ1*CKT0Z1 DRKT0 = XZ0*DRKT0Z0+XZ1*DRKT0Z1 DR2KT0 = XZ0*DR2KT0Z0+XZ1*DR2KT0Z1 CKT1 = XZ0*CKT1Z0+XZ1*CKT1Z1 DRKT1 = XZ0*DRKT1Z0+XZ1*DRKT1Z1 DR2KT1 = XZ0*DR2KT1Z0+XZ1*DR2KT1Z1 CKTP = XZ0*CKTPZ0+XZ1*CKTPZ1 DRKTP = XZ0*DRKTPZ0+XZ1*DRKTPZ1 DR2KTP = XZ0*DR2KTPZ0+XZ1*DR2KTPZ1 c Cubic interpolation in TLG: c c ! input: values of lg k where k is thermal conductivity call sngl_cinterp3( AT_pot(i1pot), AT_pot(i2pot), $ AT_pot(i3pot), AT_pot(i4pot), flt, i2pot, nT_KcPot, $ CKTM, CKT0, CKT1, CKTP, $ CK, DTK, DT2K, XT ) c ! lg k, d lg k / d lg T, d2 lg k / d2 lg T c c ! input: values of d lg k / d lg rho call sngl_cinterp3( AT_pot(i1pot), AT_pot(i2pot), $ AT_pot(i3pot), AT_pot(i4pot), flt, i2pot, nT_KcPot, $ DRKTM, DRKT0, DRKT1, DRKTP, $ DRK, DRTK, DRT2K, XT ) c ! d lg k / d lg rho, d2 lgk/(d lgT d lg rho), ... c endif c ! convert thermal conductivity to conductive opacity: c flkc = sigconlog_pot + 3.0 * flt - flro - ck c if ( ider .ne. 0 ) then flkct = 3.0 - dtk flkcro = -1.0 - drk endif c-debug[ c-debug; if ( ioudeb .gt. 5 ) write(6, c-debug; $ '(" --END kap_cond_pot( ... RETURN flkc",f11.6, c-debug; $ " flkct",f11.6," flkcro",f11.6," fkcedge",f11.6, c-debug; $ " fkcok",f11.7," )"/)') c-debug; $ flkc, flkct, flkcro, fkcedge, fkcok c-debug] c return end c c****************************************************************************** c subroutine opal_k_only(z,xh,exC,exO,slt,slr,fcn,fcon,fcnone,fu) c =============================================================== c c..... The purpose of this subroutine is to interpolate log kappa c (and obtain smooth derivatives) c in hydrogen (if X>0) and in C/O abundance and T6, R, i.e. (X,Xc,Xo,T6,R) c Interpolation in CNO abundances is allowed by user-specified fractions. c c z = Z = metallicity (this should always be the same) c xh = X = hydrogen mass fraction c exC = Xc = carbon mass fraction (excess over what is in Z) c exO = Xo = oxygen mass fraction (excess over what is in Z) c slt = logT6 = Log10{temperature in millions of degrees kelvin} c slr = logR = Log10{density(g/cm**3)/T6**3} c fcn = fraction to be applied of opacity shift from standard composition c to a composition with most or all of C converted to N c fcon = fraction to be applied of opacity shift from standard composition c to a composition with most or all of C and O converted to N c fcnone = fraction to be applied of the opacity shift from the standard c composition to a composition with all C,N,O converted to Ne c fu = fraction to be applied of opacity shift from standard composition c to the composition of the user-specified opacity file c c..... to use OPAL_F_CNOU, insert common/e_opal_z/ in the calling routine. c This common contains interpolated values for log kappa and its c first derivatives, and "out-of-table" indicators fedge,ftredge,fzedge. c c parameter ( small_1m6=1.e-6, small_m1m6=-1.e-6, small_9m7=9.e-7 ) c parameter ( small_m1m8=-1.e-8, one_p_small_1m6=1.0+small_1m6 ) c parameter ( small_1m8=1.e-8 ) c c PARAMETERS to specify opacity storage matrices: see BLOCK DATA OPAL_OPAC_DATA c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c c PARAMETERS nrdel, ntdel give matrix position differences: see OPAL_OPAC_DATA c parameter ( nrdel=nrb-1, ntdel=ntb-1 ) c c PARAMETERS: offsets for Z, for X, min low-T X offset: see OPAL_OPAC_DATA c parameter ( zdel=0.001, xdel=0.03, xdelmin=0.001 ) c c PARAMETERS: for use in call to READZEXCO, if it is called from here in OPAL: c k_hz = 1 = khighz value for READZEXCO ("use 'GN93hz' in Z-interpolation, c but no CNO-interpolation") c ofe_brack = 0.0 = [O/Fe] value for READZEXCO c parameter ( k_hz=1, ofe_brack=0.0 ) c c PARAMETER badlogkval = 1.e+35 is stored to indicate missing Log(kappa) values c parameter ( badlogkval=1.e+35, badlogklim=20. ) c c PARAMETERS used when at high-T or -RHO boundary of opacity storage matrices c parameter ( ntm_m3=ntm-3, nt_m2=nt-2, nr_m2=nr-2 ) c c PARAMETERS used to specify logT6 and logR tabulation values c parameter ( k81=nt-3, k80=k81-1, k60=k81-21, ks59=k60-1+ntdel ) parameter ( flt81m6=8.1-6., flt60m6=6.0-6., flt370m6=3.70-6. ) parameter ( flrmid = -3.0 ) c c PARAMETERS defining the storage for the additional X-values from 'GN93hz': c parameter ( mx_hi=2*mx, mo_m1=mo-1, mx_hi_nz=mx_hi*nz ) c c COMMON /xhi_opal_z/ : auxiliary matrices for additional 'GN93hz' X-values: c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c c COMMON /a_opal_z/ : matrices for opacity storage: see OPAL_OPAC_DATA c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c c COMMON /a_co_opal_z/ : matrices for opacity storage: see OPAL_OPAC_DATA c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c c COMMON /b_opal_z/ : high and low T-limits, Z-values: see OPAL_OPAC_DATA c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c c COMMON /bb_opal_z/ : some indices & abundances for T6,R and C,O interpolation c common/bb_opal_z/ xodp,xcdp,xxco,cxx,oxx, $ l1,l2,l3,l4,k1,k2,k3,k4,ip,iq(4),kzf,kzg,kzh,kzf2 save /bb_opal_z/ c c COMMON /recoin_opal_z/ : see OPAL_OPAC_DATA c common/recoin_opal_z/ itimeco,mxzero,mx03,kope,igznotgx save /recoin_opal_z/ c c COMMON /c_opal_ctrl_smooth/ : flags to control the smoothing: c common/c_opal_ctrl_smooth/ init_smo, low_CO_smo, interp_CO_smo save /c_opal_ctrl_smooth/ c c COMMON /c_level_err_opal_z/ error-checking level, set by SET_ERR_CHECK c c /c_level_err_opal_z/: --> data{level_err} common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c c COMMON /E_OPAL_Z/ : Return variables : see also instructions above c c.... OPACT - opacity obtained from a quadratic interpolation at fixed c log T6 at three values of log R; followed by quadratic interpolation c along log T6. Results smoothed by mixing overlapping quadratics. c.... DOPACT - is Dlog(k)/Dlog(T6) at constant R smoothed by mixing quadratics. c.... DOPACR - is Dlog(k)/Dlog(R) at constant T smoothed by mixing quadratics. c.... DOPACTD - is Dlog(k)/Dlog(T6) at constant rho. c.... FEDGE = 1.0 inside T6,R,Z boundaries, goes to zero when too far outside c for extrapolation (in which case opacity is not calculated). c.... FTREDGE = 1.0 inside T,R boundaries, goes to zero when too far outside. c.... FZEDGE = 1.0 inside Z limits, goes to zero when too far outside. c common /e_opal_z/ opvals(4),fedge,ftredge,fzedge save /e_opal_z/ equivalence (opvals(1),opact), (opvals(2),dopact), $ (opvals(3),dopacr), (opvals(4),dopactd) c c Stored values of input parameters for this routine, in case it was called c from another interface c common /x_opal_z/ z_opal, x_opal, xc_opal, xo_opal, slt_opal, $ slr_opal, fcn_opal, fcon_opal, fcnone_opal, fu_opal save /x_opal_z/ c common /tredges_opal_z/ ftlo_edge, fthi_edge, frlo_edge, $ frhi_edge, ftcut_edge, frcut_edge, ftr_cut_edge save /tredges_opal_z/ c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c c PARAMETERS to specify lowest logR-limit for conductive opacities c parameter ( rcondswlo = -6.0, rcondswdel = 0.5 ) c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c c-debug[ c-debug; common/outdeb/ ioudeb,oudebl,koudeb c-debug; dimension opv_prev(4) c-debug] c-test-xdel[ ! test various xdel values in opacity X-interpolation c-test-xdel; c-test-xdel; parameter ( n_xdel_test=9, n_xdel_test_m1=n_xdel_test-1 ) c-test-xdel; common/otherxdel/ opdxi(n_xdel_test),xdel_test(n_xdel_test) c-test-xdel; equivalence (opdxi(1),opdx001), (opdxi(2),opdx002), c-test-xdel; $ (opdxi(3),opdx0035), (opdxi(4),opdx005), c-test-xdel; $ (opdxi(5),opdx0075), (opdxi(6),opdx01), c-test-xdel; $ (opdxi(7),opdx02), (opdxi(n_xdel_test_m1),opdx03), c-test-xdel; $ (opdxi(n_xdel_test),opdxuse) c-test-xdel; data xdel_test/.001,.002,.0035,.005,.0075,.01,.02,.03,.03/ c-test-xdel] c___ dimension iqx(4),ntaxat(0:nrm) c=== ! we have not yet gotten a good opacity opact = badlogkval fedge = 0.0 ftredge = 1.0 fzedge = 1.0 c ftlo_edge = 1.0 fthi_edge = 1.0 frlo_edge = 1.0 frhi_edge = 1.0 ftcut_edge = 1.0 frcut_edge = 1.0 ftr_cut_edge = 1.0 c z_opal = z x_opal = xh xc_opal = exC xo_opal = exO slt_opal = slt slr_opal = slr c c..... set-up C/O axis points: making exC & exO arguments of OPAL is simpler c than resetting xxc & xxo after changing them, and also avoids an error c if constants are used for these values in the calling program. c xxc = exC xxo = exO xxco = xxc + xxo if ( z + xh + xxco .gt. one_p_small_1m6 .or. $ z .lt. small_m1m8 .or. $ min(xh,xxc+z,xxo+z,xxco+z) .le. small_m1m6 ) then write(6,4397) z,xh,xxc,xxo 4397 format(' '/' OPAL Error: bad Z',1p,e13.6,' X',e13.6, $ ' C',e13.6,' O',e13.6) stop ' STOP -- OPAL Error: bad composition value(s). ' endif z_opal = max( z_opal , 0.0 ) c c..... set X indices: if xh = a table X-value, then only use that X-table: c if ( abs( xh - xa(1) ) .lt. small_9m7 ) then mf = 1 mg = 1 mh = 1 mf2 = 1 x_opal = xa(1) else if ( mx .eq. 1 ) then write(6,4396) xh,xa(1) 4396 format(' '/' OPAL: mx=1, but X=',f10.7, $ ' differs from table value',f10.7) stop ' STOP -- OPAL Error: mx=1, but X differs from X_stored ' c ! else: find X-indices: results in ihi=5 (for xh > 0.35) or c ! ihi=4 (for xh > 0.1) or ihi=3 (for xh < or = 0.1): else ilo = 2 ihi = mx do while( ihi-ilo .gt. 1 ) imd = (ihi+ilo)/2 if ( xh .le. xa(imd) ) then ihi = imd else ilo = imd endif enddo c ! if xh = a table X-value if ( abs( xh - xa(ilo) ) .lt. small_9m7 ) then mf = ilo mg = ilo mh = ilo mf2 = ilo x_opal = xa(ilo) else if ( abs( xh - xa(ihi) ) .lt. small_9m7 ) then mf = ihi mg = ihi mh = ihi mf2 = ihi x_opal = xa(ihi) c ! else: will need to interpolate else mf = ilo - 1 mg = ilo mh = ihi if ( xh .le. xa(2) ) then mf2 = mh else mf2 = min( ihi + 1 , mx ) endif endif endif c c..... If necessary, read data files and do initializations, using READZEXCO c if ( itime .ne. 12345678 ) $ call readzexco(nz,-1.,z,-1.,k_hz,-1,ofe_brack) c c If X > 0.03 and C+O is not too large, then the more-numerous X-values from c 'GN93hz' can help, if use-flag is set: set f_xhi for later use. Only used c if [ ( kdo_xhi = 1 and X > .7 ) or ( kdo_xhi = 2 and X > .03 ) ] and we are c not sitting on an X-grid-position and C+O < 0.3; these FULL opacity shifts c are only used if C+O < 0.2, a fraction of them is used for 0.2 < C+O < 0.3: c if ( kdo_xhi .le. 0 .or. mf2 .lt. 4 .or. mf .eq. mf2 .or. $ ( kdo_xhi .eq. 1 .and. xh .le. xa(mx) ) .or. $ exC + exO .ge. 0.3 ) then f_xhi = 0.0 else if ( exC + exO .le. 0.2 ) then f_xhi = 1.0 else if ( exC + exO .lt. 0.25 ) then f_xhi = 1. - 200. * max( exC + exO - 0.2 , 0.0 )**2 else f_xhi = 200. * ( 0.3 - ( exC + exO ) )**2 endif c c Check whether CNO- and/or user-interpolation will be needed c if ( z .lt. small_1m8 ) then c need_cno = 0 need_user = 0 c else c if ( kdo_cno .gt. 0 .and. max( abs(fcn) , $ abs(fcon) , abs(fcnone) ) .gt. small_1m8 ) then need_cno = 1 else need_cno = 0 endif c if ( kdo_user .gt. 0 .and. abs(fu) .gt. small_1m8 ) then need_user = 1 else need_user = 0 endif c endif c fcn_opal = fcn * need_cno fcon_opal = fcon * need_cno fcnone_opal = fcnone * need_cno fu_opal = fu * need_user c c..... set Z indices c ! is Z out of range? if ( z .le. zlo_ex .or. z .ge. zhi_ex ) then fzedge = 0.0 if ( level_err .ge. 2 ) then write(6,10) z, zlo_ex, zhi_ex 10 format(' '/' OPAL: Z=',f11.8, $ ' is outside max extrap range (',f11.8,',',f10.8,')') stop ' STOP -- OPAL Error: bad Z value. ' endif return endif c ! check Z-extrapolation if ( z .lt. zlow ) then fzedge = max( 0.0 , ( z - zlo_ex ) / ( zlow - zlo_ex ) ) else if ( z .gt. zhigh ) then fzedge = max( 0.0 , ( zhi_ex - z ) / ( zhi_ex - zhigh ) ) else fzedge = 1. endif c ! this shouldn't happen, but just in case... if ( fzedge .le. 0. ) then if ( level_err .ge. 2 ) then write(6,10) z, zlo_ex, zhi_ex stop ' STOP -- OPAL Error: bad Z value. ' endif return endif c ! check for Z-table value: if ( numz .eq. 1 ) then ihi = 1 else ihi = 0 if ( numz .le. 3 ) then do i = 1, numz if ( abs( zsto(i) - z ) .le. zacc(i) ) ihi = i enddo else if ( abs( zsto(kzg) - z ) .le. zacc(kzg) ) then ihi = kzg else if ( abs( zsto(1) - z ) .le. zacc(1) ) then ihi = 1 endif endif c ! get Z-table indices: if ( ihi .gt. 0 ) then c kzf = ihi kzg = ihi kzh = ihi kzf2 = ihi z_opal = zsto(ihi) c else if ( numz .le. 3 ) then c kzf = 1 kzg = 2 kzh = numz kzf2 = numz c else c ihi = max( 3 , min( numz , kzh ) ) ilo = ihi - 1 imd = 1 do while ( ilo .gt. 2 .and. z .lt. zsto(ilo) ) ihi = ilo ilo = max( ilo - imd , 2 ) imd = imd + imd enddo do while ( ihi .lt. numz .and. z .gt. zsto(ihi) ) ilo = ihi ihi = min( numz , ihi + imd ) imd = imd + imd enddo c do while( ihi - ilo .gt. 1 ) imd = (ihi+ilo)/2 if ( z .le. zsto(imd) ) then ihi = imd else ilo = imd endif enddo c if ( abs( zsto(ihi) - z ) .le. zacc(ihi) ) then kzf = ihi kzg = ihi kzh = ihi kzf2 = ihi else if ( abs( zsto(ilo) - z ) .le. zacc(ilo) ) then kzf = ilo kzg = ilo kzh = ilo kzf2 = ilo else kzf = ilo - 1 kzg = ilo kzh = ihi if ( z .le. zsto(2) ) then kzf2 = kzh else kzf2 = min( ihi + 1 , numz ) endif endif c endif c ! note that xxh is not used (except perhaps in calling routine) xxh = xh c ! check T-R edges: frlo_edge = min( slr - slrlo , 0.0 ) * dlrlo_inv + 1.0 frhi_edge = min( slrhi - slr , 0.0 ) * dlrhi_inv + 1.0 ftlo_edge = min( slt - sltlo , 0.0 ) * dltlo_inv + 1.0 fthi_edge = min( slthi - slt , 0.0 ) * dlthi_inv + 1.0 c ftredge = max( 0.0 , $ min( frlo_edge , frhi_edge , ftlo_edge , fthi_edge ) ) c fedge = max( 0.0 , ftredge * fzedge ) c flrho = slr + slt * 3.0 c ! if far outside, if ( frlo_edge .le. 0.0 .or. ftlo_edge .le. 0.0 ) then c ! return at low T,R if ( kdo_alex .le. 0 .and. level_err .ge. 2 ) then write(6,20) slt+6., slr, flrho 20 format(' '/' OPAL: logT=',f9.6,', logR=',f11.6, $ ' [logRHO=',f11.6,']: beyond matrix edge') stop ' STOP -- OPAL Error: bad T or R value. ' endif return c ! but return at high T,R only if NOT in else if ( ftredge .le. 0.0 ) then c ! region where might be relevant vs. if ( level_err .lt. 2 ) then c ! K_cond if ( ( fthi_edge .le. 0.0 .and. slr .le. rcondswlo ) .or. $ ( frhi_edge .le. 0.0 .and. $ ( slt .lt. sltswhi_alex .or. $ slr .le. rcondswlo ) .and. $ ( kdo_alex .le. 0 .or. slt .ge. sltswhi_alex .or. $ flrho .ge. flrhoswhi_alex ) ) ) return c ! level_err > 1 else if ( ( fthi_edge .le. 0.0 .and. ( kdo_cond .le. 0 .or. $ slr .le. rcondswlo ) ) .or. ( frhi_edge .le. 0.0 .and. $ ( kdo_cond .le. 0 .or. slt .lt. sltswhi_alex .or. $ slr .le. rcondswlo ) .and. $ ( kdo_alex .le. 0 .or. slt .ge. sltswhi_alex .or. $ flrho .ge. flrhoswhi_alex ) ) ) then c ! level_err > 1: stop at edge write(6,20) slt+6., slr, flrho stop ' STOP -- OPAL Error: bad T or R value. ' c endif c endif c c..... convert xh to logarithmic shifted by xdel (C and O are converted later) c xxx = log10(xdel+xh) c c..... Determine log R and log T6 grid points to use in the interpolation. c Try to avoid overestimating the extent of extrapolation into any cutout. c if ( slt .gt. flt81m6 ) then k2sat = ntdel + min( nt , k81 + max( 0 , $ int( ( slt - flt81m6 ) * dfs(nt) - small_1m6 ) ) ) else if ( slt .gt. flt60m6 ) then k2sat = ntdel + min( k80 , k60 + max( 0 , $ int( ( slt - flt60m6 ) * dfs(k81) - small_1m6 ) ) ) else if ( k60 .le. 0 ) then k2sat = ntdel + k60 else k2sat = min( ks59 , max( ntdel , $ int( ( slt - flt370m6 ) * dfs(k60) + small_1m6 ) ) ) endif c if ( slr .gt. flrmid ) then l2sat = nrm - max( 0 , min( nr , $ int( ( alr(nr) - slr ) * dfsr(nr) + one_p_small_1m6 ) ) ) else l2sat = nrdel + max( 0 , min( nr , $ int( ( slr - alr(1) ) * dfsr(nr) + one_p_small_1m6 ) ) ) endif c k1x = -99 l1x = -99 k3sat = k2sat+1 k2 = max(k2sat-ntdel,1) k3 = min(k3sat-ntdel,nt) l3sat = l2sat+1 l4sat = min(l3sat,nre)+1 l2 = max(l2sat-nrdel,1) l3 = min(l3sat-nrdel,nr) c ! if too far outside, return at low T,R if ( min(k3,l3) .le. 0 ) then c if ( l3 .le. 0 ) frlo_edge = 0. if ( k3 .le. 0 ) ftlo_edge = 0. ftredge = 0. fedge = 0. if ( kdo_alex .le. 0 .and. level_err .ge. 2 ) then write(6,20) slt+6., slr, flrho stop ' STOP -- OPAL Error: bad T or R value. ' endif return c ! but extrap at high T,R else if ( k2 .gt. nt .or. l2 .gt. nr ) then c if ( l2 .gt. nr ) frhi_edge = 0. if ( k2 .gt. nt ) fthi_edge = 0. ftredge = 0. fedge = 0. c if ( level_err .lt. 2 ) then c if ( ( fthi_edge .le. 0.0 .and. slr .le. rcondswlo ) .or. $ ( frhi_edge .le. 0.0 .and. $ ( slt .lt. sltswhi_alex .or. $ slr .le. rcondswlo ) .and. $ ( kdo_alex .le. 0 .or. slt .ge. sltswhi_alex .or. $ flrho .ge. flrhoswhi_alex ) ) ) return c else if ( ( fthi_edge .le. 0.0 .and. ( kdo_cond .le. 0 .or. $ slr .le. rcondswlo ) ) .or. ( frhi_edge .le. 0.0 .and. $ ( kdo_cond .le. 0 .or. slt .lt. sltswhi_alex .or. $ slr .le. rcondswlo ) .and. $ ( kdo_alex .le. 0 .or. slt .ge. sltswhi_alex .or. $ flrho .ge. flrhoswhi_alex ) ) ) then c ! level_err > 1: stop at edge write(6,20) slt+6., slr, flrho stop ' STOP -- OPAL Error: bad T or R value. ' c endif c endif c ! initial assumption: 3x3 grid in T,R ipx = 2 do i = 1, 4 iqx(i) = 2 enddo c ! Check upper-right ragged cut-out: if ( l2sat .gt. 0 .and. ftredge .gt. 0.0 ) then c . . . c 1. . . too far out to c . . * extrapolate if ( k2sat .gt. nta(l2sat) ) then c ftr_cut_edge = 0. ftredge = 0. fedge = 0. c . . . extrapolate c 2. . . . T and R out c . . * from a corner else if ( k2sat .eq. nta(l2sat) .and. $ k2sat .gt. nta(l3sat) ) then c ftcut_edge = min( 1.0 , $ ( alt(k2) - slt ) * dfs(k3) + 1.000001 ) frcut_edge = min( 1.0 , $ ( alr(l2) - slr ) * dfsr(l3) + 1.000001 ) ftr_cut_edge = min( ftcut_edge , frcut_edge ) frhi_edge = min( frhi_edge , ftr_cut_edge ) ftredge = max( 0.0 , min( ftredge , ftr_cut_edge ) ) c-dont; k1x = k2-2 c-dont; l1x = l2-2 c . . . . . . extrapolate (in c 3. . .* . . . either T or R) c . . . .* in a corner else if ( k2sat .lt. nta(l2sat) .and. $ k2sat .eq. nta(l3sat) ) then c ftcut_edge = min( 1.0 , $ ( alt(k2) - slt ) * dfs(k3) + 1.000001 ) frcut_edge = min( 1.0 , $ ( alr(l2) - slr ) * dfsr(l3) + 1.000001 ) ftr_cut_edge = max( ftcut_edge , frcut_edge ) ftredge = max( 0.0 , min( ftredge , ftr_cut_edge ) ) c . . . . . . extrapolate R c 4. . . . . .* out from a c . .* . . .* high-R edge else if ( k2sat .lt. nta(l2sat) .and. $ k2sat .gt. nta(l3sat) ) then c if ( l2 .lt. nr ) then frcut_edge = min( 1.0 , $ ( alr(l2) - slr ) * dfsr(l3) + 1.000001 ) ftr_cut_edge = frcut_edge ftredge = max( 0.0 , min( ftredge , ftr_cut_edge ) ) endif c-dont; if ( k3sat .lt. nta(l2sat) .and. k2sat .gt. ntb ) ipx = 3 c-dont; k1x = max(k2-1,1) c-dont; l1x = l2-2 c . . . . . . . interpolate, c 5. . .*. . .*.*. 1-space inside c .*.*. .*.*. high-R,T edges c-dont; else if ( k3sat .le. nta(l3sat) .and. c-dont; $ k3sat .ge. nta(l4sat) ) then c c-dont; if ( k3sat .lt. nta(l3sat) .and. k2sat .gt. ntb ) ipx = 3 c-dont; k1x = max(k2-1,1) c-dont; l1x = max(l2-1,1) c-dont; if ( l2sat .gt. nrb ) then c-dont; do i = 1,3 c-dont; if ( k1x-1+ntdel+i .le. nta(l4sat) ) iqx(i) = 3 c-dont; enddo c-dont; endif c endif c endif c fedge = max( 0.0 , ftredge * fzedge ) c ! hi-T cut-out always extrapolated c ! unless level_err > 1 if ( level_err .ge. 2 .and. ftredge .le. 0. ) then write(6,20) slt+6., slr, flrho stop ' STOP -- OPAL Error: bad T or R value. ' endif c . . . . Outside or c . . . . 1-space c 6. *. . . inside max c * * * high-T edge c-dont; if ( k1x .lt. 0 .and. k3sat .ge. ntm ) then c-dont; k1x = nt_m2 c-dont; l1x = max(l2-1,1) c-dont; if ( l2sat .gt. nrb ) then c-dont; do i = 1,3 c-dont; if ( ntm_m3+i .le. nta(l4sat) ) iqx(i) = 3 c-dont; enddo c-dont; endif c 7. Anywhere except high-T or high-R edges: c-dont; else if ( k1x .lt. 0 ) then c-dont; k1x = max(k2-1,1) c-dont; l1x = max(l2-1,1) c-dont; if ( k2sat .gt. ntb ) ipx = 3 c-dont; if ( l2sat .gt. nrb ) then c-dont; do i = 1,4 c-dont; iqx(i) = 3 c-dont; enddo c-dont; endif c-dont; endif c ! high-T,R cutout has O.K. values k1x = min( nt_m2 , max( k2 - 1 , 1 ) ) l1x = min( nr_m2 , max( l2 - 1 , 1 ) ) if ( k1x .lt. k2 .and. k3 .lt. nt ) ipx = 3 if ( l1x .lt. l2 .and. l3 .lt. nr ) then do i = 1, 4 iqx(i) = 3 enddo endif c ! check low-T,low-R corner for X=0; avoid it if possible ichgr = 1 if ( mf .eq. mxzero .and. k1x+ntdel .lt. ntax0(l1x+nrdel) ) then c ! avoid if ( mf2 .eq. mf+3 ) then mf = mf2-2 mg = mf2-1 mh = mf2 c ! like region 1. too far out else if ( k3sat .lt. ntax0(l3sat) ) then ftredge = 0. fedge = 0. ftlo_edge = 0. if ( level_err .ge. 2 .and. kdo_alex .le. 0 ) then write(6,20) slt+6., slr, flrho stop ' STOP -- OPAL Error: bad T or R value. ' endif return c ! else, will need to revise T,R indices for first m (= mf) else ichgr = 0 endif endif c ! check similarly for X=.03 if ( ( mf .eq. mx03 .or. mg .eq. mx03 ) .and. $ k1x+ntdel .lt. ntax03(l1x+nrdel) ) then c ! avoid if ( mf2 .eq. mf+3 .and. mf .eq. mx03 ) then mf = mf2-2 mg = mf2-1 mh = mf2 c ! like region 1. too far out else if ( k3sat .lt. ntax03(l3sat) ) then ftredge = 0. fedge = 0. ftlo_edge = 0. if ( level_err .ge. 2 .and. kdo_alex .le. 0 ) then write(6,20) slt+6., slr, flrho stop ' STOP -- OPAL Error: bad T or R value. ' endif return c ! if need to revise T,R indices for mf: else if ( mf .eq. mx03 ) then ichgr = 0 endif endif c ! xhemxi: subtract Z to prevent out-of-range C+O values at small X c xhemxi = max( 1. - xh - z , 0. ) if ( kzf2 .gt. kzf ) then zlogd = log10( z + zdel ) else zlogd = 0.0 endif c-debug[ c-debug; ichk = 0 c-debug; oudebl_sto = oudebl c-debug; if ( fedge .le. 0.0 ) oudebl = max( oudebl , badlogklim ) c-debug; if ( ioudeb .gt. 1 ) then c-debug; write(6,'(/" ----- opal_k_only( z=",f10.7,", xh=",f10.7, c-debug; $ ", exC=",f10.7,", exO=",f10.7,", slt=",f10.6, c-debug; $ ", slr=",f10.6,", fcn=",f10.7,", fcon=",f10.7, c-debug; $ ", fcnone=",f10.7,", fu=",f10.7," ) -----"/ c-debug; $ " mf,mg,mh,mf2=",4i2," k1x=",i3," ipx=",i2, c-debug; $ " l1x=",i3," iqx(1:",i1,")=",4i2)') c-debug; $ z,xh,exC,exO,slt,slr,fcn,fcon,fcnone,fu, mf, mg, mh, mf2, c-debug; $ k1x, ipx, l1x, ipx + 1, ( iqx(i), i = 1, ipx + 1 ) c-debug; endif c-debug] c ! ------------------------- loop over X-mixes m do m = mf, mf2 c ! set (or restore) grid-indices, if necessary if ( ichgr .ne. 0 ) then do i = 1,4 iq(i) = iqx(i) enddo ip = ipx k1 = k1x l1 = l1x k2 = k1+1 k3 = min( k1 + 2 , nt ) k4 = min( k1 + 3 , nt ) l2 = l1+1 l3 = min( l1 + 2 , nr ) l4 = min( l1 + 3 , nr ) endif c ! check for low-T,low-R cutout at X=0 or X=.03: ichgr = 0 if ( m .eq. mxzero .and. $ k1x+ntdel .lt. ntax0(l1x+nrdel) ) then ichgr = 1 do i = max(l2sat-2,0),min(l4sat+2,nrm) ntaxat(i) = ntax0(i) enddo else if ( m .eq. mx03 .and. $ k1x+ntdel .lt. ntax03(l1x+nrdel) ) then ichgr = 1 do i = max(l2sat-2,0),min(l4sat+2,nrm) ntaxat(i) = ntax03(i) enddo endif c ! change grid indices, if in low-{R,T} cutout if ( ichgr .ne. 0 ) then k3 = min(k3sat-ntdel,nt) l3 = min(l3sat-nrdel,nr) l1sat = max(l2sat-1,0) ip = 2 do i = 1,4 iq(i) = 2 enddo c ! 2. extrapolate T,R from corner if ( k3sat .eq. ntaxat(l3sat) .and. $ k3sat .lt. ntaxat(l2sat) ) then if ( l4sat .ge. nre ) then ftlo_edge = 0. ftredge = 0. else ft = min( 1.0 , $ ( slt - alt(k3) ) * dfs(k3) + 1.000001 ) fr = min( 1.0 , $ ( slr - alr(l3) ) * dfsr(l3) + 1.000001 ) ftlo_edge = min( ftlo_edge , ft , fr ) ftredge = max( 0.0 , min( ftredge , ftlo_edge ) ) k1 = k3 l1 = l3 endif c ! 3. extrap T or R in corner else if ( k3sat .gt. ntaxat(l3sat) .and. $ k3sat .eq. ntaxat(l2sat) ) then ft = min( 1.0 , $ ( slt - alt(k3) ) * dfs(k3) + 1.000001 ) fr = min( 1.0 , $ ( slr - alr(l3) ) * dfsr(l3) + 1.000001 ) ftlo_edge = min( ftlo_edge , max( ft , fr ) ) ftredge = max( 0.0 , min( ftredge , ftlo_edge ) ) if ( ft .gt. fr .or. l4sat .ge. nre ) then k1 = k3 l1 = l3-2 if ( k3sat .lt. ntaxat(l1+nrdel) ) then l1 = l3-1 if ( l3 .ge. nr ) then ftlo_edge = 0. ftredge = 0. endif else if ( l3 .lt. nr ) then do i = 1,3 iq(i) = 3 enddo endif else k1 = max(ntaxat(l3sat)-ntdel,k3-2) l1 = l3 if ( k1 .eq. k3-2 ) ip = 3 endif c ! 4. extrapolate R else if ( k3sat .gt. ntaxat(l3sat) .and. $ k3sat .lt. ntaxat(l2sat) ) then if ( l4sat .ge. nre ) then ftlo_edge = 0. ftredge = 0. else k1 = max(ntaxat(l3sat)-ntdel,k3-2) l1 = l3 if ( k1 .eq. k3-2 ) ip = 3 if ( l3 .gt. 1 ) then fr = min( 1.0 , $ ( slr - alr(l3) ) * dfsr(l3) + 1.000001 ) ftlo_edge = min( ftlo_edge , fr ) ftredge = max( 0.0 , min( ftredge , fr ) ) endif endif c ! 8. extrapolate T else if ( k3sat .eq. ntaxat(l3sat) .and. $ k3sat .eq. ntaxat(l2sat) ) then k1 = k3 l1 = l3-2 if ( k3sat .lt. ntaxat(l1+nrdel) ) then l1 = l3-1 if ( l3 .ge. nr ) then ftredge = 0. ftlo_edge = 0. endif else if ( l3 .lt. nr ) then do i = 1,3 iq(i) = 3 enddo endif if ( k3 .gt. 1 ) then ft = min( 1.0 , $ ( slt - alt(k3) ) * dfs(k3) + 1.000001 ) ftlo_edge = min( ftlo_edge , ft ) ftredge = max( 0.0 , min( ftredge , ft ) ) endif c ! 5. inside an edge else if ( k2sat .ge. ntaxat(l2sat) .and. $ k2sat .le. ntaxat(l1sat) ) then if ( k2sat .eq. ntaxat(l2sat) .or. l3 .eq. nr ) then l1 = l3-2 k1 = k3-1 if ( k2sat .lt. ntaxat(l1+nrdel) ) then if ( l3 .lt. nr ) then l1 = l3-1 else if ( k3sat .lt. ntaxat(l1+nrdel) ) then ftlo_edge = 0. ftredge = 0. else k1 = k3 ft = min( 1.0 , $ ( slt - alt(k3) ) * dfs(k3) + 1.000001 ) ftlo_edge = min( ftlo_edge , ft ) ftredge = max( 0.0 , min( ftredge , ft ) ) endif else if ( l3 .lt. nr ) then do i = 1,3 iq(i) = 3 enddo endif else k1 = max(k3-2,1) l1 = l3-1 if ( k1 .eq. k3-2 ) ip = 3 endif endif c ! if too far out to extrapolate, return if ( ftredge .le. 0. ) then ftlo_edge = 0. fedge = 0. opact = badlogkval if ( level_err .ge. 2 .and. kdo_alex .le. 0 ) then write(6,20) slt+6., slr, flrho stop ' STOP -- OPAL Error: bad T or R value. ' endif return endif c ! use smaller of X=0 or X=.03 values c fedge = max( 0.0 , ftredge * fzedge ) c c ! get rest of revised grid indices k2 = k1+1 k3 = k1+2 k4 = k1+3 l2 = l1+1 l3 = l1+2 l4 = l1+3 c ! end of revised grid in low-T,R cutout endif c ! ------------------------- loop over Z-values kz: do kz = kzf, kzf2 c ! xhemx: subtract Z to prevent out-of-range C+O c ! values at small X xhemxz = 1. - xa(m) xhemx = xhemxz - zsto(kz) c ! If no X or Z interp if ( kzf2 .eq. kzf .and. mf2 .eq. mf ) then c xxc = exC xxo = exO c ! Else, if we will be interpolating in X or Z: else c c............. C and O fractions determined by the ray through the origin that c also passes through the point (Xc,Xo). Specific interpolation c values are determined by tabulated X values; i.e., xa(m). c Interpolation along the ray gives log(kappa(Xc,Xo)). c (Advantage of method: keeps indices within table boundaries.) c if ( xh .ge. xa(mx) + 0.1 ) then cmod = 1.0 else if ( xh .gt. xa(mx) ) then cmod = ( ( xa(mx) + 0.1 - xh ) * xhemx / xhemxi $ + ( xh - xa(mx) ) ) * 10.0 else if ( xhemxi .gt. small_1m6 ) then cmod = xhemx / xhemxi else cmod = 0. endif c if ( exC .gt. 0. ) then xxc = min( cmod * exC , xhemxz ) else if ( exC .ge. small_m1m8 .or. $ z .lt. small_1m8 ) then xxc = 0. else xxc = max( exC / z , -1. ) * zsto(kz) endif c if ( exO .gt. 0. ) then xxo = min( cmod * exO , xhemxz ) else if ( exO .ge. small_m1m8 .or. $ z .lt. small_1m8 ) then xxo = 0. else xxo = max( exO / z , -1. ) * zsto(kz) endif c endif c xxco = xxc + xxo if ( xxco .gt. xhemxz + small_1m6 ) then cmod = xhemxz / xxco xxc = xxc * cmod xxo = xxo * cmod endif c c..... convert xxc and xxo to logarithmic shifted by Z+zdel c cxx = log10(zzz(kz)+xxc) oxx = log10(zzz(kz)+xxo) c ! set up table C,O abundances for this m,kz nc = n(m,1,kz) no = nc do i = 1,nc-1 xc(i) = xcs(i) xo(i) = xos(i) enddo xc(nc) = xhemx xo(nc) = xhemx c do i = 1,nc ox(i) = oxf(m,i,kz) cx(i) = cxf(m,i,kz) xcd(i) = xcdf(m,i,kz) xod(i) = xodf(m,i,kz) cxd(i) = cxdf(m,i,kz) oxd(i) = oxdf(m,i,kz) enddo c xodp = max(-xxc+xc(nc),0.) xcdp = max(-xxo+xo(no),0.) c-debug[ c-debug; if ( m .eq. mf .and. kz .eq. kzf .and. ioudeb .gt. 0 ) c-debug; $ write(6,9409) z,xh,exC,exO,10.**slt,slt,slr, c-debug; $ xxc,xxo,mf,mf2,kzf,kzf2,k1,ip,l1,(iq(i),i=1,ip+1) c-debug; 9409 format(' '/' OPAL: Z',f10.7,' X',f10.7,' C',f10.7, c-debug; $ ' O',f10.7,' T6',f12.7,' logT6',f11.7,' logR',f11.7, c-debug; $ ' xxc',f10.7,' xxo',f10.7,' m',2i2,' kz',2i3, c-debug; $ ' k',i3,'+',i1,' l',i3,'+',4i1) c-debug] c c Interpolate in C and O: COINTSMO is better, and was more thoroughly tested: c if ( interp_CO_smo .gt. 0 ) then call cointsmo(xxc,xxo,kz) else call cointerp(xxc,xxo,kz) endif c ! ---------------- end of loop over Z-values kz enddo c c....... Interpolate in Z, if necessary, mixing overlapping quadratics. c call qzlog4int( zlogd ) c c....... completed C,O,Z interpolation. Now interpolate T6 and log R, usually c on a 4x4 grid. (log(T6(i)),i=i1,i1+3),log(R(j)),j=j1,j1+3)). Grid may c differ between X=0, X=.03, and X>.03 mixes, under some conditions. c Procedure mixes overlapping quadratics to obtain smoothed derivatives. c call t6rinterp(slr,slt) c ! ---------------- end of loop over X-mixes m enddo c c Completed C,O,Z,T6,R interpolation; interpolate logKappa & derivatives in X c c ! for low T with 0.0 < X < 0.1, may need to reduce xdel xdelat = xdel if ( mf .eq. mxzero .and. mg .eq. mx03 .and. mh .eq. mf+2 ) then delhi = opk(mh,1) - opk(mg,1) dello = opk(mg,1) - opk(mf,1) if ( delhi .gt. 0.02 .and. delhi .lt. dello ) then xdelat = max( xdel*(delhi/dello)**2 , xdelmin ) if ( delhi .lt. 0.1 .and. xdelat .lt. xdel ) $ xdelat = xdelat + (xdel-xdelat)*((0.1-delhi)*12.5)**2 if ( xdelat .lt. xdel ) then is = 0 c ! get (mf,mg,mh)-interpolated values with revised xdel do i = 1, 4 opvals(i) = qzinter(is,1,xh,2,opk(mf,i),opk(mg,i), $ opk(mh,i),0.0,xa(mf),xa(mg),xa(mh),0.0,xdelat) is = 1 enddo endif endif endif c is = 0 c ! these initializations just prevent compiler warnings: dixr = 0.0 x_3 = 0.0 x_4 = 0.0 c-debug[ x_1 = 0.0 x_2 = 0.0 c-debug] c ! if use only one X-table if ( mf .eq. mh ) then do i = 1,4 opvals(i) = opk(mf,i) enddo c-test-xdel[ c-test-xdel; do i = 1,n_xdel_test c-test-xdel; opdxi(i) = opact c-test-xdel; enddo c-test-xdel] c ! 2 tables: interpolate linearly in X else if ( mg .eq. mh ) then dixr = (xx(mg)-xxx)*dfsx(mg) do i = 1,4 opvals(i) = opk(mf,i)*dixr + opk(mg,i)*(1.-dixr) enddo c-test-xdel[ c-test-xdel; do i = 1,n_xdel_test_m1 c-test-xdel; opdxi(i) = ( opk(mf,1) c-test-xdel; $ * log10((xa(mg)+xdel_test(i))/(xh+xdel_test(i))) c-test-xdel; $ + opk(mg,1) c-test-xdel; $ * log10((xh+xdel_test(i))/(xa(mf)+xdel_test(i))) ) c-test-xdel; $ / log10((xa(mg)+xdel_test(i)) c-test-xdel; $ /(xa(mf)+xdel_test(i))) c-test-xdel; enddo c-test-xdel; opdxuse = opact c-test-xdel] c ! 3 tables: interpolate in X using quadratic else if ( mh .eq. mf2 ) then c ! if revised xdel was NOT used (usually!) if ( xdelat .ge. xdel ) then call quadsto( 1, xxx, xx(mf), xx(mg), xx(mh) ) do i = 1, 4 opvals(i) = quadget( 1, opk(mf,i), $ opk(mg,i), opk(mh,i) ) enddo endif c-test-xdel[ c-test-xdel; do i = 1,n_xdel_test_m1 c-test-xdel; opdxi(i) = quad(0,1,log10(xh+xdel_test(i)), c-test-xdel; $ opk(mf,1),opk(mg,1),opk(mh,1), c-test-xdel; $ log10(xa(mf)+xdel_test(i)), c-test-xdel; $ log10(xa(mg)+xdel_test(i)), c-test-xdel; $ log10(xa(mh)+xdel_test(i))) c-test-xdel; enddo c-test-xdel; opdxuse = opact c-test-xdel] c ! 4 tables: interpolate X between two overlapping quadratics c ! if revised xdel was NOT used (usually!) else if ( xdelat .ge. xdel ) then c ! may need dixr later below dixr = ( xx(mh) - xxx ) * dfsx(mh) c call quad4sto( 1, xxx, xx(mf), xx(mg), xx(mh), xx(mf2) ) do i = 1, 4 opvals(i) = quad4get( 1, opk(mf,i), opk(mg,i), $ opk(mh,i), opk(mf2,i) ) enddo c ! else, if revised xdel was used, combine it with (mg,mh,mf2) else c call quadsto( 2, xxx, xx(mg), xx(mh), xx(mf2) ) dixr = ( xx(mh) - xxx ) * dfsx(mh) do i = 1,4 opvals(i) = opvals(i) * dixr + ( 1. - dixr ) $ * quadget( 2, opk(mg,i), opk(mh,i), opk(mf2,i) ) enddo c-test-xdel[ c-test-xdel; do i = 1,n_xdel_test_m1 c-test-xdel; opdxi(i) = ( quad(0,1,log10(xh+xdel_test(i)),opk(mf,1), c-test-xdel; $ opk(mg,1),opk(mh,1),log10(xa(mf)+xdel_test(i)), c-test-xdel; $ log10(xa(mg)+xdel_test(i)), c-test-xdel; $ log10(xa(mh)+xdel_test(i))) c-test-xdel; $ * log10((xa(mh)+xdel_test(i))/(xh+xdel_test(i))) c-test-xdel; $ + quad(0,2,log10(xh+xdel_test(i)),opk(mg,1), c-test-xdel; $ opk(mh,1),opk(mf2,1),log10(xa(mg)+xdel_test(i)), c-test-xdel; $ log10(xa(mh)+xdel_test(i)), c-test-xdel; $ log10(xa(mf2)+xdel_test(i))) c-test-xdel; $ * log10((xh+xdel_test(i))/(xa(mg)+xdel_test(i))) ) c-test-xdel; $ / log10((xa(mh)+xdel_test(i)) c-test-xdel; $ /(xa(mg)+xdel_test(i))) c-test-xdel; enddo c-test-xdel; opdxuse = opact c-test-xdel] endif c-debug[ c-debug; if ( fedge .le. 0.0 ) oudebl = max( oudebl , badlogklim ) c-debug; do m = mf,mf2 c-debug; if ( .not. abs(opk(m,1)) .le. oudebl ) ichk = 1 c-debug; enddo c-debug; if ( ioudeb .gt. 1 .or. ichk .gt. 0 .or. c-debug; $ .not. abs(opact) .le. oudebl ) then c-debug; write(6,8415) 'Post-basic-X-interp:', c-debug; $ mf,mg,mh,mf2,kzf,kzf2,k1,ip,l1,iq(1),iq(2), c-debug; $ iq(3),iq(ip+1),z,xh,exC,exO,slt,slr c-debug; 8415 format(' '/' ',a/' opk(X): m',4i3,' kz',2i3,' k1',i3,'+',i1, c-debug; $ ' l1',i3,'+',4i1,' Z',f10.7,' X',f10.7,' C',f10.7, c-debug; $ ' O',f10.7,' logT6',f12.7,' logR',f12.7) c-debug; do m = mf,mf2 c-debug; write(6,8473) ' ',m,min(xa(m),1.-z),(opk(m,i),i=1,4) c-debug; 8473 format(a4,' (x',i2.2,') X=',f10.7,' logK=',g15.7, c-debug; $ ' DT=',g15.7,' DR=',g15.7,' DTro=',g15.7,a4) c-debug; enddo c-debug; write(6,8473) ' -->',0,xh,(opvals(i),i=1,4),' <--' c-debug; endif c-debug; do i = 1, 4 c-debug; opv_prev(i) = opvals(i) c-debug; enddo c-debug] c c If the 'GN93hz' X-indices will be needed, obtain them: c if ( f_xhi .gt. 0. .or. max( need_cno , need_user ) .gt. 0 ) then c c ! X < 0.1: if ( xh .le. 0.099999 ) then c ! set new mf,mg,mh,mf2 so that only the c ! upper X-interp quadratic is shifted mf = 1 mg = 1 if ( mf2 .ne. mxzero ) then mh = 2 mf2 = 3 else mh = 1 mf2 = 1 endif c-debug[ x_1 = xhi_in(mf) x_2 = xhi_in(mg) x_3 = xhi_in(mh) x_4 = xhi_in(mf2) c-debug] c ! X = 1-Z: else if ( xh .gt. 0.999999 - z ) then c ! high-X edge mf = mx_hi mg = mx_hi mh = mx_hi mf2 = mx_hi c-debug[ x_1 = 1. - z x_2 = x_1 x_3 = x_1 x_4 = x_1 c-debug] c ! X > 0.9: possibly fancy Z-interp: else if ( xh .ge. 0.9000009 ) then c ! first: set new mf,mg,mh,mf2 mf2 = nx_hi(kzf) x_4 = 1. - z mg = min( mx_hi - 2 , mf2 - 1 ) mf = mg - 1 mh = mg + 1 c-debug[ x_1 = xhi_in(mf) x_2 = xhi_in(mg) x_3 = xhi_in(mh) c-debug] c ! X = 0.95 case if ( abs( xhi_in(mh) - xh ) .lt. small_9m7 .and. $ xhi_use(mf2,kzf2) .ge. xhi_in(mh) - small_1m6 ) then c mh = mg + 1 mf2 = mh mg = mh mf = mh x_3 = 0.0 c ! 3-X-pt: Z > Zsto(kzf) > 0.05 else if ( mf2 .eq. mg + 1 ) then c mh = mf2 x_3 = x_4 c ! 4-X-pt: Zsto(kzf2) < 0.05 else if ( nx_hi(kzf2) .eq. mf2 ) then c x_3 = xhi_use(mh,kzf2) c ! 3-X-pt: X > 0.95 if ( xh .ge. x_3 - small_9m7 ) mf = mg c ! Otherwise else c if ( z .lt. zsto(kzh) - zacc(kzh) ) then k_k = kzg else k_k = kzh endif if ( nx_hi(k_k) .lt. mf2 ) then c ! kzf2 * * * Z | c ! | | \ | c ! kzh * * * +---> X c ! | | x \ c ! kzg * * * (use 3 c ! | | |\ X-pts) c ! kzf * * * * c ! mf mg mh mf2 mh = mf2 x_3 = x_4 else c ! kzf2 * * * Z | c ! | | \ | c ! kzh * * * +---> X c ! | | \ c ! | | x |\ (usually c ! kzg * * * * use 4 c ! | | | \ X-pts) c ! kzf * * * * c ! mf mg mh mf2 c if ( xhi_use(mh,kzh) .ge. $ xhi_in(mh) - small_1m6 ) then x_3 = xhi_in(mh) else c ! mh: curved Z-interpolation x_3 = qzinter(0,1,z,kzf2-kzf, $ xhi_use(mh,kzf),xhi_use(mh,kzg), $ xhi_use(mh,kzh),xhi_use(mh,kzf2),zsto(kzf), $ zsto(kzg),zsto(kzh),zsto(kzf2),zdel) endif c ! 3-X-pt: X > 0.95 if ( xh .ge. x_3 - small_9m7 ) mf = mg endif c endif c ! ELSE: general case: 0.1 < X < 0.9: else c mg = 2 mh = mx_hi - 2 do while ( mh - mg .gt. 1 ) imd = ( mg + mh ) / 2 if ( xh .le. xhi_in(imd) ) then mh = imd else mg = imd endif enddo c ! exact X-value: if ( abs( xh - xhi_in(mh) ) .lt. small_9m7 ) then mf = mh mg = mh mf2 = mh else if ( abs( xh - xhi_in(mg) ) .lt. small_9m7 ) then mf = mg mh = mg mf2 = mg c ! or general 4-pt X-interpolation: else mf = mg - 1 mf2 = min( mh + 1 , nx_hi(kzf) ) endif c-debug[ x_1 = xhi_in(mf) x_2 = xhi_in(mg) c-debug] c ! get the X-values for 3rd and 4th X-pts: x_3 = xhi_in(mh) c ! 3-X-pt case if ( mf2 .eq. mh ) then x_4 = x_3 c ! x4 = 0.9 or smaller else if ( mf2 .le. mx_hi - 2 ) then x_4 = xhi_in(mf2) c ! x4 = 0.95 or 1-Z else if ( nx_hi(kzf2) .eq. nx_hi(kzf) ) then x_4 = max( x_3 , min( xhi_use(mf2,kzf) , 1. - z ) ) c ! otherwise else if ( z .lt. zsto(kzh) - zacc(kzh) ) then k_k = kzg else k_k = kzh endif if ( nx_hi(k_k) .lt. mf2 ) then c ! kzf2 * * * Z | c ! | | \ | c ! kzh * * * +---> X c ! | x | \ c ! kzg * * * x4 = 1-Z c ! | | |\ c ! kzf * * * * c ! mg mh mf2 mf2 = mx_hi x_4 = 1. - z else c ! kzf2 * * * Z | c ! | | \ | c ! kzh * * * +---> X c ! | | \ c ! | x | |\ x4 from c ! kzg * * * * the line c ! | | | \ "mf2" c ! kzf * * * * c ! mg mh mf2 c if ( xhi_use(mf2,kzh) .ge. $ xhi_in(mf2) - small_1m6 ) then x_4 = xhi_in(mf2) else c ! mf2: curved Z-interpolation x_4 = qzinter(0,1,z,kzf2-kzf, $ xhi_use(mf2,kzf),xhi_use(mf2,kzg), $ xhi_use(mf2,kzh),xhi_use(mf2,kzf2),zsto(kzf), $ zsto(kzg),zsto(kzh),zsto(kzf2),zdel) endif endif endif endif c endif c c If the 'GN93hz' X-values are not available, just check for X > 0.76: c if ( f_xhi .le. 0.0 ) then c ! extrap if level_err<2 if ( xh .gt. 0.76 .and. kdo_xhi .le. 0 ) then tmp = max( 0.0 , 1.0 - ( xh - 0.76 ) / 0.04 ) fedge = fedge * tmp if ( tmp .le. 0.0 .and. level_err .ge. 2 ) then write(6,30) xh 30 format(' '/' OPAL: X=',f10.6, $ ' > 0.8, but GN93hz X-values unavailable') stop ' STOP -- OPAL Error: X too large. ' endif endif c c If X > 0.03 and C+O is not too large, then the more-numerous X-values from c 'GN93hz' can help; note that f_xhi was set above, according to this. c else c ! m is the temporary-opacity-storage X-index m = 0 c ! loop ix over 'GN93hz'-opacity-shift X-indices do ix = mf, mf2 c ! ix valid? if ( ix .le. mg .or. ix .eq. mh .or. ix .eq. mf2 ) then c m = m + 1 c ! if X available from 'Gz???.x??': if ( ireq_hi(ix) .eq. 0 ) then c ! no opacity shifts at this X do i = 1, 4 opk(m,i) = 0.0 enddo c ! ELSE: if X not available from 'Gz???.x??': else c ! get opacity shifts: loop over Z, T, R do kz = kzf, kzf2 ixm = min( ix , nx_hi(kz) ) if ( ixm .le. 5 ) then io = mo else ixm = ixm - 5 io = mo_m1 endif do it = k1,k1+ip do ir = l1,l1+iq(it-k1+1) opl(it,ir,kz) = co(ixm,mc,io,it,ir,kz) enddo enddo enddo c ! interpolate over Z call qzlog4int( zlogd ) c ! interpolate over T and R call t6rinterp(slr,slt) c endif c endif c enddo c c Now add the just-computed 'GN93hz' added-X-value opacity shifts and their c derivatives to the original opacity and derivative values: c c ! if 0.03 < X < 0.1 (1st quadratic absent): c if ( mg .eq. 1 .and. mf2 .eq. 3 ) then c call quadsto( 1, xxx, xxx_hi(1), xxx_hi(2), xxx_hi(3) ) f_xhi = f_xhi * (1.-dixr) do i = 1, 4 opvals(i) = opvals(i) + f_xhi $ * quadget( 1, opk(1,i), opk(2,i), opk(3,i) ) enddo c ! if use only one X-table else if ( mf .eq. mh ) then c do i = 1, 4 opvals(i) = opvals(i) + f_xhi * opk(1,i) enddo c ! if x4 = 0.9 or smaller... else if ( mf2 .le. mx_hi - 2 ) then c ! 3 tables: if ( mh .eq. mf2 ) then c call quadsto( 1, xxx, xxx_hi(mf), $ xxx_hi(mg), xxx_hi(mh) ) do i = 1, 4 opvals(i) = opvals(i) + f_xhi $ * quadget( 1, opk(1,i), opk(2,i), opk(3,i) ) enddo c ! or 4 tables: else c call quad4sto( 1, xxx, xxx_hi(mf), $ xxx_hi(mg), xxx_hi(mh), xxx_hi(mf2) ) do i = 1, 4 opvals(i) = opvals(i) + f_xhi $ * quad4get( 1, opk(1,i), opk(2,i), $ opk(3,i), opk(4,i) ) enddo c endif c ! 3 tables: interpolate in X using quadratic else if ( mh .eq. mf2 ) then c if ( x_3 .eq. xhi_in(mh) ) then xx_3 = xxx_hi(mh) else xx_3 = log10( x_3 + xdel ) endif call qchksto( 1, xxx, xxx_hi(mf), xxx_hi(mg), xx_3 ) do i = 1, 4 opvals(i) = opvals(i) + f_xhi $ * qchkget( 1, opk(1,i), opk(2,i), opk(3,i) ) enddo c ! 3 tables at high-X end of matrix else if ( mf .eq. mg ) then c if ( x_3 .eq. xhi_in(mh) ) then xx_3 = xxx_hi(mh) else xx_3 = log10( x_3 + xdel ) endif if ( x_4 .eq. xhi_in(mf2) ) then xx_4 = xxx_hi(mf2) else xx_4 = log10( x_4 + xdel ) endif call qchksto( 1, xxx, xxx_hi(mg), xx_3, xx_4 ) do i = 1, 4 opvals(i) = opvals(i) + f_xhi $ * qchkget( 1, opk(1,i), opk(2,i), opk(3,i) ) enddo c ! 3 tables: x4 = x3 (should not happen) else if ( x_3 .ge. x_4 ) then c if ( x_4 .eq. xhi_in(mf2) ) then xx_4 = xxx_hi(mf2) else xx_4 = log10( x_4 + xdel ) endif call qchksto( 1, xxx, xxx_hi(mf), xxx_hi(mg), xx_4 ) do i = 1, 4 opvals(i) = opvals(i) + f_xhi $ * qchkget( 1, opk(1,i), opk(2,i), opk(4,i) ) enddo c ! 4 tables: interpolate X between two overlapping quadratics else c if ( x_3 .eq. xhi_in(mh) ) then xx_3 = xxx_hi(mh) else xx_3 = log10( x_3 + xdel ) endif if ( x_4 .eq. xhi_in(mf2) ) then xx_4 = xxx_hi(mf2) else xx_4 = log10( x_4 + xdel ) endif dixr = ( xx_3 - xxx ) / ( xx_3 - xxx_hi(mg) ) call quadsto( 1, xxx, xxx_hi(mf), xxx_hi(mg), xx_3 ) call qchksto( 2, xxx, xxx_hi(mg), xx_3, xx_4 ) do i = 1, 4 opvals(i) = opvals(i) + f_xhi * ( quadget( 1, opk(1,i), $ opk(2,i), opk(3,i) ) * dixr + qchkget( 2, opk(2,i), $ opk(3,i), opk(4,i) ) * ( 1. - dixr ) ) enddo c endif c-debug[ c-debug; if ( fedge .le. 0.0 ) oudebl = max( oudebl , badlogklim ) c-debug; do m = 1, 3 + min( 1 , mf2 - mh ) c-debug; if ( .not. abs(opk(m,1)) .le. oudebl ) ichk = 1 c-debug; enddo c-debug; if ( ioudeb .gt. 2 .or. ichk .gt. 0 .or. c-debug; $ .not. abs(opact) .le. oudebl ) then c-debug; write(6,8415) 'Post-GN93hz-[possibly-high]-X-interp:', c-debug; $ mf,mg,mh,mf2,kzf,kzf2,k1,ip,l1,iq(1),iq(2), c-debug; $ iq(3),iq(ip+1),z,xh,exC,exO,slt,slr c-debug; m = 0 c-debug; do ix = mf, mf2 c-debug; if ( ix .le. mg .or. ix .eq. mh .or. ix .eq. mf2 ) then c-debug; m = m + 1 c-debug; if ( ix .eq. mf ) then c-debug; tmp = x_1 c-debug; else if ( ix .eq. mg ) then c-debug; tmp = x_2 c-debug; else if ( ix .eq. mh ) then c-debug; tmp = x_3 c-debug; else if ( ix .eq. mf2 ) then c-debug; tmp = x_4 c-debug; endif c-debug; write(6,8473) ' ',ix,tmp,(opk(m,i),i=1,4) c-debug; endif c-debug; enddo c-debug; write(6,8473) ' dK=',0,xh,(opvals(i)-opv_prev(i),i=1,4) c-debug; write(6,8473) ' +K:',0,xh,(opv_prev(i),i=1,4) c-debug; write(6,8473) ' -->',0,xh,(opvals(i),i=1,4) c-debug; endif c-debug; do i = 1, 4 c-debug; opv_prev(i) = opvals(i) c-debug; enddo c-debug] c endif c c If the CNO-interpolation is needed, perform it. c if ( max( need_cno , need_user ) .gt. 0 ) then c f_2 = fcn * need_cno f_3 = fcon * need_cno f_4 = fcnone * need_cno f_5 = fu * need_user c ! m is the temporary-opacity-storage X-index m = 0 c ! loop ix over 'GN93hz'-opacity-shift X-indices do ix = mf, mf2 c ! ix valid? if ( ix .le. mg .or. ix .eq. mh .or. ix .eq. mf2 ) then c m = m + 1 c ! get opacity shifts: loop over Z, T, R do kz = kzf, kzf2 c ixm = min( ix , nx_hi(kz) ) c call index_co_deltas( 2, ixm, ix2, ic2, io2 ) call index_co_deltas( 3, ixm, ix3, ic3, io3 ) call index_co_deltas( 4, ixm, ix4, ic4, io4 ) call index_co_deltas( 5, ixm, ix5, ic5, io5 ) c do it = k1, k1 + ip do ir = l1, l1 + iq(it-k1+1) opl(it,ir,kz) = f_2 * co(ix2,ic2,io2,it,ir,kz) $ + f_3 * co(ix3,ic3,io3,it,ir,kz) $ + f_4 * co(ix4,ic4,io4,it,ir,kz) $ + f_5 * co(ix5,ic5,io5,it,ir,kz) c-debug[ c-debug; if ( ioudeb .gt. 8 .or. .not. c-debug; $ abs(opl(it,ir,kz)) .le. oudebl ) then c-debug; write(6,9637) ix, it, ir, kz, opl(it,ir,kz) c-debug; 9637 format(' OPAL_K_ONLY cno[ix=',i1, c-debug; $ ']: opl(it=',i2.2,',ir=',i2.2,',kz=', c-debug; $ i2.2,') =',f11.7,$) c-debug; if ( need_cno .gt. 0 ) then c-debug; write(6,9638) ' <-- fcn', f_2, ix2, c-debug; $ ic2, io2, co(ix2,ic2,io2,it,ir,kz) c-debug; 9638 format(a,'[',f11.7,'] * co(',i1,',',i1, c-debug; $ ',',i1,',...)[',f11.7,']',$) c-debug; write(6,9638) ' + fcon', f_3, ix3, c-debug; $ ic3, io3, co(ix3,ic3,io3,it,ir,kz) c-debug; write(6,9638) ' + fcnone', f_4, ix4, c-debug; $ ic4, io4, co(ix4,ic4,io4,it,ir,kz) c-debug; endif c-debug; if ( need_user .gt. 0 ) then c-debug; if ( need_cno .le. 0 ) then c-debug; write(6,9638) ' <-- fu', c-debug; $ f_5, ix5, ic5, io5, c-debug; $ co(ix5,ic5,io5,it,ir,kz) c-debug; else c-debug; write(6,9638) ' + fu', c-debug; $ f_5, ix5, ic5, io5, c-debug; $ co(ix5,ic5,io5,it,ir,kz) c-debug; endif c-debug; endif c-debug; write(6,'("")') c-debug; endif c-debug] enddo enddo c enddo c ! interpolate over Z call qzlog4int( zlogd ) c ! interpolate over T and R call t6rinterp(slr,slt) c endif c enddo c c Now add the just-computed 'GN93hz' CNO-interpolation opacity shifts and c their derivatives to the original opacity and derivative values: c c ! if 0.0 < X < 0.1 (1st quadratic absent): c if ( mg .eq. 1 .and. mf2 .eq. 3 ) then c call quadsto( 1, xxx, xxx_cno(1), xxx_cno(2), xxx_cno(3) ) do i = 1, 4 opvals(i) = opvals(i) $ + quadget( 1, opk(1,i), opk(2,i), opk(3,i) ) enddo c ! if use only one X-table else if ( mf .eq. mh ) then c do i = 1, 4 opvals(i) = opvals(i) + opk(1,i) enddo c ! if x4 = 0.9 or smaller... else if ( mf2 .le. mx_hi - 2 ) then c ! 3 tables: if ( mh .eq. mf2 ) then c call quadsto( 1, xxx, xxx_cno(mf), $ xxx_cno(mg), xxx_cno(mh) ) do i = 1, 4 opvals(i) = opvals(i) $ + quadget( 1, opk(1,i), opk(2,i), opk(3,i) ) enddo c ! or 4 tables: else c call quad4sto( 1, xxx, xxx_cno(mf), $ xxx_cno(mg), xxx_cno(mh), xxx_cno(mf2) ) do i = 1, 4 opvals(i) = opvals(i) $ + quad4get( 1, opk(1,i), opk(2,i), $ opk(3,i), opk(4,i) ) enddo c endif c ! 3 tables: interpolate in X using quadratic else if ( mh .eq. mf2 ) then c if ( x_3 .eq. xhi_in(mh) ) then xx_3 = xxx_cno(mh) else xx_3 = log10( x_3 + xdel ) endif call qchksto( 1, xxx, xxx_cno(mf), xxx_cno(mg), xx_3 ) do i = 1, 4 opvals(i) = opvals(i) $ + qchkget( 1, opk(1,i), opk(2,i), opk(3,i) ) enddo c ! 3 tables at high-X end of matrix else if ( mf .eq. mg ) then c if ( x_3 .eq. xhi_in(mh) ) then xx_3 = xxx_cno(mh) else xx_3 = log10( x_3 + xdel ) endif if ( x_4 .eq. xhi_in(mf2) ) then xx_4 = xxx_cno(mf2) else xx_4 = log10( x_4 + xdel ) endif call qchksto( 1, xxx, xxx_cno(mg), xx_3, xx_4 ) do i = 1, 4 opvals(i) = opvals(i) $ + qchkget( 1, opk(1,i), opk(2,i), opk(3,i) ) enddo c ! 3 tables: x4 < x3 (e.g., if Z > 0.1) else if ( x_3 .ge. x_4 ) then c if ( x_4 .eq. xhi_in(mf2) ) then xx_4 = xxx_cno(mf2) else xx_4 = log10( x_4 + xdel ) endif call qchksto( 1, xxx, xxx_cno(mf), xxx_cno(mg), xx_4 ) do i = 1, 4 opvals(i) = opvals(i) $ + qchkget( 1, opk(1,i), opk(2,i), opk(4,i) ) enddo c ! 4 tables: interpolate X between two overlapping quadratics else c if ( x_3 .eq. xhi_in(mh) ) then xx_3 = xxx_cno(mh) else xx_3 = log10( x_3 + xdel ) endif if ( x_4 .eq. xhi_in(mf2) ) then xx_4 = xxx_cno(mf2) else xx_4 = log10( x_4 + xdel ) endif dixr = ( xx_3 - xxx ) / ( xx_3 - xxx_cno(mg) ) call quadsto( 1, xxx, xxx_cno(mf), xxx_cno(mg), xx_3 ) call qchksto( 2, xxx, xxx_cno(mg), xx_3, xx_4 ) do i = 1,4 opvals(i) = opvals(i) + quadget( 1, opk(1,i), opk(2,i), $ opk(3,i) ) * dixr + qchkget( 2, opk(2,i), opk(3,i), $ opk(4,i) ) * ( 1. - dixr ) enddo c endif c-debug[ c-debug; if ( fedge .le. 0.0 ) oudebl = max( oudebl , badlogklim ) c-debug; do m = 1, 3 + min( 1 , mf2 - mh ) c-debug; if ( .not. abs(opk(m,1)) .le. oudebl ) ichk = 1 c-debug; enddo c-debug; if ( ioudeb .gt. 1 .or. ichk .gt. 0 .or. c-debug; $ .not. abs(opact) .le. oudebl ) then c-debug; write(6,8415) 'Post-CNO-interp-X:', c-debug; $ mf,mg,mh,mf2,kzf,kzf2,k1,ip,l1,iq(1),iq(2), c-debug; $ iq(3),iq(ip+1),z,xh,exC,exO,slt,slr c-debug; m = 0 c-debug; do ix = mf, mf2 c-debug; if ( ix .le. mg .or. ix .eq. mh .or. ix .eq. mf2 ) then c-debug; m = m + 1 c-debug; if ( ix .eq. mf ) then c-debug; tmp = x_1 c-debug; else if ( ix .eq. mg ) then c-debug; tmp = x_2 c-debug; else if ( ix .eq. mh ) then c-debug; tmp = x_3 c-debug; else if ( ix .eq. mf2 ) then c-debug; tmp = x_4 c-debug; endif c-debug; write(6,8473) ' ',ix,tmp,(opk(m,i),i=1,4) c-debug; endif c-debug; enddo c-debug; write(6,8473) ' dK=',0,xh,(opvals(i)-opv_prev(i),i=1,4) c-debug; write(6,8473) ' +K:',0,xh,(opv_prev(i),i=1,4) c-debug; write(6,8473) ' -->',0,xh,(opvals(i),i=1,4) c-debug; endif c-debug] c endif c c-debug[ c-debug; if ( fedge .le. 0.0 ) oudebl = max( oudebl , badlogklim ) c-debug; if ( ioudeb .gt. 1 .or. ichk .gt. 0 .or. c-debug; $ .not. abs(opact) .le. oudebl ) then c-debug; koudeb = koudeb + 1 c-debug; write(6,'(" Final:")') c-debug; write(6,8473) ' ==>',0,xh,(opvals(i),i=1,4),' <==' c-debug; write(6,'(" ...end of OPAL_K_ONLY."/)') c-debug;c-test-xdel[ c-debug;c-test-xdel; if ( mf .ne. mh ) write(6,9387) xh, c-debug;c-test-xdel; $ (opdxi(i),i=1,n_xdel_test_m1), c-debug;c-test-xdel; $ (xdel_test(i),i=1,n_xdel_test_m1) c-debug;c-test-xdel; 9387 format(' X=',f10.7,' logK=',8g15.7/ c-debug;c-test-xdel; $ ' for delX=',f9.4,7f15.4) c-debug;c-test-xdel] c-debug; endif c-debug; oudebl = oudebl_sto c-debug] c return end c c****************************************************************************** c subroutine ask_last_opac( op, dopt, dopr, doptd, fe, ftre, fze ) c ================================================================ c common/e_opal_z/ opact,dopact,dopacr,dopactd,fedge,ftredge,fzedge c op = opact dopt = dopact dopr = dopacr doptd = dopactd fe = fedge ftre = ftredge fze = fzedge c return end c c****************************************************************************** c subroutine ask_last_xcnou(z,x,xc,xo,slt,slr,fcn,fcon,fcnone,fu) c =============================================================== c common /x_opal_z/ z_opal, x_opal, xc_opal, xo_opal, slt_opal, $ slr_opal, fcn_opal, fcon_opal, fcnone_opal, fu_opal c z = z_opal x = x_opal xc = xc_opal xo = xo_opal slt = slt_opal slr = slr_opal fcn = fcn_opal fcon = fcon_opal fcnone = fcnone_opal fu = fu_opal c return end c c****************************************************************************** c subroutine ask_opal_z_mix( imix, xiz, n_x, fninz, n_n ) c ======================================================= c dimension xiz(n_x), fninz(n_n) c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c character*2 cel_opalmixes(nel_zmix) character*8 cfile_opalmixes(n_zmixes) common/opalmixes/ xiz_mix(nel_zmix),fninz_mix(nel_zmix), $ bracketife_mix(nel_zmix),bracketofe_opalmixes(n_zmixes), $ xofe_opalmixes(n_zmixes),xiz_opalmixes(nel_zmix,n_zmixes), $ fninz_opalmixes(nel_zmix,n_zmixes), $ cel_opalmixes,cfile_opalmixes save /opalmixes/ c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c if ( imix .gt. n_zmixes .or. imix .lt. -n_totmix ) then c if ( n_x .gt. 0 ) then do i = 1, min( n_x , nel_zmix ) xiz(i) = xiz_mix(i) enddo do i = nel_zmix + 1, n_x xiz(i) = 0.0 enddo endif c if ( n_n .gt. 0 ) then do i = 1, min( n_n , nel_zmix ) fninz(i) = fninz_mix(i) enddo do i = nel_zmix + 1, n_n fninz(i) = 0.0 enddo endif c else if ( imix .gt. 0 ) then c if ( n_x .gt. 0 ) then do i = 1, min( n_x , nel_zmix ) xiz(i) = xiz_opalmixes(i,imix) enddo do i = nel_zmix + 1, n_x xiz(i) = 0.0 enddo endif c if ( n_n .gt. 0 ) then do i = 1, min( n_n , nel_zmix ) fninz(i) = fninz_opalmixes(i,imix) enddo do i = nel_zmix + 1, n_n fninz(i) = 0.0 enddo endif c else c if ( n_x .gt. 0 ) then do i = 1, min( n_x , nel_zmix ) xiz(i) = xiz_opalGS98(i,-imix) enddo do i = nel_zmix + 1, n_x xiz(i) = 0.0 enddo endif c if ( n_n .gt. 0 ) then do i = 1, min( n_n , nel_zmix ) fninz(i) = fninz_opalGS98(i,-imix) enddo do i = nel_zmix + 1, n_n fninz(i) = 0.0 enddo endif c endif c return end c c****************************************************************************** c subroutine ask_opal_mix_wt( atwt, nwt, atwthhe, nhhe, atz, nz ) c =============================================================== c dimension atwt(nwt), atwthhe(nhhe), atz(nz) c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c parameter ( n_mix_meteor = 3 ) double precision xiz_meteor, fninz_meteor character*255 cfile_meteor(n_mix_meteor) common /c_meteor_mix_opal_z/ xiz_meteor(nel_zmix,n_mix_meteor), $ fninz_meteor(nel_zmix,n_mix_meteor), $ nuc_charge_opalmixes(nel_zmix), cfile_meteor save /c_meteor_mix_opal_z/ c parameter ( atwt_H = 1.0079, atwt_He = 4.0026 ) c if ( nwt .gt. 0 ) then do i = 1, min( nwt , nel_zmix ) atwt(i) = atwt_opalGS98(i) enddo endif c if ( nhhe .gt. 0 ) then atwthhe(1) = atwt_H if ( nhhe .gt. 1 ) then atwthhe(2) = atwt_He endif endif c if ( nz .gt. 0 ) then do i = 1, min( nz , nel_zmix ) atz(i) = nuc_charge_opalmixes(i) enddo endif c return end c c****************************************************************************** c subroutine set_opal_list_level( list_level ) c ============================================ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c common /c_level_list_opal_z/ iu_list, level_list, list_mult, $ list_gn(-n_zmixes:n_totmix) save /c_level_list_opal_z/ c level_list = max( 0 , list_level ) c do i = -n_zmixes, n_totmix list_gn(i) = 0 enddo c return end c c****************************************************************************** c subroutine set_opal_list_unit( list_iu ) c ======================================== c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c common /c_level_list_opal_z/ iu_list, level_list, list_mult, $ list_gn(-n_zmixes:n_totmix) save /c_level_list_opal_z/ c if ( list_iu .lt. 0 .or. $ list_iu .eq. 5 .or. list_iu .gt. 99 ) then iu_list = 6 else iu_list = list_iu endif c return end c c****************************************************************************** c subroutine set_opal_dir( cdirin ) c ================================= c character*(*) cdirin c common/recoin_opal_z/ itimeco,mxzero,mx03,kope,igznotgx save /recoin_opal_z/ c character*255 copdir common/opdir/ copdir save /opdir/ c=== call chk_dir_name( cdirin, copdir, kope ) c if ( kope .lt. 0 ) stop $ ' STOP -- SET_OPAL_DIR Error: bad directory name. ' c return end c c****************************************************************************** c subroutine set_mol_dir( cdirin ) c ================================ c character*(*) cdirin c character*255 cfile_alex common /c_filename_alex/ need_alex_dir, cfile_alex save /c_filename_alex/ c=== call chk_dir_name( cdirin, cfile_alex, kope ) c if ( kope .lt. 0 ) stop $ ' STOP -- SET_MOL_DIR Error: bad directory name. ' c need_alex_dir = 0 c return end c c****************************************************************************** c subroutine set_cond_dir( cdirin ) c ================================= c character*(*) cdirin c parameter ( ndef_cond = 3 ) c character*255 cfile_cond character*80 cdef_cond(ndef_cond) common /c_filename_cond/ need_cond_dir, cfile_cond, cdef_cond save /c_filename_cond/ c=== call chk_dir_name( cdirin, cfile_cond, kope ) c if ( kope .lt. 0 ) stop $ ' STOP -- SET_COND_DIR Error: bad directory name. ' c need_cond_dir = 0 c return end c c****************************************************************************** c subroutine read_basic_opal_opac( iu, z, cf_hz, ofebrack, cf_ofe ) c ================================================================= c character*(*) cf_hz, cf_ofe c if ( iu .ge. 0 .and. iu .lt. 7 ) then i_u = 7 else i_u = min( iu , 96 ) endif c if ( cf_hz .eq. ' ' .or. cf_hz .eq. 'GN93hz' ) then khighz = 1 else khighz = -1 call set_altmix_main_file( cf_hz ) endif c if ( ofebrack .ne. 0.0 ) then khighz = 5 * khighz if ( khighz .gt. 0 ) then call set_ofe_file( cf_ofe ) else call set_altmix_ofe_file( cf_ofe ) endif endif c call readzexco( -9, -1.0, z, -1.0, khighz, i_u, ofebrack ) c return end c c****************************************************************************** c subroutine read_extended_opac( i_u, z, cf_hz, ofebrack, cf_ofe, $ i_alex, i_cond, i_cno, cf_user ) c =============================================================== c character*(*) cf_hz, cf_ofe, cf_user c ! get a valid Fortran unit number if ( i_u .ge. 0 .and. i_u .lt. 7 ) then iu = 7 else iu = min( i_u , 96 ) endif c ! GN93 case or not? if ( cf_hz .eq. ' ' .or. cf_hz .eq. 'GN93hz' ) then khighz = 1 else khighz = -1 call set_altmix_main_file( cf_hz ) endif c ! if non-zero [O/Fe]: reset khighz if ( ofebrack .ne. 0.0 ) then khighz = 5 * khighz if ( khighz .gt. 0 ) then call set_ofe_file( cf_ofe ) else call set_altmix_ofe_file( cf_ofe ) endif endif c ! if CNO-interp: reset khighz if ( i_cno .ne. 0 ) then if ( khighz .gt. 0 ) then khighz = khighz + 10 else khighz = khighz - 10 endif endif c ! if d_KAPPA_user: reset khighz if ( cf_user .ne. ' ' ) then call set_cno_files( ' ', ' ', ' ', ' ', cf_user ) if ( khighz .gt. 0 ) then khighz = khighz + 20 else khighz = khighz - 20 endif endif c c Read in the OPAL opacity files: c call readzexco( -9, -1.0, z, -1.0, khighz, iu, ofebrack ) c c Possibly read molecular opacities: c call read_best_mol( iu, i_alex, cf_hz, ofebrack ) c c Read conductive opacities, if input flag so indicates; c if ( iabs( i_cond ) .gt. 1 ) then call read_cond_pot( iu ) else if ( i_cond .ne. 0 ) then call readcond( iu ) endif c ! set conductive-opacity flag call set_cond_use( min(1,max(0,i_cond)), 99 ) c return end c c****************************************************************************** c subroutine set_ofe_file( cfileofe ) c =================================== c character*(*) cfileofe c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c character*2 cel_opalmixes(nel_zmix) character*8 cfile_opalmixes(n_zmixes) common/opalmixes/ xiz_mix(nel_zmix),fninz_mix(nel_zmix), $ bracketife_mix(nel_zmix),bracketofe_opalmixes(n_zmixes), $ xofe_opalmixes(n_zmixes),xiz_opalmixes(nel_zmix,n_zmixes), $ fninz_opalmixes(nel_zmix,n_zmixes), $ cel_opalmixes,cfile_opalmixes save /opalmixes/ c character*1 cb(6) common /chkpoc/ cb save /chkpoc/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c=== last = lnblnk( cfileofe ) ibeg = max( 1 , non_blank_begin(cfileofe) ) c ! blank input --> W95hz if ( last .lt. ibeg ) then cfile_opalmixes(n_zmixes) = cfile_opalmixes(4) return endif c if ( level_err .gt. 0 ) then c if ( last - ibeg .ge. 8 ) then write(6,10) last - ibeg + 1, cfileofe(ibeg:last) 10 format(' WARNING: length',i5, $ ' exceeds 8 for filename for khighz = 5:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_OFE_FILE Error: name too long. ' endif c iblank = num_blanks_contained( cfileofe ) c if ( iblank .gt. 0 ) then write(6,20) iblank, cfileofe(ibeg:last) 20 format(' WARNING:',i5,' blanks contained in filename', $ ' for khighz = -5:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_OFE_FILE Error: blanks in name. ' endif c endif c cfile_opalmixes(n_zmixes) = cfileofe(ibeg:) c return end c c****************************************************************************** c subroutine set_altmix_ofe_file( cfileofe ) c ========================================== c character*(*) cfileofe c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c=== last = lnblnk( cfileofe ) c ibeg = max( 1 , non_blank_begin(cfileofe) ) c ! blank input --> default if ( last .lt. ibeg ) then cfile_opalGS98(n_zmixes) = ' ' return endif c if ( level_err .gt. 0 ) then c if ( last - ibeg .ge. 255 ) then write(6,10) last - ibeg + 1, cfileofe(ibeg:last) 10 format(' WARNING: length',i5, $ ' exceeds 255 for filename for khighz = -5:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_ALTMIX_OFE_FILE Error: name too long. ' endif c iblank = num_blanks_contained( cfileofe ) c if ( iblank .gt. 0 ) then write(6,20) iblank, cfileofe(ibeg:last) 20 format(' WARNING:',i5,' blanks contained in filename', $ ' for khighz = -5:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_ALTMIX_OFE_FILE Error: blanks in name. ' endif c endif c cfile_opalGS98(n_zmixes) = cfileofe(ibeg:) c return end c c****************************************************************************** c subroutine set_meteor_mix_file( cfilemet ) c ========================================== c character*(*) cfilemet c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c=== last = lnblnk( cfilemet ) c ibeg = max( 1 , non_blank_begin(cfilemet) ) c if ( level_err .gt. 0 ) then c if ( last - ibeg .ge. 255 ) then write(6,10) last - ibeg + 1, cfilemet(ibeg:last) 10 format(' WARNING: length',i5, $ ' exceeds 255 for filename for meteor-mix:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_METEOR_MIX_FILE Error: name too long. ' endif c iblank = num_blanks_contained( cfilemet ) c if ( iblank .gt. 0 ) then write(6,20) iblank, cfilemet(ibeg:last) 20 format(' WARNING:',i5,' blanks contained in filename', $ ' for khighz = -5:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_METEOR_MIX_FILE Error: blanks in name. ' endif c endif c cfile_opalGS98(0) = cfilemet(ibeg:) c return end c c****************************************************************************** c subroutine set_altmix_main_file( cfile_hz ) c =========================================== c character*(*) cfile_hz c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c common /alt_change_opal_z/ main_alt_change, iulow, khighz_in, $ ofebrack_in save /alt_change_opal_z/ c=== last = lnblnk( cfile_hz ) c ibeg = max( 1 , non_blank_begin(cfile_hz) ) c if ( level_err .gt. 0 ) then c if ( last - ibeg .ge. 255 ) then write(6,10) last - ibeg + 1, cfile_hz(ibeg:last) 10 format(' WARNING: length',i5, $ ' exceeds 255 for filename for khighz = -1:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_ALTMIX_MAIN_FILE Error: name too long. ' endif c iblank = num_blanks_contained( cfile_hz ) c if ( iblank .gt. 0 ) then write(6,20) iblank, cfile_hz(ibeg:last) 20 format(' WARNING:',i5,' blanks contained in filename', $ ' for khighz = -5:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_ALTMIX_MAIN_FILE Error: blanks in name ' endif c endif c if ( last .le. 0 ) then cfile_opalGS98(1) = 'GS98hz' main_alt_change = 2 else cfile_opalGS98(1) = cfile_hz(ibeg:) main_alt_change = 1 endif c last = lnblnk( cfile_opalGS98(1) ) cfile_opalGS98(2) = cfile_opalGS98(1)(:last) // '_OFe.3_Alrd96a2' cfile_opalGS98(3) = cfile_opalGS98(1)(:last) // '_OFe.4_C95' cfile_opalGS98(4) = cfile_opalGS98(1)(:last) // '_OFe.5_W95' c return end c c****************************************************************************** c subroutine set_cno_files( cf_hz, cf_c, cf_o, cf_n, cf_user ) c ============================================================ c character*(*) cf_hz, cf_c, cf_o, cf_n, cf_user c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c character*80 cdef_CNO_ext(n_cnobeg:n_totmix) common /ext_CNO_opal_z/ len_def_CNO_ext(n_cnobeg:n_totmix), $ cdef_CNO_ext save /ext_CNO_opal_z/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c parameter ( nbegp1 = n_cnobeg + 1, nbegp2 = n_cnobeg + 2 ) c=== iwarn = max( 2 - level_err , 0 ) l_max = 0 c ! this initialization just prevents compiler warnings: l_hz = 0 c do k = n_cnobeg, n_totmix c if ( k .eq. n_cnobeg ) then last = lnblnk( cf_hz ) ibeg = max( 1 , non_blank_begin(cf_hz) ) cfile_opalGS98(k) = cf_hz(ibeg:) else if ( k .eq. nbegp1 ) then last = lnblnk( cf_c ) ibeg = max( 1 , non_blank_begin(cf_c) ) cfile_opalGS98(k) = cf_c(ibeg:) else if ( k .eq. nbegp2 ) then last = lnblnk( cf_o ) ibeg = max( 1 , non_blank_begin(cf_o) ) cfile_opalGS98(k) = cf_o(ibeg:) else if ( k .eq. n_totmix ) then last = lnblnk( cf_user ) ibeg = max( 1 , non_blank_begin(cf_user) ) cfile_opalGS98(k) = cf_user(ibeg:) else last = lnblnk( cf_n ) ibeg = max( 1 , non_blank_begin(cf_n) ) cfile_opalGS98(k) = cf_n(ibeg:) endif c if ( k .eq. n_cnobeg ) then l_hz = last - ibeg + 1 else if ( last .eq. 0 .and. l_hz .gt. 0 ) then cfile_opalGS98(k) = $ cfile_opalGS98(n_cnobeg)(:min(l_hz,255)) // $ cdef_CNO_ext(k) last = l_hz + len_def_CNO_ext(k) else if ( last .gt. 0 .and. l_hz .eq. 0 .and. $ iwarn .eq. 0 ) then write(6,10) 10 format(' WARNING: SET_CNO_FILES: blank cfile_hz', $ ' but other input filename(s) non-blank') iwarn = iwarn + 1 endif c l_max = max( l_max , last - ibeg + 1 ) c enddo c if ( l_max .gt. 255 .and. level_err .gt. 0 ) then write(6,20) l_max 20 format(' WARNING: SET_CNO_FILES: largest filename length',i5, $ ' exceeds 255') if ( level_err .ge. 2 ) stop $ ' STOP -- SET_CNO_FILES Error: filename too long. ' endif c return end c c****************************************************************************** c subroutine set_cno_ext( ie, ce_hz, ce_c, ce_o, ce_n, ce_u ) c =========================================================== c character*(*) ce_hz, ce_c, ce_o, ce_n, ce_u c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*80 cdef_CNO_ext(n_cnobeg:n_totmix) common /ext_CNO_opal_z/ len_def_CNO_ext(n_cnobeg:n_totmix), $ cdef_CNO_ext save /ext_CNO_opal_z/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c parameter ( nbegp1 = n_cnobeg + 1, nbegp2 = n_cnobeg + 2 ) c=== l_max = 0 c do k = n_cnobeg, n_totmix c ibeg = 1 if ( k .eq. n_cnobeg ) then last = lnblnk( ce_hz ) if ( last .gt. 0 ) then ibeg = non_blank_begin(ce_hz) cdef_CNO_ext(k) = ce_hz(ibeg:) endif else if ( k .eq. nbegp1 ) then last = lnblnk( ce_c ) if ( last .gt. 0 ) then ibeg = non_blank_begin(ce_c) cdef_CNO_ext(k) = ce_c(ibeg:) endif else if ( k .eq. nbegp2 ) then last = lnblnk( ce_o ) if ( last .gt. 0 ) then ibeg = non_blank_begin(ce_o) cdef_CNO_ext(k) = ce_o(ibeg:) endif else if ( k .eq. n_totmix ) then last = lnblnk( ce_u ) if ( last .gt. 0 ) then ibeg = non_blank_begin(ce_u) cdef_CNO_ext(k) = ce_u(ibeg:) endif else last = lnblnk( ce_n ) if ( last .gt. 0 ) then ibeg = non_blank_begin(ce_n) cdef_CNO_ext(k) = ce_n(ibeg:) endif endif c if ( last .gt. 0 ) then len_def_CNO_ext(k) = last - ibeg + 1 l_max = max( len_def_CNO_ext(k) , l_max ) else if ( ie .eq. k .or. ie + n_zmixes .eq. k ) then cdef_CNO_ext(k) = ' ' len_def_CNO_ext(k) = 0 endif c enddo c if ( l_max .gt. 80 .and. level_err .gt. 0 ) then write(6,20) l_max 20 format(' WARNING: SET_CNO_EXT: largest extension length',i5, $ ' exceeds 80') if ( level_err .ge. 2 ) stop $ ' STOP -- SET_CNO_EXT Error: extension too long. ' endif c return end c c****************************************************************************** c subroutine set_cond_file( cfilecond, i_full_path ) c ================================================== c character*(*) cfilecond c parameter ( ndef_cond = 3 ) c character*255 cfile_cond character*80 cdef_cond(ndef_cond) common /c_filename_cond/ need_cond_dir, cfile_cond, cdef_cond save /c_filename_cond/ c character*1 cb(6) common /chkpoc/ cb save /chkpoc/ c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c=== last = lnblnk( cfilecond ) c ibeg = max( 1 , non_blank_begin(cfilecond) ) c if ( i_full_path .gt. 0 ) then need_cond_dir = 0 else need_cond_dir = 1 endif c if ( level_err .gt. 0 ) then c if ( last - ibeg .ge. 255 ) then write(6,10) last - ibeg + 1, cfilecond(ibeg:last) 10 format(' WARNING: length',i5, $ ' exceeds 255 for H&L-Kcond filename:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_COND_FILE Error: name too long. ' endif c iblank = num_blanks_contained( cfilecond ) c if ( iblank .gt. 0 ) then write(6,20) iblank, cfilecond(ibeg:last) 20 format(' WARNING:',i5,' blanks contained in', $ ' H&L-Kcond filename:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_COND_FILE Error: blanks in name. ' endif c endif c cfile_cond = cfilecond(ibeg:) c kavail_cond = 0 c return end c c****************************************************************************** c subroutine set_cond_use( kcond, kreplace_itoh ) c =============================================== c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c if ( kcond .gt. -9 ) then kuse_cond = max( 0 , min( 1 , kcond ) ) else if ( kcond .gt. -99 ) then kuse_cond = 1 endif c if ( kreplace_itoh .gt. -9 ) then itoh_replace = max( -1 , min( 99 , kreplace_itoh ) ) else if ( kreplace_itoh .gt. -99 ) then itoh_replace = 99 endif c kdo_cond = kavail_cond * kuse_cond c return end c c****************************************************************************** c subroutine set_cond_inflags( kcond_fix, kcond_gap, kcond_have ) c =============================================================== c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c if ( kcond_fix .gt. -9 ) then ifix_h_cond_next = max( 0 , min( 1 , kcond_fix ) ) else if ( kcond_fix .gt. -99 ) then ifix_h_cond_next = 1 else ifix_h_cond_next = ifix_h_cond endif c if ( kcond_gap .gt. -9 ) then itoh_gap_next = max( 0 , min( 1 , kcond_gap ) ) else if ( kcond_gap .gt. -99 ) then itoh_gap_next = 1 else itoh_gap_next = itoh_gap endif c if ( kcond_have .gt. -9 ) then kavail_cond = max( 0 , min( 1 , kcond_have ) ) * kavail_cond else if ( kcond_have .gt. -99 .and. $ ( ifix_h_cond_next .ne. ifix_h_cond .or. $ itoh_gap_next .ne. itoh_gap ) ) then kavail_cond = 0 endif c kdo_cond = kavail_cond * kuse_cond c return end c c****************************************************************************** c subroutine ask_cond_use( kcond, kcond_avail, kreplace_itoh ) c ============================================================ c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c kcond = kuse_cond kcond_avail = kavail_cond kreplace_itoh = min( itoh_replace , $ itoh_replace_max(kavail_cond) ) c return end c c****************************************************************************** c subroutine ask_cond_inflags( kc_fix, kc_gap, kc_fix_n, kc_gap_n ) c ================================================================= c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c kc_fix = ifix_h_cond kc_gap = itoh_gap kc_fix_n = ifix_h_cond_next kc_gap_n = itoh_gap_next c return end c c****************************************************************************** c subroutine set_ferg_user( cbeg_ferg ) c ===================================== c character*(*) cbeg_ferg c parameter ( small_1m6=1.e-6 ) c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c if ( cbeg_ferg .eq. ' ' ) then c ctype_ferg(ntyp1_ferg) = ' ' ltype_ferg(ntyp1_ferg) = 0 return c endif c last = lnblnk( cbeg_ferg ) ibeg = max( 1 , non_blank_begin(cbeg_ferg) ) c if ( level_err .gt. 0 ) then c if ( last - ibeg .ge. 80 ) then write(6,10) last - ibeg + 1, cbeg_ferg(ibeg:last) 10 format(' WARNING: length',i4,' exceeds 80 for user-', $ 'supplied Ferguson 2005 file-beginning:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_FERG_USER Error: name too long. ' endif c iblank = num_blanks_contained( cbeg_ferg ) c if ( iblank .gt. 0 ) then write(6,20) iblank, cbeg_ferg(ibeg:last) 20 format(' WARNING:',i4,' blanks contained in user-', $ 'supplied Ferguson 2005 file-beginning:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_FERG_USER Error: blanks in name. ' endif c endif c ltype_ferg(ntyp1_ferg) = min( 80 , last - ibeg + 1 ) ctype_ferg(ntyp1_ferg) = cbeg_ferg(ibeg:) c return end c c****************************************************************************** c subroutine ask_ferg_user( cbeg_ferg ) c ===================================== c character*(*) cbeg_ferg c parameter ( small_1m6=1.e-6 ) c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c cbeg_ferg = ctype_ferg(ntyp1_ferg) c return end c c****************************************************************************** c subroutine set_ferg_acc( iacc ) c =============================== c parameter ( small_1m6=1.e-6 ) c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c common /c_prev_ferg/ zlogp_ferg, xp_ferg, zlp1_ferg, xp1_ferg, $ zlp2_ferg, xp2_ferg, i1p_ferg, i4p_ferg, j1p_ferg, j4p_ferg save /c_prev_ferg/ c iaccin = max( 0 , min( 1 , iacc ) ) c ! switch accuracy flag if ( iaccin .ne. iacc_ferg ) then c iacc_ferg = iaccin c ! clear any cached Z,X-interpolated Ferguson opacities zlogp_ferg = -9.0 xp_ferg = -9.0 zlp1_ferg = -9.0 xp1_ferg = -9.0 zlp2_ferg = -9.0 xp2_ferg = -9.0 i1p_ferg = -1 i4p_ferg = -9 j1p_ferg = -1 j4p_ferg = -9 c endif c return end c c****************************************************************************** c subroutine ask_ferg_acc( iacc ) c =============================== c parameter ( small_1m6=1.e-6 ) c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c iacc = iacc_ferg c return end c c****************************************************************************** c subroutine set_alex_file( cfilealex, i_full_path ) c ================================================== c character*(*) cfilealex c character*255 cfile_alex common /c_filename_alex/ need_alex_dir, cfile_alex save /c_filename_alex/ c character*1 cb(6) common /chkpoc/ cb save /chkpoc/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c=== last = lnblnk( cfilealex ) c ibeg = max( 1 , non_blank_begin(cfilealex) ) c if ( i_full_path .gt. 0 ) then need_alex_dir = 0 else need_alex_dir = 1 endif c if ( level_err .gt. 0 ) then c if ( last - ibeg .ge. 255 ) then write(6,10) last - ibeg + 1, cfilealex(ibeg:last) 10 format(' WARNING: length',i5, $ ' exceeds 255 for Alexander filename:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_ALEX_FILE Error: name too long. ' endif c iblank = num_blanks_contained( cfilealex ) c if ( iblank .gt. 0 ) then write(6,20) iblank, cfilealex(ibeg:last) 20 format(' WARNING:',i5,' blanks contained in', $ ' Alexander filename:'/' ',a) if ( level_err .ge. 2 ) stop $ ' STOP -- SET_ALEX_FILE Error: blanks in name. ' endif c endif c cfile_alex = cfilealex(ibeg:) c return end c c****************************************************************************** c subroutine set_alex_use( kalex ) c ================================ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c if ( kalex .le. -99 ) then return else if ( kalex .le. -9 ) then kuse_alex = 1 else kuse_alex = max( -4 , min( 4 , kalex ) ) endif kold = kdo_alex kdo_alex = min( 1 , kavail_alex ) * kuse_alex c ! if just switched on, make sure low-T c ! high-RHO OPAL limit includes switchover if ( kold .le. 0 .and. kdo_alex .gt. 0 ) then if ( isw_rho_alex .gt. 0 ) then call set_logt_rhosw_alex( -99.0, -99.0 ) else call set_logt6_limits( -99.0, -99.0, -99.0, -99.0 ) call set_logr_limits( -99.0, -99.0, -99.0, -99.0 ) endif endif c return end c c****************************************************************************** c subroutine set_alex_do_rhosw( irhosw ) c ====================================== c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c if ( irhosw .le. -99 ) return c kold = isw_rho_alex if ( irhosw .ne. 0 ) then isw_rho_alex = 1 else isw_rho_alex = 0 endif c ! if just switched on, check its extent to low T c if ( kdo_alex .gt. 0 .and. isw_rho_alex .gt. kold ) $ call set_logt_rhosw_alex( -99.0, -99.0 ) c return end c c****************************************************************************** c subroutine ask_alex_use( kalex, kalex_avail, itype ) c ==================================================== c parameter ( small_1m6=1.e-6 ) c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c kalex = kuse_alex kalex_avail = kavail_alex c if ( kavail_alex .le. 1 ) then itype = isw_rho_alex else if ( itype_ferg .ge. ntyp1_ferg ) then itype = 99 else itype = itype_ferg endif c return end c c****************************************************************************** c subroutine ask_khighz_ofe( khighz_used, ofebrack_used ) c ======================================================= c common /alt_change_opal_z/ main_alt_change, iulow, khighz_in, $ ofebrack_in save /alt_change_opal_z/ c khighz_used = khighz_in ofebrack_used = ofebrack_in c return end c c****************************************************************************** c subroutine ask_opal_file_used( itype, cf_used ) c =============================================== c c itype = -1: OPAL directory c 0: meteoritic-mix file (this file may not actually exist) c 1: main mix file (used if khighz is non-zero) c 2: Alexander opacities file, including directory c 3: conductive opacities file, including directory c 4: GN93hz file (needed to correct Gz???x?? if khighz non-zero) c 5: non-zero [O/Fe] file c 6: CNO-interp main mix file c 7: CNO-interp C --> N file c 8: CNO-interp CO --> N file c 9: CNO-interp CNO --> Ne file c 10: user-mix file c character*(*) cf_used c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opal_used(-1:n_totmix) common /c_mixfiles_used_opal_z/ cfile_opal_used save /c_mixfiles_used_opal_z/ c cf_used = cfile_opal_used( max( -1 , min( n_totmix , itype ) ) ) c return end c c****************************************************************************** c subroutine set_xhi( kxhi ) c ========================== c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( mx_hi=2*mx, mo_m1=mo-1, mx_hi_nz=mx_hi*nz ) c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c ! set high-X flag value kuse_xhi = max( 0 , min( 2 , kxhi ) ) if ( kavail_xhi .le. 0 ) then kdo_xhi = 0 else kdo_xhi = kuse_xhi endif c return end c c****************************************************************************** c subroutine ask_xhi( kxhi, kavail ) c ================================== c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( mx_hi=2*mx, mo_m1=mo-1, mx_hi_nz=mx_hi*nz ) c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c ! return high-X flag value kxhi = kuse_xhi c ! return availability flag kavail = max( 0 , min( 1 , kavail_xhi ) ) c return end c c****************************************************************************** c subroutine set_cno_interp( kcno, kuser ) c ======================================== c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( mx_hi=2*mx, mo_m1=mo-1, mx_hi_nz=mx_hi*nz ) c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c ! set CNO-interpolation flags kuse_cno = max( min( kcno , 1 ) , 0 ) kuse_user = max( min( kuser , 1 ) , 0 ) kdo_cno = kuse_cno * kavail_cno kdo_user = kuse_user * kavail_user c return end c c****************************************************************************** c subroutine ask_cno_interp( kcno, kuser, kcno_avail, kuser_avail ) c ================================================================= c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( mx_hi=2*mx, mo_m1=mo-1, mx_hi_nz=mx_hi*nz ) c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c ! return CNO-interpolation flags kcno = kuse_cno kuser = kuse_user kcno_avail = kavail_cno kuser_avail = kavail_user c return end c c****************************************************************************** c subroutine set_err_check( level ) c ================================= c ! set error-checking level common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c level_err = max( 0 , min( 3 , level ) ) c return end c c****************************************************************************** c subroutine ask_err_check( level ) c ================================= c ! return error-checking level common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c level = level_err c return end c c****************************************************************************** c subroutine set_logt6_limits( vlo, dvlo, vhi, dvhi ) c =================================================== c parameter ( small_1m6=1.e-6 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_tsw_ferg/ slt_max_ferg, sltswlo_ferg_def, $ sltswhi_ferg_def, sltswlo_ferg, sltswhi_ferg, $ sltswmid_ferg, dltsw2inv_ferg save /c_tsw_ferg/ c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c=== ! set T,R-values, if necessary if ( init_trvals .le. 0 ) call get_trvals c c Set the logT6 limits, according to the input values; by default, make c 1-grid-point extrapolation beyond the matrix edge just within the limits c [sharpest allowed extrapolation cutoff is 1.E-6 (no extrapolation)]. c if ( vlo .gt. -90. ) sltlo = max( alt(1) , min( alt(nt) , vlo ) ) c c ! if molecular opacity-inclusion is set, make sure c ! low-T OPAL limit is low enough for switchover if ( kdo_alex .gt. 0 ) then if ( kavail_alex .eq. 1 ) then sltlo = max( alt(1) , min( sltlo , fltswlo_alex - 6. ) ) else sltlo = max( alt(1) , min( sltlo , sltswlo_ferg ) ) endif endif c if ( dvlo .lt. -90. ) then dltlo_inv = max( dltlo_inv , $ 1. / ( sltlo - alt(1) + 0.999999 / dfs(1) ) ) else if ( dvlo .lt. 0. ) then dltlo_inv = dfs(1) * 0.999999 else dltlo_inv = 1. / min( max( dvlo , 0.000001 ) , $ sltlo - alt(1) + 0.999999 / dfs(1) ) endif c ! if Alexander opacity-inclusion is set, make sure any high-RHO c ! switchover from Alexander to OPAL does not extend too low in T c if ( kdo_alex .gt. 0 .and. $ kavail_alex .eq. 1 .and. isw_rho_alex .gt. 0 ) $ call set_logt_rhosw_alex( -99.0, -99.0 ) c if ( vhi .gt. -90. ) slthi = max( alt(1) , min( alt(nt) , vhi ) ) c if ( dvhi .lt. -90. ) then dlthi_inv = max( dlthi_inv , $ 1. / ( alt(nt) - slthi + 0.999999 / dfs(nt) ) ) else if ( dvhi .lt. 0. ) then dlthi_inv = dfs(nt) * 0.999999 else dlthi_inv = 1. / min( max( dvhi , 0.000001 ) , $ alt(nt) - slthi + 0.999999 / dfs(nt) ) endif c return end c c****************************************************************************** c subroutine set_logr_limits( vlo, dvlo, vhi, dvhi ) c ================================================== c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c=== ! set T,R-values, if necessary if ( init_trvals .le. 0 ) call get_trvals c c Set the logR limits, according to the input values; by default, make c 1-grid-point extrapolation beyond the matrix edge just within the limits c [sharpest allowed extrapolation cutoff is 1.E-6 (no extrapolation)]. c if ( vlo .gt. -90. ) slrlo = max( alr(1) , min( alr(nr) , vlo ) ) c if ( dvlo .lt. -90. ) then dlrlo_inv = max( dlrlo_inv , $ 1. / ( slrlo - alr(1) + 0.999999 / dfsr(1) ) ) else if ( dvlo .lt. 0. ) then dlrlo_inv = dfsr(1) * 0.999999 else dlrlo_inv = 1. / min( max( dvlo , 0.000001 ) , $ slrlo - alr(1) + 0.999999 / dfsr(1) ) endif c if ( vhi .gt. -90. ) slrhi = max( alr(1) , min( alr(nr) , vhi ) ) c c ! if Alexander opacity-inclusion is set, make sure OPAL opacity c ! is calculated throughout switchover region if ( kdo_alex .gt. 0 .and. kavail_alex .eq. 1 ) then if ( isw_rho_alex .le. 0 ) then slrhi = max( slrhi , min( alr(nr) , flrhoswhi_alex $ - 1. / dfsr(nr) - 3. * ( fltswlo_alex - 6. ) ) ) else slrhi = max( slrhi , min( alr(nr) , flrhoswhi_alex $ - 1. / dfsr(nr) - 3. * ( fltswlo_r_alex - 6. ) ) ) endif endif c if ( dvhi .lt. -90. ) then dlrhi_inv = max( dlrhi_inv , $ 1. / ( alr(nr) - slrhi + 0.999999 / dfsr(nr) ) ) else if ( dvhi .lt. 0. ) then dlrhi_inv = dfsr(nr) * 0.999999 else dlrhi_inv = 1. / min( max( dvhi , 0.000001 ) , $ alr(nr) - slrhi + 0.999999 / dfsr(nr) ) endif c return end c c****************************************************************************** c subroutine reset_z_limits( vlo, dvlo, vhi, dvhi ) c ================================================= c parameter ( small_1m6=1.e-6, small_m1m6=-1.e-6 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c ! if no opacities were read in, cannot reset! c if ( itime .ne. 12345678 ) return c if ( min( vlo , vhi ) .gt. small_m1m6 ) then zlow = max( zsto(1) , min( vlo , vhi , zsto(numz) ) ) zhigh = min( zsto(numz) , max( vhi , vlo , zsto(1) ) ) else if ( vlo .gt. small_m1m6 ) then zlow = max( zsto(1) , min( vlo , zhigh , zsto(numz) ) ) else if ( vhi .gt. small_m1m6 ) then zhigh = min( zsto(numz) , max( vhi , zlow , zsto(1) ) ) endif c if ( dvlo .gt. small_m1m6 ) then if ( zlow .le. zsto(1) + zacc(1) ) then zlo_ex = zlow - max( dvlo , zacc(1) ) else zlo_ex = zlow - max( dvlo , zacc(numz) ) endif else if ( zlow .le. zsto(1) + zacc(1) ) then zlo_ex = min( zlo_ex , zlow - zacc(1) ) else zlo_ex = min( zlo_ex , zlow - zacc(numz) ) endif c if ( dvhi .gt. small_m1m6 ) then zhi_ex = zhigh + max( dvhi , zacc(numz) ) else zhi_ex = max( zhi_ex , zhigh + zacc(numz) ) endif c return end c c****************************************************************************** c subroutine ask_logt6_limits( vlo, dvlo, vhi, dvhi ) c =================================================== c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c=== ! set T,R-values, if necessary if ( init_trvals .le. 0 ) call get_trvals c vlo = sltlo dvlo = 1. / dltlo_inv vhi = slthi dvhi = 1. / dlthi_inv c return end c c****************************************************************************** c subroutine ask_logr_limits( vlo, dvlo, vhi, dvhi ) c ================================================== c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c=== ! set T,R-values, if necessary if ( init_trvals .le. 0 ) call get_trvals c vlo = slrlo dvlo = 1. / dlrlo_inv vhi = slrhi dvhi = 1. / dlrhi_inv c return end c c****************************************************************************** c subroutine ask_z_limits( nzmax, zmin, zmax ) c ============================================ c c Returns NZ (maximum allowed stored Z-values) and Z-limits (0.0 and 0.1) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( mz=8, mz_m1=mz-1, mz_m2=mz-2, mzhi=11, mzal=13, $ nzm=mzal+1, nadd_zavail=nzm-mz ) c=== nzmax = min( nz , nzm ) zmin = 0.0 zmax = 0.1 c return end c c****************************************************************************** c subroutine ask_z_use( nzuse, zlo, zmid, zhi, zloex, zhiex ) c =========================================================== c parameter ( small_m1m8=-1.e-8 ) c c Returns the current values of numz, zlow, zmiddle, zhigh, zlo_ex, zhi_ex c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c=== if ( itime .ne. 12345678 ) then nzuse = 0 zlo = 0. zmid = 0.02 zhi = 0.1 zloex = small_m1m8 zhiex = 0.12 else nzuse = numz zlo = zlow zmid = zmiddle zhi = zhigh zloex = zlo_ex zhiex = zhi_ex endif c return end c c****************************************************************************** c subroutine ask_z_array( kzstart, karraystart, zarray, narray ) c ============================================================== c c Returns Z-values from zsto(), starting with element kzstart, in the c array zarray(narray), starting with element karraystart; any excess c elements in zarray() after nums is reached are filled with values of -1. c dimension zarray(narray) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c=== if ( itime .ne. 12345678 ) then nzuse = 0 else nzuse = numz endif c k_z = max( kzstart , 1 ) k_a = karraystart do while ( k_z .le. nzuse .and. k_a .le. narray ) zarray(k_a) = zsto(k_z) k_a = k_a + 1 k_z = k_z + 1 enddo do while ( k_a .le. narray ) zarray(k_a) = -1. k_a = k_a + 1 enddo c return end c c****************************************************************************** c subroutine set_smooth( initsmooth, lowCOsmooth, interpCOsmooth ) c ================================================================ c common/c_opal_ctrl_smooth/ init_smo, low_CO_smo, interp_CO_smo save /c_opal_ctrl_smooth/ c if ( initsmooth .ge. 0 ) init_smo = min( initsmooth , 2 ) c if ( lowCOsmooth .ge. 0 ) low_CO_smo = min( lowCOsmooth , 1 ) c if ( interpCOsmooth .ge. 0 ) $ interp_CO_smo = min( interpCOsmooth , 1 ) c return end c c****************************************************************************** c subroutine ask_smooth( initsmooth, lowCOsmooth, interpCOsmooth ) c ================================================================ c common/c_opal_ctrl_smooth/ init_smo, low_CO_smo, interp_CO_smo save /c_opal_ctrl_smooth/ c initsmooth = init_smo c lowCOsmooth = low_CO_smo c interpCOsmooth = interp_CO_smo c return end c c****************************************************************************** c subroutine set_logt_sw_ferg( fltsw_lo, fltsw_hi ) c ================================================= c parameter ( small_1m6=1.e-6 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c common /opac_ferg/ zlog_ferg(nzp1_ferg), xlog_ferg(nx_ferg), $ dzinvlog_ferg(nz_ferg), dzinv_ferg(nz_ferg), $ dxinvlog_ferg(nx_ferg), dxinv_ferg(nx_ferg), $ t6log_ferg(nt_ferg), rlog_ferg(nr_ferg), $ dt6inv_ferg(nt_ferg), drinv_ferg(nr_ferg), $ modt_ferg, modz0_ferg, ntuferg save /opac_ferg/ c common /c_tsw_ferg/ slt_max_ferg, sltswlo_ferg_def, $ sltswhi_ferg_def, sltswlo_ferg, sltswhi_ferg, $ sltswmid_ferg, dltsw2inv_ferg save /c_tsw_ferg/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c ! set T,R-values, if necessary if ( init_trvals .le. 0 ) call get_trvals c slt_min = alt(1) c if ( fltsw_lo .lt. -90.0 ) then c if ( fltsw_hi .lt. -90.0 ) return c if ( fltsw_hi .lt. -20.0 ) then sltswhi_ferg = sltswhi_ferg_def else sltswhi_ferg = max( slt_min + dt_alex , $ min( slt_max_ferg , fltsw_hi - 6.0 ) ) endif sltswlo_ferg = min( sltswlo_ferg , sltswhi_ferg - dt_alex ) c else if ( fltsw_hi .lt. -90.0 ) then c if ( fltsw_hi .lt. -20.0 ) then sltswlo_ferg = sltswlo_ferg_def else sltswlo_ferg = min( slt_max_ferg - dt_alex , $ max( slt_min , fltsw_lo - 6.0 ) ) endif sltswhi_ferg = max( sltswhi_ferg , sltswlo_ferg + dt_alex ) c else if ( fltsw_lo .lt. -20.0 ) then c if ( fltsw_hi .lt. -20.0 ) then sltswhi_ferg = sltswhi_ferg_def sltswlo_ferg = sltswlo_ferg_def else sltswhi_ferg = max( slt_min + dt_alex , $ min( slt_max_ferg , fltsw_hi - 6.0 ) ) sltswlo_ferg = max( slt_min , sltswhi_ferg $ - ( sltswhi_ferg_def - sltswlo_ferg_def ) ) endif c else if ( fltsw_hi .lt. -20.0 ) then c sltswlo_ferg = min( slt_max_ferg - dt_alex , $ max( slt_min , fltsw_lo - 6.0 ) ) sltswhi_ferg = min( slt_max_ferg , $ sltswlo_ferg + ( sltswhi_ferg_def - sltswlo_ferg_def ) ) c else if ( abs( fltsw_hi - fltsw_lo ) .lt. dt_alex ) then c sltswlo_ferg = min( slt_max_ferg - dt_alex , max( slt_min , $ ( fltsw_hi + fltsw_lo ) / 2.0 - 6.0 - 0.5 * dt_alex ) ) sltswhi_ferg = sltswlo_ferg + dt_alex c else c sltswhi_ferg = max( fltsw_hi , fltsw_lo ) - 6.0 sltswlo_ferg = min( fltsw_hi , fltsw_lo ) - 6.0 c if ( sltswhi_ferg .gt. slt_max_ferg ) then sltswhi_ferg = slt_max_ferg sltswlo_ferg = max( slt_min , $ slt_max_ferg - abs( fltsw_hi - fltsw_lo ) ) else if ( sltswlo_ferg .lt. slt_min ) then sltswlo_ferg = slt_min sltswhi_ferg = min( slt_max_ferg , $ slt_min + abs( fltsw_hi - fltsw_lo ) ) endif c endif c c ! if Ferguson opacity-inclusion is set, make sure low-T OPAL limit includes c ! the switchover region if ( kdo_alex .gt. 0 .and. kavail_alex .gt. 1 ) $ call set_logt6_limits( -99.0, -99.0, -99.0, -99.0 ) c return end c c****************************************************************************** c subroutine ask_logt_sw_ferg( fltsw_lo, fltsw_hi ) c ================================================= c common /c_tsw_ferg/ slt_max_ferg, sltswlo_ferg_def, $ sltswhi_ferg_def, sltswlo_ferg, sltswhi_ferg, $ sltswmid_ferg, dltsw2inv_ferg save /c_tsw_ferg/ c fltsw_lo = sltswlo_ferg + 6.0 fltsw_hi = sltswhi_ferg + 6.0 c return end c c****************************************************************************** c subroutine set_logt_sw_alex( fltsw_lo, fltsw_hi ) c ================================================= c parameter ( small_1m6=1.e-6 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c common /c_ini_alex/ z_alex(nzp1_alex),x_alex(nx_alex), $ flt_alex(nt_alex),flro_alex(nrlo_alex:nr_alex) save /c_ini_alex/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c ! set T,R-values, if necessary if ( init_trvals .le. 0 ) call get_trvals c flt_min = alt(1) + 6. c if ( fltsw_lo .lt. -90.0 ) then c if ( fltsw_hi .lt. -90.0 ) return c if ( fltsw_hi .lt. -20.0 ) then fltswhi_alex = fltswhi_alex_def else fltswhi_alex = max( flt_min + dt_alex , $ min( flt_alex(nt_alex) , fltsw_hi ) ) endif fltswlo_alex = min( fltswlo_alex , fltswhi_alex - dt_alex ) c else if ( fltsw_hi .lt. -90.0 ) then c if ( fltsw_hi .lt. -20.0 ) then fltswlo_alex = fltswlo_alex_def else fltswlo_alex = min( flt_alex(nt_alex) - dt_alex , $ max( flt_min , fltsw_lo ) ) endif fltswhi_alex = max( fltswhi_alex , fltswlo_alex + dt_alex ) c else if ( fltsw_lo .lt. -20.0 ) then c if ( fltsw_hi .lt. -20.0 ) then fltswhi_alex = fltswhi_alex_def fltswlo_alex = fltswlo_alex_def else fltswhi_alex = max( flt_min + dt_alex , $ min( flt_alex(nt_alex) , fltsw_hi ) ) fltswlo_alex = max( flt_min , $ fltswhi_alex - 2. * dt_alex ) endif c else if ( fltsw_hi .lt. -20.0 ) then c fltswlo_alex = min( flt_alex(nt_alex) - dt_alex , $ max( flt_min , fltsw_lo ) ) fltswhi_alex = min( flt_alex(nt_alex) , $ fltswlo_alex + 2. * dt_alex ) c else if ( abs( fltsw_hi - fltsw_lo ) .lt. dt_alex ) then c fltswlo_alex = min( flt_alex(nt_alex) - dt_alex , $ max( flt_min , $ ( fltsw_hi + fltsw_lo ) / 2.0 - 0.5 * dt_alex ) ) fltswhi_alex = fltswlo_alex + dt_alex c else c fltswhi_alex = min( flt_alex(nt_alex) , $ max( flt_min + dt_alex , fltsw_lo , fltsw_hi ) ) fltswlo_alex = max( flt_min , min( flt_alex(nt_alex) $ - dt_alex , fltsw_lo , fltsw_hi ) ) c endif c fltswmid_alex = ( fltswhi_alex + fltswlo_alex ) / 2. dltsw2inv_alex = 4. / ( fltswhi_alex - fltswlo_alex )**2 sltswhi_alex = fltswhi_alex - 6. sltswlo_alex = fltswlo_alex - 6. c c ! if Alexander opacity-inclusion is set, make sure low-T, high-RHO c ! OPAL limit includes switchover region if ( kdo_alex .gt. 0 .and. kavail_alex .eq. 1 ) then call set_logt6_limits( -99.0, -99.0, -99.0, -99.0 ) call set_logr_limits( -99.0, -99.0, -99.0, -99.0 ) endif c return end c c****************************************************************************** c subroutine set_logrho_sw_alex( flrhosw_lo, flrhosw_hi ) c ======================================================= c parameter ( small_1m6=1.e-6 ) c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c common /c_ini_alex/ z_alex(nzp1_alex),x_alex(nx_alex), $ flt_alex(nt_alex),flro_alex(nrlo_alex:nr_alex) save /c_ini_alex/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c if ( flrhosw_lo .lt. -90.0 ) then c if ( flrhosw_hi .lt. -90.0 ) return c if ( flrhosw_hi .lt. -20.0 ) then flrhoswhi_alex = flrhoswhi_alex_def else flrhoswhi_alex = max( flro_alex(1) + dro_alex , $ min( flro_alex(nr_alex) + dro_alex , flrhosw_hi ) ) endif flrhoswlo_alex = min( flrhoswlo_alex , $ flrhoswhi_alex - dro_alex ) c else if ( flrhosw_hi .lt. -90.0 ) then c if ( flrhosw_lo .lt. -20.0 ) then flrhoswlo_alex = flrhoswlo_alex_def else flrhoswlo_alex = min( flro_alex(nr_alex) , $ max( flro_alex(1) , flrhosw_lo ) ) endif flrhoswhi_alex = max( flrhoswhi_alex , $ flrhoswlo_alex + dro_alex ) c else if ( flrhosw_lo .lt. -20.0 ) then c if ( flrhosw_hi .lt. -20.0 ) then flrhoswhi_alex = flrhoswhi_alex_def flrhoswlo_alex = flrhoswlo_alex_def else flrhoswhi_alex = max( flro_alex(1) + dro_alex , $ min( flro_alex(nr_alex) + dro_alex , flrhosw_hi ) ) flrhoswlo_alex = max( flro_alex(1) , $ flrhoswhi_alex - 2. * dro_alex ) endif c else if ( flrhosw_hi .lt. -20.0 ) then c flrhoswlo_alex = min( flro_alex(nr_alex) , $ max( flro_alex(1) , flrhosw_lo ) ) flrhoswhi_alex = min( flro_alex(nr_alex) + dro_alex , $ flrhoswlo_alex + 2. * dro_alex ) c else c flrhoswhi_alex = min( flro_alex(nr_alex) + dro_alex , $ max( flro_alex(1) + dro_alex , $ flrhosw_lo , flrhosw_hi ) ) flrhoswlo_alex = max( flro_alex(1) , $ min( flro_alex(nr_alex) , flrhosw_lo , flrhosw_hi ) ) c if ( flrhoswhi_alex - flrhoswlo_alex .lt. dro_alex ) then flrhoswhi_alex = min( flro_alex(nr_alex) + dro_alex , $ flrhoswhi_alex + 0.5 * ( dro_alex $ - ( flrhoswhi_alex - flrhoswlo_alex ) ) ) flrhoswlo_alex = max( flro_alex(1) , $ flrhoswhi_alex - dro_alex ) flrhoswhi_alex = flrhoswlo_alex + dro_alex endif c endif c flrhoswmid_alex = ( flrhoswhi_alex + flrhoswlo_alex ) / 2. dlrhosw2inv_alex = 4. / ( flrhoswhi_alex - flrhoswlo_alex )**2 c c ! make sure low-T, high-RHO OPAL limit includes c ! switchover region if ( kdo_alex .gt. 0 .and. $ kavail_alex .eq. 1 .and. isw_rho_alex .gt. 0 ) $ call set_logt_rhosw_alex( -99.0, -99.0 ) c return end c c****************************************************************************** c subroutine set_logt_rhosw_alex( fltsw_r_lo, fltsw_r_hi ) c ======================================================== c parameter ( small_1m6=1.e-6 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c common /c_ini_alex/ z_alex(nzp1_alex),x_alex(nx_alex), $ flt_alex(nt_alex),flro_alex(nrlo_alex:nr_alex) save /c_ini_alex/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c=== ! set T,R-values, if necessary if ( init_trvals .le. 0 ) call get_trvals c flt_min = alt(1) + 6. c if ( fltsw_r_lo .lt. -90.0 ) then c if ( fltsw_r_hi .lt. -90.0 ) then c if ( fltswhi_r_alex .gt. fltswhi_alex ) then fltswlo_r_alex = max( flt_min - dt_alex , $ fltswhi_alex $ - ( fltswhi_r_alex - fltswlo_r_alex ) ) fltswhi_r_alex = fltswhi_alex endif c else if ( fltsw_r_hi .lt. -20.0 ) then c fltswhi_r_alex = min( fltswhi_alex - dt_alex , $ fltswhi_r_alex_def ) fltswlo_r_alex = min( fltswlo_r_alex , $ fltswhi_r_alex - dt_alex ) c else c fltswhi_r_alex = max( flt_min , $ min( fltswhi_alex , fltsw_r_hi ) ) fltswlo_r_alex = min( fltswlo_r_alex , $ fltswhi_r_alex - dt_alex ) c endif c else if ( fltsw_r_hi .lt. -90.0 ) then c if ( fltsw_r_lo .lt. -20.0 ) then fltswlo_r_alex = fltswlo_r_alex_def else fltswlo_r_alex = min( fltswhi_alex - dt_alex , $ max( flt_min - dt_alex , fltsw_r_lo ) ) endif fltswhi_r_alex = max( fltswhi_r_alex , $ fltswlo_r_alex + dt_alex ) c else if ( fltsw_r_lo .lt. -20.0 ) then c if ( fltsw_r_hi .lt. -20.0 ) then fltswhi_r_alex = min( fltswhi_alex - dt_alex , $ fltswhi_r_alex_def ) else fltswhi_r_alex = min( fltswhi_alex , $ max( flt_min , fltsw_r_hi ) ) endif fltswlo_r_alex = max( flt_min , $ fltswhi_r_alex - dt_alex ) - dt_alex c else if ( fltsw_r_hi .lt. -20.0 ) then c fltswlo_r_alex = max( flt_min - dt_alex , $ min( fltswhi_alex - dt_alex , fltsw_r_lo , fltsw_r_hi ) ) fltswhi_r_alex = min( fltswhi_alex , $ fltswlo_r_alex + 2. * dt_alex ) c else c fltswhi_r_alex = min( fltswhi_alex , $ max( flt_min , fltsw_r_lo , fltsw_r_hi ) ) fltswlo_r_alex = max( flt_min - dt_alex , $ min( fltswhi_alex - dt_alex , fltsw_r_lo , fltsw_r_hi ) ) c if ( fltswhi_r_alex - fltswlo_r_alex .lt. dt_alex ) then fltswhi_r_alex = min( fltswhi_alex , $ fltswhi_r_alex + 0.5 * ( dt_alex $ - ( fltswhi_r_alex - fltswlo_r_alex ) ) ) fltswlo_r_alex = max( flt_min - dt_alex , $ fltswhi_r_alex - dt_alex ) fltswhi_r_alex = fltswlo_r_alex + dt_alex endif c endif c ! make sure overlap region is O.K. if ( kdo_alex .gt. 0 .and. $ kavail_alex .eq. 1 .and. isw_rho_alex .gt. 0 ) then itmp = isw_rho_alex c ! set_logt6_limits must NOT call set_logt_rhosw_alex isw_rho_alex = 0 call set_logt6_limits( -99.0, -99.0, -99.0, -99.0 ) call set_logr_limits( -99.0, -99.0, -99.0, -99.0 ) isw_rho_alex = itmp if ( fltswlo_r_alex .lt. sltlo - 1. / dltlo_inv + 6. ) then fltswhi_r_alex = min( fltswhi_alex , sltlo - 1. / dltlo_inv $ + 6. + ( fltswhi_r_alex - fltswlo_r_alex ) ) fltswlo_r_alex = sltlo - 1. / dltlo_inv + 6. endif endif c fltswmid_r_alex = ( fltswhi_r_alex + fltswlo_r_alex ) / 2. dltsw2inv_r_alex = 4. / ( fltswhi_r_alex - fltswlo_r_alex )**2 c return end c c****************************************************************************** c subroutine ask_logt_sw_alex( fltsw_lo, fltsw_hi ) c ================================================= c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c fltsw_lo = fltswlo_alex fltsw_hi = fltswhi_alex c return end c c****************************************************************************** c subroutine ask_logrho_sw_alex( flrhosw_lo, flrhosw_hi ) c ======================================================= c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c flrhosw_lo = flrhoswlo_alex flrhosw_hi = flrhoswhi_alex c return end c c****************************************************************************** c subroutine ask_logt_rhosw_alex( fltsw_r_lo, fltsw_r_hi ) c ======================================================== c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c fltsw_r_lo = fltswlo_r_alex fltsw_r_hi = fltswhi_r_alex c return end c c****************************************************************************** c subroutine readco(z,kallrd,khighz,iu_lo) c ======================================== c c..... The purpose of this subroutine is to read the data tables; actually, c it just calls READEXCO to do the work, setting [O/Fe] = 0.0 c c Z is the metallicity; opacities will be interpolated (quadratically) in Z if c necessary, with values of Z from 0.0 to 0.1 being allowed. c kallrd is ignored (it is present only for backward compatibility). c if khighz = 0 , then the file GN93hz is not used; else, GN93hz (or GS98hz, c for khighz < 0) may be used for the case C=O=0.0 to get improved opacities. c iu_lo is the unit number from which the lowest Z-value files are read; c units iu_lo thru iu_lo+3 may be needed. c c=== call readexco(z,kallrd,max(min(khighz,1),-1),iu_lo,0.0) c return end c c****************************************************************************** c subroutine readexco(z,kallrd,khighz,iu_lo,ofebrack) c =================================================== c c..... The purpose of this subroutine is to read the data tables c c Z is the metallicity; opacities will be interpolated (quadratically) in Z if c necessary, with values of Z from 0.0 to 0.1 being allowed. c kallrd is ignored (it is present only for backward compatibility). c if khighz = 0 , then the file GN93hz is not used; c = 1 or more, then GN93hz is used if it will improve Z-interpolation c = 2 , then Alrd96a2 and GN93hz are used to interpolate in [O/Fe] c = 3 , then C95hz and GN93hz are used to interpolate in [O/Fe] c = 4 , then W95hz and GN93hz are used to interpolate in [O/Fe] c = 5 , then GN93hz and a user-specified file are used to interpolate c in [O/Fe] c = -1 thru -5 : use GS98hz (and its variants with [O/Fe] > 0.0, for c khighz < -1) to get alternate-mix opacities (note that the c file GN93hz is still read in, for reference purposes) c = -11 thru -15, 11 thru 15: same as khighz = -1 thru -5 and 1 thru c 5, except that CNO-interpolation opacity files are read in c = -21 thru -25, 21 thru 25: same as khighz = -1 thru -5 and 1 thru c 5, except that a user-specified opacity interpolation file c is read in c = -31 thru -35, 31 thru 35: same as khighz = -1 thru -5 and 1 thru c 5, except that BOTH the CNO- and user-specified opacity c interpolation files are read in c iu_lo is the unit number from which the lowest Z-value files are read; c units iu_lo thru iu_lo+3 may be needed. c ofebrack is [O/Fe], logarithmic oxygen (or alpha-element) enhancement factor, c relative to the Sun: ofebrack = log10{ (O_mix/Fe_mix) / (O_sun/Fe_sun) } . c If khighz is 0 or 1, then ofebrack is ignored; otherwise, interpolate c logKappa linearly between mix 1 and mix khighz, the interpolation factors c being such as to yield the desired [O/Fe] from combining these mixes. c Note that GN93hz has [O/Fe] = 0.0, Alrd96a2 has [O/Fe] = 0.3, C95hz has c [O/Fe] = 0.4, and W95hz has [O/Fe] = 0.5, but they have different patterns c of enhancements for elements other than oxygen. For khighz < 0, it is the c new file GS98hz that is defined to have [O/Fe] = 0.0, and its variants (by c default, GS98hz_OFe.3_Alrd96a2, GS98hz_OFe.4_C95, and GS98hz_OFe.5_W95) are c the ones used to interpolate in [O/Fe]. c parameter ( small_1m8=1.e-8, small_m1m6=-1.e-6 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c parameter ( mx_hi=2*mx ) c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c common /c_level_list_opal_z/ iu_list, level_list, list_mult, $ list_gn(-n_zmixes:n_totmix) save /c_level_list_opal_z/ c=== numz = 1 if ( z .lt. small_m1m6 ) then zat = 0.02 else if ( z .lt. small_1m8 ) then zat = 0. else zat = z endif kavail_cno = 1 kavail_user = 1 c do i = -n_zmixes, n_totmix list_gn(i) = level_list enddo list_mult = level_list c if ( level_list .gt. 0 ) then write(iu_list,1) zat, ofebrack 1 format(' ***OPAL single Z =',f11.8,', [O/Fe] =',f11.7, $ ': read the following files:') endif c call read_kz(1,zat,kallrd,khighz,iu_lo,ofebrack) c zlow = zat - zacc(1) zmiddle = zat zhigh = zat + zacc(1) zlo_ex = zlow - zacc(1) zhi_ex = zhigh + zacc(1) dfsz(1) = 1. c call finish_cno c do i = -n_zmixes, n_totmix list_gn(i) = 0 enddo list_mult = 0 c return end c c****************************************************************************** c subroutine readzexco(nzin,zlo,z,zhi,khighz,iu_lo,ofebrack) c ========================================================== c c Similar to READEXCO, except that a range of nzin Z-values from zlo to c zhi are used: see comments near the beginning of this file. c parameter ( small_1m6=1.e-6, small_m1m6=-1.e-6, small_1m8=1.e-8 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c parameter ( mx_hi=2*mx ) c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c parameter ( zdel=0.001, xdel=0.03, xdelmin=0.001 ) c parameter ( mz=8, mz_m1=mz-1, mz_m2=mz-2, mzhi=11, mzal=13, $ nzm=mzal+1, nadd_zavail=nzm-mz ) c common/zinter_opal_z/ zvalhi(mzhi),nofz(mzhi,5,mo),mnofz(mx), $ zval(mz),zalval(mzal),zavail(nzm),iadd_zavail(nadd_zavail) save /zinter_opal_z/ c common /alt_change_opal_z/ main_alt_change, iulow, khighz_in, $ ofebrack_in save /alt_change_opal_z/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c common /c_level_list_opal_z/ iu_list, level_list, list_mult, $ list_gn(-n_zmixes:n_totmix) save /c_level_list_opal_z/ c___ dimension z_use(nzm) c=== kavail_cno = 1 kavail_user = 1 c if ( level_err .gt. 0 .and. main_alt_change .ne. 0 .and. $ khighz .lt. -1 .and. mod( abs(khighz), 10 ) .gt. 1 .and. $ mod( abs(khighz), 10 ) .lt. 5 ) then write(6,5) khighz 5 format(' WARNING: khighz=',i4,' used after', $ ' ''GS98hz'' file replaced: may yield bad [O/Fe].') if ( level_err .gt. 1 ) stop $ ' STOP -- READZEXCO: Error: non-GS98hz, khighz=-2,-3,-4 ' endif c c Get the number of Z-values and the "typical" value of Z c if ( nzin .le. -9 ) then c numz = min( nz , nzm ) c else c if ( level_err .gt. 0 .and. $ ( nzin .le. 0 .or. nzin .gt. nz ) ) then write(6,10) nzin, nz 10 format(' '/' STOP -- READZEXCO: bad Nzin =',i12, $ ' (should lie in range 1 to',i3,').') stop ' STOP -- READZEXCO: Error: bad Nzin value. ' endif c numz = max( 1 , min( nzin , nz , nzm ) ) c endif c if ( z .ge. small_m1m6 ) then zat = z else if ( zlo .gt. small_m1m6 .and. zhi .ge. zlo ) then if ( nzin .eq. 2 ) then zat = ( max( zlo , 0.0 ) + max( zhi , 0.0 ) ) * 0.5 else zat = exp( ( log( max( zlo , 0.0 ) + zdel ) $ + log( max( zhi , 0.0 ) + zdel ) ) * 0.5 ) - zdel endif if ( zat .lt. small_1m8 ) zat = 0. else if ( max( zlo , zhi ) .gt. small_m1m6 ) then zat = max( zlo , zhi , 0.0 ) else zat = 0.02 endif if ( zat .lt. small_1m8 ) zat = 0. c c If there is only one Z-value to store, call readexco instead, and return c (note that readexco will call read_kz and finish_cno): c if ( numz .eq. 1 ) then c call readexco(zat,1,khighz,iu_lo,ofebrack) c if ( nzin .eq. 1 ) then if ( zlo .ge. small_m1m6 ) then zlow = min( zlow , zlo ) zlo_ex = min( zlo_ex , max( 2. * zlow - zmiddle , 0. ) ) endif zhigh = max( zhigh , zhi ) zlo_ex = min( zlo_ex , zlow - zacc(1) ) zhi_ex = max( zhi_ex , 2. * zhigh - zmiddle , $ zhigh + zacc(1) ) endif c return c endif c c If there is more than one Z-value to store: c ! make sure of available Z-values call get_zavail c ! check Z > 0.1 if ( max( zlo , zat , zhi ) .gt. zavail(nzm) + small_1m6 ) then write(6,20) nzin, zlo, zat, zhi, 'Z > 0.1 is not allowed!!!' 20 format(' '/' READZEXCO Error (NumZ=',i2, $ '): bad Z values',3f13.8/' ',a,a) stop ' STOP -- READZEXCO: Error: Z > 0.1 is not allowed!!! ' endif c ! check for Zlo, Z, Zhi out of order zlo_t = max( zlo , 0.0 ) zhi_t = max( zhi , 0.0 ) if ( zlo .lt. small_m1m6 ) zlo_t = zat if ( zhi .lt. small_m1m6 ) zhi_t = zat if ( level_err .gt. 0 .and. ( zat .gt. zhi_t + small_1m6 .or. $ zlo_t .gt. min( zat , zhi_t ) + small_1m6 ) ) then write(6,20) numz, zlo_t, zat, zhi_t, $ 'Zlo, Z, Zhi should be in increasing order' stop ' STOP -- READZEXCO: Error: bad Z values. ' endif c zmiddle = min( zat , zavail(nzm) ) c c If there should be two Z-values, then handle this case and return: if ( numz .eq. 2 ) then c ! error checking if ( level_err .gt. 0 .and. $ max( zlo , zhi ) .gt. small_m1m6 ) then if ( min( zlo , zhi ) .gt. small_m1m6 ) then if ( zhi_t - zlo_t .lt. 0.00001 ) then write(6,20) numz, zlo_t, z, zhi_t, $ 'Zhi - Zlo < 1.E-5: Zlo and Zhi', $ ' too close together for Nzin = 2' stop ' STOP -- READZEXCO: Error: bad Z values. ' else if ( zlo_t * 1.01 .gt. zhi_t + small_1m6 ) then write(6,20) numz, zlo_t, z, zhi_t, $ 'Zhi / Zlo < 1.01: Zlo and Zhi', $ ' too close together for Nzin = 2' stop ' STOP -- READZEXCO: Error: bad Z values. ' endif endif if ( zhi_t .lt. small_1m8 ) then rat_t = 0. else rat_t = zlo_t / zhi_t endif if ( rat_t .lt. 0.6 .and. $ zhi_t - zlo_t .gt. 0.0002 + small_1m8 ) then write(6,20) numz, zlo_t, z, zhi_t, $ 'Zlo / Zhi < 0.6 (and Zhi-Zlo>0.0002):', $ 'Zlo and Zhi too far apart for Nzin = 2' stop ' STOP -- READZEXCO: Error: bad Z values. ' endif endif c c (will be linear interpolation in log[Z+0.001]); default range is plus/minus c 10 percent in Z (or 2.e-5), minimum range is at least 1 percent (or 1.e-5) c if ( iabs(nzin) .gt. 2 .or. $ zlo .lt. small_m1m6 .or. zlo .gt. zat ) then if ( iabs(nzin) .gt. 2 .or. zhi .lt. zat ) then zlow = max( 0.0 , min( 0.9 * zmiddle , $ zmiddle - 0.00001 , 0.8182 * zavail(nzm) ) ) zhigh = min( zavail(nzm) , max( 1.1 * zmiddle , $ zmiddle + 0.00001 , 1.1 * zlow / 0.9 ) ) else zhigh = max( zmiddle , 0.00001 , $ min( zhi , zavail(nzm) ) ) zlow = max( 0.0 , min( zmiddle , $ 0.9 * zhigh / 1.1 , zhigh - 0.00002 ) ) endif else if ( zhi .lt. zat ) then zlow = max( 0.0 , $ min( zlo , zmiddle , zavail(nzm) - 0.01 ) ) zhigh = min( zavail(nzm) , max( zmiddle , $ 1.1 * zlow / 0.9 , zlow + 0.00002 ) ) else if ( zhi - zlo .lt. 0.00001 .or. $ zlo * 1.01 .gt. zhi ) then zlow = max( 0.0 , min( zlo , zmiddle - 0.000005 , $ zmiddle / 1.005 , zavail(nzm) - 0.01 ) ) zhigh = min( zavail(nzm) , max( zhi , zmiddle + 0.000005 , $ zmiddle * 1.005 , 0.00001 ) ) else zlow = max( 0.0 , min( zlo , zavail(nzm) - 0.01 ) ) zhigh = min( zavail(nzm) , zhi ) endif c do i = -n_zmixes, n_totmix list_gn(i) = level_list enddo list_mult = level_list c if ( level_list .gt. 0 ) then write(iu_list,1) numz, zlow, zhigh, ofebrack 1 format(' ***OPAL nZin =',i3,': Z =',f11.8,' ...',f11.8, $ ', [O/Fe] =',f11.7,': read:') endif c zat = zlow call read_kz(1,zat,1,khighz,iu_lo,ofebrack) c zat = zhigh call read_kz(2,zat,1,khighz,iu_lo,ofebrack) c zlo_ex = zlow - 0.5 * ( zhigh - zlow ) zhi_ex = zhigh + 0.5 * ( zhigh - zlow ) dfsz(2) = 1. / ( zvint(2) - zvint(1) ) dfsz(1) = dfsz(2) c call finish_cno c do i = -n_zmixes, n_totmix list_gn(i) = 0 enddo list_mult = 0 c return c c Else if all available Z-values should be used, handle this case and return: c else if ( numz .eq. nzm ) then c zlow = 0.0 zmiddle = zat zhigh = zavail(nzm) zlo_ex = small_m1m6 zhi_ex = 2. * zavail(nzm) - zavail(nzm-1) c do i = -n_zmixes, n_totmix list_gn(i) = level_list enddo list_mult = level_list c if ( level_list .gt. 0 ) then write(iu_list,1) numz, zlow, zhigh, ofebrack endif c do kz = 1, nzm zat = zavail(kz) call read_kz(kz,zat,1,khighz,iu_lo,ofebrack) if ( kz .gt. 1 ) $ dfsz(kz) = 1. / ( zvint(kz) - zvint(kz-1) ) enddo c dfsz(1) = dfsz(2) c call finish_cno c do i = -n_zmixes, n_totmix list_gn(i) = 0 enddo list_mult = 0 c return c endif c c If there should be at least three Z-values: c ! check if Z-range too big if ( level_err .gt. 0 ) then j = mz do while ( j .gt. 2 .and. zhi_t .lt. zval(j-1) + small_1m6 ) j = j - 1 enddo i = 1 do while ( i .lt. j - 1 .and. $ zlo_t .gt. zval(i+1) - small_1m6 ) i = i + 1 enddo if ( numz .lt. j - i ) then write(6,20) numz, zlo_t, z, zhi_t, $ 'Zlo and Zhi too far apart for given Nzin value' stop ' STOP -- READZEXCO: Error: bad Z values. ' endif endif c ! check for input Z-range ilodel = 1 if ( zlo .lt. small_m1m6 .or. $ ( zlo .gt. zhi .and. zhi .ge. small_m1m6 ) .or. $ ( zlo .gt. z .and. z .ge. small_m1m6 ) ) then if ( z .ge. small_m1m6 ) then zlow = z else zlow = zat endif else zlow = zlo ilodel = 0 endif if ( zlow .lt. small_1m8 ) then zlow = 0. ilo1 = 1 ilo2 = 1 else zlow = min( zlow , zavail(nzm-2) ) ilo2 = nzm - 2 do while ( ilo2 .gt. 2 .and. $ zlow .lt. zavail(ilo2-1) + small_1m6 ) ilo2 = ilo2 - 1 enddo ilo1 = 1 do while ( ilo1 .lt. ilo2 .and. $ zlow .gt. zavail(ilo1+1) - small_1m6 ) ilo1 = ilo1 + 1 enddo endif c ihidel = 1 if ( zhi .ge. max( z , zlo , small_m1m6 ) ) then zhigh = zhi ihidel = 0 else if ( z .gt. small_m1m6 ) then zhigh = z else zhigh = zat endif zhigh = max( zavail(3) , min( zavail(nzm) , zhigh ) ) if ( ilodel .eq. 0 .and. ilo1 .ge. nzm + 1 - numz ) then ihi2 = nzm ilo1 = nzm + 1 - numz else ihi2 = nzm do while ( ihi2 .gt. 3 .and. $ zhigh .lt. zavail(ihi2-1) + small_1m6 ) ihi2 = ihi2 - 1 enddo ihi1 = 3 do while ( ihi1 .lt. ihi2 .and. $ zhigh .gt. zavail(min(ihi1+1,nzm)) - small_1m6 ) ihi1 = ihi1 + 1 enddo if ( ihidel .eq. 0 .and. ihi2 .le. numz ) then ilo1 = 1 ihi2 = numz endif endif c c If the number of Z-values to be used "numz" is sufficent to encompass the c input Z-range, then handle this case and return: c if ( ihi2 - ilo1 .lt. numz ) then c ! get range -> numz, alternately adding c ! low and high Z-values if ( numz .eq. 3 .and. ihi2 - ilo1 .eq. 1 .and. $ zavail(ihi2) - z .lt. z - zavail(ilo1) .and. $ ( ihidel .gt. 0 .or. ilodel .eq. 0 ) ) $ ihi2 = min( ihi2 + 1 , nzm ) do while ( ihi2 - ilo1 + 1 .lt. numz .and. $ ( ( ilo1 .gt. 1 .and. ilodel .gt. 0 ) .or. $ ( ihi2 .lt. nzm .and. ihidel .gt. 0 ) ) ) ilo1 = max( ilo1 - ilodel , 1 ) if ( ihi2 - ilo1 + 1 .lt. numz ) $ ihi2 = min( ihi2 + ihidel , nzm ) enddo do while ( ihi2 - ilo1 + 1 .lt. numz ) ilo1 = max( ilo1 - 1 , 1 ) if ( ihi2 - ilo1 + 1 .lt. numz ) $ ihi2 = min( ihi2 + 1 , nzm ) enddo c zlow = zavail(ilo1) if ( numz .eq. 3 ) then zmiddle = zavail(ilo1+1) else if ( z .lt. small_m1m6 ) then zmiddle = ( zhi + zlo ) * 0.5 endif zhigh = zavail(ihi2) if ( ilo1 .eq. 1 ) then zlo_ex = small_m1m6 else zlo_ex = zavail(ilo1-1) endif zhi_ex = 2. * zavail(ihi2) - zavail(ihi2-1) c do i = -n_zmixes, n_totmix list_gn(i) = level_list enddo list_mult = level_list c if ( level_list .gt. 0 ) then write(iu_list,1) numz, zlow, zhigh, ofebrack endif c do kz = 1, numz zat = zavail(ilo1+kz-1) call read_kz(kz,zat,1,khighz,iu_lo,ofebrack) if ( kz .gt. 1 ) $ dfsz(kz) = 1. / ( zvint(kz) - zvint(kz-1) ) enddo c dfsz(1) = dfsz(2) c call finish_cno c do i = -n_zmixes, n_totmix list_gn(i) = 0 enddo list_mult = 0 c return c endif c c The input Z-range does not fit between a set of numz values from zavail(); c if the input value of numz was 3, then use the input Z-range even if it is c VERY wide (check only for unbalanced intervals in log[Z+0.001]), and return: c if ( numz .eq. 3 .and. nzin .eq. 3 ) then c zl_1 = log10( zlow + zdel ) zl_2 = log10( zmiddle + zdel ) zl_3 = log10( zhigh + zdel ) if ( 2. * ( zl_3 - zl_2 ) .lt. zl_2 - zl_1 .or. $ 2.6 * ( zl_2 - zl_1 ) .lt. zl_3 - zl_2 ) then zl_2 = ( zl_1 + zl_3 ) * 0.5 zmiddle = 10.**zl_2 - zdel endif c do i = -n_zmixes, n_totmix list_gn(i) = level_list enddo list_mult = level_list c if ( level_list .gt. 0 ) then write(iu_list,1) numz, zlow, zhigh, ofebrack endif c zat = zlow call read_kz(1,zat,1,khighz,iu_lo,ofebrack) zat = zmiddle call read_kz(2,zat,1,khighz,iu_lo,ofebrack) zat = zhigh call read_kz(3,zat,1,khighz,iu_lo,ofebrack) c dfsz(3) = 1. / ( zvint(3) - zvint(2) ) dfsz(2) = 1. / ( zvint(2) - zvint(1) ) dfsz(1) = dfsz(2) c zlo_ex = min( zlow - zacc(1) , $ 10.**( zl_1 - min( zl_2 - zl_1 , $ log10( ( zavail(ilo1+1) + zdel ) $ / ( zavail(ilo1) + zdel ) ) ) ) - zdel ) if ( zlo_ex .lt. small_1m8 .and. zlo_ex .gt. 0. ) zlo_ex = 0. zhi_ex = min( 10.**( 2. * zl_3 - zl_2 ) - zdel , $ zhigh + zavail(ihi2) - zavail(ihi2-1) ) c call finish_cno c do i = -n_zmixes, n_totmix list_gn(i) = 0 enddo list_mult = 0 c return c endif c c The input Z-range does not fit between a set of numz Z-values from zavail(), c and the input value of numz was greater than 3; find the corresponding c positions in the coarser array zval() of Z-values available from the c 'Gz???.x??' files, and check whether this suffices: c if ( zlow .lt. small_1m8 ) then jlo1 = 1 jlo2 = 1 else jlo2 = mz - 2 do while ( jlo2 .gt. 2 .and. $ zlow .lt. zval(jlo2-1) + small_1m6 ) jlo2 = jlo2 - 1 enddo jlo1 = 1 do while ( jlo1 .lt. jlo2 .and. $ zlow .gt. zval(jlo1+1) - small_1m6 ) jlo1 = jlo1 + 1 enddo endif jhi2 = mz do while ( jhi2 .gt. 3 .and. $ zhigh .lt. zval(jhi2-1) + small_1m6 ) jhi2 = jhi2 - 1 enddo jhi1 = 3 do while ( jhi1 .lt. jhi2 .and. $ zhigh .gt. zval(min(jhi1+1,mz)) - small_1m6 ) jhi1 = jhi1 + 1 enddo c nuse = jhi2 + 1 - jlo1 c c If this coarser spacing works, then use it, after shifting the endpoints c in to the closest encompassing Z-values from zavail(), and adding as many c Z-values from zavail() as is allowed by the value of numz: c if ( nuse .le. numz ) then c do i = jlo1, jhi2 z_use(i+1-jlo1) = zval(i) enddo z_use(1) = zavail(ilo1) z_use(nuse) = zavail(ihi2) if ( ihi2 .eq. nzm .and. ilo1 .eq. nzm - 4 .and. numz .eq. 3 ) $ z_use(2) = zavail(nzm-2) c k_a = 0 do while ( nuse .lt. numz .and. k_a .lt. nadd_zavail ) k_a = k_a + 1 zat = zavail( iadd_zavail(k_a) ) if ( zat .gt. z_use(1) + small_1m6 .and. $ zat .lt. z_use(nuse) - small_1m6 ) then i = 2 do while ( i .lt. nuse .and. $ z_use(i) + small_1m6 .lt. zat ) i = i + 1 enddo do j = nuse, i, -1 z_use(j+1) = z_use(j) enddo z_use(i) = zat nuse = nuse + 1 endif enddo if ( nuse .ne. numz ) stop $ ' STOP -- READEXCO Error: nuse < numz cannot happen. ' c c Else, if the coarser spacing still does not suffice, use an equal-interval c spacing in log(Z+0.001): c else c c-dont; z_use(1) = zavail(ilo1) c-dont; z_use(numz) = zavail(ihi2) z_use(1) = zlow z_use(numz) = zhigh z_1 = log( z_use(1) + zdel ) z_2 = log( z_use(numz) + zdel ) z_3 = ( z_2 - z_1 ) / ( numz - 1 ) do i = 2, numz - 1 z_use(i) = exp( ( i - 1 ) * z_3 + z_1 ) - zdel enddo c endif c c In either of the above cases, read in the corresponding opacities: c do i = -n_zmixes, n_totmix list_gn(i) = level_list enddo list_mult = level_list c if ( level_list .gt. 0 ) then write(iu_list,1) numz, z_use(1), z_use(numz), ofebrack endif c do kz = 1, numz call read_kz(kz,z_use(kz),1,khighz,iu_lo,ofebrack) if ( kz .gt. 1 ) dfsz(kz) = 1. / ( zvint(kz) - zvint(kz-1) ) enddo c dfsz(1) = dfsz(2) c zlow = z_use(1) zhigh = z_use(numz) c zlo_ex = min( zlow - zacc(1) , $ 10.**( zvint(1) - log10( ( zavail(ilo1+1) + zdel ) $ / ( zavail(ilo1) + zdel ) ) ) - zdel ) zhi_ex = zhigh + zavail(ihi2) - zavail(ihi2-1) c call finish_cno c do i = -n_zmixes, n_totmix list_gn(i) = 0 enddo list_mult = 0 c ! we are done: return return end c c****************************************************************************** c subroutine read_best_mol( iu, i_alex, cf_hz, ofebrack ) c ======================================================= c character*(*) cf_hz c parameter ( small_1m6=1.e-6 ) c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c common /c_ofe_in_ferg/ ofein_ferg, i_ofe_ferg, i_ofe0_ferg save /c_ofe_in_ferg/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c character*1 cb(6) common /chkpoc/ cb save /chkpoc/ c character*255 cf_tmp c ! get valid Fortran unit if ( iu .gt. 0 .and. iu .le. 99 ) iualex = iu if ( iualex .eq. 5 .or. iualex .eq. 6 ) iualex = 7 c if ( i_alex .ge. 10 ) then iferg = i_alex / 10 ialex_use = min( 4 , i_alex - 10 * iferg ) else if ( i_alex .le. -10 ) then iferg = iabs( i_alex ) / 10 ialex_use = max( -4 , i_alex + 10 * iferg ) else iferg = 0 ialex_use = min( 4 , max( -4 , i_alex ) ) endif c ! if should read in molecular opacities if ( ialex_use .ne. 0 ) then c ! if Ferguson 2005 file not spcified if ( iferg .eq. 0 ) then c ! try to match the OPAL file c if ( cf_hz .eq. ' ' .or. cf_hz .eq. 'GN93hz' ) then iferg = -2 else len = lnblnk( cf_hz ) i = len do while ( i .gt. 1 .and. cf_hz(i:i) .ne. cb(1) .and. $ cf_hz(i:i) .ne. cb(2) ) i = i - 1 enddo if ( cf_hz(i:i) .eq. cb(1) .or. $ cf_hz(i:i) .eq. cb(2) ) i = i + 1 c if ( i .eq. len ) then if ( cf_hz(i:i) .eq. 'g' .or. $ cf_hz(i:i+2) .eq. 'G' ) iferg = -2 else if ( i .le. len - 2 ) then if ( cf_hz(i:i+1) .eq. 'G.' .or. $ cf_hz(i:i+1) .eq. 'g.' .or. $ cf_hz(i:i+2) .eq. 'G93' .or. $ cf_hz(i:i+2) .eq. 'g93' ) then iferg = -2 else if ( cf_hz(i:i+2) .eq. 'G98' .or. $ cf_hz(i:i+2) .eq. 'g98' ) then iferg = -3 else if ( cf_hz(i:i+2) .eq. 'L03' .or. $ cf_hz(i:i+2) .eq. 'l03' ) then iferg = -4 else if ( cf_hz(i:i+2) .eq. 'S92' .or. $ cf_hz(i:i+2) .eq. 's92' ) then iferg = -6 if ( i .le. len - 4 ) then if ( cf_hz(i+3:i+4) .eq. 'AE' .or. $ cf_hz(i+3:i+4) .eq. 'ae' ) iferg = -7 endif else if ( i .le. len - 3 ) then if ( cf_hz(i:i+3) .eq. 'GN93' .or. $ cf_hz(i:i+3) .eq. 'gn93' ) then iferg = -2 else if ( cf_hz(i:i+3) .eq. 'GS98' .or. $ cf_hz(i:i+3) .eq. 'gs98' ) then iferg = -3 else if ( i .le. len - 4 ) then if ( cf_hz(i:i+4) .eq. 'AGS04' .or. $ cf_hz(i:i+4) .eq. 'ags04' .or. $ cf_hz(i:i+4) .eq. 'AGS05' .or. $ cf_hz(i:i+4) .eq. 'ags05' ) iferg = -5 endif endif endif endif c if ( iferg .eq. 0 .and. $ ltype_ferg(ntyp1_ferg) .le. 0 ) then c j = i do while ( i .lt. len .and. $ ( ( cf_hz(j:j) .ge. 'A' .and. $ cf_hz(j:j) .le. 'Z' ) .or. $ ( cf_hz(j:j) .ge. 'a' .and. $ cf_hz(j:j) .le. 'z' ) ) ) j = j + 1 enddo do while ( i .lt. len .and. cf_hz(j:j) .ge. '0' $ .and. cf_hz(j:j) .le. '9' ) j = j + 1 enddo j = j - 1 c if ( j .gt. i .and. j - i + 1 + lsep_ferg .le. 80 ) then iferg = - ntyp1_ferg ltype_ferg(ntyp1_ferg) = j - i + 1 + lsep_ferg ctype_ferg(ntyp1_ferg) = cf_hz(i:j) // csep_ferg endif c endif c endif c ! find a Ferguson 2005 file call find_ferg( iferg, len_beg, cf_tmp ) c ! if none found: if ( len_beg .lt. 0 ) then c ! read Alexander & Ferguson 1994 file call readalex( iu ) c ! else: read Ferguson et al 2005 files: else c ! we will read the set that we found iferg_use = itype_ferg len_beg = -1 c ! if the Ferguson 2005 file was not specified, and a c ! non-alpha-enhanced case was found, and [O/Fe] is c ! non-zero: if ( iferg .le. 0 .and. ofebrack .ne. 0.0 .and. $ ( itype_ferg .le. 6 .or. itype_ferg .gt. 12 ) ) then c imain = 3 if ( ctype_ferg(imain)(1:3) .ne. 'g98' .or. $ ctype_ferg(imain)(4:3+lsep_ferg) .ne. csep_ferg ) $ stop $ ' STOP -- bad ctype_ferg(3) value: cannot be. ' c ilo = 8 if ( ctype_ferg(ilo)(1:5) .ne. 'gs98-' ) stop $ ' STOP -- bad ctype_ferg(8) value: cannot be. ' if ( ctype_ferg(ilo)(6:5+lsep_ferg) .eq. csep_ferg .and. $ ctype_ferg(ilo)(6+lsep_ferg:6+lsep_ferg) .eq. $ '2' ) then j = 6 + lsep_ferg else if ( ctype_ferg(ilo)(6:6) .eq. '.' .and. $ ctype_ferg(ilo)(7:7) .eq. '2' ) then j = 7 else stop ' STOP -- bad ctype_ferg(8) values: cannot be. ' endif if ( ctype_ferg(ilo)(j+1:j+lsep_ferg) .ne. csep_ferg ) $ stop $ ' STOP -- bad ctype_ferg(8) value: cannot be. ' c if ( ofebrack .ge. 0.0 ) then ilo = ilo + 1 if ( ctype_ferg(ilo)(1:5) .ne. 'gs98+' .or. $ ctype_ferg(ilo)(j+1:j+lsep_ferg) .ne. csep_ferg $ .or. ctype_ferg(ilo)(j:j) .ne. '2' ) stop $ ' STOP -- bad ctype_ferg(9) value: cannot be. ' endif c ! get closest [O/Fe] pair if ( ofebrack .le. 0.2 ) then ihi = ilo else if ( ofebrack .le. 0.4 ) then ihi = ilo + 1 if ( ctype_ferg(ihi)(1:5) .ne. 'gs98+' .or. $ ctype_ferg(ihi)(j+1:j+lsep_ferg) .ne. csep_ferg $ .or. ctype_ferg(ihi)(j:j) .ne. '4' ) stop $ ' STOP -- bad ctype_ferg(10) value: cannot be. ' if ( abs( ofebrack - 0.4 ) .lt. small_1m6 ) ilo = ihi else if ( ofebrack .le. 0.6 ) then ihi = ilo + 2 ilo = ilo + 1 if ( ctype_ferg(ilo)(1:5) .ne. 'gs98+' .or. $ ctype_ferg(ilo)(j+1:j+lsep_ferg) .ne. csep_ferg $ .or. ctype_ferg(ilo)(j:j) .ne. '4' ) stop $ ' STOP -- bad ctype_ferg(10) value: cannot be. ' if ( ctype_ferg(ihi)(1:5) .ne. 'gs98+' .or. $ ctype_ferg(ihi)(j+1:j+lsep_ferg) .ne. csep_ferg $ .or. ctype_ferg(ihi)(j:j) .ne. '6' ) stop $ ' STOP -- bad ctype_ferg(11) value: cannot be. ' if ( abs( ofebrack - 0.6 ) .lt. small_1m6 ) ilo = ihi else ihi = ilo + 3 ilo = ilo + 2 if ( ctype_ferg(ilo)(1:5) .ne. 'gs98+' .or. $ ctype_ferg(ilo)(j+1:j+lsep_ferg) .ne. csep_ferg $ .or. ctype_ferg(ilo)(j:j) .ne. '6' ) stop $ ' STOP -- bad ctype_ferg(11) value: cannot be. ' if ( ctype_ferg(ihi)(1:5) .ne. 'gs98+' .or. $ ctype_ferg(ihi)(j+1:j+lsep_ferg) .ne. csep_ferg $ .or. ctype_ferg(ihi)(j:j) .ne. '8' ) stop $ ' STOP -- bad ctype_ferg(12) value: cannot be. ' if ( abs( ofebrack - 0.8 ) .lt. small_1m6 ) ilo = ihi endif c if ( ilo .ge. ntyp1_ferg .or. ihi .ge. ntyp1_ferg .or. $ imain .ge. ntyp1_ferg ) stop $ ' STOP -- bad ctype_ferg() values: cannot be. ' c ! check g98 call find_ferg( imain, len_beg, cf_tmp ) c ! check ilo if ( len_beg .ge. 0 ) $ call find_ferg( ilo, len_beg, cf_tmp ) c ! check ihi if ( len_beg .ge. 0 .and. ihi .ne. ilo ) $ call find_ferg( ihi, len_beg, cf_tmp ) c ! if all found if ( len_beg .ge. 0 ) then c ! get [O/Fe] read( ctype_ferg(ilo)(j:j), '(i1)' ) i if ( ctype_ferg(ilo)(5:5) .eq. '-' ) then ofe_lo = -0.1 * i else ofe_lo = 0.1 * i endif c ! of file(s) if ( ilo .eq. ihi ) then c ! and read them in f_ofe = ofebrack / ofe_lo c call read_add_ferg( iu, 0.0, f_ofe, imain ) call read_add_ferg( iu, -1.0, f_ofe, ilo ) c else c read( ctype_ferg(ihi)(j:j), '(i1)' ) i if ( ctype_ferg(ihi)(5:5) .eq. '-' ) then ofe_hi = -0.1 * i else ofe_hi = 0.1 * i endif c f_ofe = ( ofebrack - ofe_lo ) $ / ( ofe_hi - ofe_lo ) c call read_add_ferg( iu, 0.0, 1.0 - f_ofe, ilo ) call read_add_ferg( iu, 1.0, f_ofe, ihi ) call read_add_ferg( iu, 1.0, -1.0, imain ) c endif c ! else [if not found]: else if ( i_ofe0_ferg .gt. 0 .and. $ i_ofe_ferg .gt. 0 ) then c ! check s92 call find_ferg( i_ofe0_ferg, len_beg, cf_tmp ) c ! check s92ae if ( len_beg .ge. 0 ) $ call find_ferg( i_ofe_ferg, len_beg, cf_tmp ) c ! if found: if ( len_beg .ge. 0 ) then c ! get [O/Fe] opacity shift f_ofe = ofebrack / ofein_ferg call read_add_ferg( iu, 0.0, f_ofe, i_ofe0_ferg ) call read_add_ferg( iu, -1.0, f_ofe, i_ofe_ferg ) c endif c endif c endif c ! if [O/Fe] opacity shift was obtained: if ( len_beg .ge. 0 ) then c ! add Ferguson 2005 c ! opacities to it call read_add_ferg( iu, 1.0, 1.0, iferg_use ) c ! else: read else c ! Ferguson 2005 call read_add_ferg( iu, 0.0, 1.0, iferg_use ) c endif c endif c endif c ! set molecular-opacity flag call set_alex_use( ialex_use ) c return end c c****************************************************************************** c subroutine readferg( iu ) c ========================= c c Read in Ferguson et al. 2005 opacities, searching for an available case c call read_add_ferg( iu, 0.0, 1.0, 0 ) c return end c c****************************************************************************** c subroutine addfile_ferg(iu,f_sto,f_read,cfileferg,i_full_path) c ============================================================== c character*(*) cfileferg c call set_alex_file( cfileferg, i_full_path ) c call read_add_ferg( iu, f_sto, f_read, 1 ) c return end c c****************************************************************************** c subroutine read_add_ferg( iu, f_sto, f_read, ktype_ferg ) c ========================================================= c c Read in Ferguson et al. 2005 opacities, combining a factor f_sto times c the alread-stored logKappa values with a factor f_read times the logKappa c values newly read in. c c ktype_ferg = 0 : search for available case, in order 99,1,5,4,3,2,6,7,8, ... c 1 : use case specified by CFILE_ALEX c 2 : read GN93 case c 3 : read GS98 case c 4 : read L03 case c 5 : read AGS04 case c 6 : read S92 case c 7 : read S92AE case c 8 : read GS98-.2 case c 9 : read GS98+.2 case c 10 : read GS98+.4 case c 11 : read GS98+.6 case c 12 : read GS98+.8 case c 13 to 99 : read user-specified case c -1 to -99 : try the case |ktype_ferg|, if not found use case 0 c parameter ( small_1m6=1.e-6 ) c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c common /mat_alex_ferg/ flk_ferg(nr_ferg,nt_ferg,nz_ferg,nx_ferg) save /mat_alex_ferg/ dimension flk_alex(nrlo_alex:nr_alex,nt_alex,nzp1_alex,nx_alex) equivalence (flk_alex(nrlo_alex,1,1,1),flk_ferg(1,1,1,1)) c common /opac_ferg/ zlog_ferg(nzp1_ferg), xlog_ferg(nx_ferg), $ dzinvlog_ferg(nz_ferg), dzinv_ferg(nz_ferg), $ dxinvlog_ferg(nx_ferg), dxinv_ferg(nx_ferg), $ t6log_ferg(nt_ferg), rlog_ferg(nr_ferg), $ dt6inv_ferg(nt_ferg), drinv_ferg(nr_ferg), $ modt_ferg, modz0_ferg, ntuferg save /opac_ferg/ c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c common /c_prev_ferg/ zlogp_ferg, xp_ferg, zlp1_ferg, xp1_ferg, $ zlp2_ferg, xp2_ferg, i1p_ferg, i4p_ferg, j1p_ferg, j4p_ferg save /c_prev_ferg/ c common /c_tsw_ferg/ slt_max_ferg, sltswlo_ferg_def, $ sltswhi_ferg_def, sltswlo_ferg, sltswhi_ferg, $ sltswmid_ferg, dltsw2inv_ferg save /c_tsw_ferg/ c character*255 cfile_alex common /c_filename_alex/ need_alex_dir, cfile_alex save /c_filename_alex/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c common /c_level_list_opal_z/ iu_list, level_list, list_mult, $ list_gn(-n_zmixes:n_totmix) save /c_level_list_opal_z/ c character*255 cfile_use, clin c dimension valin(0:nr_ferg) c-debug[ c-debug; common /c_debug_ferg/ i_debug_ferg c-debug; save /c_debug_ferg/ c-debug;c c-debug; data i_debug_ferg / 0 / c-debug] c c-debug[ c-debug; if ( i_debug_ferg .gt. 1 ) write(6,'(" ")') c-debug; if ( i_debug_ferg .gt. 0 ) write(6, c-debug; $ '(" ***** read_add_ferg(",a,i5,2(a,f11.7),a,i5,a,i3,a)') c-debug; $ ' iu', iu, ' f_sto', f_sto, ' f_read', f_read, c-debug; $ ' ktype_ferg', ktype_ferg, c-debug; $ " ) [kavail_alex=", kavail_alex, "]" c-debug] if ( iu .gt. 0 .and. iu .le. 99 ) iualex = iu if ( iualex .eq. 5 .or. iualex .eq. 6 ) iualex = 7 c if ( f_read .eq. 0.0 ) return c list_mult = level_list c if ( max( abs(f_sto) , abs(f_read) ) .gt. 10.0 ) then write(6,10) kavail_alex, f_sto, f_read 10 format(/' READ_ADD_FERG Error: (avail',i2,'): bad F_STO', $ 1p,e14.6,' , F_READ',e14.6) stop ' STOP -- READ_ADD_FERG Error: bad F_STO and/or F_READ. ' endif c ! clear any cached Z,X-interpolated Ferguson opacities zlogp_ferg = -9.0 xp_ferg = -9.0 zlp1_ferg = -9.0 xp1_ferg = -9.0 zlp2_ferg = -9.0 xp2_ferg = -9.0 i1p_ferg = -1 i4p_ferg = -9 j1p_ferg = -1 j4p_ferg = -9 c fusto = f_sto c if ( kavail_alex .lt. 2 .or. f_sto .eq. 0.0 ) then c fusto = 0.0 c ntuferg = nt_ferg modt_ferg = 0 modz0_ferg = 0 c do ix = 1, nx_ferg do iz = 1, nz_ferg do it = 1, nt_ferg do ir = 1, nr_ferg flk_ferg(ir,it,iz,ix) = 0.0 enddo enddo enddo enddo c if ( kavail_alex .lt. 2 ) then c do i = 1, nz_ferg zlog_ferg(i) = log10( z_ferg(i) + zdel_ferg ) if ( i .gt. 1 ) then dzinv_ferg(i) = 1.0 / ( z_ferg(i) - z_ferg(i-1) ) dzinvlog_ferg(i) = $ 1.0 / ( zlog_ferg(i) - zlog_ferg(i-1) ) endif enddo dzinv_ferg(1) = dzinv_ferg(2) dzinvlog_ferg(1) = dzinvlog_ferg(2) zlog_ferg(nzp1_ferg) = ( zlog_ferg(nz_ferg) $ - zlog_ferg(nz_ferg-1) ) + zlog_ferg(nz_ferg) c do i = 1, nx_ferg xlog_ferg(i) = log10( x_ferg(i) + xdel_ferg ) if ( i .gt. 1 ) then dxinv_ferg(i) = 1.0 / ( x_ferg(i) - x_ferg(i-1) ) dxinvlog_ferg(i) = $ 1.0 / ( xlog_ferg(i) - xlog_ferg(i-1) ) endif enddo dxinv_ferg(1) = dxinv_ferg(2) dxinvlog_ferg(1) = dxinvlog_ferg(2) c endif c endif c kavail_alex = 0 c call init_ferg_indices c itype_ferg = 0 c call find_ferg( ktype_ferg, len_beg, cfile_use ) c if ( itype_ferg .le. 0 ) then write(6,100) $ max( -ntyp1_ferg, min( ntyp1_ferg , ktype_ferg ) ) 100 format(/' READFERG Error: Furguson 2005 opacities not found', $ ' (looking for type', i4,').') stop ' STOP -- READFERG Error: Furguson 2005 file not found. ' endif c do ix = 1, nx_ferg c x = x_ferg(ix) c c-debug[ c-debug; if ( i_debug_ferg .gt. 8 ) write(6,'(" ")') c-debug; if ( i_debug_ferg .gt. 2 ) write(6, c-debug; $ '(" read(ix=",i3,") X=",f10.6," files ...")') c-debug; $ ix, x c-debug] if ( ix .ne. nxm1_ferg ) then izhi = nz_ferg else izhi = n2_ferg endif c do iz = 1, izhi c len = len_beg j = ione_ferg(itype_ferg) z = z_ferg(iz) c if ( ix .lt. nx_ferg ) then cfile_use(len+1:) = cx_ferg(ix) len = len + lx_ferg(ix) j = 0 else if ( iz .gt. 1 ) then x = 1.0 - z cfile_use(len+1:) = cz_ferg(iz) len = len + lz_ferg(iz) do i = len_beg + 1, len if ( i .eq. len ) then read( cfile_use(i:i), '(i1)' ) j if ( j .eq. 0 ) stop $ ' STOP -- READFERG Error: bad last Z digit. ' write( cfile_use(i:i), '(i1)' ) 10 - j else if ( cfile_use(i:i) .ne. '0' ) then stop ' STOP -- READFERG Error: bad digit in Z. ' else cfile_use(i:i) = '9' endif enddo j = 0 else if ( j .eq. 0 ) then cfile_use(len+1:) = cx_ferg(ix) len = len + lx_ferg(ix) else if ( j .gt. 0 ) then cfile_use(len+1:) = 'one' len = len + 3 else cfile_use(len+1:) = 'one' // csep_ferg cfile_use(len+4+lsep_ferg:) = cext_ferg call open_chk_zip( -99999, cfile_use, igzip, '???' ) if ( igzip .gt. -99999 ) then len = len + 3 j = 1 else cfile_use(len+1:) = cx_ferg(ix) len = len + lx_ferg(ix) j = 0 endif endif c if ( j .eq. 0 ) then cfile_use(len+1:) = csep_ferg len = len + lsep_ferg cfile_use(len+1:) = cz_ferg(iz) len = len + lz_ferg(iz) endif c cfile_use(len+1:) = csep_ferg len = len + lsep_ferg c cfile_use(len+1:) = cext_ferg len = len + lext_ferg c c-debug[ c-debug; if ( i_debug_ferg .gt. 8 ) write(6,'(" ")') c-debug; if ( i_debug_ferg .gt. 4 ) write(6, c-debug; $ '(" read(ix,iz=",2i3,") Z=",f10.6," file: ",a)') c-debug; $ ix, iz, z, cfile_use(:len) c-debug] if ( list_mult .gt. 0 ) then if ( iu_list .eq. iualex ) then write(6,4) iu_list 4 format(/' ***OPAL WARNING: READ_ADD_FERG:', $ ' bad LIST_IU =',i3, $ ', reset to 6 (standard output)'/) iu_list = 6 endif if ( list_mult .eq. level_list ) then if ( fusto .eq. 0.0 .and. f_read .eq. 1.0 ) then if ( list_mult .eq. 1 ) then write(iu_list,1) itype_ferg, cfile_use(:len), $ ' ...' 1 format(' ***OPAL/MOL_FERG Type',i3,': ',a,a) else write(iu_list,1) itype_ferg, cfile_use(:len) endif else if ( list_mult .eq. 1 ) then write(iu_list,2) fusto, itype_ferg, f_read, $ cfile_use(:len), ' ...' 2 format(' ***OPAL/MOL_FERG_(STO *',f11.6, $ ') + Type',i3,':',f11.6,' * ',a,a) else write(iu_list,2) fusto, itype_ferg, f_read, $ cfile_use(:len) endif else if ( list_mult .eq. 1 ) then write(iu_list,3) cfile_use(:len), ' ...' 3 format(' ***OPAL/MOL_FERG: ',a,a) else write(iu_list,3) cfile_use(:len) endif list_mult = list_mult - 1 endif c call open_chk_zip( iualex, cfile_use, igzip, $ 'READFERG Error: Ferguson 2005 opacity file not found:' $ ) c clin = ' ' line = 0 c do while ( clin(1:5) .ne. 'log T' ) c line = line + 1 read(iualex,'(a255)',err=900,end=950) clin c len = lnblnk( clin ) x_at = -9.999999 z_at = -9.999999 do i = 2, len - 9 if ( clin(i-1:i) .eq. 'X=' ) then read( clin(i+1:i+9) , '(f9.6)' ) x_at else if ( clin(i-1:i) .eq. 'Z=' ) then read( clin(i+1:i+9) , '(f9.6)' ) z_at endif enddo c if ( ( x_at .gt. -9.9 .or. z_at .gt. -9.9 ) .and. $ ( abs( z_at - z ) .gt. small_1m6 .or. $ abs( x_at - x ) .gt. small_1m6 ) ) then write(6,200) x, z, x_at, z_at, line, $ clin(:len), cfile_use(:lnblnk(cfile_use)) 200 format(/' READFERG: input file should have X =', $ f10.7,', Z =',f10.7/ $ ' but read bad value(s) X =', $ f10.7,', Z =',f10.7,' from line',i5,':'/a/ $ ' of Ferguson et al. 2005', $ ' molecular opacity file called:'/' ',a/) stop ' STOP -- READFERG Error: bad Ferg-file X,Z. ' endif c enddo c if ( igot_r_ferg .eq. 0 ) then read(clin,'(6x,35f7.3)',err=900) $ (rlog_ferg(i),i=1,nr_ferg) do i = 2, nr_ferg if ( rlog_ferg(i) .le. rlog_ferg(i-1) ) stop $ ' STOP -- READFERG Error: bad file R value. ' drinv_ferg(i) = 1.0 $ / ( rlog_ferg(i) - rlog_ferg(i-1) ) enddo drinv_ferg(1) = drinv_ferg(2) igot_r_ferg = 1 else read(clin,'(6x,35f7.3)',err=900) (valin(i),i=1,nr_ferg) do i = 1, nr_ferg if ( abs( rlog_ferg(i) - valin(i) ) .gt. $ small_1m6 ) stop $ ' STOP -- READFERG Error: bad file logR value. ' enddo endif c it = 0 c do while ( it .lt. ntuferg ) c it = it + 1 line = line + 1 c-debug[ c-debug; if ( i_debug_ferg .gt. 8 ) write(6, c-debug; $ '(" read(ix,iz,it=",3i3,") line",i6," ...")') c-debug; $ ix, iz, it, line c-debug] c ! note EOF check read(iualex,'(a255)',err=900,end=250) clin read(clin,'(f5.3,1x,35f7.3)',err=900) $ (valin(i),i=0,nr_ferg) c if ( igot_t_ferg .eq. 0 ) then t6log_ferg(it) = valin(0) - 6.0 if ( modt_ferg .eq. 0 .and. valin(0) .lt. 3.4801 ) $ modt_ferg = it if ( modz0_ferg .eq. 0 .and. valin(0) .lt. 3.899 ) $ modz0_ferg = it if ( it .eq. 1 ) then if ( abs( t6log_ferg(it) - slt_max_ferg ) .gt. $ small_1m6 ) stop $ ' STOP -- READFERG Error: bad file T value. ' else if ( t6log_ferg(it) .ge. t6log_ferg(it-1) ) stop $ ' STOP -- READFERG Error: bad file T value. ' dt6inv_ferg(it) = 1.0 $ / ( t6log_ferg(it) - t6log_ferg(it-1) ) endif else if ( abs( valin(0) - 6.0 - t6log_ferg(it) ) .gt. $ small_1m6 ) then stop ' STOP -- READFERG Error: bad file logT value. ' endif c do i = 1, nr_ferg flk_ferg(i,it,iz,ix) = fusto * flk_ferg(i,it,iz,ix) $ + f_read * valin(i) enddo c ! end of T-input loop enddo c ! skip EOF-code when no EOF found goto 270 c ! if file ends at logT of 3.0 or more, it is an error c ! (note: one file of the L03 mix is missing logT < 2.8) 250 continue if ( it .eq. 1 ) goto 950 if ( t6log_ferg(it-1) .gt. -3.0 ) goto 950 ntuferg = it - 1 c 270 continue c igot_t_ferg = 1 c call close_chk_zip( iualex, cfile_use, igzip ) c c-debug[ c-debug; if ( i_debug_ferg .gt. 8 ) write(6, c-debug; $ '(" DONE(ix,iz=",2i3,") Z=",f10.6," file: ",a)') c-debug; $ ix, iz, z, cfile_use(:lnblnk(cfile_use)) c-debug] enddo c enddo c c-debug[ c-debug; if ( i_debug_ferg .gt. 8 ) write(6,'(" ")') c-debug; if ( i_debug_ferg .gt. 1 ) write(6, c-debug; $ '(a,i3,":",f6.3," < logT <",f6.3)') c-debug; $ ' DONE reading Ferguson 2005 molecular opacities, type', c-debug; $ itype_ferg, t6log_ferg(ntuferg) + 6.0, t6log_ferg(1) + 6.0 c-debug] dt6inv_ferg(1) = dt6inv_ferg(2) c kavail_alex = 2 kdo_alex = kuse_alex c ! if molecular opacity-inclusion is set, make sure c ! low-T OPAL limit is low enough for switchover if ( kdo_alex .gt. 0 ) $ call set_logt6_limits( -99.0, -99.0, -99.0, -99.0 ) c c-debug[ c-debug; if ( i_debug_ferg .gt. 1 ) write(6, c-debug; $ '(" read_add_ferg: RETURN.")') c-debug] return c 900 write(6,910) line, clin(:max(1,lnblnk(clin))), $ cfile_use(:lnblnk(cfile_use)) 910 format(/' READFERG Error: while reading line',i6,':'/ $ ' "',a,'"'/ $ ' of a Ferguson 2005 opacity file:'/ $ ' ',a) stop ' STOP -- READFERG Error: reading Ferguson 2005 file. ' c 950 write(6,960) line, cfile_use(:lnblnk(cfile_use)) 960 format(/' READFERG Error: premature EOF at line',i6, $ ' of a Ferguson 2005 opacity file:'/ $ ' ',a) stop ' STOP -- READFERG Error: reading Ferguson 2005 file. ' end c c****************************************************************************** c subroutine find_ferg( ktype_ferg, len_beg, cfile_use ) c ====================================================== c character*255 cfile_use c c ktype_ferg = 0 : search for available case, in order 99,1,5,4,3,2,6,7,8, ... c 1 : use case specified by CFILE_ALEX c 2 : read GN93 case c 3 : read GS98 case c 4 : read L03 case c 5 : read AGS04 case c 6 : read S92 case c 7 : read S92AE case c 8 : read GS98-.2 case c 9 : read GS98+.2 case c 10 : read GS98+.4 case c 11 : read GS98+.6 case c 12 : read GS98+.8 case c 13 to 99 : read user-specified case c -1 to -99 : try the case |ktype_ferg|, if not found use case 0 c c Set itype_ferg to the case found, and return the filename cfile_use c that was found and the length len_beg prior to the X-specification in c the filename. c parameter ( small_1m6=1.e-6 ) c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c character*255 cfile_alex common /c_filename_alex/ need_alex_dir, cfile_alex save /c_filename_alex/ c character*255 copdir common/opdir/ copdir save /opdir/ c character*1 cb(6) common /chkpoc/ cb save /chkpoc/ c ! which should we check if ( ktype_ferg .eq. 0 ) then ilo = 1 ihi = ntyp1_ferg else ilo = 0 if ( ktype_ferg .gt. 0 ) then ihi = 0 else ihi = ntyp1_ferg endif endif c ! try with and without copdir, cfile_alex do itry = 1, 4 c ! first to check itype_ferg = min( ntyp1_ferg , iabs(ktype_ferg) ) c c ! for each type that should be checked: do ichk = ilo, ihi c if ( ichk .gt. 0 ) itype_ferg = itype_def_ferg(ichk) c len = 0 cfile_use = ' ' c ! prepend opacity directory? if ( copdir .ne. ' ' .and. $ ( ( itry .le. 2 .and. need_alex_dir .gt. 0 ) .or. $ ( itry .gt. 2 .and. need_alex_dir .le. 0 ) ) ) then cfile_use = copdir len = lnblnk( cfile_use ) if ( len .ge. 250 ) then cfile_use = ' ' len = 0 else if ( copdir(len:len) .ne. cb(1) .and. $ copdir(len:len) .ne. cb(2) ) then if ( cb(2) .eq. ']' ) then i = len do while ( i .gt. 0 .and. $ cfile_use(max(1,i):max(1,i)) .ne. '[' ) i = i - 1 enddo else i = 0 endif len = len + 1 if ( i .gt. 0 ) then cfile_use(len:len) = cb(2) else cfile_use(len:len) = cb(1) endif endif endif c ! append Alex-directory (check VMS case): i = lnblnk( cfile_alex ) if ( i .gt. 0 .and. len + i .lt. 250 .and. $ ( itry .eq. 1 .or. itry .eq. 3 ) ) then if ( len .gt. 0 .and. cb(2) .eq. ']' .and. $ cfile_alex(1:1) .eq. '[' .and. $ cfile_use(max(len,1):max(len,1)) .eq. ']' ) then cfile_use(len:len) = '.' cfile_use(len+1:) = cfile_alex(2:) len = len + i - 1 else cfile_use(len+1:) = cfile_alex len = len + i endif endif c ! append beginning of filename if ( itype_ferg .gt. 1 ) then c do while ( len .gt. 0 .and. $ cfile_use(max(len,1):max(len,1)) .ne. cb(1) .and. $ cfile_use(max(len,1):max(len,1)) .ne. cb(2) ) cfile_use(len:len) = ' ' len = len - 1 enddo c cfile_use(len+1:) = ctype_ferg(itype_ferg) len = len + max( 0 , ltype_ferg(itype_ferg) ) c endif c ! append the rest of the Z=0.00001,X=0.99999 filename len_beg = len c if ( cz_ferg(2) .ne. '00001' ) stop $ ' STOP -- READFERG Error: bad lowest Z value > 0. ' c do i = len + 1, len + lz_ferg(2) if ( i .le. 255 ) then cfile_use(i:i) = '9' endif enddo len = len + lz_ferg(2) if ( len .lt. 255 ) cfile_use(len+1:) = csep_ferg len = len + lsep_ferg if ( len .lt. 255 ) cfile_use(len+1:) = cz_ferg(2) len = len + lz_ferg(2) if ( len .lt. 255 ) cfile_use(len+1:) = csep_ferg len = len + lsep_ferg if ( len .lt. 255 ) cfile_use(len+1:) = cext_ferg len = len + lext_ferg c ! skip any filename that is too long if ( len .le. 255 ) then c call open_chk_zip( -99999, cfile_use, igzip, '???' ) c ! found? return if ( igzip .gt. -99999 ) return c ! check subdirectory? if ( csub_ferg(itype_ferg)(1:1) .ne. ' ' ) then c lsub_ferg = lnblnk( csub_ferg(itype_ferg) ) + 1 c ! for VMS only if ( cb(2) .eq. ']' ) then i = len_beg do while ( i .gt. 0 .and. $ cfile_use(max(i,1):max(i,1)) .ne. cb(1) .and. $ cfile_use(max(i,1):max(i,1)) .ne. cb(2) ) i = i - 1 enddo if ( i .eq. 0 .or. $ cfile_use(max(i,1):max(i,1)) .eq. ':' ) $ lsub_ferg = lsub_ferg + 1 endif c ! if filename not too long: if ( len + lsub_ferg .le. 255 ) then c len_beg = len_beg + lsub_ferg c ! shift filename i = len do while ( i .gt. 0 .and. $ cfile_use(max(i,1):max(i,1)) .ne. cb(1) .and. $ cfile_use(max(i,1):max(i,1)) .ne. cb(2) ) cfile_use(i+lsub_ferg:i+lsub_ferg) = $ cfile_use(i:i) i = i - 1 enddo c ! for VMS only: need '[' or '.' if ( cb(2) .eq. ']' ) then if ( i .eq. 0 .or. $ cfile_use(max(i,1):max(i,1)) .eq. $ ':' ) then i = i + 1 lsub_ferg = lsub_ferg - 1 cfile_use(i:i) = '[' else cfile_use(i:i) = '.' endif endif c ! insert subdirectory name c cfile_use(i+1:i+lsub_ferg) = csub_ferg(itype_ferg) cfile_use(i+lsub_ferg:i+lsub_ferg) = cb(2) c call open_chk_zip( -99999, cfile_use, $ igzip, '???' ) c ! found? if ( igzip .gt. -99999 ) return c endif c endif c endif c enddo c enddo c ! if no file found: return with values to so indicate len_beg = -1 itype_ferg = 0 c return end c c****************************************************************************** c subroutine init_ferg_indices c ============================ c c Initialize Ferguson array-position indices to valid values; clear cache. c common /c_ferg_indices/ mf, mg, mh, mf2, kf, kg, kh, kf2, $ i1, i2, i3, i4, j1, j2, j3, j4 save /c_ferg_indices/ c common /c_prev_ferg/ zlogp_ferg, xp_ferg, zlp1_ferg, xp1_ferg, $ zlp2_ferg, xp2_ferg, i1p_ferg, i4p_ferg, j1p_ferg, j4p_ferg save /c_prev_ferg/ c mf = 1 mg = 2 mh = 3 mf2 = 4 c kf = 1 kg = 2 kh = 3 kf2 = 4 c i1 = 1 i2 = 2 i3 = 3 i4 = 4 c j1 = 1 j2 = 2 j3 = 3 j4 = 4 c zlogp_ferg = -9.0 xp_ferg = -9.0 zlp1_ferg = -9.0 xp1_ferg = -9.0 zlp2_ferg = -9.0 xp2_ferg = -9.0 c i1p_ferg = -1 i4p_ferg = -9 j1p_ferg = -1 j4p_ferg = -9 c return end c c****************************************************************************** c subroutine readalex( iu ) c ========================= c c Read in the (outdated) Alexander & Ferguson 1994 molecular opacities. c c If 0 < iu < 100, use Fortran unit iu; otherwise, use default unit of 23. c c !**************************************************************************! c ! Alexander 1994 molecular/grain opacity tables. ! c ! (Ref: D.R. Alexander & J.W. Ferguson 1994, ApJ,437,879-891) ! c ! (*Note: These tables were provided by Dr Chris Tout with the H exhausted ! c ! tables (i.e. X=0) having to be extracted from full tables with ! c ! smoothing taken out. See program alex_extract.f90 for details.) ! c !**************************************************************************! c Note: except for Z=1.0, the X=0 tables are identical to the X=0.0001 tables. c c===================================================== ALEXANDER's README FILE: c Each table begins with a header record which describes the composition. c After the header record, the data format is as follows. Opacities for c a given temperature appear on three consequtive lines. The format of c these lines is: (i2,i3,f6.3,f5.1,8f8.3/10f8.3/7f8.3) c c index number for this temperature (I2) c number of densities for this temperature (I3) c log T (F6.3) c log rho for first density (F5.1) c (each successive point increments the density by 0.250 dex) c values of the Rosseland opacity expressed as logs (25F8.3) c c When you publish papers which utilize these opacities, please acknowledge c my contribution and the support of grants NSF AST-9217946 and STScI GO-4685. c============================================================================== c c ---In the original file alexopac.tab : c The Z=0.002 opacities were bad for logT > 3.2, c the Z=0.001 opacities were bad for logT < 3.7, c and for X=0.1 the Z=0.0001 opacities were bad for logT > 3.6. c c ---In the corrected file Alexopac : c The three cases with bad opacities have been fixed. c A set of {Z=0.0,X=0.7} opacities have been obtained using Fig. 1 of c Alexander & Ferguson 1994, and the OPAL opacities at logT = 3.75 or higher. c For {Z=0.0,X=0.0} a rough approximation of the opacities has been obtained c by using the OPAL opacities at high-T, and extrapolating logK downwards in c logT, by fitting a least-squares quadratic to the average OPAL opacity at c each temperature in the range logT[3.75,3.90] and using this quadratic c logK = 5.78723 * (logT-3.75)^2 + 10.78878 * (logT-3.75) + const c at each density to extrapolate down in temperature, with the constant set to c yield the lowest available OPAL opacity at that density. c For other X-values at Z=0.0 these two opacity sets were interpolated in X. c For the higher metallicity cases Z=0.05 and 0.1, the Alexander opacities c were extrapolated in Z using the Z=0.02 and 0.03 cases, taking the average c of the result of extrapolating K in Z and of logK in logZ. c Note that the X=0.0001 opacities should be treated as if they had X=0. c c The Z=1.0 opacity set has been moved to the beginning of the file, and the c opacities with Z=0.0, 0.05, and 0.1 inserted in the appropriate places. c c Note that Alexander opacities are not given for X > 0.8, so there may be c some inaccuracy in extrapolating towards X = 1 - Z, but comparison with c OPAL opacities suggests that any such X-extrapolation error is at worst c comparable to the difference between the OPAL and Alexander opacities c (at least in the temperature range where OPAL and Alexander tables overlap). c c ANDERS & GREVESSE 89 MIX in CORRECTED file Alexopac : c ------------------------------------------------------ c logRHO = -12.0 (0.25) -6.0 : 25 values, c logT = 4.10 (-0.05) 3.00 : 23 values, in all cases. c c Z=1.0 1.X=0.0 -- -- -- -- -- c Z=0.0 2.X=0.0 13.X=0.03 24.X=0.10 35.X=0.35 46.X=0.70 57.X=0.80 c Z=0.0001 3.X=0.0001 14.X=0.03 25.X=0.10 36.X=0.35 47.X=0.70 58.X=0.80 c Z=0.0003 4.X=0.0001 15.X=0.03 26.X=0.10 37.X=0.35 48.X=0.70 59.X=0.80 c Z=0.001 5.X=0.0001 16.X=0.03 27.X=0.10 38.X=0.35 49.X=0.70 60.X=0.80 c Z=0.002 6.X=0.0001 17.X=0.03 28.X=0.10 39.X=0.35 50.X=0.70 61.X=0.80 c Z=0.004 7.X=0.0001 18.X=0.03 29.X=0.10 40.X=0.35 51.X=0.70 62.X=0.80 c Z=0.01 8.X=0.0001 19.X=0.03 30.X=0.10 41.X=0.35 52.X=0.70 63.X=0.80 c Z=0.02 9.X=0.0001 20.X=0.03 31.X=0.10 42.X=0.35 53.X=0.70 64.X=0.80 c Z=0.03 10.X=0.0001 21.X=0.03 32.X=0.10 43.X=0.35 54.X=0.70 65.X=0.80 c Z=0.05 11.X=0.0001 22.X=0.03 33.X=0.10 44.X=0.35 55.X=0.70 66.X=0.80 c Z=0.1 12.X=0.0001 23.X=0.03 34.X=0.10 45.X=0.35 56.X=0.70 67.X=0.80 c parameter ( small_1m6=1.e-6, small_1m5=1.e-5 ) c character*255 copdir common/opdir/ copdir save /opdir/ c character*1 cb(6) common /chkpoc/ cb save /chkpoc/ c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c common /mat_alex_ferg/ flk_ferg(nr_ferg,nt_ferg,nz_ferg,nx_ferg) save /mat_alex_ferg/ dimension flk_alex(nrlo_alex:nr_alex,nt_alex,nzp1_alex,nx_alex) equivalence (flk_alex(nrlo_alex,1,1,1),flk_ferg(1,1,1,1)) c common /opac_alex/ zlog_alex(nzp1_alex),xlog_alex(nx_alex), $ dzinvlog_alex(nzp1_alex),dxinvlog_alex(nx_alex) save /opac_alex/ c common /c_ini_alex/ z_alex(nzp1_alex),x_alex(nx_alex), $ flt_alex(nt_alex),flro_alex(nrlo_alex:nr_alex) save /c_ini_alex/ c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c character*255 cfile_alex common /c_filename_alex/ need_alex_dir, cfile_alex save /c_filename_alex/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c common /c_level_list_opal_z/ iu_list, level_list, list_mult, $ list_gn(-n_zmixes:n_totmix) save /c_level_list_opal_z/ c character*255 cfile_opal_used(-1:n_totmix) common /c_mixfiles_used_opal_z/ cfile_opal_used save /c_mixfiles_used_opal_z/ c___ character*255 cfile_use dimension flk_min(nt_alex), dflkt_max(nt_alex) c=== if ( iu .gt. 0 .and. iu .le. 99 ) iualex = iu if ( iualex .eq. 5 .or. iualex .eq. 6 ) iualex = 7 c c ! if were already obtained, return if ( kavail_alex .eq. 1 ) return c ! get log Z and X values do i = 1,nzp1_alex zlog_alex(i) = log10(z_alex(i)+zdel_alex) if ( i .gt. 1 ) $ dzinvlog_alex(i) = 1./(zlog_alex(i)-zlog_alex(i-1)) enddo dzinvlog_alex(1) = dzinvlog_alex(2) c do i = 1,nx_alex xlog_alex(i) = log10(x_alex(i)+xdel_alex) if ( i .gt. 1 ) $ dxinvlog_alex(i) = 1./(xlog_alex(i)-xlog_alex(i-1)) enddo dxinvlog_alex(1) = dxinvlog_alex(2) c ! get Alexander opacity file name: if ( need_alex_dir .gt. 0 ) then kx = lnblnk(copdir) else kx = 0 endif kt = lnblnk(cfile_alex) kd = 0 c ! blank? Use default if ( kt .le. 0 .or. cfile_alex(1:1) .eq. ' ' ) then kd = ltype_ferg(1) kt = 0 else if ( cfile_alex(kt:kt) .eq. cb(1) .or. $ cfile_alex(kt:kt) .eq. cb(2) ) kd = ltype_ferg(1) endif c ! directory + file name too long? if ( kx + kt + kd .gt. 255 ) then if ( kd .gt. 0 ) then if ( kx .gt. 0 ) then if ( kt .gt. 0 ) then write(6,10) copdir(:kx), $ cfile_alex(:kt), ctype_ferg(1)(:kd) else write(6,10) copdir(:kx), ctype_ferg(1)(:kd) endif else if ( kt .gt. 0 ) then write(6,10) cfile_alex(:kt), ctype_ferg(1)(:kd) else write(6,10) ctype_ferg(1)(:kd) endif else if ( kx .gt. 0 ) then write(6,10) copdir(:kx), cfile_alex(:kt) else write(6,10) cfile_alex(:kt) endif 10 format(' READALEX Error: directory + file name > 255 chars:'/ $ ' ',a/' ',a,a) stop ' STOP -- READALEX Error: dir+file name > 255 chars. ' endif c ! combine directory and file name if ( kx .gt. 0 ) then c ! check for error in directory name if ( copdir(kx:kx) .ne. cb(1) .and. $ copdir(kx:kx) .ne. cb(2) ) then write(6,15) cb(1), cb(2), copdir(:kx) 15 format(' READALEX Error: directory name does not end in "', $ a1,'" or "',a1,'":'/' ',a) stop ' STOP -- READALEX Error: directory name bad last char' endif c if ( kd .le. 0 ) then cfile_use = copdir(:kx) // cfile_alex else if ( kt .le. 0 ) then cfile_use = copdir(:kx) // ctype_ferg(1) else cfile_use = copdir(:kx) // cfile_alex(:kt) // ctype_ferg(1) endif c else if ( kd .le. 0 ) then c cfile_use = cfile_alex c else if ( kt .le. 0 ) then c cfile_use = ctype_ferg(1) c else c cfile_use = cfile_alex(:kt) // ctype_ferg(1) c endif c cfile_opal_used(2) = cfile_use c if ( level_list .gt. 0 ) then if ( iu_list .eq. iualex ) then write(6,4) iu_list 4 format(/' ***OPAL WARNING: READALEX:', $ ' bad LIST_IU =',i3, $ ', reset to 6 (standard output)'/) iu_list = 6 endif write(iu_list,1) cfile_use(:lnblnk(cfile_use)) 1 format(' ***OPAL/MOL_ALEX[OLD]: ',a) endif c ! open Alexander opacity file call open_chk_zip( iualex, cfile_use, i_gzip, $ 'READALEX Error: Alexander 1994 opacity file not found:' ) c c Read Alexander opacities for (Z = 1.0, X = 0.0) and for c Z = { 0.0, 0.0001, 0.0003, 0.001, 0.002, 0.004, 0.01, 0.02, 0.03, 0.05, 0.1 } c at X = { 0.0, 0.03, 0.1, 0.35, 0.7, 0.8 } , c in all cases for the temperature-density range c logT = 3.00 (0.05) 4.10 , logRHO = -12.00 (0.25) -6.00 c ! read Z=1,X=0 case: read(iualex,100) x,z 100 format(29x,f6.4,7x,f6.4) c 0----+----1----+----2----+---- 0----+-- c100 format('ANDERS & GREVESSE 89 MIX X=',f6.4,' Z=',f6.4) if ( abs(x) .gt. small_1m6 .or. abs(z-1.) .gt. small_1m6 ) stop $ ' STOP -- READALEX: bad initial X not 0 or Z not 1. ' do kt = nt_alex,1,-1 read(iualex,115) ktat,nrat,fltat,flroloat, $ (flk_alex(kr,kt,nzp1_alex,1),kr=1,nr_alex) 115 format(i2,i3,f6.3,f5.1,8f8.3/10f8.3/7f8.3) if ( ktat+kt-1 .ne. nt_alex .or. nrat .ne. nr_alex .or. $ abs(fltat-flt_alex(kt)) .gt. small_1m5 .or. $ abs(flroloat-flro_alex(1)) .gt. small_1m5 ) stop $ ' STOP -- READALEX: bad opacity input line for X=0,Z=1. ' enddo c ! read all other (X,Z) cases: do kx = 1,nx_alex do kz = 1,nz_alex read(iualex,100) x,z if ( ( abs(x_alex(kx)-x) .gt. small_1m6 .and. $ ( x_alex(kx) .ne. 0. .or. $ abs(x-0.0001) .gt. small_1m6 ) ) .or. $ abs(z_alex(kz)-z) .gt. small_1m6 ) stop $ ' STOP -- SETALEX: bad X or Z value. ' do kt = nt_alex,1,-1 read(iualex,115) ktat,nrat,fltat,flroloat, $ (flk_alex(kr,kt,kz,kx),kr=1,nr_alex) if ( ktat+kt-1 .ne. nt_alex .or. nrat .ne. nr_alex .or. $ abs(fltat-flt_alex(kt)) .gt. small_1m5 .or. $ abs(flroloat-flro_alex(1)) .gt. small_1m5 ) stop $ ' STOP -- READALEX: bad opacity input line. ' enddo enddo enddo c ! close file call close_chk_zip( iualex, cfile_use, i_gzip ) c c Extrapolate Alexander opacities down in density as far as logRHO = -14 (note c that the file contains opacities only for densities down to logRHO = -12). c The extrapolation algorithm below should yield reasonable results, except c at very low temparatures (logT < 3.15). c do kz = 1, nzp1_alex c do kx = 1, nx_alex - ( kz / nzp1_alex ) * nxm1_alex c kt_min = 1 c ! at each T for logRHO >= -12: do kt = 1, nt_alex c kt1 = min( kt + 1 , nt_alex ) c ! find minimum logKappa flk_min(kt) = flk_alex(1,kt,kz,kx) c ! and maximum increase c ! in logKappa with decreasing T kr_hi = 2 dflkt_max(kt) = max( 0.25 , flk_alex(1,kt,kz,kx) $ - flk_alex(1,kt1,kz,kx) ) do kr = 2, nr_alex flk_min(kt) = min( flk_min(kt) , $ flk_alex(kr,kt,kz,kx) ) if ( kr .eq. kr_hi ) then if ( flk_alex(kr,kt,kz,kx) .lt. $ flk_alex(kr,kt1,kz,kx) ) then kr_hi = kr + 1 else if ( flk_alex(kr,kt,kz,kx) - $ flk_alex(1,kt,kz,kx) .lt. $ max( dflkt_max(kt) , $ min( 3. * ( flk_alex(kr-1,kt,kz,kx) - $ flk_alex(1,kt,kz,kx) ) , $ 2. * ( flk_alex(kr,kt,kz,kx) $ - flk_alex(kr,kt1,kz,kx) ) ) ) ) then dflkt_max(kt) = max( dflkt_max(kt) , $ flk_alex(kr,kt,kz,kx) $ - flk_alex(kr,kt1,kz,kx) ) kr_hi = kr + 1 endif endif enddo c if ( flk_min(kt) .lt. flk_min(kt_min) ) kt_min = kt c enddo c ! max allowed K-increase as T decreases do kt = 1, nt_alex - 2 dflkt_max(kt) = max( 0.5 , dflkt_max(kt) , $ dflkt_max(kt+1) , dflkt_max(kt+2) ) enddo c ! estimate reasonable minimum allowed logKappa for logRHO<-12 c if ( kz .eq. 1 ) then c ! Z = 0.0 : no minimum at low T kt_min = nt_alex / 2 c do kt = kt_min, 1, -1 flk_min(kt) = flk_min(kt) + 10. * min( 0.0 , $ flk_alex(1,kt,1,kx) - flk_alex(2,kt,1,kx) ) enddo c else c ! Z > 0.0 : get minima at low T del = min( 0.0 , $ flk_min(kt_min) - flk_min(min(kt_min+1,nt_alex)) ) if ( kt_min .lt. nt_alex - 5 ) then del = min( del , $ 0.8 * ( flk_min(kt_min+1) - flk_min(kt_min+2) ) ) endif c do kt = kt_min, 1, -1 flk_min(kt) = min( flk_min(kt) , flk_min(kt+1) + del ) enddo c endif c ! all Z: get minima at high T flk_min(nt_alex) = flk_min(nt_alex) $ + 1.5 * min( 0.0 , flk_alex(1,nt_alex,kz,kx) $ - flk_alex(2,nt_alex,kz,kx) ) c do kt = nt_alex, kt_min + 1, -1 flk_min(kt) = min( flk_min(min(kt+1,nt_alex)) , $ flk_min(kt) , $ flk_min(kt) + 1.5 * ( flk_alex(1,kt,kz,kx) $ - flk_alex(2,kt,kz,kx) ) ) enddo c if ( kz .eq. 1 ) kt_min = 1 c ! extrapolate logKappa in logRHO do kt = nt_alex, 1, -1 c del = flk_alex(1,kt,kz,kx) - flk_alex(2,kt,kz,kx) tmp = flk_alex(2,kt,kz,kx) - flk_alex(3,kt,kz,kx) c ! Kappa-jump? c ! => flat extrap if ( kz .gt. 1 .and. ( ( del * tmp .gt. 0.0 .and. $ abs( del ) .gt. max( 0.1 , 2. * abs( tmp ) ) ) .or. $ ( del * tmp .le. 0.0 .and. abs( del ) .gt. $ max( 0.1 , 1.5 * abs( tmp ) ) ) ) ) del = 0.0 c c ! when logKappa smooth in logRHO, extrapolate linearly c do kr = 0, nrlo_alex, -1 c ! but reduce increase if ( del .gt. 0.0 .and. kt .ge. kt_min ) $ del = 0.7 * del c ! check approach to minimum flk_alex(kr,kt,kz,kx) = $ max( flk_alex(kr+1,kt,kz,kx) + del , $ 0.5 * ( flk_alex(kr+1,kt,kz,kx) $ + flk_min(kt) ) ) c ! and check max allowed increase as T c ! decreases if ( kt .lt. min( kt_min , nt_alex - 2 ) ) then tmp = max( flk_min(kt) , $ flk_alex(kr,kt+1,kz,kx) + dflkt_max(kt) ) if ( tmp .lt. flk_alex(kr,kt,kz,kx) ) then flk_alex(kr,kt,kz,kx) = tmp del = min( del , tmp - flk_alex(kr+1,kt,kz,kx) ) if ( kr .lt. 0 ) flk_alex(kr+1,kt,kz,kx) = $ min( flk_alex(kr+1,kt,kz,kx) , 0.33 * tmp $ + 0.67 * flk_alex(kr+2,kt,kz,kx) ) endif endif c enddo c enddo c enddo c enddo c kavail_alex = 1 kdo_alex = kuse_alex c ! if Alexander opacity-inclusion is set, make sure c ! low-T OPAL limit is low enough for switchover if ( kdo_alex .gt. 0 ) $ call set_logt6_limits( -99.0, -99.0, -99.0, -99.0 ) c return end c c****************************************************************************** c subroutine read_cond_pot( iu ) c ============================== c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c parameter ( ndef_cond = 3 ) c character*255 cfile_cond character*80 cdef_cond(ndef_cond) common /c_filename_cond/ need_cond_dir, cfile_cond, cdef_cond save /c_filename_cond/ c if ( kavail_cond .le. 1 .and. cfile_cond .eq. ' ' ) $ cfile_cond = ' PotONLY' c call readcond( iu ) c ! if only have H&L, then try again if ( kavail_cond .le. 1 ) then kavail_cond = 0 cfile_cond = ' PotONLY' call readcond( iu ) endif c return end c c****************************************************************************** c subroutine readcond( iu ) c ========================= c parameter ( small_1m6=1.e-6, small_1m5=1.e-5, small_1m4=1.e-4 ) c double precision picon, fkbcon, clightcon, hbarcon, $ fkchcon, fkch3con, sigradcon, fkcondcon parameter ( picon=3.141592653589793d0, fkbcon=1.38066d-16, $ clightcon=2.99792458d+10, hbarcon=1.0545727d-27, $ fkchcon=fkbcon/(clightcon*hbarcon), $ fkch3con=fkchcon*fkchcon*fkchcon, $ sigradcon=picon*picon*fkbcon*fkch3con*clightcon/60.d0, $ fkcondcon=16.d0*sigradcon/3.d0 ) parameter ( t0_pot=3.0, dt_pot=0.3333, r0_pot=-6.0, dr_pot=0.25 ) c parameter ( nT_KcPot=19, nR_KcPot=64, nZ_KcPot=15 ) c parameter ( ntlokc=37, ntlokcm1=ntlokc-1, nthikc=90-ntlokcm1, $ nrlokc=-23, nrlokcm1=nrlokc-1, nrhikc=24-nrlokcm1, nkc=3, $ nthikcm1=nthikc-1, nrhikcm1=nrhikc-1, nkcp1=nkc+1 ) parameter ( dlt_kc=.1, dlr_kc=.25, dltinv_kc=10., dlrinv_kc=4. ) c character*2 celkc_hl(nkc) common /c_flkcond_hlpot/ flkc_pot(nT_KcPot,nR_KcPot,nZ_KcPot), $ AT_pot(nT_KcPot), AR_pot(nR_KcPot), AZ_pot(nZ_KcPot), $ sigconlog_pot, itlo_hl(nrhikc,nkc), ithi_hl(nrhikc,nkc), $ irhi_hl(nkc), itlo_ok_hl(nrhikc,nkc), $ irjump_hl(nkc), celkc_hl save /c_flkcond_hlpot/ c dimension flkc_hl(nthikc,nrhikc,nkc), $ flrolo_hl(nkc), flrohi_hl(nkc), $ fltlo_hl(nkc), flthi_hl(nkc), $ flRlo_hl(nkc), flRhi_hl(nkc), kZ_pot(nZ_KcPot) equivalence (flkc_pot(1,1,1),flkc_hl(1,1,1)), $ (AR_pot(1),flrolo_hl(1)), (AR_pot(nkcp1),flrohi_hl(1)), $ (AT_pot(1),fltlo_hl(1)), (AT_pot(nkcp1),flthi_hl(1)), $ (AZ_pot(1),flRlo_hl(1)), (AZ_pot(nkcp1),flRhi_hl(1)), $ (itlo_hl(1,1),kZ_pot(1)) c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c parameter ( ndef_cond = 3 ) c character*255 cfile_cond character*80 cdef_cond(ndef_cond) common /c_filename_cond/ need_cond_dir, cfile_cond, cdef_cond save /c_filename_cond/ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c common /c_level_list_opal_z/ iu_list, level_list, list_mult, $ list_gn(-n_zmixes:n_totmix) save /c_level_list_opal_z/ c character*255 cfile_opal_used(-1:n_totmix) common /c_mixfiles_used_opal_z/ cfile_opal_used save /c_mixfiles_used_opal_z/ c parameter ( nitoh=5, nhl=4 ) c common /c_kcond_itoh/ ai_kc(nitoh), ax_kc(0:3,nitoh,3), $ bx_kc(0:2,nitoh,3), cx_kc(0:2,nitoh,3) save /c_kcond_itoh/ c character*255 copdir common/opdir/ copdir save /opdir/ c character*1 cb(6) common /chkpoc/ cb save /chkpoc/ c common /c_pot_indices/ zkpot(0:3,0:3), zlg_pot_p, i1pot_p, $ i4pot_p, j1pot_p, j4pot_p, i1pot, i2pot, i3pot, i4pot, $ j1pot, j2pot, j3pot, j4pot, k1pot, k2pot, k3pot, k4pot save /c_pot_indices/ c-debug[ c-debug; common /c_debug_kcond/ i_debug_kcond c-debug; save /c_debug_kcond/ c-debug] c___ character*255 cfile_use c character*40 cin c character*2 cst(4), ctmp c dimension flk_in(nthikc), xi(5) c=== if ( iu .gt. 0 .and. iu .le. 99 ) iucond = iu c c ! if were already obtained, return if ( kavail_cond .ne. 0 ) return c ifix_h_cond = ifix_h_cond_next itoh_gap = itoh_gap_next c cst(1) = 'st' cst(2) = 'nd' cst(3) = 'rd' cst(4) = 'th' c celkc_hl(1) = 'H ' celkc_hl(2) = 'He' celkc_hl(3) = 'C ' c c Get the H&L or Potekhin conductive opacity file name, and open it: c if ( need_cond_dir .gt. 0 ) then kx = lnblnk(copdir) else kx = 0 endif kt = lnblnk(cfile_cond) c ! check for error in directory name if ( kx .gt. 0 ) then if ( copdir(kx:kx) .ne. cb(1) .and. $ copdir(kx:kx) .ne. cb(2) ) then write(6,15) cb(1), cb(2), copdir(:kx) 15 format(' READCOND Error: directory name does not end in "', $ a1,'" or "',a1,'":'/' ',a) stop ' STOP -- READCOND Error: directory name bad last char' endif endif c ! blank? try defaults if ( kt .le. 0 .or. cfile_cond(1:1) .eq. ' ' ) then c cfile_cond = ' ' igzip = -99999 i = ndef_cond kx = lnblnk(copdir) if ( kx .gt. 0 ) then if ( copdir(kx:kx) .ne. cb(1) .and. $ copdir(kx:kx) .ne. cb(2) ) kx = 0 endif if ( kt .gt. 0 ) then ilo = 2 else ilo = 1 endif c do while ( i .ge. ilo .and. igzip .eq. -99999 ) kt = lnblnk( cdef_cond(i) ) call open_chk_zip( -99999, cdef_cond(i), igzip, '???' ) if ( igzip .ne. -99999 ) then kx = 0 need_cond_dir = 0 cfile_cond = cdef_cond(i) else if ( kx .gt. 0 ) then cfile_use = copdir(:kx) // cdef_cond(i) call open_chk_zip( -99999, cfile_use, igzip, '???' ) if ( igzip .ne. -99999 ) then need_cond_dir = 1 cfile_cond = cdef_cond(i) endif endif i = i - 1 enddo c if ( igzip .eq. -99999 ) then write(6,6) 6 format(' READCOND Error: Cannot find any of the', $ ' default conductive opacity files:') do i = ndef_cond, ilo, -1 write(6,7) cdef_cond(i)(:lnblnk(cdef_cond(i))) 7 format(' ',a) enddo if ( kx .gt. 0 ) then write(6,8) copdir(:kx) 8 format(' in the local directory,', $ ' nor in the specified OPAL directory:'/' ',a) else write(6,9) 9 format(' in the local directory.') endif stop ' STOP -- READCOND Error: NO conductive opacity file.' endif c endif c ! directory + file name too long? if ( kx + kt .gt. 252 ) then if ( kx .gt. 0 ) then write(6,10) copdir(:kx), cfile_cond(:kt) else write(6,10) cfile_cond(:kt) endif 10 format(' READCOND Error: directory + file name > 252 chars:'/ $ ' ',a/' ',a) stop ' STOP -- READCOND Error: dir+file name > 252 chars. ' endif c ! combine directory and file name if ( kx .gt. 0 ) then c cfile_use = copdir(:kx) // cfile_cond kt = kt + kx c else c cfile_use = cfile_cond c endif c cfile_opal_used(3) = cfile_use c ! open the file call open_chk_zip( iucond, cfile_use, i_gzip, $ 'READCOND Error: conductive opacity file not found.' ) c c Check the first line to see if this is the Potekhin conductive opacity file. c If so, go (to near the end of this subroutine) to read these in; c otherwise, read in the H&L conductive opacities logKcond c line = 0 linep = 0 ngot = 0 c ! for each of the H&L tables (i.e., elements H, He, C): do kx = 1, nkc c flRlo_hl(kx) = 99. flRhi_hl(kx) = -99. c ! read the table-range values for this element line = line + 1 read(iucond,'(a40)',end=990) cin c ! is it a Potekhin 2006 file ? if ( kx .eq. 1 ) then if ( level_list .gt. 0 ) then if ( iu_list .eq. iucond ) then write(6,4) iu_list 4 format(/' ***OPAL WARNING: READCOND:', $ ' bad LIST_IU =',i3, $ ', reset to 6 (standard output)'/) iu_list = 6 endif if ( cin(1:7) .ne. ' -5.75 ' ) then write(iu_list,1) cfile_use(:lnblnk(cfile_use)) 1 format(' ***OPAL/COND_Pot06: ',a) goto 400 else write(iu_list,2) cfile_use(:lnblnk(cfile_use)) 2 format(' ***OPAL/COND_H&L: ',a) endif else if ( cin(1:7) .ne. ' -5.75 ' ) then goto 400 endif endif c read(cin,100,err=900,end=910) flrolo_hl(kx), $ flrohi_hl(kx), drho, dt, $ flthi_hl(kx), fltlo_hl(kx), ctmp 100 format(6f6.2,1x,a2) c ! check for errors in input linep = line if ( max( abs( drho - dlr_kc ) , abs( dt - dlt_kc ) ) $ .gt. small_1m6 .or. flrolo_hl(kx) .ge. $ flrohi_hl(kx) .or. flthi_hl(kx) .le. $ fltlo_hl(kx) .or. ctmp .ne. celkc_hl(kx) ) goto 900 c krlo = nint( flrolo_hl(kx) * dlrinv_kc - nrlokcm1 ) irhi_hl(kx) = nint( flrohi_hl(kx) * dlrinv_kc - nrlokcm1 ) c if ( krlo .ne. 1 .or. ( kx .gt. 1 .and. $ irhi_hl(kx) .ne. nrhikc ) .or. ( kx .eq. 1 .and. $ ( irhi_hl(kx) .gt. nrhikc .or. $ irhi_hl(kx) .lt. nrhikc - 4 ) ) ) goto 900 c ! for each RHO: do kr = 1, irhi_hl(kx) c ! read logT, nT, some logKcond flro = ( kr + nrlokcm1 ) * dlr_kc ngot = 12 line = line + 1 read(iucond,200,err=920,end=930) flthi, numt, $ ( flk_in(i), i = 1, min( 12 , numt ) ) 200 format( f4.1, i3, 12f6.3 ) c ! check for errors in input linep = line if ( numt .lt. 2 .or. numt .gt. nthikc ) goto 920 ngot = min( 12 , numt ) c ! set the T-range at this RHO c ithi_hl(kr,kx) = nint( flthi * dltinv_kc - ntlokcm1 ) ndel = ithi_hl(kr,kx) + 1 itlo_hl(kr,kx) = ndel - numt if ( itlo_hl(kr,kx) .le. 0 .or. $ ithi_hl(kr,kx) .gt. nthikc ) goto 920 c ! REMOVE ANOMALOUS VALUE if ( kx .eq. min( 1 , ifix_h_cond ) .and. $ abs( flro + 0.5 ) .lt. small_1m4 ) then itlo_hl(kr,1) = max( itlo_hl(kr,1) , $ nint( 5.5 * dltinv_kc - ntlokcm1 ) ) endif c itlo_ok_hl(kr,kx) = itlo_hl(kr,kx) c ! update the table logR-range flRhi_hl(kx) = max( flRhi_hl(kx) , $ flro - ( flthi - ( numt - 1 ) * dlt_kc - 6. ) * 3. ) flRlo_hl(kx) = min( flRlo_hl(kx) , $ flro - ( flthi - 6. ) * 3. ) c ! check for bad logKcond values nzer = 0 do i = 1, ngot if ( flk_in(i) .eq. 0.0 ) then if ( nzer .gt. 0 ) goto 920 nzer = nzer + 1 else if ( flk_in(i) .lt. -30. .or. $ flk_in(i) .gt. 30. ) then goto 920 endif enddo c ! read any further lines at this RHO: do while ( ngot .lt. numt ) c ! read next line ngs = ngot + 1 ngot = min( ngot + 12 , numt ) line = line + 1 read(iucond,250,err=940,end=930) $ ( flk_in(i), i = ngs, ngot ) 250 format( 7x, 12f6.3 ) c ! and check for bad logKcond values do i = ngs, ngot if ( flk_in(i) .eq. 0.0 ) then if ( nzer .gt. 0 ) goto 940 nzer = nzer + 1 else if ( flk_in(i) .lt. -30. .or. $ flk_in(i) .gt. 30. ) then goto 940 endif enddo c enddo c ! transfer input logKcond values into matrix do i = 1, numt flkc_hl(ndel-i,kr,kx) = flk_in(i) enddo c enddo c enddo c ! close file when done call close_chk_zip( iucond, cfile_use, i_gzip ) c c ! set "H&L conductive opacities available" flag kavail_cond = 1 kdo_cond = kavail_cond * kuse_cond c c Extend the logKcond values in a reasonable way into the areas of the H&L c matrix where nothing was read in. c ! extend the high-RHO part of the c ! H table to slightly lower T, using shape of He table krhi = irhi_hl(1) kr = krhi c do while ( kr .gt. 1 .and. $ itlo_hl(kr,1) .le. itlo_hl(min(kr+1,krhi),1) .and. $ itlo_hl(kr,2) .le. itlo_hl(min(kr+1,nrhikc),2) ) c kt = itlo_hl(kr,1) c if ( itlo_hl(kr,2) .lt. kt ) then c del = flkc_hl(kt,kr,1) - flkc_hl(kt,kr,2) c do kt = itlo_hl(kr,1) - 1, itlo_hl(kr,2), -1 flkc_hl(kt,kr,1) = flkc_hl(kt,kr,2) + del enddo c ! update O.K. T-range itlo_ok_hl(kr,1) = itlo_hl(kr,2) c endif c kr = kr - 1 c enddo c ! fill any mini-gap just created (should not be needed) krat = kr + 1 c if ( itlo_hl(kr,1) .le. itlo_hl(krat,1) .and. $ itlo_hl(kr,1) .gt. itlo_ok_hl(krat,1) ) then c ktlo = itlo_ok_hl(krat,1) krhi = kr c ! find low edge of mini-gap c do while ( kr .gt. 2 .and. itlo_hl(kr,1) .gt. ktlo .and. $ itlo_hl(kr-1,1) .le. itlo_hl(kr,1) ) kr = kr - 1 enddo c krlim = kr ktlo = max( ktlo , itlo_hl(krlim,1) ) c ! for all T in the gap: do kt = itlo_hl(krhi,1) - 1, ktlo, -1 c ! find low edge at this T krlo = krat - 1 do while ( krlo .gt. krlim .and. $ kt .lt. itlo_ok_hl(krlo,1) ) krlo = krlo - 1 enddo c kthi = kt + 1 del1 = flkc_hl(kt,krlo,1) - flkc_hl(kthi,krlo,1) del2 = flkc_hl(kt,krat,1) - flkc_hl(kthi,krat,1) c ! fill the gap do kr = krlo + 1, krat - 1 flkc_hl(kt,kr,1) = flkc_hl(kthi,kr,1) $ + ( ( krat - kr ) * del1 + ( kr - krlo ) * del2 ) $ / ( krat - krlo ) itlo_ok_hl(kr,1) = kt enddo c enddo c endif c ! extend the H table to higher RHO, c ! using the shape of the He table if ( krhi .lt. nrhikc ) then c kthi = min( ithi_hl(krhi,1) , ithi_hl(krhi,2) ) ktlo = max( itlo_ok_hl(krlo,1) , itlo_ok_hl(krlo,2) ) c do kr = krhi + 1, nrhikc c ithi_hl(kr,1) = ithi_hl(kr,2) itlo_ok_hl(kr,1) = itlo_hl(kr,2) itlo_hl(kr,1) = itlo_hl(kr,2) $ + itlo_hl(krhi,1) - itlo_ok_hl(krhi,1) c ktat = kthi c do kt = ithi_hl(kr,2), itlo_hl(kr,2), -1 flkc_hl(kt,kr,1) = flkc_hl(ktat,krhi,1) $ - flkc_hl(ktat,krhi,2) + flkc_hl(kt,kr,2) ktat = max( ktat - 1 , ktlo ) enddo c enddo c endif c ! for all three H&L tables (H, He, and C): extend... do kx = 1, nkc c ! this initialization just prevents compiler warnings: ktlo = 0 c ! @maxRHO: extend to maxT (shouldn't be needed) kt = ithi_hl(nrhikc,kx) if ( kt .lt. nthikc ) then del1 = flkc_hl(kt,nrhikc,kx) - flkc_hl(kt-1,nrhikc,kx) del2 = max( 0.0 , flkc_hl(kt-1,nrhikc,kx) $ - flkc_hl(kt-2,nrhikc,kx) - del1 ) do while ( kt .lt. nthikc ) kt = kt + 1 del2 = 0.5 * del2 del1 = max( 0.5 * del1 , del1 - del2 ) flkc_hl(kt,nrhikc,kx) = flkc_hl(kt-1,nrhikc,kx) + del1 enddo endif c ! fill in missing values at high T (low RHO): do kr = nrhikcm1, 1, -1 do kt = ithi_hl(kr,kx) + 1, nthikc flkc_hl(kt,kr,kx) = flkc_hl(kt-1,kr,kx) $ + min( flkc_hl(kt,kr+1,kx) $ - flkc_hl(kt-1,kr+1,kx) , $ flkc_hl(kt-1,kr,kx) - flkc_hl(kt-2,kr,kx) ) enddo enddo c ! @minRHO: extend to minT (needed for He and C) kt = itlo_hl(1,kx) if ( kt .gt. 1 ) then del1 = flkc_hl(kt,1,kx) - flkc_hl(kt+1,1,kx) do while ( kt .gt. 1 ) kthi = kt kt = kt - 1 flkc_hl(kt,1,kx) = flkc_hl(kthi,1,kx) + del1 enddo endif c ! fill in "gap" at mid-RHO, low T: krhi = nrhikcm1 do while ( krhi .gt. 2 .and. $ itlo_ok_hl(krhi-1,kx) .le. itlo_ok_hl(krhi,kx) ) krhi = krhi - 1 enddo c krat = krhi do while ( krat .gt. 2 .and. $ itlo_ok_hl(krat-1,kx) .ge. itlo_ok_hl(krat,kx) ) krat = krat - 1 enddo c if ( krat .lt. 2 ) stop $ ' STOP -- READCOND Error: bad mid-RHO gap: cannot be. ' c ktlim = itlo_ok_hl(krat,kx) - 1 c ! IF Itoh Kcond used in filling "gap": c if ( itoh_replace .ge. 0 .and. itoh_gap .gt. 0 ) then c do i = 1, 5 xi(i) = 0.0 enddo xi(kx) = 1.0 c ! for Hydrogen: if ( kx .eq. 1 ) then c krlo = nint( 1.25 * dlrinv_kc ) - nrlokcm1 krat = nint( 2.0 * dlrinv_kc ) - nrlokcm1 krit = krlo - 1 c ! for logRHO = 1.25, 1.5, 1.75, 2.0 do while ( krit .lt. krat ) c ! set to approx logKc(Itoh) at low T krit = krit + 1 c if ( krit .lt. krhi ) stop $ ' STOP -- READCOND Error: bad RHO(H) cannot be.' c c ! set dKc = logKc(H&L) - logKc(Itoh) c ! at Tmin(H&L) flro = ( krit + nrlokcm1 ) * dlr_kc kt = itlo_ok_hl(krit,1) flt = ( kt + ntlokcm1 ) * dlt_kc call kapcond( flro, flt, xi(1), xi(2), xi(3), $ xi(4), xi(5), -9., -9., -9., -1, $ del2, flkct, flkcro, fkcedge, fkcok ) del1 = flkc_hl(kt,krit,kx) - del2 c ! at all lower T values do kt = itlo_ok_hl(krit,1) - 1, 1, -1 c ! reduce dKc magnitude if ( del1 .lt. 0.0 ) then del1 = min( del1 + 0.05 , 0.5 * del1 ) else del1 = max( del1 - 0.05 , 0.5 * del1 ) endif c ! set logKc(H&L) = logKc(Itoh) + dKc [goes to c ! logKc(Itoh) at low T] flt = ( kt + ntlokcm1 ) * dlt_kc call kapcond( flro, flt, xi(1), xi(2), xi(3), $ xi(4), xi(5), -9., -9., -9., -1, $ del2, flkct, flkcro, fkcedge, fkcok ) flkc_hl(kt,krit,kx) = del2 + del1 c enddo c enddo c krhiat = krlo c ! for Helium and Carbon: else c ! for logRHO = 1.5 krit = nint( 1.5 * dlrinv_kc ) - nrlokcm1 c if ( krat .lt. krhi - 1 ) stop $ ' STOP -- READCOND Error: bad krat cannot be. ' c ktlo = 0 fkcedge = 0.0 flro = ( krit + nrlokcm1 ) * dlr_kc kthi = itlo_ok_hl(krit,kx) c ! set to logKc(Itoh) at very low T do while ( fkcedge .eq. 0.0 ) ktlo = ktlo + 1 if ( ktlo .ge. itlo_ok_hl(krit,kx) ) stop $ ' STOP -- READCOND Error: bad ktlo cannot be. ' flt = ( ktlo + ntlokcm1 ) * dlt_kc call kapcond( flro, flt, xi(1), xi(2), xi(3), $ xi(4), xi(5), -9., -9., -9., -1, $ flkc_hl(ktlo,krit,kx), $ flkct, flkcro, fkcedge, fkcok ) enddo c ! and up to Tmax(Itoh) < Tmin(H&L) do while ( fkcedge .gt. 0.0 ) ktlo = ktlo + 1 if ( ktlo .ge. kthi ) stop $ ' STOP -- READCOND Error: bad ktlo cannot be. ' flt = ( ktlo + ntlokcm1 ) * dlt_kc call kapcond( flro, flt, xi(1), xi(2), xi(3), $ xi(4), xi(5), -9., -9., -9., -1, $ flkc_hl(ktlo,krit,kx), $ flkct, flkcro, fkcedge, fkcok ) enddo ktlo = ktlo - 1 c ! interp: Tmax(Itoh) up to Tmin(H&L) do kt = ktlo + 1, kthi - 1 flkc_hl(kt,krit,kx) = $ ( ( kthi - kt ) * flkc_hl(ktlo,krit,kx) $ + ( kt - ktlo ) * flkc_hl(kthi,krit,kx) ) $ / ( kthi - ktlo ) enddo c ! fill "gap" at logRHO > 1.5, for all T down to lowest c ! Tmin(H&L)[logRHO > 1.5] do kt = ktlim, itlo_ok_hl(krhi,kx), -1 c ! find gap high-RHO edge krat = krhi do while ( krat .gt. krit .and. $ kt .ge. itlo_ok_hl(krat,kx) ) krat = krat - 1 enddo c ! if gap exists at this T if ( krat .gt. krit ) then c ! find gap low-RHO edge krlo = krat krat = krat + 1 c do while ( krlo .gt. krit .and. $ kt .lt. itlo_ok_hl(krlo,kx) ) krlo = krlo - 1 enddo c kthi = kt + 1 del1 = flkc_hl(kt,krlo,kx) - flkc_hl(kthi,krlo,kx) del2 = flkc_hl(kt,krat,kx) - flkc_hl(kthi,krat,kx) c ! & fill do kr = krlo + 1, krat - 1 flkc_hl(kt,kr,kx) = ( flkc_hl(kthi,kr,kx) $ + ( ( krat - kr ) * del1 $ + ( kr - krlo ) * del2 ) $ / ( krat - krlo ) ) enddo c endif c enddo c ! Carbon: let T1 = Tmax(Itoh)[logRHO=1.5] if ( kx .eq. 3 ) then c ! let T2 = Tmin(H&L)[logRHO>1.5] ktloat = itlo_ok_hl(krhi,kx) c ! at higher RHO along Tmax(Itoh): do kr = krit + 1, krhi - 1 c ! for this RHO: start at T1 ktat = ktlo flro = ( kr + nrlokcm1 ) * dlr_kc flt = ( ktat + ntlokcm1 ) * dlt_kc call kapcond( flro, flt, xi(1), xi(2), xi(3), $ xi(4), xi(5), -9., -9., -9., -1, $ flkc, flkct, flkcro, fkcedge, fkcok ) c ! store Kc(Itoh) del1 = flkc - flkc_hl(ktat,kr,kx) if ( kr .eq. krhi - 1 ) del1 = 0.5 * del1 c flkc_hl(ktat,kr,kx) = flkc_hl(ktat,kr,kx) + del1 c c ! interp T1 down to T2 if ( ktloat .lt. ktat - 1 ) then del2 = del1 / ( ktat - ktloat ) do kt = ktloat + 1, ktat - 1 flkc_hl(kt,kr,kx) = flkc_hl(kt,kr,kx) $ + ( kt - ktloat ) * del2 enddo endif c kthiat = itlo_ok_hl(kr,kx) c ! for T up to Tmax(Itoh)[RHO] do while ( fkcedge .gt. 0.0 ) c ! store logKc(Itoh) ktat = ktat + 1 if ( ktat .ge. kthiat ) stop $ ' STOP -- READCOND Error: bad ktat cannot' flt = ( ktat + ntlokcm1 ) * dlt_kc call kapcond( flro, flt, xi(1), xi(2), xi(3), $ xi(4), xi(5), -9., -9., -9., -1, $ flkc, flkct, flkcro, fkcedge, fkcok ) if ( fkcedge .gt. 0.0 ) then del1 = flkc - flkc_hl(ktat,kr,kx) if ( kr .eq. krhi - 1 ) del1 = 0.5 * del1 flkc_hl(ktat,kr,kx) = flkc_hl(ktat,kr,kx) $ + del1 endif c enddo c ! interp Tmax(Itoh)[RHO] up to Tmin(H&L)[RHO] ktat = ktat - 1 del2 = del1 / ( kthiat - ktat ) c do kt = ktat + 1, kthiat - 1 flkc_hl(kt,kr,kx) = flkc_hl(kt,kr,kx) $ + ( kthiat - kt ) * del2 enddo c enddo c endif c ktlim = itlo_ok_hl(krit-1,kx) - 1 krhiat = krit c endif c ! for Hydrogen, Helium, and Carbon: c ! for all temperatures T in "gap" do kt = ktlim, 1, -1 c d_hi = 0.8 d_lo = 0.2 if ( kx .eq. 3 .or. kx .eq. 2 ) then if ( kt .ge. ktlo ) then kr1 = - nrlokcm1 else kr1 = max( 1 , $ nint( ( kt - ktlo ) * 0.25 - nrlokcm1 ) ) d_hi = 0.9 d_lo = 0.1 endif kr2 = krhiat do while ( kr1 .lt. krhiat .and. $ kt .ge. itlo_ok_hl(min(kr1+1,nrhikc),kx) ) kr1 = kr1 + 1 enddo else if ( kx .eq. 1 ) then kr2 = nint( 0.75 * dlrinv_kc ) - nrlokcm1 if ( kt .ge. itlo_ok_hl(kr2,kx) ) then kr1 = nint( -1.0 * dlrinv_kc ) - nrlokcm1 do while ( kr1 .lt. kr2 .and. $ kt .ge. itlo_ok_hl(min(kr1+1,nrhikc),kx) ) kr1 = kr1 + 1 enddo else kr1 = kr2 - 1 kr2 = krhiat endif else kr1 = nrhikc kr2 = 0 endif c ! for all densities below where used Kc(Itoh) c ! find upper RHO-edge of gap at highest RHO krat = krhiat - 1 do while ( krat .gt. 1 .and. $ kt .ge. itlo_ok_hl(krat,kx) ) krat = krat - 1 enddo c ! find and fill any gaps do while ( krat .gt. 2 ) c ! find lower RHO-edge of gap krlo = krat krat = krat + 1 c do while ( krlo .gt. 1 .and. $ kt .lt. itlo_ok_hl(krlo,kx) ) krlo = krlo - 1 enddo c ! and fill it for all RHO in gap kthi = kt + 1 del1 = flkc_hl(kt,krlo,kx) - flkc_hl(kthi,krlo,kx) del2 = flkc_hl(kt,krat,kx) - flkc_hl(kthi,krat,kx) c ! fill gap @ T do kr = krlo + 1, krat - 1 flkc_hl(kt,kr,kx) = ( flkc_hl(kthi,kr,kx) $ + ( ( krat - kr ) * del1 $ + ( kr - krlo ) * del2 ) $ / ( krat - krlo ) ) if ( kr .gt. kr1 .and. kr .lt. kr2 ) $ flkc_hl(kt,kr,kx) = d_hi * flkc_hl(kt,kr,kx) $ + d_lo * ( ( kr2 - kr ) * flkc_hl(kt,kr1,kx) $ + ( kr - kr1 ) * flkc_hl(kt,kr2,kx) ) $ / ( kr2 - kr1 ) enddo c ! find upper RHO-edge of next gap, if any krat = krlo do while ( krat .gt. 1 .and. $ kt .ge. itlo_ok_hl(krat,kx) ) krat = krat - 1 enddo c enddo c enddo c ! (set the definition of high RHO, low T for below) krat = krit if ( kx .eq. 1 ) then ktlim = nthikc else ktlim = itlo_ok_hl(krhi,kx) - 1 endif c ! ELSE: if Itoh Kcond NOT used in filling "gap": else c ktlo = itlo_ok_hl(krhi,kx) c ! for all T in the gap: do kt = ktlim, ktlo, -1 c ! find edges of gap at this T krlo = krat - 1 c ! find low edge do while ( krat .lt. krhi .and. $ kt .lt. itlo_ok_hl(krat,kx) ) krat = krat + 1 enddo c ! & high do while ( krlo .gt. 1 .and. $ kt .lt. itlo_ok_hl(krlo,kx) ) krlo = krlo - 1 if ( itlo_ok_hl(krlo,kx) .gt. $ itlo_ok_hl(krlo+1,kx) ) stop $ ' STOP -- READCOND Error: ragged bottom cannot.' enddo c if ( kt .lt. itlo_ok_hl(krlo,kx) ) stop $ ' STOP -- READCOND Error: bad mid-RHO gap cannot. ' c kthi = kt + 1 del1 = flkc_hl(kt,krlo,kx) - flkc_hl(kthi,krlo,kx) del2 = flkc_hl(kt,krat,kx) - flkc_hl(kthi,krat,kx) c ! fill gap @ T do kr = krlo + 1, krat - 1 flkc_hl(kt,kr,kx) = flkc_hl(kthi,kr,kx) $ + ( ( krat - kr ) * del1 $ + ( kr - krlo ) * del2 ) $ / ( krat - krlo ) enddo c enddo c ! find RHO just above gap krhi = nrhikc do while ( krhi .gt. 1 .and. itlo_ok_hl(max(1,krhi-1),kx) $ .lt. itlo_ok_hl(krhi,kx) ) krhi = krhi - 1 enddo c ktlim = nthikc c if ( krhi .gt. 1 ) then c ! @RHO just above gap: extend to minT kt = itlo_ok_hl(krhi,kx) del1 = flkc_hl(kt,krhi,kx) - flkc_hl(kt+1,krhi,kx) del2 = flkc_hl(kt+1,krhi,kx) - flkc_hl(kt+2,krhi,kx) $ - del1 do while ( kt .gt. 1 ) kthi = kt kt = kt - 1 del2 = 0.5 * del2 del1 = del1 - del2 flkc_hl(kt,krhi,kx) = flkc_hl(kthi,krhi,kx) + del1 enddo c ! fill the new gap created by this extension krlo = krhi - 1 do kt = itlo_ok_hl(krhi,kx) - 1, 1, -1 kthi = kt + 1 do while ( krlo .gt. 1 .and. $ kt .lt. itlo_ok_hl(krlo,kx) ) krlo = krlo - 1 enddo del1 = flkc_hl(kt,krlo,kx) - flkc_hl(kthi,krlo,kx) del2 = flkc_hl(kt,krhi,kx) - flkc_hl(kthi,krhi,kx) do kr = krlo + 1, krhi - 1 flkc_hl(kt,kr,kx) = flkc_hl(kthi,kr,kx) $ + ( ( krhi - kr ) * del1 $ + ( kr - krlo ) * del2 ) / ( krhi - krlo ) enddo enddo c ktlim = itlo_ok_hl(krhi,kx) c endif c krat = krhi c ! (end of "gap" Itoh Kcond alternatives) endif c ! IN ALL CASES: c ! fill in missing values at high RHO, low T: do kr = krat + 1, nrhikc krlo = kr - 1 kthi = itlo_ok_hl(kr,kx) - 1 if ( kr .le. krhi ) kthi = min( kthi , ktlim ) do kt = kthi, 1, -1 flkc_hl(kt,kr,kx) = flkc_hl(kt+1,kr,kx) $ + min( flkc_hl(kt,krlo,kx) $ - flkc_hl(kt+1,krlo,kx) , $ flkc_hl(kt+2,kr,kx) - flkc_hl(kt+1,kr,kx) ) enddo enddo c enddo c call find_rjump_hl_cond c ! DONE: return return c 900 write(6,905) line, kx, celkc_hl(kx) 905 format(' READCOND Error (file line',i4, $ '): bad table-range values beginning element_',i1,'= ',a2) if ( linep .eq. line ) write(6,907) flrolo_hl(kx), $ flrohi_hl(kx), drho, dt, $ flthi_hl(kx), fltlo_hl(kx), ctmp 907 format(' READCOND Error: logRHO',f6.2,' :',f6.2,' dlogRHO,T', $ 2f5.2,' logT',2f5.2,' for ',a2) write(6,908) cfile_use(:lnblnk(cfile_use)) 908 format(' ',a) stop ' STOP -- READCOND Error: bad H&L table-range values. ' c 990 continue if ( line .eq. 1 ) then write(6,995) cfile_use(:lnblnk(cfile_use)) 995 format(' READCOND Error: unexpected EOF', $ ' at beginning of conductive opacity file:'/' ',a) stop ' STOP -- READCOND Error: EOF at beginning of file. ' endif c 910 write(6,915) line, kx, celkc_hl(kx) 915 format(' READCOND Error (file line',i4, $ '): unexpected EOF at beginning of element_',i1,'= ',a2) write(6,908) cfile_use(:lnblnk(cfile_use)) stop ' STOP -- READCOND Error: EOF (missing H&L Kcond table). ' c 920 write(6,925) line, kx, celkc_hl(kx), kr 925 format(' READCOND Error (file line ',i4,'): element_',i1,'=',a2, $ ' @ logRHO_',i2.2,': bad logT,nT,logKcond') if ( linep .eq. line ) write(6,927) flro, flthi, numt, $ ithi_hl(kr,kx), itlo_hl(kr,kx), ';', $ ( ' ', flk_in(i), i = 1, ngot ) 927 format(' READCOND Error (logRHO',f6.2,'): logThi',f5.1, $ ' nT',i4,' (index',i3,' :',i3,')',a,a1,' logKcond:', $ 2(/' READCOND Error: ',6(f9.5,a1))) write(6,908) cfile_use(:lnblnk(cfile_use)) stop ' STOP -- READCOND Error: H&L table: bad logT,nT,logKcond. ' c 930 write(6,935) line, kx, celkc_hl(kx), kr, flro, $ 1 + (ngot-1)/12, cst( min( 4 , 1 + (ngot-1)/12 ) ) if ( ngot .gt. 12 ) write(6,927) dlr_kc * ( kr + nrlokcm1 ), $ flthi, numt, ithi_hl(kr,kx), itlo_hl(kr,kx), $ ': ... EOF' 935 format(' READCOND Error (file line',i4, $ '): EOF: element_',i1,'=',a2, $ ' @ logRHO_',i2.2,'=',f6.2,':',i2,a2,'-line') write(6,908) cfile_use(:lnblnk(cfile_use)) stop ' STOP -- READCOND Error: EOF (in H&L Kcond table). ' c 940 write(6,945) line, kx, celkc_hl(kx), kr, 1 + (ngot-1)/12, $ cst( min( 4 , 1 + (ngot-1)/12 ) ) 945 format(' READCOND Error (file line',i4,'): element_',i1,'=',a2, $ ' bad logKcond @ logRHO_',i2.2,':',i1,a2,'-line') write(6,927) flro, flthi, numt, $ ithi_hl(kr,kx), itlo_hl(kr,kx), ';', $ ( ' ', flk_in(i), i = 1, ngot ) write(6,908) cfile_use(:lnblnk(cfile_use)) stop ' STOP -- READCOND Error: H&L table: bad logKcond value. ' c c Alternative part: read in Potekhin file (note 1st line already skipped): c 400 continue c ! for each Z do iz = 1, nZ_KcPot c line = line + 1 c read(iucond,*,err=800,end=810) z_pot, $ ( AT_pot(it), it = 1, nT_KcPot ) cREADCOND Error (Potekhin file line 123): bad at.no. z_nuc(12) = -1.1234567e-12 if ( z_pot .lt. 1.0 .or. z_pot .gt. 130.0 .or. $ ( iz .eq. 1 .and. z_pot .ne. 1.0 ) .or. $ abs( z_pot - nint(z_pot) ) .gt. small_1m5 ) then write(6,700) line, iz, z_pot 700 format(' READCOND Error (Potekhin file line',i4, $ '): bad at.no. z_nuc(',i2.2,') =',1p,e15.7) stop ' STOP -- READCOND Error: Potekhin file: bad z_nuc. ' endif c AZ_pot(iz) = log10( z_pot ) kZ_pot(iz) = nint( z_pot ) c ! note logT spacing is NOT even: c ! d logT = 0.333 0.334 0.333 0.333 ... do it = 2, nT_KcPot if ( abs( AT_pot(it) - AT_pot(it-1) - dt_pot ) .gt. 0.001 $ .or. abs( AT_pot(1) - t0_pot ) .gt. small_1m6 ) then cREADCOND Error (Potekhin file line 123): bad logT values for z_nuc(12) = 123: cREADCOND Error: should be logT = 3.0 (1/3) 9.0, but input was: logT = 3.000 cREADCOND Error: 3.333 3.667 4.000 4.333 4.667 5.000 5.333 5.667 6.000 cREADCOND Error: 6.333 6.667 7.000 7.333 7.667 8.000 8.333 8.667 9.000 write(6,710) line, iz, kZ_pot(iz), $ ( AT_pot(i), i = 1, nT_KcPot ) 710 format(' READCOND Error (Potekhin file line',i4, $ '): bad logT values for z_nuc(',i2.2,') =',i4,':'/ $ ' cREADCOND Error: should be logT = 3.0 (1/3)', $ ' 9.0, but input was: logT =',f7.3, $ 2(/' READCOND Error:',9f7.3)) write(6,908) cfile_use(:lnblnk(cfile_use)) stop ' STOP -- READCOND Error: Potekhin file: bad T. ' endif enddo c ! for each RHO do ir = 1, nR_KcPot c ! read in all T-values line = line + 1 read(iucond,*,err=800,end=810) AR_pot(ir), $ ( flkc_pot(it,ir,iz), it = 1, nT_KcPot ) c if ( ( ir .eq. 1 .and. $ abs( AR_pot(ir) - r0_pot ) .gt. small_1m5 ) .or. $ ( ir .gt. 1 .and. abs( AR_pot(ir) $ - AR_pot(max(ir-1,1)) - dr_pot ) .gt. $ small_1m5 ) ) then cREADCOND Error (Potekhin file line 123): bad logRHO value for z_nuc(12) = 123: cREADCOND Error: should be logRHO = -12.123456: bad input logRHO = -12.123456 if ( ir .eq. 1 ) then write(6,720) line, iz, kZ_pot(iz), r0_pot, AR_pot(ir) else write(6,720) line, iz, kZ_pot(iz), $ AR_pot(ir-1) + dr_pot, AR_pot(ir) endif 720 format(' READCOND Error (Potekhin file line',i4, $ '): bad logRHO value for z_nuc(',i2.2,') =',i4,':'/ $ ' READCOND Error: should be logRHO =',f11.6, $ ': bad input logRHO =',f11.6) write(6,908) cfile_use(:lnblnk(cfile_use)) stop ' STOP -- READCOND Error: Potekhin file: bad RHO. ' endif c enddo c enddo c ! close file when done call close_chk_zip( iucond, cfile_use, i_gzip ) c c ! set "Potekhin conductive opacities available" flag kavail_cond = 2 kdo_cond = kavail_cond * kuse_cond c ! to convert conductivity to opacity sigconlog_pot = log10( fkcondcon ) c ! clear cache i1pot_p = 0 i4pot_p = -1 j1pot_p = 0 j4pot_p = -1 zlg_pot_p = -1.e30 c return c cREADCOND Error (Potekhin file line 123): error reading input values. 800 write(6,805) line 805 format(' READCOND Error (Potekhin file line',i4, $ '): error reading input values.') write(6,908) cfile_use(:lnblnk(cfile_use)) stop ' STOP -- READCOND Error: Potekhin file read error. ' c cREADCOND Error (Potekhin file line 123): unexpected end of file. 810 write(6,815) line 815 format(' READCOND Error (Potekhin file line',i4, $ '): unexpected end of file.') write(6,908) cfile_use(:lnblnk(cfile_use)) stop ' STOP -- READCOND Error: unexpected EOF (in Potekhin file)' c end c c****************************************************************************** c subroutine find_rjump_hl_cond c ============================= c parameter ( nT_KcPot=19, nR_KcPot=64, nZ_KcPot=15 ) c parameter ( ntlokc=37, ntlokcm1=ntlokc-1, nthikc=90-ntlokcm1, $ nrlokc=-23, nrlokcm1=nrlokc-1, nrhikc=24-nrlokcm1, nkc=3, $ nthikcm1=nthikc-1, nrhikcm1=nrhikc-1, nkcp1=nkc+1 ) parameter ( dlt_kc=.1, dlr_kc=.25, dltinv_kc=10., dlrinv_kc=4. ) c character*2 celkc_hl(nkc) common /c_flkcond_hlpot/ flkc_pot(nT_KcPot,nR_KcPot,nZ_KcPot), $ AT_pot(nT_KcPot), AR_pot(nR_KcPot), AZ_pot(nZ_KcPot), $ sigconlog_pot, itlo_hl(nrhikc,nkc), ithi_hl(nrhikc,nkc), $ irhi_hl(nkc), itlo_ok_hl(nrhikc,nkc), $ irjump_hl(nkc), celkc_hl save /c_flkcond_hlpot/ c dimension flkc_hl(nthikc,nrhikc,nkc), $ flrolo_hl(nkc), flrohi_hl(nkc), $ fltlo_hl(nkc), flthi_hl(nkc), $ flRlo_hl(nkc), flRhi_hl(nkc), kZ_pot(nZ_KcPot) equivalence (flkc_pot(1,1,1),flkc_hl(1,1,1)), $ (AR_pot(1),flrolo_hl(1)), (AR_pot(nkcp1),flrohi_hl(1)), $ (AT_pot(1),fltlo_hl(1)), (AT_pot(nkcp1),flthi_hl(1)), $ (AZ_pot(1),flRlo_hl(1)), (AZ_pot(nkcp1),flRhi_hl(1)), $ (itlo_hl(1,1),kZ_pot(1)) c do kc = 1, nkc ir = irhi_hl(kc) do while ( ir .gt. 2 .and. $ itlo_hl(ir-1,kc) .le. itlo_hl(ir,kc) ) ir = ir - 1 if ( ir .eq. 2 ) stop $ ' STOP -- find_rjump_hl_cond Error: ir=2 cannot be. ' enddo irjump_hl(kc) = ir enddo c return end c c****************************************************************************** c subroutine dump_opal_opac( iu_out, cf_d ) c ========================================= c character*(*) cf_d c parameter ( small_1m6=1.e-6 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/c_opal_ctrl_smooth/ init_smo, low_CO_smo, interp_CO_smo save /c_opal_ctrl_smooth/ c common /alt_change_opal_z/ main_alt_change, iulow, khighz_in, $ ofebrack_in save /alt_change_opal_z/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c parameter ( mx_hi=2*mx, mo_m1=mo-1, mo_m2=mo-2 ) c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c character*2 cel_opalmixes(nel_zmix) character*8 cfile_opalmixes(n_zmixes) common/opalmixes/ xiz_mix(nel_zmix),fninz_mix(nel_zmix), $ bracketife_mix(nel_zmix),bracketofe_opalmixes(n_zmixes), $ xofe_opalmixes(n_zmixes),xiz_opalmixes(nel_zmix,n_zmixes), $ fninz_opalmixes(nel_zmix,n_zmixes), $ cel_opalmixes,cfile_opalmixes save /opalmixes/ c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c character*255 cfile_opal_used(-1:n_totmix) common /c_mixfiles_used_opal_z/ cfile_opal_used save /c_mixfiles_used_opal_z/ c character*80 cdef_CNO_ext(n_cnobeg:n_totmix) common /ext_CNO_opal_z/ len_def_CNO_ext(n_cnobeg:n_totmix), $ cdef_CNO_ext save /ext_CNO_opal_z/ c common /cno_delta_opal_z/ fcno_mul(4), fninz_cno(nel_zmix,5), $ xiz_cno(nel_zmix,5), d_fninz_user(nel_zmix), $ fcno_fac(0:3,4), fninz_heavy, xiz_heavy, d_fninz_u_heavy, $ s_ninzai_mix, ds_ninzai_u, fn_o_over_cno, fninz_co_mix save /cno_delta_opal_z/ c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c parameter ( zdel=0.001, xdel=0.03, xdelmin=0.001 ) c parameter ( mz=8, mz_m1=mz-1, mz_m2=mz-2, mzhi=11, mzal=13, $ nzm=mzal+1, nadd_zavail=nzm-mz ) c common/zinter_opal_z/ zvalhi(mzhi),nofz(mzhi,5,mo),mnofz(mx), $ zval(mz),zalval(mzal),zavail(nzm),iadd_zavail(nadd_zavail) save /zinter_opal_z/ c common/recoin_opal_z/ itimeco,mxzero,mx03,kope,igznotgx save /recoin_opal_z/ c common/alink_opal_z/ NTEMP,NSM,nrlow,nrhigh,RLE,t6arr(100), $ coff(100,nrm) save /alink_opal_z/ c character*4 cxfil(5),czfil(mz) common/czinte_opal_z/ cxfil,czfil save /czinte_opal_z/ c character*255 copdir common/opdir/ copdir save /opdir/ c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c common /mat_alex_ferg/ flk_ferg(nr_ferg,nt_ferg,nz_ferg,nx_ferg) save /mat_alex_ferg/ dimension flk_alex(nrlo_alex:nr_alex,nt_alex,nzp1_alex,nx_alex) equivalence (flk_alex(nrlo_alex,1,1,1),flk_ferg(1,1,1,1)) c common /opac_alex/ zlog_alex(nzp1_alex),xlog_alex(nx_alex), $ dzinvlog_alex(nzp1_alex),dxinvlog_alex(nx_alex) save /opac_alex/ c common /opac_ferg/ zlog_ferg(nzp1_ferg), xlog_ferg(nx_ferg), $ dzinvlog_ferg(nz_ferg), dzinv_ferg(nz_ferg), $ dxinvlog_ferg(nx_ferg), dxinv_ferg(nx_ferg), $ t6log_ferg(nt_ferg), rlog_ferg(nr_ferg), $ dt6inv_ferg(nt_ferg), drinv_ferg(nr_ferg), $ modt_ferg, modz0_ferg, ntuferg save /opac_ferg/ c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c common /c_ofe_in_ferg/ ofein_ferg, i_ofe_ferg, i_ofe0_ferg save /c_ofe_in_ferg/ c common /c_prev_ferg/ zlogp_ferg, xp_ferg, zlp1_ferg, xp1_ferg, $ zlp2_ferg, xp2_ferg, i1p_ferg, i4p_ferg, j1p_ferg, j4p_ferg save /c_prev_ferg/ c common /c_tsw_ferg/ slt_max_ferg, sltswlo_ferg_def, $ sltswhi_ferg_def, sltswlo_ferg, sltswhi_ferg, $ sltswmid_ferg, dltsw2inv_ferg save /c_tsw_ferg/ c character*255 cfile_alex common /c_filename_alex/ need_alex_dir, cfile_alex save /c_filename_alex/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c parameter ( nT_KcPot=19, nR_KcPot=64, nZ_KcPot=15 ) c parameter ( ntlokc=37, ntlokcm1=ntlokc-1, nthikc=90-ntlokcm1, $ nrlokc=-23, nrlokcm1=nrlokc-1, nrhikc=24-nrlokcm1, nkc=3, $ nthikcm1=nthikc-1, nrhikcm1=nrhikc-1, nkcp1=nkc+1 ) parameter ( dlt_kc=.1, dlr_kc=.25, dltinv_kc=10., dlrinv_kc=4. ) c character*2 celkc_hl(nkc) common /c_flkcond_hlpot/ flkc_pot(nT_KcPot,nR_KcPot,nZ_KcPot), $ AT_pot(nT_KcPot), AR_pot(nR_KcPot), AZ_pot(nZ_KcPot), $ sigconlog_pot, itlo_hl(nrhikc,nkc), ithi_hl(nrhikc,nkc), $ irhi_hl(nkc), itlo_ok_hl(nrhikc,nkc), $ irjump_hl(nkc), celkc_hl save /c_flkcond_hlpot/ c dimension flkc_hl(nthikc,nrhikc,nkc), $ flrolo_hl(nkc), flrohi_hl(nkc), $ fltlo_hl(nkc), flthi_hl(nkc), $ flRlo_hl(nkc), flRhi_hl(nkc), kZ_pot(nZ_KcPot) equivalence (flkc_pot(1,1,1),flkc_hl(1,1,1)), $ (AR_pot(1),flrolo_hl(1)), (AR_pot(nkcp1),flrohi_hl(1)), $ (AT_pot(1),fltlo_hl(1)), (AT_pot(nkcp1),flthi_hl(1)), $ (AZ_pot(1),flRlo_hl(1)), (AZ_pot(nkcp1),flRhi_hl(1)), $ (itlo_hl(1,1),kZ_pot(1)) c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c common /c_pot_indices/ zkpot(0:3,0:3), zlg_pot_p, i1pot_p, $ i4pot_p, j1pot_p, j4pot_p, i1pot, i2pot, i3pot, i4pot, $ j1pot, j2pot, j3pot, j4pot, k1pot, k2pot, k3pot, k4pot save /c_pot_indices/ c parameter ( ndef_cond = 3 ) c character*255 cfile_cond character*80 cdef_cond(ndef_cond) common /c_filename_cond/ need_cond_dir, cfile_cond, cdef_cond save /c_filename_cond/ c=== if ( itime .ne. 12345678 ) stop $ ' STOP -- DUMP_OPAL_OPAC: Error: no opacities to dump. ' c last = lnblnk( cf_d ) c if ( last .le. 0 ) stop $ ' STOP -- DUMP_OPAL_OPAC: Error: blank dumpfile name. ' c if ( iu_out .gt. 0 .and. iu_out .le. 99 .and. $ iu_out .ne. 5 .and. iu_out .ne. 6 ) then iu = iu_out else iu = iulow endif c call opneuf( iu, cf_d ) c write(iu) init_smo, low_CO_smo, interp_CO_smo, $ main_alt_change, iulow, khighz_in, $ ofebrack_in, level_err, nz, mx c write(iu) indx,t6list,alr,n write(iu) alt,dfs,dfsr,b,m,mf,xa,alrf write(iu) flogtin,dfsx,oxf,cxf write(iu) xcdf,xodf,itime,cxdf write(iu) oxdf,q,h,xcd,xod,xc,xo write(iu) xcs,xos,cxd,oxd,cx,ox,zzz,xxh write(iu) xx,nc,no,zsto,zvint,dfsz,zacc write(iu) zlow,zmiddle,zhigh,zlo_ex,zhi_ex, numz c do kz = 1, numz do kr = 1, nr do kt = 1, nt write(iu) ( ( ( co(ix,ic,io,kt,kr,kz), ix = 1, mx ), $ ic = 1, mc ), io = 1, mo ) enddo enddo enddo c write(iu) xhi_in, xcno_use, $ xhi_use, xxx_cno, xxx_hi, $ nx_hi, ireq_hi, khighx, kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user c write(iu) xiz_mix,fninz_mix, $ bracketife_mix,bracketofe_opalmixes, $ xofe_opalmixes,xiz_opalmixes, $ fninz_opalmixes, $ cel_opalmixes,cfile_opalmixes c write(iu) bracketofe_opalGS98, $ xofe_opalGS98,xiz_opalGS98, $ fninz_opalGS98,atwt_opalGS98, $ cfile_opalGS98 c write(iu) len_def_CNO_ext, $ cdef_CNO_ext c write(iu) fcno_mul, fninz_cno, $ xiz_cno, d_fninz_user, $ fcno_fac, fninz_heavy, xiz_heavy, d_fninz_u_heavy, $ s_ninzai_mix, ds_ninzai_u, fn_o_over_cno, fninz_co_mix c write(iu) nta, ntax0, $ ntax03, sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals c write(iu) zvalhi,nofz,mnofz, $ zval,zalval,zavail,iadd_zavail c write(iu) itimeco,mxzero,mx03,kope,igznotgx c write(iu) NTEMP,NSM,nrlow,nrhigh,RLE,t6arr c write(iu) cxfil,czfil, copdir c write(iu) cfile_opal_used c write(iu) kavail_alex, kuse_alex, kdo_alex, iualex c ! NOT itoh_replace_max write(iu) kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next c write(iu) need_alex_dir, cfile_alex c write(iu) need_cond_dir, cfile_cond c if ( kavail_alex .gt. 1 ) then c write(iu) nr_ferg, nt_ferg, nz_ferg, nx_ferg, $ ntype_ferg, ntyp1_ferg, zdel_ferg, xdel_ferg c do kx = 1, nx_ferg do kz = 1, nz_ferg write(iu) ( ( flk_ferg(kr,kt,kz,kx), $ kr = 1, nr_ferg ), kt = 1, nt_ferg ) enddo enddo c write(iu) zlog_ferg, xlog_ferg, dzinvlog_ferg, dzinv_ferg, $ dxinvlog_ferg, dxinv_ferg, t6log_ferg, rlog_ferg, $ dt6inv_ferg, drinv_ferg, modt_ferg, modz0_ferg, ntuferg c write(iu) z_ferg, x_ferg, iacc_ferg, igot_t_ferg, igot_r_ferg, $ itype_ferg, lsep_ferg, lext_ferg, ltype_ferg, $ itype_def_ferg, ione_ferg, lz_ferg, lx_ferg, $ cz_ferg, cx_ferg, $ ctype_ferg, csub_ferg, csep_ferg, cext_ferg c write(iu) ofein_ferg, i_ofe_ferg, i_ofe0_ferg c write(iu) zlogp_ferg, xp_ferg, zlp1_ferg, xp1_ferg, $ zlp2_ferg, xp2_ferg, $ i1p_ferg, i4p_ferg, j1p_ferg, j4p_ferg c write(iu) slt_max_ferg, sltswlo_ferg_def, $ sltswhi_ferg_def, sltswlo_ferg, sltswhi_ferg, $ sltswmid_ferg, dltsw2inv_ferg c else if ( kavail_alex .gt. 0 ) then c write(iu) zlog_alex, xlog_alex, dzinvlog_alex, dxinvlog_alex c do kx = 1, nx_alex do kz = 1, nz_alex + max( 0 , 2 - kx ) write(iu) ( ( flk_alex(kr,kt,kz,kx), $ kr = nrlo_alex, nr_alex ), kt = 1, nt_alex ) enddo enddo c write(iu) fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, $ fltswlo_r_alex_def, fltswhi_r_alex_def, fltswlo_alex, $ fltswhi_alex, fltswmid_alex, dltsw2inv_alex, $ sltswhi_alex, flrhoswlo_alex, flrhoswhi_alex, $ flrhoswmid_alex, dlrhosw2inv_alex, fltswlo_r_alex, $ fltswhi_r_alex, fltswmid_r_alex, dltsw2inv_r_alex, $ isw_rho_alex c endif c if ( kavail_cond .gt. 1 ) then c write(iu) flkc_pot c write(iu) AT_pot, AR_pot, AZ_pot, sigconlog_pot, kZ_pot c write(iu) zkpot, zlg_pot_p, i1pot_p, $ i4pot_p, j1pot_p, j4pot_p, i1pot, i2pot, i3pot, i4pot, $ j1pot, j2pot, j3pot, j4pot, k1pot, k2pot, k3pot, k4pot c else if ( kavail_cond .gt. 0 ) then c write(iu) flkc_hl c write(iu) flrolo_hl, flrohi_hl, $ fltlo_hl, flthi_hl, $ flRlo_hl, flRhi_hl, $ itlo_hl, ithi_hl, $ irhi_hl, itlo_ok_hl, celkc_hl c endif c close(iu) c return end c c****************************************************************************** c subroutine read_opal_dump( iu_in, cf_d ) c ======================================== c character*(*) cf_d c parameter ( small_1m6=1.e-6 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/c_opal_ctrl_smooth/ init_smo, low_CO_smo, interp_CO_smo save /c_opal_ctrl_smooth/ c common /alt_change_opal_z/ main_alt_change, iulow, khighz_in, $ ofebrack_in save /alt_change_opal_z/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c parameter ( mx_hi=2*mx, mo_m1=mo-1, mo_m2=mo-2 ) c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c character*2 cel_opalmixes(nel_zmix) character*8 cfile_opalmixes(n_zmixes) common/opalmixes/ xiz_mix(nel_zmix),fninz_mix(nel_zmix), $ bracketife_mix(nel_zmix),bracketofe_opalmixes(n_zmixes), $ xofe_opalmixes(n_zmixes),xiz_opalmixes(nel_zmix,n_zmixes), $ fninz_opalmixes(nel_zmix,n_zmixes), $ cel_opalmixes,cfile_opalmixes save /opalmixes/ c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c character*255 cfile_opal_used(-1:n_totmix) common /c_mixfiles_used_opal_z/ cfile_opal_used save /c_mixfiles_used_opal_z/ c character*80 cdef_CNO_ext(n_cnobeg:n_totmix) common /ext_CNO_opal_z/ len_def_CNO_ext(n_cnobeg:n_totmix), $ cdef_CNO_ext save /ext_CNO_opal_z/ c common /cno_delta_opal_z/ fcno_mul(4), fninz_cno(nel_zmix,5), $ xiz_cno(nel_zmix,5), d_fninz_user(nel_zmix), $ fcno_fac(0:3,4), fninz_heavy, xiz_heavy, d_fninz_u_heavy, $ s_ninzai_mix, ds_ninzai_u, fn_o_over_cno, fninz_co_mix save /cno_delta_opal_z/ c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c parameter ( zdel=0.001, xdel=0.03, xdelmin=0.001 ) c parameter ( mz=8, mz_m1=mz-1, mz_m2=mz-2, mzhi=11, mzal=13, $ nzm=mzal+1, nadd_zavail=nzm-mz ) c common/zinter_opal_z/ zvalhi(mzhi),nofz(mzhi,5,mo),mnofz(mx), $ zval(mz),zalval(mzal),zavail(nzm),iadd_zavail(nadd_zavail) save /zinter_opal_z/ c common/recoin_opal_z/ itimeco,mxzero,mx03,kope,igznotgx save /recoin_opal_z/ c common/alink_opal_z/ NTEMP,NSM,nrlow,nrhigh,RLE,t6arr(100), $ coff(100,nrm) save /alink_opal_z/ c character*4 cxfil(5),czfil(mz) common/czinte_opal_z/ cxfil,czfil save /czinte_opal_z/ c character*255 copdir common/opdir/ copdir save /opdir/ c parameter ( nr_ferg=19, nt_ferg=85, nz_ferg=16, nx_ferg=10, $ nxm1_ferg=nx_ferg-1, nxm2_ferg=nx_ferg-2, n2_ferg=nz_ferg-3, $ ntype_ferg=12, ntyp1_ferg=ntype_ferg+1, nzp1_ferg=nz_ferg+1, $ nr_alex=25, nt_alex=23, nz_alex=11, nx_alex=6, $ nzp1_alex=nz_alex+1, nrm1_alex=nr_alex-1, nrlo_alex=-7, $ nxm1_alex=nx_alex-1, nxm2_alex=nx_alex-2, zex_alex=0.05, $ ntm1_alex=nt_alex-1, nrlop1_alex=nrlo_alex+1, dt_alex=0.05, $ dro_alex=0.25, zdel_alex=0.001, xdelmin_alex = 0.00001, $ xdel_alex=0.03, droinv_alex=4.0, dtinv_alex=20.0, $ zdel_ferg=2.e-6, z0_ferg=small_1m6*zdel_ferg, $ xdel_ferg=0.03 ) c common /mat_alex_ferg/ flk_ferg(nr_ferg,nt_ferg,nz_ferg,nx_ferg) save /mat_alex_ferg/ dimension flk_alex(nrlo_alex:nr_alex,nt_alex,nzp1_alex,nx_alex) equivalence (flk_alex(nrlo_alex,1,1,1),flk_ferg(1,1,1,1)) c common /opac_alex/ zlog_alex(nzp1_alex),xlog_alex(nx_alex), $ dzinvlog_alex(nzp1_alex),dxinvlog_alex(nx_alex) save /opac_alex/ c common /opac_ferg/ zlog_ferg(nzp1_ferg), xlog_ferg(nx_ferg), $ dzinvlog_ferg(nz_ferg), dzinv_ferg(nz_ferg), $ dxinvlog_ferg(nx_ferg), dxinv_ferg(nx_ferg), $ t6log_ferg(nt_ferg), rlog_ferg(nr_ferg), $ dt6inv_ferg(nt_ferg), drinv_ferg(nr_ferg), $ modt_ferg, modz0_ferg, ntuferg save /opac_ferg/ c character*5 cz_ferg(nz_ferg), cx_ferg(nx_ferg) character*80 ctype_ferg(ntyp1_ferg), csub_ferg(ntyp1_ferg), $ csep_ferg, cext_ferg common /c_ini_ferg/ z_ferg(nz_ferg), x_ferg(nx_ferg), iacc_ferg, $ igot_t_ferg, igot_r_ferg, itype_ferg, lsep_ferg, lext_ferg, $ ltype_ferg(ntyp1_ferg), itype_def_ferg(ntyp1_ferg), $ ione_ferg(ntyp1_ferg), lz_ferg(nz_ferg), lx_ferg(nx_ferg), $ cz_ferg, cx_ferg, ctype_ferg, csub_ferg, $ csep_ferg, cext_ferg save /c_ini_ferg/ c common /c_ofe_in_ferg/ ofein_ferg, i_ofe_ferg, i_ofe0_ferg save /c_ofe_in_ferg/ c common /c_prev_ferg/ zlogp_ferg, xp_ferg, zlp1_ferg, xp1_ferg, $ zlp2_ferg, xp2_ferg, i1p_ferg, i4p_ferg, j1p_ferg, j4p_ferg save /c_prev_ferg/ c common /c_tsw_ferg/ slt_max_ferg, sltswlo_ferg_def, $ sltswhi_ferg_def, sltswlo_ferg, sltswhi_ferg, $ sltswmid_ferg, dltsw2inv_ferg save /c_tsw_ferg/ c character*255 cfile_alex common /c_filename_alex/ need_alex_dir, cfile_alex save /c_filename_alex/ c common /c_got_alex/ kavail_alex, kuse_alex, kdo_alex, iualex save /c_got_alex/ c common /c_trho_sw_alex/ fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, fltswlo_r_alex_def, $ fltswhi_r_alex_def, fltswlo_alex, fltswhi_alex, $ fltswmid_alex, dltsw2inv_alex, sltswhi_alex, flrhoswlo_alex, $ flrhoswhi_alex, flrhoswmid_alex, dlrhosw2inv_alex, $ fltswlo_r_alex, fltswhi_r_alex, fltswmid_r_alex, $ dltsw2inv_r_alex, sltswlo_alex, isw_rho_alex save /c_trho_sw_alex/ c parameter ( nT_KcPot=19, nR_KcPot=64, nZ_KcPot=15 ) c parameter ( ntlokc=37, ntlokcm1=ntlokc-1, nthikc=90-ntlokcm1, $ nrlokc=-23, nrlokcm1=nrlokc-1, nrhikc=24-nrlokcm1, nkc=3, $ nthikcm1=nthikc-1, nrhikcm1=nrhikc-1, nkcp1=nkc+1 ) parameter ( dlt_kc=.1, dlr_kc=.25, dltinv_kc=10., dlrinv_kc=4. ) c character*2 celkc_hl(nkc) common /c_flkcond_hlpot/ flkc_pot(nT_KcPot,nR_KcPot,nZ_KcPot), $ AT_pot(nT_KcPot), AR_pot(nR_KcPot), AZ_pot(nZ_KcPot), $ sigconlog_pot, itlo_hl(nrhikc,nkc), ithi_hl(nrhikc,nkc), $ irhi_hl(nkc), itlo_ok_hl(nrhikc,nkc), $ irjump_hl(nkc), celkc_hl save /c_flkcond_hlpot/ c dimension flkc_hl(nthikc,nrhikc,nkc), $ flrolo_hl(nkc), flrohi_hl(nkc), $ fltlo_hl(nkc), flthi_hl(nkc), $ flRlo_hl(nkc), flRhi_hl(nkc), kZ_pot(nZ_KcPot) equivalence (flkc_pot(1,1,1),flkc_hl(1,1,1)), $ (AR_pot(1),flrolo_hl(1)), (AR_pot(nkcp1),flrohi_hl(1)), $ (AT_pot(1),fltlo_hl(1)), (AT_pot(nkcp1),flthi_hl(1)), $ (AZ_pot(1),flRlo_hl(1)), (AZ_pot(nkcp1),flRhi_hl(1)), $ (itlo_hl(1,1),kZ_pot(1)) c common /c_got_cond/ kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next, itoh_replace_max(0:2) save /c_got_cond/ c common /c_pot_indices/ zkpot(0:3,0:3), zlg_pot_p, i1pot_p, $ i4pot_p, j1pot_p, j4pot_p, i1pot, i2pot, i3pot, i4pot, $ j1pot, j2pot, j3pot, j4pot, k1pot, k2pot, k3pot, k4pot save /c_pot_indices/ c parameter ( ndef_cond = 3 ) c character*255 cfile_cond character*80 cdef_cond(ndef_cond) common /c_filename_cond/ need_cond_dir, cfile_cond, cdef_cond save /c_filename_cond/ c___ logical lxst c=== last = lnblnk( cf_d ) c if ( last .le. 0 ) stop $ ' STOP -- READ_OPAL_DUMP: Error: blank dumpfile name. ' c call inqfil( cf_d, lxst ) c if ( .not. lxst ) then write(6,'(" READ_OPAL_DUMP: dumpfile not found:"/" ",a)') $ cf_d(:last) stop ' STOP -- READ_OPAL_DUMP: Error: dumpfile not found. ' endif c if ( iu_in .gt. 0 .and. iu_in .le. 99 .and. $ iu_in .ne. 5 .and. iu_in .ne. 6 ) then iu = iu_in else iu = iulow endif c call opoluf( iu, cf_d ) c read(iu) init_smo, low_CO_smo, interp_CO_smo, $ main_alt_change, iulow, khighz_in, $ ofebrack_in, level_err, nz_sto, mx_sto c if ( nz .ne. nz_sto ) then close(iu) write(6,20) nz, nz_sto, cf_d(:last) 20 format(/' READ_OPAL_DUMP: nz=',i3,' .ne. nz=',i3, $ ' in dumpfile:'/' ',a) stop ' STOP -- READ_OPAL_DUMP: Error: bad parameter nz. ' else if ( mx .ne. mx_sto ) then close(iu) write(6,30) mx, mx_sto, cf_d(:last) 30 format(/' READ_OPAL_DUMP: mx=',i3,' .ne. mx=',i3, $ ' in dumpfile:'/' ',a) stop ' STOP -- READ_OPAL_DUMP: Error: bad parameter mx. ' endif c read(iu) indx,t6list,alr,n read(iu) alt,dfs,dfsr,b,m,mf,xa,alrf read(iu) flogtin,dfsx,oxf,cxf read(iu) xcdf,xodf,itime,cxdf read(iu) oxdf,q,h,xcd,xod,xc,xo read(iu) xcs,xos,cxd,oxd,cx,ox,zzz,xxh read(iu) xx,nc,no,zsto,zvint,dfsz,zacc read(iu) zlow,zmiddle,zhigh,zlo_ex,zhi_ex, numz c do kz = 1, numz do kr = 1, nr do kt = 1, nt read(iu) ( ( ( co(ix,ic,io,kt,kr,kz), ix = 1, mx ), $ ic = 1, mc ), io = 1, mo ) enddo enddo enddo c read(iu) xhi_in, xcno_use, $ xhi_use, xxx_cno, xxx_hi, $ nx_hi, ireq_hi, khighx, kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user c read(iu) xiz_mix,fninz_mix, $ bracketife_mix,bracketofe_opalmixes, $ xofe_opalmixes,xiz_opalmixes, $ fninz_opalmixes, $ cel_opalmixes,cfile_opalmixes c read(iu) bracketofe_opalGS98, $ xofe_opalGS98,xiz_opalGS98, $ fninz_opalGS98,atwt_opalGS98, $ cfile_opalGS98 c read(iu) len_def_CNO_ext, $ cdef_CNO_ext c read(iu) fcno_mul, fninz_cno, $ xiz_cno, d_fninz_user, $ fcno_fac, fninz_heavy, xiz_heavy, d_fninz_u_heavy, $ s_ninzai_mix, ds_ninzai_u, fn_o_over_cno, fninz_co_mix c read(iu) nta, ntax0, $ ntax03, sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals c read(iu) zvalhi,nofz,mnofz, $ zval,zalval,zavail,iadd_zavail c read(iu) itimeco,mxzero,mx03,kope,igznotgx c read(iu) NTEMP,NSM,nrlow,nrhigh,RLE,t6arr c read(iu) cxfil,czfil, copdir c read(iu) cfile_opal_used c read(iu) kavail_alex, kuse_alex, kdo_alex, iualex c ! NOT itoh_replace_max read(iu) kavail_cond, kuse_cond, kdo_cond, iucond, $ ifix_h_cond, itoh_gap, itoh_replace, $ ifix_h_cond_next, itoh_gap_next c read(iu) need_alex_dir, cfile_alex c read(iu) need_cond_dir, cfile_cond c if ( kavail_alex .gt. 1 ) then c call init_ferg_indices c read(iu) kr_ferg, kt_ferg, kz_ferg, kx_ferg, $ ktype_ferg, ktyp1_ferg, tzdel_ferg, txdel_ferg c if ( kr_ferg .ne. nr_ferg .or. kt_ferg .ne. nt_ferg .or. $ kz_ferg .ne. nz_ferg .or. kx_ferg .ne. nx_ferg .or. $ ktype_ferg .gt. ntype_ferg .or. $ abs( tzdel_ferg - zdel_ferg ) .gt. small_1m6 .or. $ abs( txdel_ferg - xdel_ferg ) .gt. small_1m6 ) then close(iu) write(6,50) kr_ferg, kt_ferg, kz_ferg, kx_ferg, ktype_ferg, $ tzdel_ferg, txdel_ferg, nr_ferg, nt_ferg, nz_ferg, $ nx_ferg, ntype_ferg, zdel_ferg, xdel_ferg, cf_d(:last) 50 format(/' READ_OPAL_DUMP: nr_ferg=',i3,', nt_ferg=',i3, $ ', nz_ferg=',i3,', nx_ferg=',i3,','/ $ ' ntype_ferg=',i3,', zdel_ferg=',f10.7, $ ', xdel_ferg=',f10.7,' DIFFER from'/ $ ' STORED VALUES: nr_ferg=',i3,', nt_ferg=',i3, $ ', nz_ferg=',i3,', nx_ferg=',i3,','/ $ ' ntype_ferg=',i3,', zdel_ferg=',f10.7, $ ', xdel_ferg=',f10.7,' in dumpfile:'/' ',a) stop ' STOP -- READ_OPAL_DUMP Error: bad KAPPA_ferg size. ' endif c do kx = 1, nx_ferg do kz = 1, nz_ferg read(iu) ( ( flk_ferg(kr,kt,kz,kx), $ kr = 1, nr_ferg ), kt = 1, nt_ferg ) enddo enddo c read(iu) zlog_ferg, xlog_ferg, dzinvlog_ferg, dzinv_ferg, $ dxinvlog_ferg, dxinv_ferg, t6log_ferg, rlog_ferg, $ dt6inv_ferg, drinv_ferg, modt_ferg, modz0_ferg, ntuferg c read(iu) z_ferg, x_ferg, iacc_ferg, igot_t_ferg, igot_r_ferg, $ itype_ferg, lsep_ferg, lext_ferg, $ ( ltype_ferg(i), i = 1, ktype_ferg ), $ ltype_ferg(ntyp1_ferg), itype_def_ferg(1), $ itype_def_ferg(2), ( itype_def_ferg(i), $ i = ntyp1_ferg - ktyp1_ferg + 3, ntyp1_ferg ), $ ( ione_ferg(i), i = 1, ktype_ferg ), $ ione_ferg(ntyp1_ferg), lz_ferg, lx_ferg, $ cz_ferg, cx_ferg, $ ( ctype_ferg(i), i = 1, ktype_ferg ), $ ctype_ferg(ntyp1_ferg), $ ( csub_ferg(i), i = 1, ktype_ferg ), $ csub_ferg(ntyp1_ferg), csep_ferg, cext_ferg c c ! if old default-ferg-type-input-order array size was smaller, ensure c ! that array has no duplicates if ( ktyp1_ferg .lt. ntyp1_ferg ) then ihi = ntyp1_ferg - ktyp1_ferg + 2 do i = 3, ihi ieq = 0 do j = 1, ntyp1_ferg if ( ( j .lt. i .or. j .gt. ihi ) .and. $ itype_def_ferg(j) .eq. itype_def_ferg(i) ) $ ieq = 1 enddo if ( ieq .ne. 0 ) then itype_def_ferg(i) = ntyp1_ferg + 1 do while ( ieq .ne. 0 ) itype_def_ferg(i) = itype_def_ferg(i) - 1 if ( itype_def_ferg(i) .le. 0 ) stop $ ' STOP -- READ_OPAL_DUMP Error: bad itype?! ' ieq = 0 do j = 1, ntyp1_ferg if ( ( j .lt. i .or. j .gt. ihi ) .and. $ itype_def_ferg(j) .eq. itype_def_ferg(i) ) $ ieq = 1 enddo enddo endif enddo endif c read(iu) ofein_ferg, i_ofe_ferg, i_ofe0_ferg c read(iu) zlogp_ferg, xp_ferg, zlp1_ferg, xp1_ferg, $ zlp2_ferg, xp2_ferg, $ i1p_ferg, i4p_ferg, j1p_ferg, j4p_ferg c read(iu) slt_max_ferg, sltswlo_ferg_def, $ sltswhi_ferg_def, sltswlo_ferg, sltswhi_ferg, $ sltswmid_ferg, dltsw2inv_ferg c else if ( kavail_alex .gt. 0 ) then c read(iu) zlog_alex, xlog_alex, dzinvlog_alex, dxinvlog_alex c do kx = 1, nx_alex do kz = 1, nz_alex + max( 0 , 2 - kx ) read(iu) ( ( flk_alex(kr,kt,kz,kx), $ kr = nrlo_alex, nr_alex ), kt = 1, nt_alex ) enddo enddo c read(iu) fltswlo_alex_def, fltswhi_alex_def, $ flrhoswlo_alex_def, flrhoswhi_alex_def, $ fltswlo_r_alex_def, fltswhi_r_alex_def, fltswlo_alex, $ fltswhi_alex, fltswmid_alex, dltsw2inv_alex, $ sltswhi_alex, flrhoswlo_alex, flrhoswhi_alex, $ flrhoswmid_alex, dlrhosw2inv_alex, fltswlo_r_alex, $ fltswhi_r_alex, fltswmid_r_alex, dltsw2inv_r_alex, $ isw_rho_alex c sltswlo_alex = fltswlo_alex - 6. c endif c if ( kavail_cond .gt. 1 ) then c read(iu) flkc_pot c read(iu) AT_pot, AR_pot, AZ_pot, sigconlog_pot, kZ_pot c read(iu) zkpot, zlg_pot_p, i1pot_p, $ i4pot_p, j1pot_p, j4pot_p, i1pot, i2pot, i3pot, i4pot, $ j1pot, j2pot, j3pot, j4pot, k1pot, k2pot, k3pot, k4pot c else if ( kavail_cond .gt. 0 ) then c read(iu) flkc_hl c read(iu) flrolo_hl, flrohi_hl, $ fltlo_hl, flthi_hl, $ flRlo_hl, flRhi_hl, $ itlo_hl, ithi_hl, $ irhi_hl, itlo_ok_hl, celkc_hl c call find_rjump_hl_cond c endif c close(iu) c return end c c****************************************************************************** c subroutine read_kz(kz,z,kallrd,khighz,iu_lo,ofebrack) c ===================================================== c c NOTE: kallrd is ignored (it is present only for backward compatibility). c c PARAMETERS to control the offset from zero for the logarithmic interpolation: c zdel = 0.001 (must be the same value as in OPAL) c xdel = 0.03 (must be the same value as in OPAL) c xdelgn93 = 0.005 = xdel value for use with X-interpolation in 'GN93hz' file c among X-tables 0.0, 0.1, 0.2 (to get X = 0.03 mix); note c that 0.005 works slightly better for this than 0.03 c parameter ( small_1m6=1.e-6, small_1m8=1.e-8, small_m1m8=-1.e-8 ) c parameter ( small_1m5=1.e-5, small_3m7=3.e-7 ) c parameter ( zdel=0.001, xdel=0.03, xdelgn93=0.005 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( mx_hi=2*mx, mo_m1=mo-1, mo_m2=mo-2 ) c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c parameter ( nrdel=nrb-1, ntdel=ntb-1 ) parameter ( nrm_m2=nrm-2, nt_m1=nt-1, nre_p1=nre+1, nre_m1=nre-1 ) parameter ( badlogkval=1.e+35, badlogklim=20. ) parameter ( ks81=ntm-3, ks83=ks81+1, ks60=ks81-21, ks61=ks60+1, $ alrlo=-8.0, flogtlo=3.75, flogt60=6.0, flogt81=8.1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c character*2 cel_opalmixes(nel_zmix) character*8 cfile_opalmixes(n_zmixes) common/opalmixes/ xiz_mix(nel_zmix),fninz_mix(nel_zmix), $ bracketife_mix(nel_zmix),bracketofe_opalmixes(n_zmixes), $ xofe_opalmixes(n_zmixes),xiz_opalmixes(nel_zmix,n_zmixes), $ fninz_opalmixes(nel_zmix,n_zmixes), $ cel_opalmixes,cfile_opalmixes save /opalmixes/ c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c common /c_level_list_opal_z/ iu_list, level_list, list_mult, $ list_gn(-n_zmixes:n_totmix) save /c_level_list_opal_z/ c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c character*255 cfile_opal_used(-1:n_totmix) common /c_mixfiles_used_opal_z/ cfile_opal_used save /c_mixfiles_used_opal_z/ c character*80 cdef_CNO_ext(n_cnobeg:n_totmix) common /ext_CNO_opal_z/ len_def_CNO_ext(n_cnobeg:n_totmix), $ cdef_CNO_ext save /ext_CNO_opal_z/ c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c c COMMON /c_opal_ctrl_smooth/ : flags to control the opacity smoothing: c common/c_opal_ctrl_smooth/ init_smo, low_CO_smo, interp_CO_smo save /c_opal_ctrl_smooth/ c common/alink_opal_z/ NTEMP,NSM,nrlow,nrhigh,RLE,t6arr(100), $ coff(100,nrm) save /alink_opal_z/ c COMMON/CST_OPAL_Z/ NRL,RLS,nset,tmax save /CST_OPAL_Z/ c common/e_opal_z/ opact,dopact,dopacr,dopactd,fedge,ftredge,fzedge save /e_opal_z/ c common/recoin_opal_z/ itimeco,mxzero,mx03,kope,igznotgx save /recoin_opal_z/ c parameter ( mz=8, mz_m1=mz-1, mz_m2=mz-2, mzhi=11, mzal=13, $ nzm=mzal+1, nadd_zavail=nzm-mz ) c common/zinter_opal_z/ zvalhi(mzhi),nofz(mzhi,5,mo),mnofz(mx), $ zval(mz),zalval(mzal),zavail(nzm),iadd_zavail(nadd_zavail) save /zinter_opal_z/ c common /alt_change_opal_z/ main_alt_change, iulow, khighz_in, $ ofebrack_in save /alt_change_opal_z/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c character*4 cxfil(5),czfil(mz) common/czinte_opal_z/ cxfil,czfil save /czinte_opal_z/ c c The following common block /opdir/ contains a character file giving the c directory where the Gz???.x?? files are to be found. c character*255 copdir common/opdir/ copdir save /opdir/ c___ c c copfil = the full opacity filename (including directory), changed as needed c copalt = temporary (needed only for error message: new form of opacity file) c character*255 copfil,copalt c c cin / ch holds a line read in from the opacity file (with opacity values) c character*137 cin c-noneed; character*1 ch(137) c-noneed; equivalence (ch(1),cin) c c lxst is a logical variable used to check whether the new form Gz???.x?? of c opacity files exists, rather than the old form Gx??z* c logical lxst c c LOCAL ARRAYS: c cofzat(4,nrm) = temporary storage for input opacity values as a function of c R, at up to four Z-table values (these will be interpolated c in Z if necessary, prior to being stored) c xzalat(3) = X-table value(s) for relevant mix(es) in 'GN93hz'. For m = mx03 c (X=0.03), xzalat = { 0.0 , 0.1 , 0.2 }; else, xzalat(1) = xa(m) c kzvalnof(4) = Z-indexes in number-of-mixes table nofz for each of the (up c to 4) Z-tables being interpolated among (in Gz???.x?? files) c nofmjz(4) = temporary number-of-C-mixes for each of the (up to 4) Z-tables c being interpolated among: for a given X-table index m and c O-table index j, nofmjz(i) = nofz(kzvalnof(i),mnofz(m),j) c iz_get(4) = flag, for each of the (up to 4) Z-tables being interpolated c among, to tell the function mixfind whether to read in or check c the Z-composition; 1 = read it in, -1 = check it, 0 = neither c (i.e., not presently positioned at the beginning of the file). c The function mixfind resets this flag to zero. c iz_rew(4) = flag, for each of the (up to 4) Z-tables being interpolated c among, to tell the function mixfind whether to rewind the file c being read in before looking for the next (Z,X,C,O) mix; c 1 = rewind, 0 = do not rewind. The function mixfind resets c this flag to zero, unless the mix being looked for is not found c or does not follow consecutively after the previous mix, in c which case it is reset to unity ("rewind next time") c iz_tab(4) = mix-table index in Gz???.x?? opacity files, for each of the (up c to 4) Z-tables being interpolated among; it is set by mixfind c ico_got(mc,mo) = matrix of flags telling whether the corresponding (C,O) c opacity table was read in/interpolated successfully (for c the current X-table index m); 1 = succeeded, 0 = failed. c In a few cases, near the line C+O = 1-X-Z, a mix may not c be present at enough Z-table values to allow it to be c interpolated in Z, in which case this flag will be set to c zero; rather than extrapolating such a mix in Z, it is c subsequently interpolated in C or O (note that it will c lie near a mix on the line C+O = 1-X-Z, so there will not c be much of an interpolation). c nthx0(0:nrm) = temporary version of ntax0(0:nrm), used for "hz"-files c nthx03(0:nrm) = temporary version of ntax03(0:nrm), used for "hz"-files c dimension cofzat(4,nrm),xzalat(3),kzvalnof(4),nofmjz(4), $ iz_get(4),iz_rew(4),iz_tab(4),ico_got(mc,mo), $ nthx0(0:nrm),nthx03(0:nrm) c c LOCAL ARRAYS: cofzhi(ntm,nrm,6) is used for temporary storage for opacities c from 'GN93hz' or from file with non-zero [O/Fe]; xhi_look(6) and zhi_look(6) c are used to hold the 'GN93hz' X-values, including those not found in the c 'Gz???.x??' files, and the corresponding Z-values to be looked for. c dimension cofzhi(ntm,nrm,6), xhi_look(6), zhi_look(6) c c Storage for the compression-flags and opacity file names that are opened, c and the line numbers in these opacity files: c dimension igzip_sto(0:3) character*255 cop_sto(0:3) dimension line(0:3) c c-debug-chk[ c-debug-chk; dimension chk_max(20),chk_min(20),chk_sum(20),chk_ssq(20), c-debug-chk; $ n_chk(20) c-debug-chk;c c-debug-chk; common /readkz_opal_debug_chk/ iout_debug_chk_ofe c-debug-chk] c-test-xdel[ ! test xdel values in GN93hz X-interp c-test-xdel; parameter ( n_xdtst=4 ) c-test-xdel; dimension cof_tst(ntm,nrm,n_xdtst),dif_tst(4,n_xdtst), c-test-xdel; $ xdel_tst(n_xdtst) c-test-xdel; data xdel_tst/0.03,0.01,0.001,0.0001/ c-test-xdel] c-debug-chk[ c-debug-chk; data iout_debug_chk_ofe / 99999 / c-debug-chk] c c=== if ( kz .le. 0 .or. kz .gt. nz ) stop $ ' STOP -- READCO Error: Z-index out of range: cannot be! ' c c Check input unit number iu_lo, and use it to set iulow. c if ( iu_lo .ge. 7 .and. iu_lo .le. 96 ) then iulow = iu_lo else if ( iu_lo .ge. 0 .and. level_err .gt. 0 ) then stop ' STOP -- READCO Error: bad iulow value. ' endif c if ( level_err .gt. 99 .and. kallrd .le. 0 ) write(6, $ '(" ***WARNING: READCO: kallrd < 1 ignored.")') c c Check some parameter values, and do some initializations. c call opalinit( khighz, ofebrack, z, kz, 0 ) c khighz_in = khighz ofebrack_in = ofebrack c ! Z out of range? if ( z .ge. zval(mz) + small_1m6 .or. z .le. small_m1m8 ) then write(6,8703) z 8703 format(' '/' READCO Error: Z=',f10.7, $ ': Z > 0.1 (or < 0) not allowed!!!') stop ' STOP -- READCO Error: bad Z value: out of range. ' endif c ! accuracy to match table zacc(kz) = min( small_1m6 , max( small_1m8 , 0.01 * z ) ) c c Find the correct Z value(s) to be read in, in the range 0.0 to 0.1 c kzbelo = mz do while( kzbelo .gt. 1 .and. z .le. zval(kzbelo) - small_1m6 ) kzbelo = kzbelo-1 enddo c c If Z is very close to a tabulated Z-value, don't need to interpolate, c unless Z --> 0 ; note that nmorez ("number of extra Z-values") indicates c the presence and type of interpolation: c nmorez = 0 if the tabulated Z-value can be used (with no Z-interpolation), c nmorez = 2 if quadratic interpolation among 3 Z-values will be performed, c nmorez = 3 if overlapping quadratices will be used among 4 Z-values. c if ( abs( zval(kzbelo) - z ) .le. zacc(kz) ) then zat = zval(kzbelo) kzlow = kzbelo k1zfac = kzbelo nmorez = 0 c ! else: closest 3 or 4 table Z-values to interpolate among else zat = z kzlow = min( max( 1 , kzbelo - 1 ) , mz_m2 ) k1zfac = min( kzbelo , mz_m1 ) nmorez = min( kzbelo + 2 , mz ) - kzlow endif c kzlow_m1 = kzlow - 1 k2zfac = min( k1zfac + 1 , kzlow + nmorez ) c ! find position in nofz do i = kzlow, kzlow + nmorez kzvalnof(i-kzlow_m1) = int( 100. * zval(i) + 1.01 ) enddo kznof = min( int( 100. * z + 1.0001 ) , mzhi ) lznof = max( int( 100. * z + 0.9999 ) , 1 ) c c NOTE that if Z > 0 and the GS98 mix is being used (khighz < 0), then both c the GN93hz and GS98hz files will always be needed; if [O/Fe] is non-zero c and khighz < -1, then a GS98 [O/Fe]-file is also needed. OTHERWISE: c Check if need C+O=0.0 "hz" tables: if [O/Fe] = 0 or Z = 0, there will be no c need to interpolate in [O/Fe] (set khizat = 1), and if there is no need to c interpolate in [O/Fe], then for Z equal to a Z-table value or .01 < Z < .02 c the "hz" tables will yield no improvement and are not used (set khizat = 0). c c ! this is in [0:5] khighz_index = min( mod( abs(khighz), 10 ) , n_zmixes ) c c ! parameter mx=5 ALWAYS; then khighz_cno = 1 if CNO-interp needed, c ! = 2 if user-file needed, = 3 if both needed if ( mx .eq. 5 ) then khighz_cno = min( abs(khighz) / 10 , 3 ) if ( khighz_cno .ge. 2 .and. kavail_user .le. 0 ) $ khighz_cno = khighz_cno - 2 if ( mod( khighz_cno, 2 ) .eq. 1 .and. kavail_cno .le. 0 ) $ khighz_cno = khighz_cno - 1 else khighz_cno = 0 endif c c if Z = 0.0 or khighz = 0, then khizat = klozat = 0 c else if khighz > 0, then khizat = k[O/Fe] (or 1 if [O/Fe]=0.0), klozat = 0 c else if khighz < 0, then khizat = 1, klozat = k[O/Fe] (or 1 if [O/Fe]=0.0) c if ( z .lt. zacc(kz) ) then klozat = 0 khizat = 0 else if ( khighz .lt. 0 ) then khizat = 1 if ( ofebrack .eq. 0. ) then klozat = 1 else klozat = khighz_index endif else klozat = 0 khizat = khighz_index if ( ofebrack .eq. 0. ) khizat = min(khizat,1) if ( khizat .eq. 1 .and. ( ( zval(k1zfac) .ge. 0.01 .and. $ zval(k2zfac) .le. 0.02 ) .or. nmorez .eq. 0 ) ) $ khizat = 0 endif c ! these initializations just prevent compiler warnings: kzalow = 1 facxhz = 1.0 fofe = 1.0 omfofe = 0.0 c c If needed, get position in C+O=0.0 "hz"-tables, which have more Z values. c Note that nzalmo (for GN93hz) is analogous to nmorez (for Gz???.x?? files) c if ( khizat .gt. 0 ) then kzalbe = mzal do while( kzalbe .gt. 1 .and. $ z .le. zalval(kzalbe) - small_1m6 ) kzalbe = kzalbe - 1 enddo if ( abs( zalval(kzalbe) - z ) .le. zacc(kz) ) then zat = zalval(kzalbe) kzalow = kzalbe nzalmo = 0 else kzalow = max( 1 , kzalbe - 1 ) nzalmo = min( kzalbe + 2 , mzal ) - kzalow endif endif c ! set the directory-part of the opacity filename if ( kope .eq. 0 ) then copfil = ' ' else copfil = copdir(:kope) endif c ! store present m-value (should be unnecessary) mstore = m c ! (for usual X-values): khighx(kz) = 1 (set high-X deltas) khighx(kz) = 0 if ( khighz_index .ne. 0 .and. mx .eq. 5 .and. $ max( abs( xhi_in(1) - xa(1) ) , abs( 0.03 - xa(2) ) , $ abs( xhi_in(2) - xa(3) ) , abs( xhi_in(4) - xa(4) ) , $ abs( xhi_in(6) - xa(5) ) ) .le. small_1m6 ) khighx(kz) = 1 c c ! get shifted z-value Z+zdel, for log interpolation zzz(kz) = zat + zdel zvint(kz) = log10( zzz(kz) ) zsto(kz) = zat c ! should read in Z-composition from first opacity file igetzxi = 1 c c {--------------------------------------- Begin loop over m values (X-tables): c do m = 1, mx c ! later Z-compositions: just check if ( m .ne. 1 ) igetzxi = -1 c ! get C,O compositions for this m xhemx = 1. - xa(m) - zat do i = 1, mc nc = i no = i xc(i) = xcs(i) xo(i) = xos(i) c ! allow some round-off error: if ( xcs(i) .ge. xhemx - small_1m6 ) then xc(i) = xhemx xo(i) = xhemx goto 10 endif enddo 10 continue c ! check that number of C-mixes is correct c if ( nc .ne. nofz(kznof,mnofz(m),1) .and. $ nc .ne. nofz(lznof,mnofz(m),1) ) then write(6,8704) m,lznof,kznof,nofz(lznof,mnofz(m),1), $ nofz(kznof,mnofz(m),1),nc 8704 format(' '/' READCO Error: (m=',i1, $ ') bad nc value: nofz({',i2,' or',i3,'},m,1)={', $ i1,' or',i2,'} .ne. nc=',i1) stop ' STOP -- READCO Error: bad nc value: cannot be. ' endif c c........ initialization: for itime, oxf...oxdf, n(m,*,kz) (xx was done above) c c........ this is the first time through this m and kz. Calculate the decadic c log of the perimeter points shifted by Z+zdel (to avoid divergence c at origin: zdel=0.001); m refers to xa(m), the hydrogen table value. c do i = 1, nc c ! O,C values for each X,C,O oxf(m,i,kz) = log10( zzz(kz) + xo(i) ) cxf(m,i,kz) = log10( zzz(kz) + xc(i) ) xcdf(m,i,kz) = xo(no) - xo(i) xodf(m,i,kz) = xc(nc) - xc(i) cxdf(m,i,kz) = log10( zzz(kz) + xcdf(m,i,kz) ) oxdf(m,i,kz) = log10( zzz(kz) + xodf(m,i,kz) ) c ! present C,O values ox(i) = oxf(m,i,kz) cx(i) = cxf(m,i,kz) xcd(i) = xcdf(m,i,kz) xod(i) = xodf(m,i,kz) cxd(i) = cxdf(m,i,kz) oxd(i) = oxdf(m,i,kz) c enddo c ! set and check number-of-mixes table n(m,j,kz) do j = 1, nc - 1 do i = 1, nc if ( xcd(j) .ge. xc(i) ) then n(m,j,kz) = i + 1 if ( xcd(j) .lt. xc(i) + small_1m6 ) n(m,j,kz) = i endif enddo if ( n(m,1,kz) .ne. nc .or. $ ( n(m,j,kz) .ne. nofz(kznof,mnofz(m),j) $ .and. n(m,j,kz) .ne. nofz(lznof,mnofz(m),j) ) ) then write(6,8705) m,nc,j,n(m,j,kz),lznof,kznof,j, $ nofz(lznof,mnofz(m),j),nofz(kznof,mnofz(m),j) 8705 format(' '/' READCO Error: (m=',i1,',nc=',i1, $ ') bad value of n(m,',i1,')=',i1, $ ' .ne. nofz({',i2,' or',i3,'},m,',i1,')={', $ i1,' or',i2,'}') stop ' STOP -- READCO Error: bad n(m,j): cannot be. ' endif enddo c ! nc-th elements sometimes needed, though this may not be do j = nc, mc n(m,j,kz) = 0 enddo c ! initialize boundaries at low-X,low-R,low-T if ( kz .eq. 1 ) then if ( m .eq. mxzero ) then do i = nrb, nre ntax0(i) = ntb enddo else if ( m .eq. mx03 ) then do i = nrb, nre ntax03(i) = ntb enddo endif endif c ! end of initializations for this m value c c If it will increase accuracy, first read in C+O=0.0 "hz" table(s) from GN93hz c (and possibly from a file with [O/Fe] > 0), for the present m value. c c Note that 'Gz???.x??' files contain Z=0.05, while 'GN93hz' contains Z=0.04 c and 0.06; thus, for Z near 0.05, the 'Gz???.x??' opacities are more accurate c than the 'GN93hz' opacities. For .04 < Z < .05 or for .05 < Z < .06 , the c 'GN93hz' opacities are read in, but their effects are reduced (according to c how close Z is to 0.05) by setting the factor facxhz to a value less than c unity. c c Note that X=0.03 (m=2) requires X-interpolation in the 'GN93hz' tables: this c is only done if interpolating in [O/Fe] as well, and the effect of the m=2 c 'GN93hz' opacities is nullified by setting facxhz to zero. (The 'GN93hz' c opacity shifts for m=2 may be obtained later by interpolating opacity shifts c among m=1,3,4 if this is possible.) c ! read 'GN93hz' only if necessary: c if ( khizat .gt. 0 .and. ( m .ne. mx03 .or. $ khizat .gt. 1 .or. klozat .gt. 0 ) ) then c c ! for m = mx03 (X=.03), X-interpolation in c ! GN93hz is less accurate than the Gz???.x?? c ! opacities: the GN93hz opacities are needed c ! only for [O/Fe] shifts, so set facxhz=0. if ( m .eq. mx03 ) then facxhz = 0. nxdo = 3 xzalat(1) = 0. xzalat(2) = 0.1 xzalat(3) = 0.2 do i = nrb, nre nthx03(i) = ntb enddo c ! Else (for m not mx03): do need GN93hz shifts: else facxhz = 1. c ! but near Z = 0.05, the Gz???.x?? opacities are c ! better: reduce facxhz if ( zat .gt. 0.04 .and. zat .lt. 0.06 ) $ facxhz = 1. - 100. * min( zat - 0.04 , 0.06 - zat ) nxdo = 1 xzalat(1) = xa(m) if ( m .eq. mxzero ) then do i = nrb, nre nthx0(i) = ntb enddo endif endif c ! number of "excess" X-tables (for interpolation) nmorex = nxdo - 1 c ! indices for GN93hz Z-tabulation array zalval j1 = kzalow j2 = j1 + min( 1 , nzalmo ) j3 = j1 + min( 2 , nzalmo ) j4 = j1 + min( 3 , nzalmo ) c is = 0 isx = 0 iu = iulow c ! start with always-needed GN93hz file iofe = 1 c ! for {klozat,khizat} = {0,1} {0,4} {1,1} {1,4} c ! co(m,mc,mo,{T},{R},kz) = GN93 GN93 GN93 GN93 c ! co(m,mc,mo-1, ... ) = none W95 GS98 GS98 c ! co(m,mc,mo-2, ... ) = none none none GS98_W95 moat = mo c ! read C+O=0.0 "hz"-table(s): do while ( iofe .ne. 0 ) c ! get filename if ( iofe .gt. 0 ) then copfil(kope+1:) = cfile_opalmixes(iofe) if ( iofe .eq. 1 ) then cfile_opal_used(1) = cfile_opalmixes(iofe) cfile_opal_used(4) = cfile_opalmixes(iofe) else cfile_opal_used(n_zmixes) = cfile_opalmixes(iofe) endif else if ( iofe .eq. -1 ) then cfile_opal_used(1) = cfile_opalGS98(1) copfil(kope+1:) = cfile_opalGS98(1) else call chk_ofe_alt_file( -iofe ) copfil(kope+1:) = cfile_opal_used(n_zmixes) if ( cfile_opalGS98(-iofe) .ne. ' ' ) $ cfile_opalGS98(-iofe) = $ cfile_opal_used(n_zmixes) endif endif c if ( list_gn(iofe) .gt. 0 ) then if ( iu_list .eq. iu ) then write(6,4) iu_list 4 format(/' ***OPAL WARNING: READCO:', $ ' bad LIST_IU =',i3, $ ', reset to 6 (standard output)'/) iu_list = 6 endif write(iu_list,2) iofe, copfil(:lnblnk(copfil)) 2 format(' ***OPAL/Type_1_(',i2,'): ',a) list_gn(iofe) = 0 endif c ! open file call open_chk_zip( iu, copfil, igzip, $ 'READCO Error: hz-file (C+O=0.0) not found.' ) c line(1) = 0 c ! dummy table-number; initial cofzhi index itab_dum = 0 kzsto = 0 c ! get Z-composition(s) from "hz"-files, if ( m .eq. 1 ) then igetzxi = 1 c ! or just check them if they were already gotten else igetzxi = -1 endif c ! loop over X values, if more than one do kx = 1, nxdo c ! increment cofzhi mix-store-position kzsto = kzsto + 1 c ! loop over file Z values do iz = kzalow, kzalow + nzalmo c ! kat is Z-index in cofzhi kat = kzsto + iz - kzalow c ! find mix; stop if not found i_rewind = 0 ifound = mixfind(iu,iofe,igetzxi,i_rewind, $ itab_dum,line(1), $ zalval(iz),xzalat(kx),0.0,0.0) if ( ifound .eq. 0 ) then write(6,1791) zalval(iz),xzalat(kx),0.0,0.0, $ copfil(:lnblnk(copfil)) 1791 format(' '/' READCO: Error finding mix Z=', $ f6.4,' X=',f6.4,' C=',f6.4,' O=',f6.4, $ ' from file:'/' ',a/' ') stop ' STOP -- READCO: error reading hz-mix. ' endif c ! check [O/Fe] if ( kx .eq. 1 .and. iz .eq. kzalow ) then if ( iofe .eq. 1 ) then c ! (this cannot happen) if ( abs( bracketofe_opalmixes(1) ) .gt. $ small_3m7 ) write(6,1783) 'GN93hz', $ bracketofe_opalmixes(1) 1783 format(/' READCO: Error: ',a, $ ' file has [O/Fe] =',f12.7/20x, $ '(its [O/Fe] should be 0.0)',5x, $ 'THIS SHOULD NOT HAPPEN!'/) if ( abs( bracketofe_opalmixes(1) ) .gt. $ small_3m7 ) stop $ ' STOP -- READCO: non-0 [O/Fe]_GN93hz ' c ! is file [O/Fe] too small? else if ( iofe .gt. 0 ) then if ( abs(bracketofe_opalmixes(iofe)) .lt. $ max(0.1*abs(ofebrack),0.001) ) then write(6,2631) ofebrack, $ bracketofe_opalmixes(iofe), $ iofe, copfil(:lnblnk(copfil)) 2631 format(' '/' READCO: [O/Fe] =',f10.6, $ ': cannot get from [O/Fe] =', $ f10.6,' in file',i3,':'/' ',a/' ') stop ' STOP -- READCO: bad [O/Fe] file. ' endif else if ( iofe .eq. -1 ) then c ! (this cannot happen) if ( abs( bracketofe_opalGS98(1) ) .gt. $ small_3m7 ) write(6,1783) $ 'alternate-solar (e.g., GS98hz)', $ bracketofe_opalGS98(1) if ( abs( bracketofe_opalGS98(1) ) .gt. $ small_3m7 ) stop $ ' STOP -- READCO: non-0 [O/Fe]_GS98hz ' c ! is file [O/Fe] too small? else if ( abs(bracketofe_opalGS98(-iofe)) .lt. $ max(0.1*abs(ofebrack),0.001) ) then write(6,2631) ofebrack, $ bracketofe_opalGS98(-iofe), $ iofe, copfil(:lnblnk(copfil)) stop ' STOP -- READCO: bad [O/Fe] file. ' endif endif endif c ! loop over logT values, to read in opacities do k = 1, ntm c ! read logT,{logKappa(R) @ all R} line(1) = line(1) + 1 read(iu,7300) cin 7300 format(a137) read(cin,7140) flt, (cofzhi(k,il,kat),il=1,nrm) 7140 format(f4.2,19f7.3) c ! bad logT ? if ( abs(flogtin(k)-flt) .gt. small_1m5 ) then write(6,1734) flt, flogtin(k), $ copfil(:lnblnk(copfil)), line(1), $ cin(:max(1,lnblnk(cin))), $ zalval(iz),xzalat(kx),0.0,0.0 1734 format(/' Error reading logT value =',f10.6, $ ' should be',f10.6, $ ' from opacity file:'/' ',a/ $ ' at line',i8,', which contained:'/ $ ' "',a,'"'/ $ ' while reading mix [Z=',f6.4, $ ' X=',f6.4,' C=',f6.4,' O=',f6.4,']'/ $ ' *****THIS SHOULD NOT HAPPEN.'/) stop ' STOP -- READCO: bad logT value. ' endif c ! logKappa(R) is: do il = nrm, 1, -1 c ! absent if ( cin(7*il-2:7*il+4) .eq. $ ' ' ) then if ( k .le. max(nta(il),nta(0)) ) stop $ ' STOP -- READCO: bad upper edge. ' c c ! get value, for smoothing c cofzhi(k,il,kat) = 2.*cofzhi(k-1,il,kat) $ - cofzhi(k-2,il,kat) c ! should be absent else if ( k .gt. nta(il) .and. $ il .ge. nrb .and. il .le. nre ) then stop ' STOP -- READCO: bad upper edge. ' c ! 9.999 else if ( cofzhi(k,il,kat) .gt. 9. ) then if ( ( m .ne. mxzero .and. m .ne. mx03 ) $ .or. il .ge. nrm_m2 .or. $ flt .ge. 4.2 ) then stop ' STOP -- READCO: bad low edge. ' else if ( m .eq. mxzero ) then nthx0(il) = max( nthx0(il) , k + 1 ) else if ( m .eq. mx03 ) then nthx03(il) = max( nthx03(il) , k + 1 ) endif c ! get value, for smoothing c cofzhi(k,il,kat) = 2.*cofzhi(k,il+1,kat) $ - cofzhi(k,il+2,kat) endif c ! end of check-logKappa(R) loop enddo c ! end of T-loop enddo c ! end of Z-loop enddo c ! interpolate in Z, if needed if ( nzalmo .gt. 0 ) then kdelzhi = kzalow - kzsto do k = 1, ntm do il = 1, nrm cofzhi(k,il,kzsto) = qzinter(is,1,zat, $ nzalmo,cofzhi(k,il,j1-kdelzhi), $ cofzhi(k,il,j2-kdelzhi), $ cofzhi(k,il,j3-kdelzhi), $ cofzhi(k,il,j4-kdelzhi), $ zalval(j1),zalval(j2),zalval(j3), $ zalval(j4),zdel) is = 1 enddo enddo endif c ! end of X-loop enddo c ! close hz-file (have all necessary opacities from it) c call close_chk_zip( iu, copfil, igzip ) c c ! interpolate in X if necessary if ( nxdo .eq. 3 ) then do k = 1,ntm do il = 1,nrm c-test-xdel[ c-test-xdel; do ij = 1,n_xdtst c-test-xdel; cof_tst(k,il,ij) = qzinter(isx,ij+2, c-test-xdel; $ xa(m),nmorex,cofzhi(k,il,1), c-test-xdel; $ cofzhi(k,il,2),cofzhi(k,il,3), c-test-xdel; $ 0.0,xzalat(1),xzalat(2),xzalat(3), c-test-xdel; $ 0.0,xdel_tst(ij)) c-test-xdel; enddo c-test-xdel] cofzhi(k,il,1) = qzinter(isx,2,xa(m),nmorex, $ cofzhi(k,il,1),cofzhi(k,il,2), $ cofzhi(k,il,3),0.0,xzalat(1),xzalat(2), $ xzalat(3),0.0,xdelgn93) isx = 1 enddo enddo endif c-test-xdel[ c-test-xdel; do ij = 1,n_xdtst c-test-xdel; do il = 1,nrm c-test-xdel; do k = 1,ntm c-test-xdel; coff(k,il) = cof_tst(k,il,ij) c-test-xdel; enddo c-test-xdel; enddo c-test-xdel; if ( init_smo .gt. 0 ) then c-test-xdel; tmax = 10. c-test-xdel; nset = ks81 c-test-xdel; NSM = 1 c-test-xdel; RLS = alrf(1) c-test-xdel; RLE = alrf(nrm) c-test-xdel; nrhigh = int(dfsr(nr)*(RLE-RLS)+1.00001) c-test-xdel; nrlow = 1 c-test-xdel; call opaltab c-test-xdel; endif c-test-xdel; do il = 1,nrm c-test-xdel; do k = 1,ntm c-test-xdel; cof_tst(k,il,ij) = coff(k,il) c-test-xdel; enddo c-test-xdel; enddo c-test-xdel; enddo c-test-xdel] c ! transfer opacities from Z,X-interpolation storage do il = 1,nrm do k = 1,ntm coff(k,il) = cofzhi(k,il,1) enddo enddo c ! revise high-T,RHO extension call revise_hitr_for_initsmooth c ! smooth hz-opacities, if init_smo > 0 if ( init_smo .gt. 0 ) then tmax = 10. nset = ks81 NSM = 1 c ! note: MUST have all dfsr(i) = 1./0.5 RLS = alrf(1) RLE = alrf(nrm) nrhigh = int( dfsr(nr) * ( RLE - RLS ) + 1.00001 ) nrlow = 1 c ! fit and smooth OPAL kappas, up to T6 = tmax call opaltab c ! end of hz-opacity smoothing endif c ! set any missing values to 1.0E+35 do il = nre, nrb, -1 c-not-these[ ! except at high-T,RHO c-not-these; if ( nta(il) .lt. ntm ) then c-not-these; do k = nta(il) + 1, ntm c-not-these; coff(k,il) = badlogkval c-not-these; enddo c-not-these; endif c-not-these] if ( m .eq. mxzero ) then if ( il .lt. nre ) $ nthx0(il) = max( nthx0(il) , nthx0(il+1) ) if ( nthx0(il) .gt. ntb ) then do k = ntb, nthx0(il) - 1 coff(k,il) = badlogkval enddo endif else if ( m .eq. mx03 ) then if ( il .lt. nre ) $ nthx03(il) = max( nthx03(il) , nthx03(il+1) ) if ( nthx03(il) .gt. ntb ) then do k = ntb, nthx03(il) - 1 coff(k,il) = badlogkval enddo endif endif enddo c ! store present hz-opacity set in free space do il = 1,nr jl = il+nrdel do k = 1,nt co(m,mc,moat,k,il,kz) = coff(k+ntdel,jl) enddo enddo c ! position to store next hz-opacity set moat = moat - 1 c ! get next iofe value, if any if ( iofe .eq. -klozat ) then iofe = 0 else if ( iofe .eq. -1 ) then iofe = -klozat else if ( iofe .eq. khizat ) then iofe = max( -klozat , -1 ) else iofe = khizat endif c ! end of loop reading in C+O=0.0 table(s) enddo c ! only check (don't store) Z-composition, in future igetzxi = -1 c ! end of obtaining C+O=0.0 'GN93hz'-table(s) endif c c Read in opacities from 'Gz???.x??' files, interpolating in Z if necessary, c for files with the present m value (i.e., with the present X value xa(m)). c UPDATE: 25 May 1999: look for newer format Gz???.x?? first; if this is not c found, then look for older format Gx??z* instead. c c ! turn off all "mix-acquired" flags do i = 1, mc do j = 1, mo ico_got(i,j) = 0 enddo enddo c ! get filename(s) and open file(s): do iu = iulow, iulow + nmorez c if ( igznotgx .ge. 0 ) then copfil(kope+1:kope+1) = 'G' copfil(kope+2:kope+5) = czfil(kzlow+iu-iulow) if ( copfil(kope+4:kope+4) .eq. ' ' ) $ copfil(kope+4:kope+4) = '0' if ( copfil(kope+5:kope+5) .eq. ' ' ) $ copfil(kope+5:kope+5) = '0' copfil(kope+6:) = cxfil(m) copfil(kope+6:kope+6) = '.' else copfil(kope+1:kope+4) = cxfil(m) copfil(kope+5:) = czfil(kzlow+iu-iulow) endif c if ( igznotgx .eq. 0 ) then call inqfil(copfil,lxst) if ( .not. lxst ) $ call inqfil( copfil(1:kope+9) // '.gz' , lxst ) if ( .not. lxst ) $ call inqfil( copfil(1:kope+9) // '.Z' , lxst ) if ( lxst ) then igznotgx = 1 else copalt = copfil copfil(kope+1:kope+4) = cxfil(m) copfil(kope+5:) = czfil(kzlow+iu-iulow) call inqfil(copfil,lxst) if ( .not. lxst ) then k_e = kope + 8 if ( copfil(k_e:k_e) .eq. ' ' ) k_e = k_e - 1 if ( copfil(k_e:k_e) .eq. ' ' ) k_e = k_e - 1 call inqfil( copfil(1:k_e) // '.gz' , lxst ) if ( .not. lxst ) $ call inqfil( copfil(1:k_e) // '.Z' , lxst ) endif if ( lxst ) then igznotgx = -1 else write(6,7399) copalt(:lnblnk(copalt)), $ copfil(:lnblnk(copfil)) 7399 format(' '/' STOP -- READCO: neither Gz???.x??', $ ' nor Gx??z* OPAL opacity files found:'/ $ ' ',a/' ',a) stop ' STOP -- READCO: Gz???.x?? file not found. ' endif endif endif c cop_sto(iu-iulow) = copfil c if ( level_list .gt. 0 ) then if ( iu_list .eq. iu ) then write(6,4) iu_list iu_list = 6 endif if ( list_mult .gt. 0 ) then if ( list_mult .eq. 1 ) then write(iu_list,1) copfil(:lnblnk(copfil)), ' ...' 1 format(' ***OPAL/Type_2: ',a,a) else write(iu_list,1) copfil(:lnblnk(copfil)) endif list_mult = list_mult - 1 endif endif c call open_chk_zip( iu, copfil, igzip_sto(iu-iulow), $ 'READCO Error: Gz???.x?? opacity file not found.' ) line(iu-iulow) = 0 c enddo c ! read in Z-composition only for 1st file do i = 1, nmorez + 1 iz_get(i) = -1 iz_rew(i) = 0 iz_tab(i) = 0 enddo iz_get(1) = igetzxi c ! Z-position indices j1 to j4, for array zval j1 = kzlow j2 = j1 + min( 1 , nmorez ) j3 = j1 + min( 2 , nmorez ) j4 = j1 + min( 3 , nmorez ) is = 0 c ! loop over dXo (excess oxygen) index j do j = 1, no - 1 c ! number of dXc values at Z for this dXo ihi = n(m,j,kz) do jz = 1, nmorez + 1 nofmjz(jz) = nofz(kzvalnof(jz),mnofz(m),j) enddo c ! loop over dXc (excess carbon) index i do i = 1, ihi c ! number of "extra" Z-values, for interpolation nmorat = nmorez c ! note: the case i=1,j=1 will ALWAYS have is1=1 is1 = 1 c ! loop over Z values: find tables do iz = kzlow, kzlow + nmorez c ! other Z-index jz starts at 1 jz = iz - kzlow_m1 iu = iulow + iz - kzlow c ! if a mix (with higher Z-value) is c ! missing a needed C-O table, then c ! rewinding may work (if needed table c ! duplicates an earlier C-O table) c if ( i .gt. nofmjz(jz) ) iz_rew(jz) = 1 cget = xcs(i) if ( i .eq. ihi ) $ cget = min( cget , 1.-xa(m)-xos(j)-zval(iz) ) ifound = mixfind(iu,1,iz_get(jz),iz_rew(jz), $ iz_tab(jz),line(iu-iulow), $ zval(iz),xa(m),cget,xos(j)) c ! if table is not c ! present in this file, it cannot c ! be used in the Z-interpolation, if ( ifound .eq. 0 ) then c ! so reduce nmorat nmorat = min( iz - kzlow - 1 , nmorat ) c ! (cannot happen): if ( nmorat .lt. 0 ) then write(6,1791) zval(iz),xa(m),cget,xos(j), $ cop_sto(iu $ -iulow)(:lnblnk(cop_sto(iu-iulow))) stop ' STOP -- READCO: error reading mix. ' c-debug-chk[ c-debug-chk; else c-debug-chk; write(6,1878) m,z,i,j,jz,nofmjz(jz), c-debug-chk; $ iz_rew(jz),nmorat c-debug-chk; 1878 format(' m=',i1,' Z=',f9.7, c-debug-chk; $ ' cannot find i=',i1,' j=',i1, c-debug-chk; $ ' Z(jz=',i1,'): Nofmjz=',i1, c-debug-chk; $ ' irew=',i2,' nmorat=',i2) c-debug-chk] endif is1 = 2 is = 0 endif enddo c ! if needed table exists at enough Z-values, read it in: c if ( nmorat .eq. nmorez .or. nmorat .eq. 2 ) then c ! loop over T: do k = 1, ntm c ! loop over Z values: read line do iz = kzlow, kzlow + nmorat jz = iz - kzlow_m1 iu = iulow + iz - kzlow c ! read logT, & logKappa(R) for all R line(iu-iulow) = line(iu-iulow) + 1 read(iu,7300) cin read(cin,7140) flt,(cofzat(jz,il),il=1,nrm) c ! bad logT ? if ( abs(flogtin(k)-flt) .gt. small_1m5 ) then write(6,1734) flt, flogtin(k), cop_sto(iu $ -iulow)(:lnblnk(cop_sto(iu-iulow))), $ line(iu-iulow), $ cin(:max(1,lnblnk(cin))), $ zval(iz),xa(m),cget,xos(j) stop ' STOP -- READCO: bad logT value. ' endif c ! store logT if ( k .ge. ntb ) alt(k-ntdel) = flt - 6. flogtin(k) = flt c ! logKappa(R) is: do il = nrm, 1, -1 c ! absent if ( cin(7*il-2:7*il+4) .eq. $ ' ' ) then if ( k .le. max(nta(il),nta(0)) ) stop $ ' STOP -- READCO: bad upper edge. ' cofzat(1,il) = badlogkval c ! or should be else if ( k .gt. nta(il) .and. $ il .ge. nrb .and. il .le. nre ) then stop ' STOP -- READCO: bad upper edge. ' c ! or 9.999 else if ( cofzat(jz,il) .gt. 9. ) then if ( ( m .ne. mxzero .and. m .ne. mx03 ) $ .or. il .ge. nrm_m2 .or. $ flt .ge. 4.2 ) then stop ' STOP -- READCO: bad low edge. ' c c ! set lower bounds: else if ( m .eq. mxzero ) then ntax0(il) = max( ntax0(il) , k + 1 ) else if ( m .eq. mx03 ) then ntax03(il) = max( ntax03(il) , k + 1 ) endif c ! for smoothing: cofzat(jz,il) = 2.*cofzat(jz,il+1) $ -cofzat(jz,il+2) endif c ! end of check-logKappa(R) loop enddo c ! end of Z-loop enddo c ! interpolate logKappa(R) in Z; store in COFF do il = 1, nrm c ! if opacity missing, extrapolate value for c ! smoothing if ( abs(cofzat(1,il)) .gt. badlogklim ) then coff(k,il) = 2.*coff(k-1,il) - coff(k-2,il) c c ! else if table-Z is O.K. else if ( nmorez .eq. 0 ) then coff(k,il) = cofzat(1,il) c ! else, Z-interpolation else coff(k,il) = qzinter(is,is1,zat,nmorat, $ cofzat(j1-kzlow_m1,il), $ cofzat(j2-kzlow_m1,il), $ cofzat(j3-kzlow_m1,il), $ cofzat(j4-kzlow_m1,il),zval(j1), $ zval(j2),zval(j3),zval(j4),zdel) is = 1 endif enddo c ! end of T-loop enddo c ! revise high-T,RHO extension call revise_hitr_for_initsmooth c ! smooth opacities, if init_smo > 0 if ( init_smo .gt. 0 ) then tmax = 10. nset = ks81 NSM = 1 c ! note: MUST have all dfsr(i) = 1./0.5 RLS = alrf(1) RLE = alrf(nrm) nrhigh = int( dfsr(nr) * ( RLE - RLS ) + 1.00001 ) nrlow = 1 c ! fit and smooth OPAL kappas, up to T6 = tmax call opaltab c ! end of opacity smoothing endif c ! store opacities do il = 1, nr jl = il + nrdel do k = 1, nt co(m,i,j,k,il,kz) = coff(k+ntdel,jl) enddo enddo c ! set flag indicating this table was read in ico_got(i,j) = 1 c ! end of reading in table endif c ! end of loop over dXc (excess carbon) index enddo c ! end of loop over dXo (excess oxygen) index enddo c c........ Read remaining diagonal tables (along line Y=0 in dXc,dXo plane) c do jz = 1, nmorez + 1 nofmjz(jz) = nofz(kzvalnof(jz),mnofz(m),1) - 1 if ( nofmjz(jz) .lt. no - 1 ) iz_rew(jz) = 1 enddo c ! loop over dXc (excess carbon) inverted-index j; note c ! that table being read in will be stored at i=(no-j) do j = 1, no - 1 c nmorat = nmorez is1 = 1 nomj = no - j c ! loop over Z values: find tables do iz = kzlow, kzlow + nmorat iu = iulow + iz - kzlow jz = iz - kzlow_m1 oget = 1. - xa(m) - xcs(nomj) - zval(iz) ifound = mixfind(iu,1,iz_get(jz),iz_rew(jz), $ iz_tab(jz),line(iu-iulow), $ zval(iz),xa(m),xcs(nomj),oget) if ( ifound .eq. 0 ) then nmorat = min( iz - kzlow - 1 , nmorat ) if ( nmorat .lt. 0 ) then write(6,1791) zval(iz),xa(m),xcs(nomj),oget, $ cop_sto(iu-iulow)(:lnblnk(cop_sto(iu-iulow))) stop ' STOP -- READCO: error reading mix. ' c-debug-chk[ c-debug-chk; else c-debug-chk; write(6,2878) m,z,j,mo,jz,nofmjz(jz), c-debug-chk; $ iz_rew(jz),nmorat c-debug-chk; 2878 format(' m=',i1,' Z=',f9.7, c-debug-chk; $ ' cannot find i=',i1,' j=',i1, c-debug-chk; $ ' Z(jz=',i1,'): Nofmjz=',i1, c-debug-chk; $ ' irew=',i2,' nmorat=',i2) c-debug-chk] endif is1 = 2 is = 0 endif enddo c ! if needed table exists at enough z-values, read it in: c if ( nmorat .eq. nmorez .or. nmorat .eq. 2 ) then c ! loop over T: do k = 1, ntm c ! loop over Z values: read line do iz = kzlow, kzlow + nmorat jz = iz - kzlow_m1 iu = iulow + iz - kzlow c ! read logT, & logKappa(R) for all R line(iu-iulow) = line(iu-iulow) + 1 read(iu,7300) cin read(cin,7140) flt,(cofzat(jz,il),il=1,nrm) c ! bad logT ? if ( abs(flogtin(k)-flt) .gt. small_1m5 ) then write(6,1734) flt, flogtin(k), cop_sto(iu $ -iulow)(:lnblnk(cop_sto(iu-iulow))), $ line(iu-iulow), cin(:max(1,lnblnk(cin))), $ zval(iz),xa(m),xcs(nomj),oget stop ' STOP -- READCO: bad logT value. ' endif c ! logKappa(R) is: do il = nrm, 1, -1 c ! absent if ( cin(7*il-2:7*il+4) .eq. ' ' ) then if ( k .le. max(nta(il),nta(0)) ) stop $ ' STOP -- READCO: bad upper edge. ' cofzat(1,il) = badlogkval c ! or should be else if ( k .gt. nta(il) .and. $ il .ge. nrb .and. il .le. nre ) then stop ' STOP -- READCO: bad upper edge. ' c ! or 9.999 else if ( cofzat(jz,il) .gt. 9. ) then if ( ( m .ne. mxzero .and. m .ne. mx03 ) $ .or. il .ge. nrm_m2 .or. $ flt .ge. 4.2 ) then stop ' STOP -- READCO: bad low edge. ' else if ( m .eq. mxzero ) then ntax0(il) = max( ntax0(il) , k + 1 ) else if ( m .eq. mx03 ) then ntax03(il) = max( ntax03(il) , k + 1 ) endif c ! for smoothing cofzat(jz,il) = 2.*cofzat(jz,il+1) $ - cofzat(jz,il+2) endif c ! end of check-logKappa(R) loop enddo c ! end of Z-loop enddo c ! interpolate in Z; store in COFF do il = 1, nrm if ( abs(cofzat(1,il)) .gt. badlogklim ) then coff(k,il) = 2.*coff(k-1,il) - coff(k-2,il) else if ( nmorez .eq. 0 ) then coff(k,il) = cofzat(1,il) else coff(k,il) = qzinter(is,is1,zat,nmorat, $ cofzat(j1-kzlow_m1,il), $ cofzat(j2-kzlow_m1,il), $ cofzat(j3-kzlow_m1,il), $ cofzat(j4-kzlow_m1,il),zval(j1), $ zval(j2),zval(j3),zval(j4),zdel) is = 1 endif enddo c ! end of T-loop enddo c ! revise high-T,RHO extension call revise_hitr_for_initsmooth c ! smooth opacities, if init_smo > 0 if ( init_smo .gt. 0 ) then tmax = 10. nset = ks81 NSM = 1 c ! note: MUST have all dfsr(i) = 1./0.5 RLS = alrf(1) RLE = alrf(nrm) nrhigh = int( dfsr(nr) * ( RLE - RLS ) + 1.00001 ) nrlow = 1 c ! fit and smooth OPAL kappas, up to T6 = tmax call opaltab c ! end of opacity smoothing endif c ! store opacities do il = 1,nr jl = il+nrdel do k = 1,nt co(m,nomj,mo,k,il,kz) = coff(k+ntdel,jl) enddo enddo c ! set flag indicating this table was read in ico_got(nomj,mo) = 1 c ! end of reading in table endif c ! end of loop over dXc (excess carbon) inverted-index enddo c ! close 'Gz???.x??' files do iu = iulow, iulow + nmorez call close_chk_zip( iu, cop_sto(iu-iulow), $ igzip_sto(iu-iulow) ) enddo c ! for X=0 or .03, ensure low-R,low-T corner c ! has no steps in the wrong direction if ( m .eq. mxzero ) then do il = nre_m1, nrb, -1 ntax0(il) = max( ntax0(il) , ntax0(il+1) ) enddo else if ( m .eq. mx03 ) then do il = nre_m1,nrb,-1 ntax03(il) = max( ntax03(il) , ntax03(il+1) ) enddo endif c ! Set missing opacity values in low-T,R,X corner (but c ! not in high-T,R corner) to badlogkval = 1.0E+35 do il = 1, nr jl = il + nrdel if ( m .eq. mxzero ) then khi = ntax0(jl) - ntb else if ( m .eq. mx03 ) then khi = ntax03(jl) - ntb else khi = 0 endif if ( khi .gt. 0 ) then do j = 1,mo if ( j .lt. no ) then ihi = n(m,j,kz) else if ( j .eq. mo ) then ihi = no - 1 else ihi = 0 endif if ( ihi .gt. 0 ) then do k = 1, khi do i = 1, ihi co(m,i,j,k,il,kz) = badlogkval enddo enddo endif enddo endif c-not-these[ c-not-these; if ( nta(jl) .lt. ntm ) then c-not-these; do j = 1, mo c-not-these; if ( j .lt. no ) then c-not-these; ihi = n(m,j,kz) c-not-these; else if ( j .eq. mo ) then c-not-these; ihi = no - 1 c-not-these; else c-not-these; ihi = 0 c-not-these; endif c-not-these; if ( ihi .gt. 0 ) then c-not-these; do k = nta(jl) + 1 - ntdel, nt c-not-these; do i = 1, ihi c-not-these; co(m,i,j,k,il,kz) = badlogkval c-not-these; enddo c-not-these; enddo c-not-these; endif c-not-these; enddo c-not-these; endif c-not-these] enddo c c........ Interpolate any missing opacity tables in dXc or dXo; these will be c at or near the line Y=0, arising from the fact that files for higher c Z-values may not have had as many dXc or dXo tables in them as are c needed for the input (interpolated) Z-value. c ! first, main tables: do j = 1, no - 1 ihi = n(m,j,kz) do i = 1, ihi c ! if flag indicates missing table if ( ico_got(i,j) .eq. 0 ) then oat = xos(j) cat = min( xcs(i) , 1. - xa(m) - zat - oat ) c-debug-chk[ c-debug-chk; write(6,1973) zat,m,i,j,ihi,cat,oat c-debug-chk; 1973 format(' '/' Z=',f9.7,' --- interpolate', c-debug-chk; $ ' mix (m=',i1,',i=',i1,',j=',i1, c-debug-chk; $ ') with ihi=',i1,' C=',f10.7,' O=',f10.7) c-debug-chk; difmax = -9.999999 c-debug-chk; difmin = 9.999999 c-debug-chk; sumdif = 0. c-debug-chk; sumsq = 0. c-debug-chk; numsq = 0 c-debug-chk; diflmax = -9.999999 c-debug-chk; diflmin = 9.999999 c-debug-chk; sumldif = 0. c-debug-chk; sumlsq = 0. c-debug-chk] c ! if C > or = O in missing table, if ( cat .ge. oat ) then c ! then the only C-value that can be c ! missing is the next-to-highest one c ! at ihi-1 = n(m,j,kz)-1 c if ( ico_got(ihi,j) .le. 0 .and. i .ne. ihi ) $ write(6,1873) zat,m,ihi,j,ihi, $ min(xcs(ihi),1.-xa(m)-zat-oat),oat if ( i .ne. ihi-1 .or. i .lt. 3 ) $ write(6,1873) zat,m,i,j,ihi, $ min(xcs(i),1.-xa(m)-zat-oat),oat 1873 format(' '/' Z=',f9.7,' ??? CANNOT miss', $ ' mix (m=',i1,',i=',i1,',j=',i1, $ ') with ihi=',i1,' C=',f10.7,' O=',f10.7) if ( ico_got(ihi,j) .le. 0 .or. $ i .lt. 3 .or. i .ne. ihi - 1 ) stop $ ' STOP -- READCO: missing mix: CANNOT be. ' c im2 = i - 2 im1 = i - 1 cxhi = log10( zzz(kz) + min( xcs(ihi) , $ 1. - xa(m) - zat - oat ) ) c-debug-chk[ c-debug-chk; write(6,1974) i,j,'C',xcs(i),'C',cx(i), c-debug-chk; $ im2,j,im1,j,ihi,j,'C',xcs(im2),xcs(im1), c-debug-chk; $ min(xcs(ihi),1.-xa(m)-zat-oat), c-debug-chk; $ 'C',cx(im2),cx(im1),cxhi c-debug-chk; 1974 format(' --- interpolate (',i1,',',i1, c-debug-chk; $ ') in ',a1,'=',f10.6,' log',a1,'=',f10.6, c-debug-chk; $ ' among (',i1,',',i1,') (',i1,',',i1, c-debug-chk; $ ') (',i1,',',i1,'): ',a1,'=',3f10.6, c-debug-chk; $ ' log',a1,'=',3f10.6) c-debug-chk] c ! interpolate in C to get missing table: c call quadsto( 1, cx(i), cx(im2), cx(im1), cxhi ) do il = 1, nr do k = 1, nt if ( abs( co(m,im1,j,k,il,kz) ) .lt. $ badlogklim ) then co(m,i,j,k,il,kz) = quadget( 1, $ co(m,im2,j,k,il,kz), $ co(m,im1,j,k,il,kz), $ co(m,ihi,j,k,il,kz) ) c-debug-chk[ c-debug-chk; if ( t6list(k) .gt. 0.09999 ) then c-debug-chk; dif = co(m,i,j,k,il,kz) c-debug-chk; $ -co(m,ihi,j,k,il,kz) c-debug-chk; difl = co(m,i,j,k,il,kz) c-debug-chk; $ -co(m,im1,j,k,il,kz) c-debug-chk; difmax = max(dif,difmax) c-debug-chk; difmin = min(dif,difmin) c-debug-chk; sumdif = sumdif+dif c-debug-chk; sumsq = sumsq+dif**2 c-debug-chk; numsq = numsq+1 c-debug-chk; diflmax = max(difl,diflmax) c-debug-chk; diflmin = min(difl,diflmin) c-debug-chk; sumldif = sumldif+difl c-debug-chk; sumlsq = sumlsq+difl**2 c-debug-chk; endif c-debug-chk] endif enddo enddo ico_got(i,j) = -1 c ! else, if C < O in missing table, but c ! it is not on the diagonal Y=0: else if ( i .lt. ihi ) then c ! then the only O-value that can c ! be missing is next-to-highest c ! one, at j = n(m,i,kz)-1 c if ( ico_got(i,mo) .le. 0 ) $ write(6,2873) z,m,i,mo,n(m,1,kz)-1, $ xcs(i),1.-xa(m)-zat-xcs(i) if ( j .lt. 3 .or. j .ne. n(m,i,kz)-1 ) $ write(6,2873) z,m,i,j,ihi, $ min(xcs(i),1.-xa(m)-zat-oat),oat, $ ' n(m,i)=',n(m,i,kz) 2873 format(' '/' Z=',f9.7,' ??? CANNOT miss', $ ' mix (m=',i1,',i=',i1,',j=',i1, $ ') with ihi=',i1,' C=',f10.7,' O=',f10.7, $ a8,i1) if ( ico_got(i,mo) .le. 0 .or. $ j .lt. 3 .or. j .ne. n(m,i,kz)-1 ) stop $ ' STOP -- READCO: missing mix: CANNOT be. ' c jm2 = j - 2 jm1 = j - 1 oxhi = log10( 1. - xa(m) - zat - xcs(i) $ + zzz(kz) ) c-debug-chk[ c-debug-chk; write(6,2974) i,j,'O',xos(j),'O',ox(j), c-debug-chk; $ i,jm2,i,jm1,i,mo,'O',xos(jm2),xos(jm1), c-debug-chk; $ 1.-xa(m)-zat-xcs(i), c-debug-chk; $ 'O',ox(jm2),ox(jm1),oxhi c-debug-chk; 2974 format(' --- interpolate (',i1,',',i1, c-debug-chk; $ ') in ',a1,'=',f10.6,' log',a1,'=',f10.6, c-debug-chk; $ ' among (',i1,',',i1,') (',i1,',',i1, c-debug-chk; $ ') (',i1,',',i1,'): ',a1,'=',3f10.6, c-debug-chk; $ ' log',a1,'=',3f10.6) c-debug-chk] c ! interpolate in O to get missing table: c call quadsto( 1, ox(j), ox(jm2), ox(jm1), oxhi ) do il = 1, nr do k = 1, nt if ( abs( co(m,i,jm1,k,il,kz) ) .lt. $ badlogklim ) then co(m,i,j,k,il,kz) = quadget( 1, $ co(m,i,jm2,k,il,kz), $ co(m,i,jm1,k,il,kz), $ co(m,i,mo,k,il,kz) ) c-debug-chk[ c-debug-chk; if ( t6list(k) .gt. 0.09999 ) then c-debug-chk; dif = co(m,i,j,k,il,kz) c-debug-chk; $ -co(m,i,mo,k,il,kz) c-debug-chk; difl = co(m,i,j,k,il,kz) c-debug-chk; $ -co(m,i,jm1,k,il,kz) c-debug-chk; difmax = max(dif,difmax) c-debug-chk; difmin = min(dif,difmin) c-debug-chk; sumdif = sumdif+dif c-debug-chk; sumsq = sumsq+dif**2 c-debug-chk; numsq = numsq+1 c-debug-chk; diflmax = max(difl,diflmax) c-debug-chk; diflmin = min(difl,diflmin) c-debug-chk; sumldif = sumldif+difl c-debug-chk; sumlsq = sumlsq+difl**2 c-debug-chk; endif c-debug-chk] endif enddo enddo ico_got(i,j) = -1 c ! else, if C < O in missing table, and c ! it is on the diagonal Y=0 (note that c ! this never actually happens): else nmorat = 3 j3 = 3 do while( j3 .lt. no - 1 .and. cat .gt. xcs(j3) $ .and. ico_got(j3+1,mo) .gt. 0 ) j3 = j3 + 1 enddo j4 = j3 + 1 if ( j4 .ge. no .or. ico_got(j4,mo) .le. 0 ) then j4 = j3 nmorat = 2 endif j2 = j3 - 1 j1 = j2 - 1 c if ( ico_got(j1,mo) .le. 0 ) write(6,4873) $ zat,m,j1,mo,no-1,xcs(j1),1.-xa(m)-zat-xcs(j1) if ( ico_got(j2,mo) .le. 0 ) write(6,4873) $ zat,m,j2,mo,no-1,xcs(j2),1.-xa(m)-zat-xcs(j2) if ( ico_got(j3,mo) .le. 0 ) write(6,4873) $ zat,m,j3,mo,no-1,xcs(j3),1.-xa(m)-zat-xcs(j3) 4873 format(' '/' Z=',f9.7,' ??? CANNOT miss', $ ' mix (m=',i1,',i=',i1,',j=',i1, $ ') with ihi=',i1,' C=',f10.7,' O=',f10.7) if ( ico_got(j1,mo) .le. 0 .or. $ ico_got(j2,mo) .le. 0 .or. $ ico_got(j3,mo) .le. 0 ) stop $ ' STOP -- READCO: missing mix: CANNOT be. ' c c-debug-chk[ c-debug-chk; write(6,1975) i,j,'C',cat,'C',cx(i), c-debug-chk; $ nmorat+1,j1,mo,j2,mo,j3,mo,j4,mo, c-debug-chk; $ 'C',xcs(j1),xcs(j2),xcs(j3),xcs(j4), c-debug-chk; $ 'C',cx(j1),cx(j2),cx(j3),cx(j4) c-debug-chk; 1975 format(' (',i1,',',i1,') ',a1,'=',f10.6, c-debug-chk; $ ' log',a1,'=',f10.6,' among',i2, c-debug-chk; $ ' of (',i1,',',i1,') (',i1,',',i1, c-debug-chk; $ ') (',i1,',',i1,') (',i1,',',i1,'): ', c-debug-chk; $ a1,'=',4f10.6,' log',a1,'=',4f10.6) c-debug-chk] is = 0 do il = 1, nr do k = 1, nt if ( abs( co(m,j1,mo,k,il,kz) ) .lt. $ badlogklim ) then co(m,i,j,k,il,kz) = qzinter(is,1,cat, $ nmorat,co(m,j1,mo,k,il,kz), $ co(m,j2,mo,k,il,kz), $ co(m,j3,mo,k,il,kz), $ co(m,j4,mo,k,il,kz),xcs(j1), $ xcs(j2),xcs(j3),xcs(j4),zzz(kz)) is = 1 c-debug-chk[ c-debug-chk; if ( t6list(k) .gt. 0.09999 ) then c-debug-chk; dif = co(m,i,j,k,il,kz) c-debug-chk; $ -co(m,j3,mo,k,il,kz) c-debug-chk; difl = co(m,i,j,k,il,kz) c-debug-chk; $ -co(m,j2,mo,k,il,kz) c-debug-chk; difmax = max(dif,difmax) c-debug-chk; difmin = min(dif,difmin) c-debug-chk; sumdif = sumdif+dif c-debug-chk; sumsq = sumsq+dif**2 c-debug-chk; numsq = numsq+1 c-debug-chk; diflmax = max(difl,diflmax) c-debug-chk; diflmin = min(difl,diflmin) c-debug-chk; sumldif = sumldif+difl c-debug-chk; sumlsq = sumlsq+difl**2 c-debug-chk; endif c-debug-chk] endif enddo enddo ico_got(i,j) = -1 c-debug-chk[ c-debug-chk; write(6,8712) numsq,diflmin,diflmax, c-debug-chk; $ sumldif/max(numsq,1), c-debug-chk; $ sqrt(sumlsq/max(numsq,1)), c-debug-chk; $ numsq,difmin,difmax,sumdif/max(numsq,1), c-debug-chk; $ sqrt(sumsq/max(numsq,1)) c-debug-chk; 8712 format(' '/' ', c-debug-chk; $ ' --- result: relative DIFmid:', c-debug-chk; $ i5,'[',f10.6,' ,',f10.6,' ]ave',f10.6, c-debug-chk; $ ' rms',f10.6,' DIFhi:',i5,'[',f10.6, c-debug-chk; $ ' ,',f10.6,' ]ave',f10.6,' rms',f10.6) c-debug-chk] endif endif enddo enddo c ! next, remaining diagonal tables (at Y=0): c ! (only the table at no-1 can possibly be missing) do j = 1, no - 2 if ( ico_got(j,mo) .eq. 0 ) write(6,3873) $ zat,m,j,mo,no-1,xcs(j),1.-xa(m)-zat-xcs(j) 3873 format(' '/' Z=',f9.7,' ??? CANNOT miss', $ ' mix (m=',i1,',i=',i1,',j=',i1, $ ') with ihi=',i1,' C=',f10.7,' O=',f10.7) if ( ico_got(j,mo) .eq. 0 ) stop $ ' STOP -- READCO: missing mix: CANNOT be. ' enddo c j = no - 1 c ! if table at no-1 is missing: if ( ico_got(j,mo) .eq. 0 ) then oat = 1. - xa(m) - zat - xcs(j) c-debug-chk[ c-debug-chk; write(6,4973) m,zat,j,mo,no-1,xcs(j),oat c-debug-chk; 4973 format(' '/' Z=',f9.7,' --- interpolate', c-debug-chk; $ ' mix (m=',i1,',i=',i1,',j=',i1, c-debug-chk; $ ') with ihi=',i1,' C=',f10.7,' O=',f10.7) c-debug-chk; difmax = -9.999999 c-debug-chk; difmin = 9.999999 c-debug-chk; sumdif = 0. c-debug-chk; sumsq = 0. c-debug-chk; numsq = 0 c-debug-chk; diflmax = -9.999999 c-debug-chk; diflmin = 9.999999 c-debug-chk; sumldif = 0. c-debug-chk; sumlsq = 0. c-debug-chk] c ! may use quadratic, or two overlapping quadratics nmorat = 3 j3 = 3 do while( j3 .lt. no - 1 .and. oat .gt. xos(j3) .and. $ ico_got(max(n(m,j3+1,kz),1),j3+1) .gt. 0 ) j3 = j3+1 enddo j4 = j3+1 if ( j4 .ge. no .or. $ ico_got(j4,max(n(m,j4,kz),1)) .le. 0 ) then j4 = j3 nmorat = 2 endif j2 = j3-1 j1 = j2-1 c-noneed[ ! (checked above) c-noneed; if ( ico_got(n(m,j1,kz),j1) .le. 0 .or. c-noneed; $ ico_got(n(m,j2,kz),j2) .le. 0 .or. c-noneed; $ ico_got(n(m,j3,kz),j3) .le. 0 ) stop c-noneed; $ ' STOP -- READCO: mix CANNOT be missing. ' c-noneed] c-debug-chk[ c-debug-chk; write(6,2975) j,mo,'O',oat,'O',log10(oat+zzz(kz)), c-debug-chk; $ nmorat+1,n(m,j1,kz),j1,n(m,j2,kz),j2, c-debug-chk; $ n(m,j3,kz),j3,n(m,j4,kz),j4, c-debug-chk; $ 'O',xos(j1),xos(j2),xos(j3),xos(j4), c-debug-chk; $ 'O',ox(j1),ox(j2),ox(j3),ox(j4) c-debug-chk; 2975 format(' (',i1,',',i1,') ',a1,'=',f10.6, c-debug-chk; $ ' log',a1,'=',f10.6,' among',i2, c-debug-chk; $ ' of (',i1,',',i1,') (',i1,',',i1, c-debug-chk; $ ') (',i1,',',i1,') (',i1,',',i1,'): ', c-debug-chk; $ a1,'=',4f10.6,' log',a1,'=',4f10.6) c-debug-chk] c ! interpolate along the diagonal (using O-abundance) is = 0 do il = 1, nr do k = 1, nt if ( abs( co(m,n(m,j1,kz),j1,k,il,kz) ) .lt. $ badlogklim ) then co(m,j,mo,k,il,kz) = qzinter(is,1,oat,nmorat, $ co(m,n(m,j1,kz),j1,k,il,kz), $ co(m,n(m,j2,kz),j2,k,il,kz), $ co(m,n(m,j3,kz),j3,k,il,kz), $ co(m,n(m,j4,kz),j4,k,il,kz), $ xos(j1),xos(j2),xos(j3),xos(j4),zzz(kz)) is = 1 c-debug-chk[ c-debug-chk; if ( t6list(k) .gt. 0.09999 ) then c-debug-chk; dif = co(m,j,mo,k,il,kz) c-debug-chk; $ - co(m,n(m,j3,kz),j3,k,il,kz) c-debug-chk; difl = co(m,j,mo,k,il,kz) c-debug-chk; $ - co(m,n(m,j2,kz),j2,k,il,kz) c-debug-chk; difmax = max(dif,difmax) c-debug-chk; difmin = min(dif,difmin) c-debug-chk; sumdif = sumdif+dif c-debug-chk; sumsq = sumsq+dif**2 c-debug-chk; numsq = numsq+1 c-debug-chk; diflmax = max(difl,diflmax) c-debug-chk; diflmin = min(difl,diflmin) c-debug-chk; sumldif = sumldif+difl c-debug-chk; sumlsq = sumlsq+difl**2 c-debug-chk; endif c-debug-chk] endif enddo enddo ico_got(j,mo) = -1 c-debug-chk[ c-debug-chk; write(6,7712) numsq,diflmin,diflmax, c-debug-chk; $ sumldif/max(numsq,1), c-debug-chk; $ sqrt(sumlsq/max(numsq,1)), c-debug-chk; $ numsq,difmin,difmax,sumdif/max(numsq,1), c-debug-chk; $ sqrt(sumsq/max(numsq,1)) c-debug-chk; 7712 format(' '/' ', c-debug-chk; $ ' --- result: relative DIFmid:', c-debug-chk; $ i5,'[',f10.6,' ,',f10.6,' ]ave',f10.6, c-debug-chk; $ ' rms',f10.6,' DIFhi:',i5,'[',f10.6, c-debug-chk; $ ' ,',f10.6,' ]ave',f10.6,' rms',f10.6) c-debug-chk] endif c 0.10-- @ + + @ c If possible, make mixes next to the C=O=0.0 C c mix smooth for CO-interpolation (but only if c low_CO_smo > 0 in common /c_opal_ctrl_smooth/). 0.03-- @ + @ + c The diagram at right, of the lower-left corner c of the C-O plane, shows the mixes that may be 0.01-- * * + + c interpolated as "*" , the mixes interpolated 0.00-- @ * @ @ c among as "@" , and unused mixes as "+". | | | | c 0. | .03 .10 c .01 O if ( low_CO_smo .gt. 0 ) then call quadsto( 1, oxf(m,2,kz), oxf(m,1,kz), $ oxf(m,3,kz), oxf(m,4,kz) ) c-debug-chk[ c-debug-chk; difmax = -9.999999 c-debug-chk; difmin = 9.999999 c-debug-chk; sumdif = 0. c-debug-chk; sumsq = 0. c-debug-chk; numsq = 0 c-debug-chk; diflmax = -9.999999 c-debug-chk; diflmin = 9.999999 c-debug-chk; sumldif = 0. c-debug-chk; sumlsq = 0. c-debug-chk; numlsq = 0 c-debug-chk] c ! loop over the three mixes next to C=O=0.0 mix do imix = 1, 3 ifac = ( 4 - imix ) / 2 ifac1 = ifac + 1 ifac2 = ifac1 + ifac ifac3 = ifac2 + ifac jfac = imix / 2 jfac1 = jfac + 1 jfac2 = jfac1 + jfac jfac3 = jfac2 + jfac do il = 1, nr do k = 1, nt v1 = co(m,1,1,k,il,kz) if ( abs(v1) .lt. badlogklim ) then v2 = co(m,ifac1,jfac1,k,il,kz) v3 = co(m,ifac2,jfac2,k,il,kz) v4 = co(m,ifac3,jfac3,k,il,kz) cofmin = min( .8*v1+.2*v3 , .2*v1+.8*v3 ) cofmax = max( .8*v1+.2*v3 , .2*v1+.8*v3 ) if ( (v4-v3)*(v3-v1) .gt. 0. .and. $ ( v2 .lt. cofmin .or. $ v2 .gt. cofmax ) ) then co(m,ifac1,jfac1,k,il,kz) = max( min( $ quadget( 1, v1, v3, v4 ) , $ cofmax ) , cofmin ) c-debug-chk[ c-debug-chk; dif = co(m,1+ifac,1+jfac,k,il,kz)-v2 c-debug-chk; if ( t6list(k) .gt. 0.09999 ) then c-debug-chk; difmax = max(dif,difmax) c-debug-chk; difmin = min(dif,difmin) c-debug-chk; sumdif = sumdif+dif c-debug-chk; sumsq = sumsq+dif**2 c-debug-chk; numsq = numsq+1 c-debug-chk; else c-debug-chk; diflmax = max(dif,diflmax) c-debug-chk; diflmin = min(dif,diflmin) c-debug-chk; sumldif = sumldif+dif c-debug-chk; sumlsq = sumlsq+dif**2 c-debug-chk; numlsq = numlsq+1 c-debug-chk; endif c-debug-chk] endif endif enddo enddo enddo c-debug-chk[ c-debug-chk; write(6,8733) m,zat,numlsq,diflmin,diflmax, c-debug-chk; $ sumldif/max(numlsq,1), c-debug-chk; $ sqrt(sumlsq/max(numlsq,1)), c-debug-chk; $ numsq,difmin,difmax,sumdif/max(numsq,1), c-debug-chk; $ sqrt(sumsq/max(numsq,1)) c-debug-chk; 8733 format(' '/' m=',i1,' Z=',f9.7, c-debug-chk; $ ' fix C,O=[1,2] T6<0.1:', c-debug-chk; $ i5,'[',f10.6,' ,',f10.6,' ]ave',f10.6, c-debug-chk; $ ' rms',f10.6,' T6>0.1:',i5,'[',f10.6,' ,', c-debug-chk; $ f10.6,' ]ave',f10.6,' rms',f10.6) c-debug-chk] endif c c Peform any specified opacity shifts, from GN93hz and [O/Fe] c if ( m .eq. 1 ) then c ! if needed, get Z-composition of GS98 mix if ( klozat .eq. 1 ) then c do i = 1, nel_zmix xiz_mix(i) = xiz_opalGS98(i,1) fninz_mix(i) = fninz_opalGS98(i,1) bracketife_mix(i) = 0. enddo c ! or of GN93 mix else if ( khizat .eq. 1 .and. klozat .eq. 0 ) then c do i = 1, nel_zmix xiz_mix(i) = xiz_opalmixes(i,1) fninz_mix(i) = fninz_opalmixes(i,1) bracketife_mix(i) = 0. enddo c endif c endif c ! If GN93 m=2 shift, [O/Fe]: if ( khizat .eq. 1 .and. m .eq. mx03 .and. $ klozat .eq. 0 ) then c ! set all shifts to zero c ! (m=2 GN93hz shift may be interpolated later) do il = 1, nr do k = 1, nt co(m,mc,mo_m1,k,il,kz) = 0. co(m,mc,mo,k,il,kz) = 0. enddo enddo c ! Else, if there are any shifts: else if ( khizat .gt. 0 ) then c ! If GN93 but no [O/Fe] shift: c if ( khizat .eq. 1 .and. klozat .eq. 0 ) then c ! then set it to zero do il = 1, nr do k = 1, nt co(m,mc,mo_m1,k,il,kz) = 0. enddo enddo c ! Else, if there is the [O/Fe] or the GS98-GN93 shift: else c ! get interpolation factors fofe (for GN93hz) and omfofe=1-fofe c ! & Z-composition of interpolated mix if ( klozat .gt. 1 ) then c ! GS98 + [O/Fe] shift xofe = 10.**ofebrack * xofe_opalGS98(1) fofe = ( fninz_opalGS98(kel_o,klozat) $ - xofe * fninz_opalGS98(kel_fe,klozat) ) $ / ( ( fninz_opalGS98(kel_fe,1) $ - fninz_opalGS98(kel_fe,klozat) ) * xofe $ + fninz_opalGS98(kel_o,klozat) $ - fninz_opalGS98(kel_o,1) ) omfofe = 1. - fofe mofe = mo_m2 moat = mo_m1 c ! get Z-composition of interpolated mix if ( m .eq. 1 ) then sum_niai = 0.0 do i = 1, nel_zmix fninz_mix(i) = fofe * fninz_opalGS98(i,1) $ + omfofe * fninz_opalGS98(i,klozat) xiz_mix(i) = fninz_mix(i) * atwt_opalGS98(i) sum_niai = sum_niai + xiz_mix(i) enddo do i = 1, nel_zmix xiz_mix(i) = xiz_mix(i) / sum_niai bracketife_mix(i) = log10( $ ( max( fninz_mix(i) , 1.e-36 ) $ * fninz_opalGS98(kel_fe,1) ) $ / ( max( fninz_mix(kel_fe) , 1.e-36 ) $ * fninz_opalGS98(i,1) ) ) enddo c-debug-chk[ c-debug-chk; if ( iout_debug_chk_ofe .gt. 0 ) then c-debug-chk; write(6,2377) ofebrack,-klozat, c-debug-chk; $ bracketofe_opalGS98(klozat), c-debug-chk; $ fofe,klozat,omfofe,klozat,klozat c-debug-chk; 2377 format(' '/' To get mix with [O/Fe] =', c-debug-chk; $ f11.7,' from mix',i2,' with [O/Fe] =', c-debug-chk; $ f11.7,': f_(1) =',f11.7,' , f_(',i1, c-debug-chk; $ ') =',f11.7,':'/' '/ c-debug-chk; $ ' i Xi/Z_(1) Ni/Nz_(1)', c-debug-chk; $ ' Xi/Z_(',i1,') Ni/Nz_(',i1,')', c-debug-chk; $ ' Xi/Z_mix Ni/Nz_mix [i/Fe]'/ c-debug-chk; $ ' == ========== ==========', c-debug-chk; $ ' ========== ========== ==========', c-debug-chk; $ ' ========== ==========') c-debug-chk; do i = 1,nel_zmix c-debug-chk; write(6,2376) cel_opalmixes(i), c-debug-chk; $ xiz_opalGS98(i,1), c-debug-chk; $ fninz_opalGS98(i,1), c-debug-chk; $ xiz_opalGS98(i,klozat), c-debug-chk; $ fninz_opalGS98(i,klozat), c-debug-chk; $ xiz_mix(i),fninz_mix(i), c-debug-chk; $ bracketife_mix(i) c-debug-chk; 2376 format(' ',a2,3(f12.7,f11.7),f11.7) c-debug-chk; enddo c-debug-chk; write(6,'(" ")') c-debug-chk; iout_debug_chk_ofe = iout_debug_chk_ofe - 1 c-debug-chk; endif c-debug-chk] endif c else if ( khizat .gt. 1 ) then c ! [O/Fe] shift only xofe = 10.**ofebrack * xofe_opalmixes(1) fofe = ( fninz_opalmixes(kel_o,khizat) $ - xofe * fninz_opalmixes(kel_fe,khizat) ) $ / ( ( fninz_opalmixes(kel_fe,1) $ - fninz_opalmixes(kel_fe,khizat) ) * xofe $ + fninz_opalmixes(kel_o,khizat) $ - fninz_opalmixes(kel_o,1) ) omfofe = 1. - fofe mofe = mo_m1 moat = mo c ! get Z-composition of interpolated mix if ( m .eq. 1 ) then sum_niai = 0.0 do i = 1, nel_zmix fninz_mix(i) = fofe * fninz_opalmixes(i,1) $ + omfofe * fninz_opalmixes(i,khizat) xiz_mix(i) = fninz_mix(i) * atwt_opalGS98(i) sum_niai = sum_niai + xiz_mix(i) enddo do i = 1, nel_zmix xiz_mix(i) = xiz_mix(i) / sum_niai bracketife_mix(i) = log10( $ ( max( fninz_mix(i) , 1.e-36 ) $ * fninz_opalmixes(kel_fe,1) ) $ / ( max( fninz_mix(kel_fe) , 1.e-36 ) $ * fninz_opalmixes(i,1) ) ) enddo c-debug-chk[ c-debug-chk; if ( iout_debug_chk_ofe .gt. 0 ) then c-debug-chk; write(6,2377) ofebrack,khizat, c-debug-chk; $ bracketofe_opalmixes(khizat), c-debug-chk; $ fofe,khizat,omfofe,khizat,khizat c-debug-chk; do i = 1,nel_zmix c-debug-chk; write(6,2376) cel_opalmixes(i), c-debug-chk; $ xiz_opalmixes(i,1), c-debug-chk; $ fninz_opalmixes(i,1), c-debug-chk; $ xiz_opalmixes(i,khizat), c-debug-chk; $ fninz_opalmixes(i,khizat), c-debug-chk; $ xiz_mix(i),fninz_mix(i), c-debug-chk; $ bracketife_mix(i) c-debug-chk; enddo c-debug-chk; write(6,'(" ")') c-debug-chk; iout_debug_chk_ofe = iout_debug_chk_ofe - 1 c-debug-chk; endif c-debug-chk] endif c else c ! GS98 shift only mofe = mo_m1 moat = mo_m1 fofe = 0. omfofe = 1. c endif c ! compute [O/Fe],GS98 shifts relative to GN93hz opacities c-debug-chk[ c-debug-chk; sumsq = 0. c-debug-chk; sumdif = 0. c-debug-chk; difmax = -9.999999 c-debug-chk; difmin = 9.999999 c-debug-chk; numsq = 0 c-debug-chk] do il = 1, nr do k = nt, 1, -1 if ( abs( co(m,mc,mo_m1,k,il,kz) ) .lt. badlogklim $ .and. abs( co(m,mc,mo,k,il,kz) ) .lt. $ badlogklim .and. abs( co(m,mc,mofe,k,il,kz) ) $ .lt. badlogklim ) then dif = ( co(m,mc,mofe,k,il,kz) * omfofe $ + co(m,mc,moat,k,il,kz) * fofe ) $ - co(m,mc,mo,k,il,kz) co(m,mc,mo_m1,k,il,kz) = dif c-debug-chk[ c-debug-chk; if ( t6list(k) .gt. 0.009999 ) then c-debug-chk; sumdif = sumdif+dif c-debug-chk; sumsq = sumsq+dif**2 c-debug-chk; difmax = max(dif,difmax) c-debug-chk; difmin = min(dif,difmin) c-debug-chk; numsq = numsq+1 c-debug-chk; endif c-debug-chk] else if ( k .lt. nt ) then co(m,mc,mo_m1,k,il,kz) = $ co(m,mc,mo_m1,k+1,il,kz) else if ( il .gt. 1 ) then co(m,mc,mo_m1,k,il,kz) = $ co(m,mc,mo_m1,k,il-1,kz) else co(m,mc,mo_m1,k,il,kz) = 0. endif enddo enddo c-debug-chk[ c-debug-chk; write(6,2379) m,zat,numsq,difmin,difmax, c-debug-chk; $ sumdif/max(numsq,1),sqrt(sumsq/max(numsq,1)), c-debug-chk; $ sqrt(max(sumsq-sumdif**2/max(numsq,1),0.) c-debug-chk; $ /max(numsq-1,1)) c-debug-chk; 2379 format(' '/' m=',i1,' Z=',f9.7, c-debug-chk; $ ' [O/Fe] deltas for T6>0.01: N=', c-debug-chk; $ i4,' DEL[',f10.6,' ,',f10.6,' ] DELave=',f10.6, c-debug-chk; $ ' DELrms=',f10.6,' sig',f10.6) c-debug-chk] endif c ! compute GN93hz shifts relative to Gz???.x?? opacities c-debug-chk[ c-debug-chk; difmax = -9.999999 c-debug-chk; difmin = 9.999999 c-debug-chk; sumdif = 0. c-debug-chk; sumsq = 0. c-debug-chk; numsq = 0 c-debug-chk] c-test-xdel[ c-test-xdel; do ij = 1,n_xdtst c-test-xdel; dif_tst(1,ij) = -9.999999 c-test-xdel; dif_tst(2,ij) = 9.999999 c-test-xdel; dif_tst(3,ij) = 0. c-test-xdel; dif_tst(4,ij) = 0. c-test-xdel; enddo c-test-xdel] c ! note: facxhz=0.0 for m=2, <1.0 for .040.01: N=', c-debug-chk; $ i4,' DEL[',f10.6,' ,',f10.6,' ] DELave=',f10.6, c-debug-chk; $ ' DELrms=',f10.6,' sig',f10.6, c-debug-chk; $ ' reduced by facxhz=',f10.7) c-debug-chk] c-test-xdel[ c-test-xdel; if ( nxdo .eq. 3 ) then c-test-xdel; do ij = 1,n_xdtst c-test-xdel; write(6,5817) numsq,dif_tst(1,ij),dif_tst(2,ij), c-test-xdel; $ dif_tst(3,ij)/max(numsq,1), c-test-xdel; $ sqrt(dif_tst(4,ij)/max(numsq,1)), c-test-xdel; $ sqrt(max(dif_tst(4,ij)-dif_tst(3,ij)**2 c-test-xdel; $ /max(numsq,1),0.)/max(numsq-1,1)), c-test-xdel; $ xdel_tst(ij) c-test-xdel; 5817 format(' ', c-test-xdel; $ ' GN93hz deltas for T6>0.01: N=',i4, c-test-xdel; $ ' DEL[',f10.6,' ,',f10.6,' ] DELave=',f10.6, c-test-xdel; $ ' DELrms=',f10.6,' sig',f10.6, c-test-xdel; $ ' for Xdel=',f6.4) c-test-xdel; enddo c-test-xdel; endif c-test-xdel] endif c-debug-chk[ c-debug-chk; do i = 1,no-1 c-debug-chk; oat = 1.-xa(m)-zat-xcs(i) c-debug-chk; io = -1 c-debug-chk; do j = 1,no-1 c-debug-chk; ihi = n(m,j,kz) c-debug-chk; cat = min(xcs(ihi),1.-xa(m)-zat-xos(j)) c-debug-chk; if ( max( abs(xcs(i)-cat) , abs(oat-xos(j)) ) c-debug-chk; $ .lt. 0.0011 ) then c-debug-chk; io = ihi c-debug-chk; jo = j c-debug-chk; endif c-debug-chk; enddo c-debug-chk; if ( io .gt. 0 ) then c-debug-chk; difmax = -9.999999 c-debug-chk; difmin = 9.999999 c-debug-chk; sumdif = 0. c-debug-chk; sumsq = 0. c-debug-chk; numsq = 0 c-debug-chk; do il = 1,nr c-debug-chk; do k = 6,nta(il+nrdel)-ntdel c-debug-chk; dif = co(m,io,jo,k,il,kz)-co(m,i,mo,k,il,kz) c-debug-chk; difmax = max(dif,difmax) c-debug-chk; difmin = min(dif,difmin) c-debug-chk; sumdif = sumdif+dif c-debug-chk; sumsq = sumsq+dif**2 c-debug-chk; numsq = numsq+1 c-debug-chk; enddo c-debug-chk; enddo c-debug-chk; write(6,1598) m,zat,io,jo,i,mo,numsq,difmin,difmax, c-debug-chk; $ sumdif/max(numsq,1),sqrt(sumsq/max(numsq,1)), c-debug-chk; $ min(xcs(io),1.-xa(m)-z-xos(jo)),xos(jo), c-debug-chk; $ xcs(i),1.-xa(m)-z-xcs(i) c-debug-chk; 1598 format(' '/' m=',i1,' Z=',f9.7,' d:(',i1,',',i1, c-debug-chk; $ ')-(',i1,',',i1,') for T6>0.01: N=',i4,' DIF[', c-debug-chk; $ f10.6,' ,',f10.6,' ] DIFave=',f10.6,' DIFrms=', c-debug-chk; $ f10.6,' CO',2f10.7,' &',2f10.7) c-debug-chk; endif c-debug-chk; enddo c-debug-chk] c ! End of loop over m values enddo c c }--------------------------------------- End of loop over m values (X-tables) c c-debug-chk[ c-debug-chk; write(6,8418) (i,(n(i,j,kz),j=1,mo),' ',i=1,mx) c-debug-chk; 8418 format(' '/' -- n(m,j): ',5(' (m=',i1,')',8i2,a1)) c-debug-chk] c ! interpolate GN93hz opacity shifts for m=2, if possible; note c ! that other shifts being interpolated among already contain c ! the factor of facxhz. No need to revise any m=2 [O/Fe] shift. c if ( khizat .gt. 0 .and. mx .ge. 4 .and. $ mxzero .eq. 1 .and. mx03 .eq. 2 ) then c c-debug-chk[ c-debug-chk; sumsq = 0. c-debug-chk; sumdif = 0. c-debug-chk; difmax = -9.999999 c-debug-chk; difmin = 9.999999 c-debug-chk; numsq = 0 c-debug-chk] call quadsto( 1, xx(2), xx(1), xx(3), xx(4) ) c c ! for all densities and temperatures do il = 1, nr do k = nt, 1, -1 c ! if it is possible to interpolate c if ( abs( co(1,1,1,k,il,kz) ) .lt. badlogklim .and. $ abs( co(2,1,1,k,il,kz) ) .lt. badlogklim ) then c c ! new GN93hz shift dif = quadget( 1, co(1,mc,mo,k,il,kz), $ co(3,mc,mo,k,il,kz), co(4,mc,mo,k,il,kz) ) c-debug-chk[ c-debug-chk; if ( t6list(k) .gt. 0.009999 ) then c-debug-chk; sumdif = sumdif+dif c-debug-chk; sumsq = sumsq+dif**2 c-debug-chk; difmax = max(dif,difmax) c-debug-chk; difmin = min(dif,difmin) c-debug-chk; numsq = numsq+1 c-debug-chk; endif c-debug-chk] co(2,mc,mo,k,il,kz) = dif else if ( k .lt. nt ) then co(2,mc,mo,k,il,kz) = co(2,mc,mo,k+1,il,kz) else if ( il .gt. 1 ) then co(2,mc,mo,k,il,kz) = co(2,mc,mo,k,il-1,kz) else co(2,mc,mo,k,il,kz) = 0.0 endif c enddo enddo c-debug-chk[ c-debug-chk; if ( facxhz .gt. 0. .and. facxhz .lt. 1. ) then c-debug-chk; difmin = difmin/facxhz c-debug-chk; difmax = difmax/facxhz c-debug-chk; sumdif = sumdif/facxhz c-debug-chk; sumsq = sumsq/facxhz**2 c-debug-chk; else c-debug-chk; facxhz = 1. c-debug-chk; endif c-debug-chk; write(6,2371) z,numsq,difmin,difmax, c-debug-chk; $ sumdif/max(numsq,1),sqrt(sumsq/max(numsq,1)),facxhz c-debug-chk; 2371 format(' '/' m=2 Z=',f9.7, c-debug-chk; $ ' GN93hz alt-deltas T6>0.01: N=', c-debug-chk; $ i4,' DIF[',f10.6,' ,',f10.6,' ] DIFave=',f10.6, c-debug-chk; $ ' DIFrms=',f10.6,' reduced by facxhz=',f10.7) c-debug-chk] c ! end of interpolation of GN93hz opacity shifts for m=2 endif c ! apply all opacity shifts calculated above if ( khizat .gt. 0 ) then c ! Begin loop over m values: do m = 1, mx c c-debug-chk[ c-debug-chk; difmax = -9.999999 c-debug-chk; difmin = 9.999999 c-debug-chk; sumdif = 0. c-debug-chk; sumsq = 0. c-debug-chk; numsq = 0 c-debug-chk; difcmax = -9.999999 c-debug-chk; difcmin = 9.999999 c-debug-chk; sumcdif = 0. c-debug-chk; sumcsq = 0. c-debug-chk; numcsq = 0 c-debug-chk; diflmax = -9.999999 c-debug-chk; diflmin = 9.999999 c-debug-chk; sumldif = 0. c-debug-chk; sumlsq = 0. c-debug-chk; numlsq = n(m,1,kz)-2 c-debug-chk; do j = 1,n(m,1,kz)-1 c-debug-chk; numlsq = numlsq+n(m,j,kz) c-debug-chk; enddo c-debug-chk; difomax = -9.999999 c-debug-chk; difomin = 9.999999 c-debug-chk; difdmax = 0. c-debug-chk; numosq = 0 c-debug-chk; num1 = 0 c-debug-chk] c ! perform the opacity shifts computed above do il = 1, nr do k = 1, nta(il+nrdel) - ntdel c dif = co(m,mc,mo,k,il,kz) + co(m,mc,mo_m1,k,il,kz) c-debug-chk[ c-debug-chk; if ( t6list(k) .gt. 0.009999 ) then c-debug-chk; difcmax = max(dif,difcmax) c-debug-chk; difcmin = min(dif,difcmin) c-debug-chk; sumcdif = sumcdif+dif c-debug-chk; sumcsq = sumcsq+dif**2 c-debug-chk; numcsq = numcsq+1 c-debug-chk; if ( dif .eq. 0. ) then c-debug-chk; numsq = numsq+numlsq c-debug-chk; num1 = num1+numlsq c-debug-chk; diflmax = max(0.,diflmax) c-debug-chk; diflmin = min(0.,diflmin) c-debug-chk; difmax = max(0.,difmax) c-debug-chk; difmin = min(0.,difmin) c-debug-chk; endif c-debug-chk; endif c-debug-chk] if ( dif .ne. 0. ) then c if ( abs(dif) .gt. 0.01 ) then diffac = 10.**dif - 1. else c ! (more accurate for small dif) difl = 2.302585 * dif diffac = ((difl*.16666667+.5)*difl+1.)*difl endif c ! first, do shifts for all except C=O=0.0 mix: ilo = 2 do j = 1, mo if ( j .lt. n(m,1,kz) ) then ihi = n(m,j,kz) else if ( j .eq. mo ) then ihi = n(m,1,kz) - 1 else ihi = 0 endif if ( ihi .gt. 0 ) then do i = ilo, ihi c ! If Kappa(COrich) does not exceed c ! Kappa(C=O=0): then apply shift as c ! delta{Log(Kappa)}, the fractional c ! shift in Kappa, which may be a c ! smaller shift delta'{Kappa} in the c ! opacity Kappa itself if ( co(m,i,j,k,il,kz) .le. $ co(m,1,1,k,il,kz) ) then difl = dif c ! Else Kappa(COrich) > Kappa(C=O=0): c ! convert delta{Log(Kappa)} to an c ! absolute shift delta{Kappa} and c ! apply this (taking the log again); c ! this will be a smaller fractional c ! shift delta'{log(Kappa)} else difl = log10( 10.**( co(m,1,1,k,il,kz) $ - co(m,i,j,k,il,kz) ) * diffac $ + 1. ) c-debug-chk[ c-debug-chk; if ( abs(difl) .gt. c-debug-chk; $ abs(dif) ) then c-debug-chk; difdmax = max( c-debug-chk; $ abs(difl)-abs(dif), c-debug-chk; $ difdmax) c-debug-chk; difomax = max(difomax,dif) c-debug-chk; difomin = min(difomin,dif) c-debug-chk; numosq = numosq+1 c-debug-chk; endif c-debug-chk] c ! this can only happen to the extent of c ! roundoff error if ( abs(difl) .gt. abs(dif) ) $ difl = dif endif c ! apply shift co(m,i,j,k,il,kz) = $ co(m,i,j,k,il,kz) + difl c-debug-chk[ c-debug-chk; if ( t6list(k) .gt. 0.009999 ) then c-debug-chk; difmax = max(difl,difmax) c-debug-chk; difmin = min(difl,difmin) c-debug-chk; sumdif = sumdif+difl c-debug-chk; sumsq = sumsq+difl**2 c-debug-chk; numsq = numsq+1 c-debug-chk; if ( difl .eq. dif ) c-debug-chk; $ num1 = num1+1 c-debug-chk; difl = (difl-dif)/dif c-debug-chk; diflmax = max(difl,diflmax) c-debug-chk; diflmin = min(difl,diflmin) c-debug-chk; sumldif = sumldif+difl c-debug-chk; sumlsq = sumlsq+difl**2 c-debug-chk; endif c-debug-chk] enddo endif ilo = 1 enddo c ! now shift C=O=0.0 mix: c co(m,1,1,k,il,kz) = co(m,1,1,k,il,kz) + dif c endif c enddo enddo c-debug-chk[ c-debug-chk; write(6,9782) m,numcsq,difcmin,difcmax,sumcdif c-debug-chk; $ /max(numcsq,1),sqrt(sumcsq/max(numcsq,1)), c-debug-chk; $ sqrt(max(sumcsq-sumcdif**2/max(numcsq,1),0.) c-debug-chk; $ /max(numcsq-1,1)),z c-debug-chk; 9782 format(' '/' m=',i1,' total deltas C+O=0, T6>0.01:', c-debug-chk; $ i6,' [',f10.6,' ,',f10.6,' ]ave',f10.6, c-debug-chk; $ ' rms',f10.6,' sig',f10.6,' for Z=',f10.7) c-debug-chk; write(6,8782) m,numsq,difmin,difmax, c-debug-chk; $ sumdif/max(numsq,1),sqrt(sumsq/max(numsq,1)), c-debug-chk; $ diflmin+1.,num1,diflmax+1., c-debug-chk; $ sumldif/max(numsq,1)+1.,sqrt(max(sumlsq c-debug-chk; $ -sumldif**2/max(numsq,1),0.)/max(numsq-1,1)) c-debug-chk; 8782 format(' '/' m=',i1,' total deltas C+O>0, T6>0.01:', c-debug-chk; $ i6,' [',f10.6,' ,',f10.6,' ]ave',f10.6, c-debug-chk; $ ' rms',f10.6,' freduce[',f10.6,' ,',i6,':', c-debug-chk; $ f10.6,' ]ave',f10.6,' sig',f10.6) c-debug-chk; if ( numosq .gt. 0 ) write(6,8783) numosq,difdmax, c-debug-chk; $ difomin,difomax c-debug-chk; 8783 format(' '/i23, c-debug-chk; $ ' Kco > K0 cases where log(linear delta)', c-debug-chk; $ ' > old log delta, by up to',f13.9, c-debug-chk; $ ' for deltas as large as [',f13.9,' ,',f13.9,' ]') c-debug-chk] c ! end of loop over m-values enddo c ! end of opacity shifts endif c ! how many GN93hz X-values for the present value of Z mx_use = mx_hi do while ( xhi_in(mx_use-1) .gt. 0.999999 - zat ) mx_use = mx_use - 1 enddo nx_hi(kz) = mx_use c c If khighx > 0 then one should set the corrections at the 'GN93hz' X-values c that are not present in the 'Gz???.x??' files. c if ( khighx(kz) .le. 0 ) then c ! set flags showing high-X unavailable kavail_xhi = 0 kdo_xhi = 0 c else c ! set flags showing whether high-X is available kavail_xhi = 1 do i = 1, kz kavail_xhi = min( khighx(i) , kavail_xhi ) enddo if ( kavail_xhi .le. 0 ) then kdo_xhi = 0 else kdo_xhi = kuse_xhi endif c-debug-chk[ c-debug-chk; do i = 1, 20 c-debug-chk; chk_max(i) = -9. c-debug-chk; chk_min(i) = 9. c-debug-chk; chk_sum(i) = 0. c-debug-chk; chk_ssq(i) = 0. c-debug-chk; n_chk(i) = 0 c-debug-chk; enddo c-debug-chk] c ! get the 'GN93hz' Z-indices (may not have been done above) zat = z kzalbe = mzal do while( kzalbe .gt. 1 .and. $ z .le. zalval(kzalbe) - small_1m6 ) kzalbe = kzalbe - 1 enddo if ( abs( zalval(kzalbe) - z ) .le. zacc(kz) ) then zat = zalval(kzalbe) kzalow = kzalbe nzalmo = 0 else kzalow = max( 1 , kzalbe - 1 ) nzalmo = min( kzalbe + 2 , mzal ) - kzalow endif int_hi_z = 0 c ! set the directory-part of the opacity filename if ( kope .eq. 0 ) then cop_sto(1) = ' ' cop_sto(2) = ' ' else cop_sto(1) = copdir(:kope) cop_sto(2) = copdir(:kope) endif c ! get filename if ( klozat .eq. 0 ) then cop_sto(1)(kope+1:) = cfile_opalmixes(1) cfile_opal_used(1) = cfile_opalmixes(1) i = 1 else cop_sto(1)(kope+1:) = cfile_opalGS98(1) cfile_opal_used(1) = cfile_opalGS98(1) i = -1 endif iu = iulow c if ( list_gn(i) .gt. 0 ) then if ( iu_list .eq. iu ) then write(6,4) iu_list iu_list = 6 endif write(iu_list,2) i, cop_sto(1)(:lnblnk(cop_sto(1))) list_gn(i) = 0 endif c ! open file call open_chk_zip( iu, cop_sto(1), igzip, $ 'READCO Error: hz-file (C+O=0.0,[O/Fe]=0) not found.' ) c line(1) = 0 line(2) = 0 itab_dum = 0 khighx(kz) = 1 c ! Z > 0 & [O/Fe] > 0 ? c if ( khighz_index .gt. 1 .and. kzalow + nzalmo .gt. 1 ) then c khighx(kz) = 2 if ( khighz .gt. 0 ) then cop_sto(2)(kope+1:) = cfile_opalmixes(khighz_index) cfile_opal_used(n_zmixes) = $ cfile_opalmixes(khighz_index) i = khighz_index else call chk_ofe_alt_file( khighz_index ) if ( cfile_opalGS98(khighz_index) .ne. ' ' ) $ cfile_opalGS98(khighz_index) = $ cfile_opal_used(n_zmixes) cop_sto(2)(kope+1:) = cfile_opal_used(n_zmixes) i = -khighz_index endif iu_ofe = iu + 1 c if ( list_gn(i) .gt. 0 ) then if ( iu_list .eq. iu_ofe ) then write(6,4) iu_list iu_list = 6 endif write(iu_list,2) i, cop_sto(2)(:lnblnk(cop_sto(2))) list_gn(i) = 0 endif c call open_chk_zip( iu_ofe, cop_sto(2), igzip_ofe, $ 'READCO Error: hz-file (C+O=0.0,[O/Fe]>0) not found.' $ ) itab_dum_ofe = 0 c endif c ix = 0 m = 0 io = mo iz_hi = nzalmo c ! loop over 'GN93hz' X-values: c do while ( ix .lt. mx_use .and. iz_hi .lt. 5 ) c ! get position in co() ix = ix + 1 m = m + 1 if ( m .gt. mx ) then io = io - 1 m = 1 endif c ! get Z and X values to look for in 'GN93hz' iz_hi = nzalmo if ( ix .eq. mx_use ) then do iz = 0, nzalmo zhi_look(iz+1) = zalval(kzalow+iz) xhi_look(iz+1) = 1. - zhi_look(iz+1) enddo else do iz = 0, nzalmo zhi_look(iz+1) = zalval(kzalow+iz) xhi_look(iz+1) = min( xhi_in(ix) , $ 1. - zhi_look(iz+1) ) enddo c ! check for X-column bifurcation at Z = 0.05, X = 0.95 c if ( ix .eq. mx_hi - 1 .and. nzalmo .eq. 3 ) then if ( zat .gt. 0.03 .and. zat .lt. 0.04 ) then iz_hi = 2 int_hi_z = 0 else if ( zat .gt. 0.04 .and. zat .lt. 0.05 ) then iz_hi = 5 int_hi_z = 0 zhi_look(5) = zhi_look(3) xhi_look(5) = xhi_look(3) zhi_look(6) = zhi_look(4) xhi_look(6) = xhi_look(4) zhi_look(3) = zalval(kzalow) xhi_look(3) = 1. - zhi_look(3) zhi_look(4) = zalval(kzalow+1) xhi_look(4) = 1. - zhi_look(4) endif endif endif c ! loop over the required Z-values for this X do iz = 0, iz_hi c kat = iz + 1 c ! find mix; stop if not found i_rewind = 0 igetzxi = 0 ifound = mixfind(iu,1,igetzxi,i_rewind,itab_dum, $ line(1),zhi_look(kat),xhi_look(kat),0.0,0.0) if ( ifound .eq. 0 ) then i_rewind = 1 igetzxi = 0 ifound = mixfind(iu,1,igetzxi,i_rewind,itab_dum, $ line(1),zhi_look(kat),xhi_look(kat),0.0,0.0) if ( ifound .eq. 0 ) then write(6,1791) zhi_look(kat),xhi_look(kat), $ 0.0,0.0,cop_sto(1)(:lnblnk(cop_sto(1))) stop ' STOP -- READCO: error reading hz-mix. ' endif endif if ( khighx(kz) .gt. 1 ) then i_rewind = 0 igetzxi = 0 ifound = mixfind(iu_ofe,1,igetzxi,i_rewind, $ itab_dum_ofe,line(2), $ zhi_look(kat),xhi_look(kat),0.0,0.0) if ( ifound .eq. 0 ) then i_rewind = 1 igetzxi = 0 ifound = mixfind(iu_ofe,1,igetzxi,i_rewind, $ itab_dum_ofe,line(2), $ zhi_look(kat),xhi_look(kat),0.0,0.0) if ( ifound .eq. 0 ) then write(6,1791) zhi_look(kat),xhi_look(kat), $ 0.0,0.0,cop_sto(2)(:lnblnk(cop_sto(2))) stop ' STOP -- READCO: error reading hz-mix. ' endif endif endif c ! loop over logT values, to read in opacities do k = 1, ntm c ! read logT, & logKappa(R) for all R line(1) = line(1) + 1 read(iu,8300) cin 8300 format(a137) read(cin,8140) flt, (cofzhi(k,il,kat),il=1,nrm) 8140 format(f4.2,19f7.3) c ! bad logT ? if ( abs(flogtin(k)-flt) .gt. small_1m5 ) then write(6,1734) flt, flogtin(k), $ cop_sto(1)(:lnblnk(cop_sto(1))), $ line(1), cin(:max(1,lnblnk(cin))), $ zhi_look(kat),xhi_look(kat),0.0,0.0 stop ' STOP -- READCO: bad logT value. ' endif c il_lo = 1 il_hi = nrm c ! logKappa(R) is: do il = nrm, 1, -1 c ! absent if ( cin(7*il-2:7*il+4) .eq. ' ' ) then if ( k .le. max(nta(il),nta(0)) ) stop $ ' STOP -- READCO: bad upper edge. ' il_hi = min( il_hi , il - 1 ) c ! should be absent else if ( k .gt. nta(il) .and. $ il .ge. nrb .and. il .le. nre ) then stop ' STOP -- READCO: bad upper edge. ' c ! 9.999 else if ( cofzhi(k,il,kat) .gt. 9. ) then if ( ix .ne. 1 ) stop $ ' STOP -- READCO: bad low edge [O/Fe]=0. ' il_lo = max( il_lo , il + 1 ) endif enddo c ! also read [O/Fe] > 0, if needed if ( khighx(kz) .gt. 1 ) then line(2) = line(2) + 1 read(iu_ofe,8300) cin read(cin,8140) flt, (coff(k,il),il=1,nrm) if ( abs(flogtin(k)-flt) .gt. small_1m5 ) then write(6,1734) flt, flogtin(k), $ cop_sto(2)(:lnblnk(cop_sto(2))), $ line(2), cin(:max(1,lnblnk(cin))), $ zhi_look(kat),xhi_look(kat),0.0,0.0 stop ' STOP -- READCO: bad logT value. ' endif do il = nrm, 1, -1 if ( cin(7*il-2:7*il+4) .eq. ' ' ) then if ( k .le. max(nta(il),nta(0)) ) stop $ ' STOP -- READCO: bad upper edge. ' il_hi = min( il_hi , il - 1 ) else if ( k .gt. nta(il) .and. $ il .ge. nrb .and. il .le. nre ) then stop ' STOP -- READCO: bad upper edge. ' else if ( coff(k,il) .gt. 9. ) then if ( ix .ne. 1 ) stop $ ' STOP -- READCO: bad low edge. ' il_lo = max( il_lo , il + 1 ) endif enddo do il = 1, nrm cofzhi(k,il,kat) = fofe * cofzhi(k,il,kat) $ + omfofe * coff(k,il) enddo endif c ! for smoothing if ( il_lo .gt. 1 .or. il_hi .lt. nrm ) then do il = nrm, 1, -1 if ( il .gt. il_hi ) then cofzhi(k,il,kat) = 2. * cofzhi(k-1,il,kat) $ - cofzhi(k-2,il,kat) else if ( il .lt. il_lo ) then cofzhi(k,il,kat) = 2. * cofzhi(k,il+1,kat) $ - cofzhi(k,il+2,kat) endif enddo endif c ! (end of loop to read opacities at all T-values): enddo c ! (end of loop over required Z-values for this X): enddo c ! actual X at Zsto(kz) xhi_use(ix,kz) = min( xhi_in(ix) , 1. - zat ) c ! Z-interpolation: if ( iz_hi .le. 3 ) then c ! standard case: for all T,R: do k = 1, ntm do il = 1, nrm c ! logK at Zsto,X coff(k,il) = qzinter(int_hi_z,1,zat,iz_hi, $ cofzhi(k,il,1),cofzhi(k,il,2), $ cofzhi(k,il,3),cofzhi(k,il,4), $ zhi_look(1),zhi_look(2),zhi_look(3), $ zhi_look(4),zdel) int_hi_z = 1 enddo enddo c ! ELSE: bifurcation: else c ! do both X = 1-Z and X = 0.95 xhi_use(mx_hi,kz) = 1. - zat c ! for all T,R: do k = 1, ntm do il = 1, nrm c ! logK at Zsto,X=1-Z coff(k,il) = qzinter(int_hi_z,1,zat,3, $ cofzhi(k,il,3),cofzhi(k,il,4), $ cofzhi(k,il,5),cofzhi(k,il,6), $ zhi_look(3),zhi_look(4),zhi_look(5), $ zhi_look(6),zdel) c ! temp: Z=0.05,X=0.95 cof_tmp = qzinter(int_hi_z,2,0.05,3, $ cofzhi(k,il,3),cofzhi(k,il,4), $ cofzhi(k,il,5),cofzhi(k,il,6), $ zhi_look(3),zhi_look(4),zhi_look(5), $ zhi_look(6),zdel) c ! Zsto(kz),X=0.95 cofzhi(k,il,1) = qzinter(int_hi_z,3,zat,2, $ cofzhi(k,il,1),cofzhi(k,il,2), $ cof_tmp,0.0, $ zhi_look(1),zhi_look(2),0.05,0.0,zdel) int_hi_z = 1 enddo enddo c ! revise high-T,RHO extension call revise_hitr_for_initsmooth c ! smooth hz-opacities, if init_smo > 0 if ( init_smo .gt. 0 ) then tmax = 10. nset = ks81 RLS = alrf(1) RLE = alrf(nrm) nrhigh = int( dfsr(nr) * ( RLE - RLS ) + 1.00001 ) nrlow = 1 call opaltab endif c ! store X=1-Z hz-opacity set do il = 1, nr jl = il + nrdel do k = 1, nt co(mx,mc,mo_m1,k,il,kz) = coff(k+ntdel,jl) enddo enddo c ! prepare to smooth present X=0.95 hz-opacity set do k = 1, ntm do il = 1, nrm coff(k,il) = cofzhi(k,il,1) enddo enddo c endif c ! revise high-T,RHO extension call revise_hitr_for_initsmooth c ! smooth hz-opacities, if init_smo > 0 if ( init_smo .gt. 0 ) then tmax = 10. nset = ks81 RLS = alrf(1) RLE = alrf(nrm) nrhigh = int( dfsr(nr) * ( RLE - RLS ) + 1.00001 ) nrlow = 1 call opaltab endif c ! store present hz-opacity set do il = 1, nr jl = il + nrdel do k = 1, nt co(m,mc,io,k,il,kz) = coff(k+ntdel,jl) enddo enddo c ! (end of loop over 'GN93hz' X-values): enddo c ! close 'GN93hz' file(s) if ( khighx(kz) .gt. 1 ) then call close_chk_zip( iu_ofe, cop_sto(2), igzip_ofe ) endif call close_chk_zip( iu, cop_sto(1), igzip ) c ! some needed values xxx_max = log10( 1. - zat + xdel ) xxx_03 = log10( 0.03 + xdel ) c ! for convenience, define ALL xhi_use if ( mx_use .lt. mx_hi ) then do ix = mx_use + 1, mx_hi xhi_use(ix,kz) = xhi_use(mx_use,kz) enddo endif c ! get the dlogKappa values for 'GN93hz' X-values: c call quadsto( 5, xxx_hi(5), xxx_hi(2), xxx_hi(4), xxx_hi(6) ) do ix = 7, mx_use if ( xhi_in(ix) .lt. 1.000001 - zat ) then call quadsto( ix, xxx_hi(ix), $ xxx_hi(2), xxx_hi(4), xxx_hi(6) ) else call quadsto( ix, log10( 1. - zat + xdel ), $ xxx_hi(2), xxx_hi(4), xxx_hi(6) ) endif enddo c call quadsto( 1, xxx_hi(3), xxx_hi(2), xxx_hi(4), xxx_hi(6) ) call quad4sto( 3, xxx_hi(3), $ xx(2), xxx_hi(2), xxx_hi(4), xxx_hi(6) ) c c ! loop over all densities and temperatures do il = 1, nr c jl = il + nrdel c do k = 1, nt c ! if in high-T,R cutout: no shift: if ( k .gt. nta(jl) ) then c do ix = 1, mx co(ix,mc,mo,k,il,kz) = 0.0 co(ix,mc,mo_m1,k,il,kz) = 0.0 enddo c ! else: compute shifts for all X-values: else c ! bad logK ? if ( max( co(3,1,1,k,il,kz) , co(4,1,1,k,il,kz) , $ co(5,1,1,k,il,kz) ) .gt. 9.0 ) stop $ ' STOP -- Error: bad co(3:5,1,1,*,*) cannot be ' c-debug-chk[ c-debug-chk; if ( k+ntdel .gt. 5 ) then c-debug-chk; cof_del = co(2,mc,mo,k,il,kz) c-debug-chk; $ - co(3,1,1,k,il,kz) c-debug-chk; n_chk(12) = n_chk(12) + 1 c-debug-chk; chk_max(12) = max( chk_max(12) , cof_del ) c-debug-chk; chk_min(12) = min( chk_min(12) , cof_del ) c-debug-chk; chk_sum(12) = chk_sum(12) + cof_del c-debug-chk; chk_ssq(12) = chk_ssq(12) + cof_del**2 c-debug-chk; cof_del = co(4,mc,mo,k,il,kz) c-debug-chk; $ - co(4,1,1,k,il,kz) c-debug-chk; n_chk(14) = n_chk(14) + 1 c-debug-chk; chk_max(14) = max( chk_max(14) , cof_del ) c-debug-chk; chk_min(14) = min( chk_min(14) , cof_del ) c-debug-chk; chk_sum(14) = chk_sum(14) + cof_del c-debug-chk; chk_ssq(14) = chk_ssq(14) + cof_del**2 c-debug-chk; cof_del = co(1,mc,mo_m1,k,il,kz) c-debug-chk; $ - co(5,1,1,k,il,kz) c-debug-chk; n_chk(16) = n_chk(16) + 1 c-debug-chk; chk_max(16) = max( chk_max(16) , cof_del ) c-debug-chk; chk_min(16) = min( chk_min(16) , cof_del ) c-debug-chk; chk_sum(16) = chk_sum(16) + cof_del c-debug-chk; chk_ssq(16) = chk_ssq(16) + cof_del**2 c-debug-chk; endif c-debug-chk] c ! if no logK at X=0.03: if ( co(2,1,1,k,il,kz) .gt. 9.0 .or. $ k+ntdel .lt. ntax03(nr+nrdel) ) then c ! 3-X-pt at X=0.2 cof_tmp = quadget( 1, co(2,mc,mo,k,il,kz), $ co(4,mc,mo,k,il,kz), co(1,mc,mo_m1,k,il,kz) ) co(3,mc,mo,k,il,kz) = co(3,mc,mo,k,il,kz) $ - cof_tmp c-debug-chk[ c-debug-chk; cof_o = quadget(1,co(3,1,1,k,il,kz), c-debug-chk; $ co(4,1,1,k,il,kz),co(5,1,1,k,il,kz)) c-debug-chk; cof_del = cof_tmp - cof_o c-debug-chk] c ! else: if logK available at X=0.03: else c-debug-chk[ c-debug-chk; if ( k+ntdel .gt. 5 .and. c-debug-chk; $ k+ntdel .lt. ntax0(nr+nrdel) .and. c-debug-chk; $ co(1,1,1,k,il,kz) .lt. 9. ) then c-debug-chk; cof_del = co(1,mc,mo,k,il,kz) c-debug-chk; $ - co(1,1,1,k,il,kz) c-debug-chk; n_chk(11) = n_chk(11) + 1 c-debug-chk; chk_max(11) = max( chk_max(11) , cof_del ) c-debug-chk; chk_min(11) = min( chk_min(11) , cof_del ) c-debug-chk; chk_sum(11) = chk_sum(11) + cof_del c-debug-chk; chk_ssq(11) = chk_ssq(11) + cof_del**2 c-debug-chk; endif c-debug-chk] c ! 4-X-pt at X=0.2 c cof_tmp = quad4get( 3, co(2,1,1,k,il,kz), $ co(2,mc,mo,k,il,kz), $ co(4,mc,mo,k,il,kz), $ co(1,mc,mo_m1,k,il,kz) ) co(3,mc,mo,k,il,kz) = co(3,mc,mo,k,il,kz) $ - cof_tmp c-debug-chk[ c-debug-chk; cof_o = quad4get(3,co(2,1,1,k,il,kz), c-debug-chk; $ co(3,1,1,k,il,kz),co(4,1,1,k,il,kz), c-debug-chk; $ co(5,1,1,k,il,kz)) c-debug-chk; cof_del = cof_tmp - cof_o c-debug-chk] endif c-debug-chk[ c-debug-chk; if ( k+ntdel .gt. 5 ) then c-debug-chk; n_chk(13) = n_chk(13) + 1 c-debug-chk; chk_max(13) = max( chk_max(13) , cof_del ) c-debug-chk; chk_min(13) = min( chk_min(13) , cof_del ) c-debug-chk; chk_sum(13) = chk_sum(13) + cof_del c-debug-chk; chk_ssq(13) = chk_ssq(13) + cof_del**2 c-debug-chk; endif c-debug-chk] c ! 3-X-pt dlogK at X=0.5 cof_tmp = quadget( 5, co(2,mc,mo,k,il,kz), $ co(4,mc,mo,k,il,kz), co(1,mc,mo_m1,k,il,kz) ) co(5,mc,mo,k,il,kz) = co(5,mc,mo,k,il,kz) - cof_tmp c-debug-chk[ c-debug-chk; if ( k+ntdel .gt. 5 ) then c-debug-chk; cof_o = quadget(5,co(3,1,1,k,il,kz), c-debug-chk; $ co(4,1,1,k,il,kz),co(5,1,1,k,il,kz)) c-debug-chk; cof_del = cof_tmp - cof_o c-debug-chk; n_chk(15) = n_chk(15) + 1 c-debug-chk; chk_max(15) = max( chk_max(15) , cof_del ) c-debug-chk; chk_min(15) = min( chk_min(15) , cof_del ) c-debug-chk; chk_sum(15) = chk_sum(15) + cof_del c-debug-chk; chk_ssq(15) = chk_ssq(15) + cof_del**2 c-debug-chk; endif c-debug-chk] c ! 3-X-pt dlogK at X = 0.8, 0.9, 0.95, 1-Z: do ix = 7, mx_use cof_tmp = quadget( ix, co(2,mc,mo,k,il,kz), $ co(4,mc,mo,k,il,kz), co(1,mc,mo_m1,k,il,kz) ) co(ix-5,mc,mo_m1,k,il,kz) = $ co(ix-5,mc,mo_m1,k,il,kz) - cof_tmp c-debug-chk[ c-debug-chk; if ( k+ntdel .gt. 5 ) then c-debug-chk; cof_o = quadget(ix,co(3,1,1,k,il,kz), c-debug-chk; $ co(4,1,1,k,il,kz),co(5,1,1,k,il,kz)) c-debug-chk; cof_del = cof_tmp - cof_o c-debug-chk; n_chk(ix+10) = n_chk(ix+10) + 1 c-debug-chk; chk_max(ix+10) = max( chk_max(ix+10) , c-debug-chk; $ cof_del ) c-debug-chk; chk_min(ix+10) = min( chk_min(ix+10) , c-debug-chk; $ cof_del ) c-debug-chk; chk_sum(ix+10) = chk_sum(ix+10) + cof_del c-debug-chk; chk_ssq(ix+10) = chk_ssq(ix+10) c-debug-chk; $ + cof_del**2 c-debug-chk; endif c-debug-chk] enddo c ! dlogK=0.0 at X = 0.03, 0.1, 0.35, 0.7: these c ! are available in 'Gz???.x??' files co(1,mc,mo,k,il,kz) = 0.0 co(2,mc,mo,k,il,kz) = 0.0 co(4,mc,mo,k,il,kz) = 0.0 co(1,mc,mo_m1,k,il,kz) = 0.0 c-debug-chk[ c-debug-chk; if ( k+ntdel .gt. 5 ) then c-debug-chk; m = 0 c-debug-chk; io = mo c-debug-chk; do ix = 1, mx_use c-debug-chk; m = m + 1 c-debug-chk; if ( m .gt. 5 ) then c-debug-chk; m = 1 c-debug-chk; io = io - 1 c-debug-chk; endif c-debug-chk; cof_del = co(m,mc,io,k,il,kz) c-debug-chk; n_chk(ix) = n_chk(ix) + 1 c-debug-chk; chk_max(ix) = max( chk_max(ix) , cof_del ) c-debug-chk; chk_min(ix) = min( chk_min(ix) , cof_del ) c-debug-chk; chk_sum(ix) = chk_sum(ix) + cof_del c-debug-chk; chk_ssq(ix) = chk_ssq(ix) + cof_del**2 c-debug-chk; enddo c-debug-chk; endif c-debug-chk] endif enddo enddo c-debug-chk[ c-debug-chk; write(6,6273) kz, zat, ofebrack, mx_use, iz_hi, kzalow, c-debug-chk; $ (n_chk(ix),ix=1,20), c-debug-chk; $ (chk_min(ix),ix=1,20), (chk_max(ix),ix=1,20), c-debug-chk; $ (chk_sum(ix)/max(n_chk(ix),1),ix=1,20), c-debug-chk; $ (sqrt(chk_ssq(ix)/max(n_chk(ix),1)),ix=1,20) c-debug-chk; 6273 format(' '/' kz =',i3,' Z =',f10.6,' [O/Fe] =',f6.3, c-debug-chk; $ ' mx_use =',i3,' iz_hi =',i2,' kzalow =',i3, c-debug-chk; $ ' : X_hi deltas:'/' '/' N',20i10/' min',20f10.6/ c-debug-chk; $ ' max',20f10.6/' ave',20f10.6/' rms',20f10.6/' ') c-debug-chk] c ! remember to set X_1 = 0.03 for 'GN93hz' shifts xhi_use(1,kz) = 0.03 c endif c c If required, read in CNO- and/or user-interpolation opacity tables c if ( khighz_cno .eq. 0 ) then c kavail_cno = 0 kavail_user = 0 c else c kdel = 1 if ( khighz_cno .ge. 2 ) then khi = n_totmix if ( khighz_cno .eq. 2 ) then kdel = khi - n_cnobeg kavail_cno = 0 endif else khi = n_totmix - 1 kavail_user = 0 endif c ! get the 'GN93hz' Z-indices (may not have been done above) zat = z kzalbe = mzal do while( kzalbe .gt. 1 .and. $ z .le. zalval(kzalbe) - small_1m6 ) kzalbe = kzalbe - 1 enddo if ( abs( zalval(kzalbe) - z ) .le. zacc(kz) ) then zat = zalval(kzalbe) kzalow = kzalbe nzalmo = 0 else kzalow = max( 1 , kzalbe - 1 ) nzalmo = min( kzalbe + 2 , mzal ) - kzalow endif int_hi_z = 0 c ! set the directory-part of the opacity filename if ( kope .eq. 0 ) then cop_sto(1) = ' ' cop_sto(2) = ' ' else cop_sto(1) = copdir(:kope) cop_sto(2) = copdir(:kope) endif c ! get filename if ( cfile_opalGS98(n_cnobeg) .ne. ' ' ) then cop_sto(1)(kope+1:) = cfile_opalGS98(n_cnobeg) cfile_opal_used(n_cnobeg) = cfile_opalGS98(n_cnobeg) i = n_cnobeg else if ( khighz .gt. 0 ) then cop_sto(1)(kope+1:) = cfile_opalmixes(1) cfile_opal_used(n_cnobeg) = cfile_opalmixes(1) i = 1 else cop_sto(1)(kope+1:) = cfile_opalGS98(1) cfile_opal_used(n_cnobeg) = cfile_opalGS98(1) i = -1 endif last = lnblnk( cop_sto(1) ) iu = iulow c if ( list_gn(i) .gt. 0 ) then if ( iu_list .eq. iu ) then write(6,4) iu_list iu_list = 6 endif write(iu_list,2) i, cop_sto(1)(:last) list_gn(i) = 0 endif c ! get indices where X=1-Z 'GN93hz' opacities will be stored c call index_co_deltas( 5, mx_hi, kkx, kkc, kko ) c ! loop over CNO-files do kfil = n_cnobeg, khi, kdel c iset = kfil - n_zmixes if ( iset .eq. 1 ) iset = 5 c if ( cfile_opalGS98(kfil) .ne. ' ' ) then cop_sto(2)(kope+1:) = cfile_opalGS98(kfil) cfile_opal_used(kfil) = cfile_opalGS98(kfil) else cop_sto(2) = cop_sto(1)(1:last) // cdef_CNO_ext(kfil) cfile_opal_used(kfil) = cop_sto(1)(kope+1:last) // $ cdef_CNO_ext(kfil) endif c if ( list_gn(kfil) .gt. 0 ) then if ( iu_list .eq. iu ) then write(6,4) iu_list iu_list = 6 endif write(iu_list,2) kfil, cop_sto(2)(:lnblnk(cop_sto(2))) list_gn(kfil) = 0 endif c ! open file call open_chk_zip( iu, cop_sto(2), igzip, $ 'READCO Error: hz-file (C+O=0.0,intCNO) not found.' ) c line(2) = 0 itab_dum = 0 ix = 0 iz_hi = nzalmo igetzxi = 1 c ! X=1-Z indices call index_co_deltas( iset, mx_hi, jjx, jjc, jjo ) c c ! loop over 'GN93hz' X-values: c do while ( ix .lt. mx_use .and. iz_hi .lt. 5 ) c ! get indices in co() ix = ix + 1 call index_co_deltas( iset, ix, jx, jc, jo ) c ! & stored 'GN93hz' call index_co_deltas( 5, ix, kx, kc, ko ) c c ! get Z and X values to look for in CNO-file iz_hi = nzalmo if ( ix .eq. mx_use ) then do iz = 0, nzalmo zhi_look(iz+1) = zalval(kzalow+iz) xhi_look(iz+1) = 1. - zhi_look(iz+1) enddo else do iz = 0, nzalmo zhi_look(iz+1) = zalval(kzalow+iz) xhi_look(iz+1) = min( xhi_in(ix) , $ 1. - zhi_look(iz+1) ) enddo c ! check for X-column bifurcation at Z = 0.05, X = 0.95 c if ( ix .eq. mx_hi - 1 .and. nzalmo .eq. 3 ) then if ( zat .gt. 0.03 .and. zat .lt. 0.04 ) then iz_hi = 2 int_hi_z = 0 else if ( zat .gt. 0.04 .and. zat .lt. 0.05 ) then iz_hi = 5 int_hi_z = 0 zhi_look(5) = zhi_look(3) xhi_look(5) = xhi_look(3) zhi_look(6) = zhi_look(4) xhi_look(6) = xhi_look(4) zhi_look(3) = zalval(kzalow) xhi_look(3) = 1. - zhi_look(3) zhi_look(4) = zalval(kzalow+1) xhi_look(4) = 1. - zhi_look(4) endif endif endif c ! loop over the required Z-values for this X do iz = 0, iz_hi c kat = iz + 1 c ! find mix; stop if not found i_rewind = 0 ifound = mixfind(iu,-kfil,igetzxi,i_rewind, $ itab_dum,line(2), $ zhi_look(kat),xhi_look(kat),0.0,0.0) igetzxi = 0 if ( ifound .eq. 0 ) then i_rewind = 1 ifound = mixfind(iu,-kfil,igetzxi,i_rewind, $ itab_dum,line(2), $ zhi_look(kat),xhi_look(kat),0.0,0.0) igetzxi = 0 if ( ifound .eq. 0 ) then write(6,1791) zhi_look(kat),xhi_look(kat), $ 0.0,0.0,cop_sto(2)(:last) stop ' STOP -- READCO: error reading CNO-mix. ' endif endif c ! loop over logT values, to read in opacities do k = 1, ntm c ! read logT, & logKappa(R) for all R line(2) = line(2) + 1 read(iu,'(a137)') cin read(cin,'(f4.2,19f7.3)') flt, $ (cofzhi(k,il,kat),il=1,nrm) c ! bad logT ? if ( abs(flogtin(k)-flt) .gt. small_1m5 ) then write(6,1734) flt, flogtin(k), $ cop_sto(2)(:lnblnk(cop_sto(2))), $ line(2), cin(:max(1,lnblnk(cin))), $ zhi_look(kat),xhi_look(kat),0.0,0.0 stop ' STOP -- READCO: bad logT value. ' endif c il_lo = 1 il_hi = nrm c ! logKappa(R) is: do il = nrm, 1, -1 c ! absent if ( cin(7*il-2:7*il+4) .eq. ' ' ) then il_hi = min( il_hi , il - 1 ) c ! 9.999 else if ( cofzhi(k,il,kat) .gt. 9. ) then il_lo = max( il_lo , il + 1 ) endif enddo c ! for deltas if ( il_lo .gt. 1 .or. il_hi .lt. nrm ) then do il = nrm, 1, -1 if ( il .gt. il_hi ) then cofzhi(k,il,kat) = 2. * cofzhi(k-1,il,kat) $ - cofzhi(k-2,il,kat) else if ( il .lt. il_lo ) then cofzhi(k,il,kat) = 2. * cofzhi(k,il+1,kat) $ - cofzhi(k,il+2,kat) endif enddo endif c ! (end of loop to read opacities at all T-values): enddo c ! (end of loop over required Z-values for this X): enddo c ! actual X at Zat xcno_use(ix,kz) = min( xhi_in(ix) , 1. - zat ) c ! Z-interpolation: if ( iz_hi .le. 3 ) then c ! standard case: for all T,R: do k = 1, ntm do il = 1, nrm c ! logK at Zsto,X coff(k,il) = qzinter(int_hi_z,1,zat,iz_hi, $ cofzhi(k,il,1),cofzhi(k,il,2), $ cofzhi(k,il,3),cofzhi(k,il,4), $ zhi_look(1),zhi_look(2),zhi_look(3), $ zhi_look(4),zdel) int_hi_z = 1 enddo enddo c ! ELSE: bifurcation: else c ! do both X = 1-Z and X = 0.95 xcno_use(mx_hi,kz) = 1. - zat c ! for all T,R: do k = 1, ntm do il = 1, nrm c ! logK at Zsto,X=1-Z coff(k,il) = qzinter(int_hi_z,1,zat,3, $ cofzhi(k,il,3),cofzhi(k,il,4), $ cofzhi(k,il,5),cofzhi(k,il,6), $ zhi_look(3),zhi_look(4),zhi_look(5), $ zhi_look(6),zdel) c ! temp: Z=0.05,X=0.95 cof_tmp = qzinter(int_hi_z,2,0.05,3, $ cofzhi(k,il,3),cofzhi(k,il,4), $ cofzhi(k,il,5),cofzhi(k,il,6), $ zhi_look(3),zhi_look(4),zhi_look(5), $ zhi_look(6),zdel) c ! Zsto(kz),X=0.95 cofzhi(k,il,1) = qzinter(int_hi_z,3,zat,2, $ cofzhi(k,il,1),cofzhi(k,il,2), $ cof_tmp,0.0, $ zhi_look(1),zhi_look(2),0.05,0.0,zdel) int_hi_z = 1 enddo enddo c ! revise high-T,RHO extension call revise_hitr_for_initsmooth c ! smooth CNO-opac, if init_smo > 1 if ( init_smo .ge. 2 ) then tmax = 10. nset = ks81 RLS = alrf(1) RLE = alrf(nrm) nrhigh = int( dfsr(nr) * ( RLE - RLS ) + 1.00001 ) nrlow = 1 call opaltab endif c ! store X=1-Z hz-opacity set if ( kfil .eq. n_cnobeg ) then do il = 1, nr jl = il + nrdel do k = 1, nt co(jjx,jjc,jjo,k,il,kz) = coff(k+ntdel,jl) enddo enddo else do il = 1, nr jl = il + nrdel do k = 1, nt co(jjx,jjc,jjo,k,il,kz) = coff(k+ntdel,jl) $ - co(kkx,kkc,kko,k,il,kz) enddo enddo endif c ! get present X=0.95 hz-opacity set do k = 1, ntm do il = 1, nrm coff(k,il) = cofzhi(k,il,1) enddo enddo c endif c ! revise high-T,RHO extension call revise_hitr_for_initsmooth c ! smooth CNO-opac, if init_smo > 1 if ( init_smo .ge. 2 ) then tmax = 10. nset = ks81 RLS = alrf(1) RLE = alrf(nrm) nrhigh = int( dfsr(nr) * ( RLE - RLS ) + 1.00001 ) nrlow = 1 call opaltab endif c ! store present hz-opacity set if ( kfil .eq. n_cnobeg ) then do il = 1, nr jl = il + nrdel do k = 1, nt c-debug[ c-debug; if ( co(jx,jc,jo,k,il,kz) .lt. badlogklim ) c-debug; $ stop ' STOP -- Error: CNO overwrite. ' c-debug] co(jx,jc,jo,k,il,kz) = coff(k+ntdel,jl) enddo enddo else do il = 1, nr jl = il + nrdel do k = 1, nt c-debug[ c-debug; if ( kfil .lt. n_totmix .and. c-debug; $ co(jx,jc,jo,k,il,kz) .lt. badlogklim ) c-debug; $ stop ' STOP -- Error: CNO overwrite. ' c-debug] co(jx,jc,jo,k,il,kz) = coff(k+ntdel,jl) $ - co(kx,kc,ko,k,il,kz) enddo enddo endif c ! (end of loop over 'GN93hz' X-values): enddo c ! close CNO-file call close_chk_zip( iu, cop_sto(2), igzip ) c ! (end CNO-file loop): enddo c endif c ! restore old m value (this should not be necessary) m = mstore c ! and return. return end c c****************************************************************************** c subroutine revise_hitr_for_initsmooth c ===================================== c c revise high-T,RHO extension for smoothing and extrapolation c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common/b_opal_z/ nta(0:nrm_p1),ntax0(0:nrm), $ ntax03(0:nrm), sltlo, slthi, dltlo_inv, dlthi_inv, $ slrlo, slrhi, dlrlo_inv, dlrhi_inv, init_trvals save /b_opal_z/ c common/alink_opal_z/ NTEMP,NSM,nrlow,nrhigh,RLE,t6arr(100), $ coff(100,nrm) save /alink_opal_z/ c k = nta(1) c il = nrm do while ( il .gt. 1 .and. nta(il) .lt. k ) il = il - 1 enddo c ! requires min logR > -2.0 if ( nta(il) .eq. k ) then c if ( il .eq. 1 ) then tmp = 0.0 else tmp = coff(k,il) - coff(k,il-1) if ( il .gt. 2 ) tmp = 2.0 * tmp $ - ( coff(k,il-1) - coff(k,il-2) ) endif c tmp = max( -0.1 , min( 0.1 , tmp ) ) c do i = il + 1, nrm coff(k,i) = coff(k,i-1) + tmp if ( nta(i) .eq. k - 1 ) coff(k,i) = $ min( coff(k,i) , coff(k-1,i) ) enddo c i = max( il - 7 , 1 ) d_lim = coff(k,i) - coff(k-1,i) do while ( i .lt. nrm ) i = i + 1 if ( nta(i) .ge. k - 1 ) then d_lim = max( d_lim , $ coff(k,i) - coff(k-1,i) ) il = i endif enddo c k = k - 1 if ( il .eq. 1 ) then tmp = 0.0 else tmp = coff(k,il) - coff(k,il-1) endif c do i = il + 1, nrm c coff(k,i) = max( coff(k,i-1) + tmp , $ coff(k+1,i) - d_lim ) c do j = k - 1, nta(i) + 1, -1 fac = ( flogtin(k) - flogtin(j) ) $ / ( flogtin(k) - flogtin(nta(i)) ) coff(j,i) = max( coff(j+1,i) , $ ( 2.0 * coff(j,i-1) - coff(j,max(1,i-2)) $ + ( 1. - fac ) * coff(k,i) $ + fac * coff(nta(i),i) ) * 0.5 ) enddo c enddo c endif c return end c c****************************************************************************** c subroutine cointsmo(xxc,xxo,kz) c =============================== c c The purpose of COINTSMO is to interpolate smoothly in C and O abundances. c c This subroutine yields smoother opacities than alternate COINTERP below. c c Note that the quadratic-interpolation function quad has been replaced with c the function qchk here; the latter function checks whether two of the c interpolation points are nearly coincident (which would magnify the effect c of any uncertainties in the tabulated opacities), and uses something more c nearly linear if so. This is sometimes necessary to prevent wildly wrong c opacity values for certain Z-values above Z=0.03, and also in some cases to c allow linear interpolation along lines where only two opacity values exist. c For the special case where C or O is slightly negative (slight depletion in c C or O), the function qchk does a linear extrapolation using a combination c of the lowest three C or O gridpoints. c parameter ( small_1m6=1.e-6 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c common/bb_opal_z/ xodp,xcdp,xxco,cxx,oxx, $ l1,l2,l3,l4,k1,k2,k3,k4,ip,iq(4),kzf,kzg,kzh,kzf2 save /bb_opal_z/ c-debug[ c-debug; common/outdeb/ ioudeb,oudebl,koudeb c-debug] c___ dimension j2m(mc),j3m(mc),j4m(mc) c=== is = 0 c ! IF C+O = 0: trivial: if ( max( abs(xxc) , abs(xxo) ) .lt. small_1m6 ) then c do it = k1,k1+ip do ir = l1,l1+iq(it-k1+1) opl(it,ir,kz) = co(m,1,1,it,ir,kz) enddo enddo c ! we are done: return return c endif c ! ELSE: if C,O not 0: i3 = min( indx(min(int(100.*max(xxc,0.)),100)+1) + 1 , nc ) i4 = min( i3+1 , nc ) i1 = max( i3-2 , 1 ) i2 = i3-1 j3 = min( indx(min(int(100.*max(xxo,0.)),100)+1) + 1 , no ) j4 = min( j3+1 , no ) j1 = max( j3-2 , 1 ) j2 = j3-1 c n2 = i1+1 n3 = i1+2 m2 = j1+1 m3 = j1+2 c ! these initializations just prevent compiler warnings: cfac = 0.0 ofac = 0.0 afac = 0.0 bfac = 0.0 ib1 = 1 ib2 = 2 ib3 = 3 ib4 = 4 j4n = 0 j2n = 4 nb2 = 2 nb3 = 3 jb1 = 1 jb2 = 2 jb3 = 3 jb4 = 4 mb2 = 2 mb3 = 3 c ! if C > or = O: then j3 < no unless m=5, C=O=0.1 if ( xxc .ge. xxo ) then c if ( i4 .gt. n3 ) cfac = (cxx-cx(i2))/(cx(i3)-cx(i2)) c ! if O = 0.0: if ( abs(xxo) .lt. small_1m6 ) then c if ( i4 .le. n3 ) then call qchksto( 1, cxx, $ cx(i1), cx(n2), min(cx(n3),cxd(1)) ) do it = k1, k1 + ip do ir = l1, l1 + iq(it-k1+1) opl(it,ir,kz) = qchkget( 1, co(m,i1,1,it,ir,kz), $ co(m,n2,1,it,ir,kz), co(m,n3,1,it,ir,kz) ) c-debug[ c-debug; if ( ioudeb .gt. 7 .or. .not. c-debug; $ abs(opl(it,ir,kz)) .le. oudebl ) then c-debug; if ( ioudeb .le. 5 .or. ( it .eq. k1 .and. c-debug; $ ir .eq. l1 ) ) write(6,*) ' ' c-debug; write(6,9414) m,it,ir,kz,'O=0','C',cxx,'K', c-debug; $ opl(it,ir,kz),0.,(j,1,min(cx(j),cxd(1)), c-debug; $ co(m,j,1,it,ir,kz),j=i1,n3) c-debug; 9414 format(' COINTSMO(x',i1,',t',i2.2,',r',i2.2, c-debug; $ ',z',i2.2,')',a3,' ',a1,f11.7,' : ',a1, c-debug; $ ' =',g15.7,' <--(f=',f10.7, c-debug; $ ') kc,ko,CorO,K:',4(i3,i2,2f11.7)) c-debug; endif c-debug] enddo enddo else call quadsto( 1, cxx, cx(i1), cx(i2), cx(i3) ) call qchksto( 2, cxx, $ cx(i2), cx(i3), min(cx(i4),cxd(1)) ) do it = k1, k1 + ip do ir = l1, l1 + iq(it-k1+1) opl(it,ir,kz) = ( 1. - cfac ) * quadget( 1, $ co(m,i1,1,it,ir,kz), co(m,i2,1,it,ir,kz), $ co(m,i3,1,it,ir,kz) ) $ + cfac * qchkget( 2, co(m,i2,1,it,ir,kz), $ co(m,i3,1,it,ir,kz), co(m,i4,1,it,ir,kz) ) c-debug[ c-debug; if ( ioudeb .gt. 7 .or. .not. c-debug; $ abs(opl(it,ir,kz)) .le. oudebl ) then c-debug; if ( ioudeb .le. 5 .or. ( it .eq. k1 .and. c-debug; $ ir .eq. l1 ) ) write(6,*) ' ' c-debug; write(6,9414) m,it,ir,kz,'O=0','C',cxx,'K', c-debug; $ opl(it,ir,kz),cfac,(j,1,min(cx(j),cxd(1)), c-debug; $ co(m,j,1,it,ir,kz),j=i1,i4) c-debug; endif c-debug] enddo enddo endif c ! we are done: return return c endif c ! else if C > O, and O not 0.0 icomax = -1 if ( xxco .gt. xcd(1) - small_1m6 ) icomax = 1 if ( j1 .lt. j2 ) ofac = (oxx-ox(j2))/(ox(j3)-ox(j2)) if ( icomax .lt. 0 ) then i4 = min( i4 , n(m,j2,kz) ) cof(i1,1) = cx(i1) cof(i2,1) = cx(i2) cof(i3,1) = cx(i3) cof(i4,1) = cx(i4) if ( i3 .ge. n(m,j3,kz) .and. xxo .ge. xod(i3) ) then i4 = i3 icomax = 0 cof(i4,1) = log10(zzz(kz)+xcdp) else if ( i4 .ge. n(m,j3,kz) ) then icomax = 0 cof(i4,1) = log10(zzz(kz)+xcdp) endif do i = i1,i4 j2m(i) = m2 if ( m2 .ge. n(m,i,kz) ) j2m(i) = mo j3m(i) = m3 if ( m3 .ge. n(m,i,kz) ) j3m(i) = mo j4m(i) = j4 if ( j4 .ge. n(m,i,kz) ) j4m(i) = mo enddo endif ihi = i4 if ( icomax .ge. 0 ) then ihi = i4-1 if ( j4 .lt. no ) then j2m(i4) = n(m,j4,kz) j4m(i4) = j4 cof(4,4) = ox(j4) else j2m(i4) = max( n(m,j4-1,kz) - 2 , 1 ) j4m(i4) = mo cof(4,4) = oxd(j2m(i4)) endif j4n = 0 if ( xxo .gt. xod(nc-1) + small_1m6 ) then if ( icomax .gt. 0 ) cof(i4,1) = log10(zzz(kz)+xcdp) bfac = min( 0.5 , ( xxo - xod(nc-1) ) $ / max( xod(1)-2.*xod(nc-1) , small_1m6 ) ) ib3 = min( indx(int(100.*max(xcdp,0.))+1) + 1 , nc ) ib4 = min( ib3 + 1 , nc ) ib1 = max( ib3 - 2 , 1 ) ib2 = ib3-1 nb2 = ib1+1 nb3 = ib1+2 if ( ib4 .gt. nb3 ) $ afac = (cof(i4,1)-cx(ib2))/(cx(ib3)-cx(ib2)) if ( ib4 .lt. nc ) then j2n = ib4 j4n = mo cof(5,5) = cx(ib4) else j4n = max( n(m,ib4-1,kz) - 2 , 1 ) j2n = n(m,j4n,kz) cof(5,5) = cxd(j4n) endif endif endif c if ( icomax .ge. 0 ) then if ( j4 .le. m3 ) then call qchksto( 13, oxx, ox(j1), ox(m2), cof(4,4) ) else call quadsto( 13, oxx, ox(j1), ox(j2), ox(j3) ) call qchksto( 14, oxx, ox(j2), ox(j3), cof(4,4) ) endif if ( j4n .gt. 0 ) then if ( ib4 .le. nb3 ) then call qchksto( 15, cof(i4,1), $ cx(ib1), cx(nb2), cof(5,5) ) else call quadsto( 15, cof(i4,1), $ cx(ib1), cx(ib2), cx(ib3) ) call qchksto( 16, cof(i4,1), $ cx(ib2), cx(ib3), cof(5,5) ) endif endif endif if ( icomax .le. 0 ) then iw = 0 is = 0 do i = i1, ihi iw = iw + 1 if ( j4m(i) .le. j3m(i) ) then call qchksto( iw, oxx, ox(j1), min(ox(m2),oxd(i)), $ min(ox(m3),oxd(i)) ) else if ( is .eq. 0 ) $ call quadsto( 11, oxx, ox(j1), ox(j2), ox(j3) ) is = 1 call qchksto( iw, oxx, ox(j2), ox(j3), $ min(ox(j4),oxd(i)) ) endif enddo if ( i4 .le. n3 ) then call qchksto( 9, cxx, cof(i1,1), cof(n2,1), cof(n3,1) ) else call quadsto( 9, cxx, cof(i1,1), cof(i2,1), cof(i3,1) ) call qchksto( 10, cxx, cof(i2,1), cof(i3,1), cof(i4,1) ) endif endif c do it = k1, k1 + ip do ir = l1, l1 + iq(it-k1+1) if ( icomax .ge. 0 ) then if ( j4 .le. m3 ) then cof(i4,2) = qchkget( 13, $ co(m,n(m,j1,kz),j1,it,ir,kz), $ co(m,n(m,m2,kz),m2,it,ir,kz), $ co(m,j2m(i4),j4m(i4),it,ir,kz) ) else cof(i4,2) = ( 1. - ofac ) * quadget( 13, $ co(m,n(m,j1,kz),j1,it,ir,kz), $ co(m,n(m,j2,kz),m2,it,ir,kz), $ co(m,n(m,j3,kz),m3,it,ir,kz) ) $ + ofac * qchkget( 14, $ co(m,n(m,j2,kz),j2,it,ir,kz), $ co(m,n(m,j3,kz),j3,it,ir,kz), $ co(m,j2m(i4),j4m(i4),it,ir,kz) ) endif if ( j4n .gt. 0 ) then if ( ib4 .le. nb3 ) then cof(i4,2) = ( 1. - bfac ) * cof(i4,2) $ + bfac * qchkget( 15, $ co(m,ib1,mo,it,ir,kz), $ co(m,nb2,mo,it,ir,kz), $ co(m,j2n,j4n,it,ir,kz) ) else cof(i4,2) = ( 1. - bfac ) * cof(i4,2) + bfac $ * ( ( 1. - afac ) * quadget( 15, $ co(m,ib1,mo,it,ir,kz), $ co(m,ib2,mo,it,ir,kz), $ co(m,ib3,mo,it,ir,kz) ) $ + afac * qchkget( 16, $ co(m,ib2,mo,it,ir,kz), $ co(m,ib3,mo,it,ir,kz), $ co(m,j2n,j4n,it,ir,kz) ) ) endif endif endif if ( icomax .gt. 0 ) then opl(it,ir,kz) = cof(i4,2) else iw = 0 do i = i1, ihi iw = iw + 1 if ( j4m(i) .le. j3m(i) ) then cof(i,2) = qchkget( iw, co(m,i,j1,it,ir,kz), $ co(m,i,j2m(i),it,ir,kz), $ co(m,i,j3m(i),it,ir,kz) ) else cof(i,2) = (1.-ofac) * quadget( 11, $ co(m,i,j1,it,ir,kz), co(m,i,j2,it,ir,kz), $ co(m,i,j3,it,ir,kz) ) + ofac $ * qchkget( iw, co(m,i,j2,it,ir,kz), $ co(m,i,j3,it,ir,kz), $ co(m,i,j4m(i),it,ir,kz) ) endif enddo if ( i4 .le. n3 ) then opl(it,ir,kz) = qchkget( 9, cof(i1,2), cof(n2,2), $ cof(n3,2) ) else opl(it,ir,kz) = ( 1. - cfac ) * quadget( 9, $ cof(i1,2), cof(i2,2), cof(i3,2) ) $ + cfac * qchkget( 10, cof(i2,2), cof(i3,2), $ cof(i4,2) ) endif endif c-debug[ c-debug; if ( ioudeb .gt. 7 .or. c-debug; $ .not. abs(opl(it,ir,kz)) .le. oudebl .or. c-debug; $ .not. abs(cof(i4,2)) .le. oudebl .or. c-debug; $ ( icomax .le. 0 .and. c-debug; $ ( .not. abs(cof(i1,2)) .le. oudebl .or. c-debug; $ .not. abs(cof(i2,2)) .le. oudebl .or. c-debug; $ .not. abs(cof(i3,2)) .le. oudebl ) ) ) then c-debug; write(6,*) ' ' c-debug; if ( icomax .le. 0 ) then c-debug; do i = i1,ihi c-debug; if ( j4m(i) .le. j3m(i) ) then c-debug; write(6,9414) m,it,ir,kz,'C>O','O',oxx, c-debug; $ 'K',cof(i,2),0.,i,j1,ox(j1), c-debug; $ co(m,i,j1,it,ir,kz), c-debug; $ i,j2m(i),min(ox(m2),oxd(i)), c-debug; $ co(m,i,j2m(i),it,ir,kz), c-debug; $ i,j3m(i),min(ox(m3),oxd(i)), c-debug; $ co(m,i,j3m(i),it,ir,kz) c-debug; else c-debug; write(6,9414) m,it,ir,kz,'C>O','O',oxx, c-debug; $ 'K',cof(i,2),ofac,(i,j,ox(j), c-debug; $ co(m,i,j,it,ir,kz),j=j1,j3), c-debug; $ i,j4m(i),min(ox(j4),oxd(i)), c-debug; $ co(m,i,j4m(i),it,ir,kz) c-debug; endif c-debug; enddo c-debug; endif c-debug; if ( j4 .le. m3 ) ofac = 0. c-debug; if ( icomax .ge. 0 ) write(6,9414) m,it,ir,kz,'C>O', c-debug; $ 'o',oxx,'K',cof(i4,2),ofac,(n(m,j,kz),j,ox(j), c-debug; $ co(m,n(m,j,kz),j,it,ir,kz),j=j1,j4-1),j2m(i4), c-debug; $ j4m(i4),cof(4,4),co(m,j2m(i4),j4m(i4),it,ir,kz) c-debug; if ( ib4 .le. nb3 ) afac = 0. c-debug; if ( icomax .ge. 0 .and. j4n .gt. 0 ) write(6,9414) c-debug; $ m,it,ir,kz,'C>O','c',cof(i4,1),'b',bfac,afac, c-debug; $ (j,mo,cx(j),co(m,j,mo,it,ir,kz),j=ib1,ib4-1), c-debug; $ j2n,j4n,cof(5,5),co(m,j2n,j4n,it,ir,kz) c-debug; if ( i4 .le. n3 ) cfac = 0. c-debug; if ( icomax .le. 0 ) write(6,9415) m,it,ir,kz, c-debug; $ 'C>O','C',cxx,opl(it,ir,kz),cfac, c-debug; $ (' ',j,cof(j,1),cof(j,2),j=i1,i4) c-debug; 9415 format(' COINTSMO(x',i1,',t',i2.2,',r',i2.2, c-debug; $ ',z',i2.2,')',a3,' ',a1,f11.7, c-debug; $ ' : K =',g15.7,' <--(f=',f10.7, c-debug; $ ') kc,ko,CorO,K:',4(a1,' (',i1,')',2f11.7)) c-debug; endif c-debug] enddo enddo c ! else if C < O: then i3 < nc else c if ( j4 .gt. m3 ) ofac = (oxx-ox(j2))/(ox(j3)-ox(j2)) c ! if C = 0.0: if ( abs(xxc) .lt. small_1m6 ) then c if ( j4 .le. m3 ) then j3m(1) = m3 if ( m3 .ge. no ) j3m(1) = mo call qchksto( 1, oxx, $ ox(j1), ox(m2), min(ox(m3),oxd(1)) ) do it = k1, k1 + ip do ir = l1, l1 + iq(it-k1+1) opl(it,ir,kz) = qchkget( 1, co(m,1,j1,it,ir,kz), $ co(m,1,m2,it,ir,kz), $ co(m,1,j3m(1),it,ir,kz) ) c-debug[ c-debug; if ( ioudeb .gt. 7 .or. .not. c-debug; $ abs(opl(it,ir,kz)) .le. oudebl ) then c-debug; if ( ioudeb .le. 5 .or. ( it .eq. k1 .and. c-debug; $ ir .eq. l1 ) ) write(6,*) ' ' c-debug; write(6,9414) m,it,ir,kz,'C=0','O',oxx,'K', c-debug; $ opl(it,ir,kz),0.,(1,j,ox(j), c-debug; $ co(m,1,j,it,ir,kz),j=j1,m2),1,j3m(1), c-debug; $ co(m,1,j3m(1),it,ir,kz),min(ox(j3),oxd(1)) c-debug; endif c-debug] enddo enddo else j4m(1) = j4 if ( j4 .ge. no ) j4m(1) = mo call quadsto( 1, oxx, ox(j1), ox(j2), ox(j3) ) call qchksto( 2, oxx, $ ox(j2), ox(j3), min(ox(j4),oxd(1)) ) do it = k1,k1+ip do ir = l1,l1+iq(it-k1+1) opl(it,ir,kz) = (1.-ofac) * quadget( 1, $ co(m,1,j1,it,ir,kz), co(m,1,j2,it,ir,kz), $ co(m,1,j3,it,ir,kz) ) $ + ofac * qchkget( 2, co(m,1,j2,it,ir,kz), $ co(m,1,j3,it,ir,kz), $ co(m,1,j4m(1),it,ir,kz) ) c-debug[ c-debug; if ( ioudeb .gt. 7 .or. .not. c-debug; $ abs(opl(it,ir,kz)) .le. oudebl ) then c-debug; if ( ioudeb .le. 5 .or. ( it .eq. k1 .and. c-debug; $ ir .eq. l1 ) ) write(6,*) ' ' c-debug; write(6,9414) m,it,ir,kz,'C=0','O',oxx,'K', c-debug; $ opl(it,ir,kz),ofac,(1,j,ox(j), c-debug; $ co(m,1,j,it,ir,kz),j=j1,j3), c-debug; $ 1,j4m(1),co(m,1,j4m(1),it,ir,kz), c-debug; $ min(ox(j4),oxd(1)) c-debug; endif c-debug] enddo enddo endif c ! we are done: return return c endif c ! else if O > C, and C not 0.0: icomax = -1 if ( xxco .gt. xcd(1) - small_1m6 ) icomax = 1 if ( i1 .lt. i2 ) cfac = (cxx-cx(i2))/(cx(i3)-cx(i2)) if ( icomax .lt. 0 ) then j4 = min( j4 , n(m,i2,kz) ) cof(j1,1) = ox(j1) cof(j2,1) = ox(j2) cof(j3,1) = ox(j3) cof(j4,1) = ox(j4) if ( j3 .ge. n(m,i3,kz) .and. xxc .ge. xcd(j3) ) then j4 = j3 icomax = 0 cof(j4,1) = log10(zzz(kz)+xodp) else if ( j4 .ge. n(m,i3,kz) ) then icomax = 0 cof(j4,1) = log10(zzz(kz)+xodp) endif endif ihi = j4 if ( icomax .ge. 0 ) then ihi = j4-1 if ( i4 .lt. nc ) then j2m(4) = i4 j4m(4) = mo cof(4,4) = cx(i4) else j4m(4) = max( n(m,i4-1,kz) - 2 , 1 ) j2m(4) = n(m,j4m(4),kz) cof(4,4) = cxd(j4m(4)) endif j4n = 0 if ( xxc .gt. xcd(no-1) + small_1m6 ) then if ( icomax .gt. 0 ) cof(j4,1) = log10(zzz(kz)+xodp) bfac = min((xxc-xcd(no-1))/max(xcd(1)-2.*xcd(no-1), $ small_1m6),0.5) jb3 = min( indx(int(100.*max(xodp,0.))+1) + 1 , no ) jb4 = min( jb3+1 , no ) jb1 = max( jb3-2 , 1 ) jb2 = jb3-1 mb2 = jb1+1 mb3 = jb1+2 if ( jb4 .gt. mb3 ) $ afac = (cof(j4,1)-ox(jb2))/(ox(jb3)-ox(jb2)) if ( jb4 .lt. no ) then j2n = n(m,jb4,kz) j4n = jb4 cof(5,5) = ox(jb4) else j2n = max( n(m,jb4-1,kz) - 2 , 1 ) j4n = mo cof(5,5) = oxd(j2n) endif endif endif c if ( icomax .ge. 0 ) then if ( i4 .le. n3 ) then call qchksto( 13, cxx, cx(i1), cx(n2), cof(4,4) ) else call quadsto( 13, cxx, cx(i1), cx(i2), cx(i3) ) call qchksto( 14, cxx, cx(i2), cx(i3), cof(4,4) ) endif if ( j4n .gt. 0 ) then if ( jb4 .le. mb3 ) then call qchksto( 15, cof(j4,1), $ ox(jb1), ox(mb2), cof(5,5) ) else call quadsto( 15, cof(j4,1), $ ox(jb1), ox(jb2), ox(jb3) ) call qchksto( 16, cof(j4,1), $ ox(jb2), ox(jb3), cof(5,5) ) endif endif endif if ( icomax .le. 0 ) then iw = 0 is = 0 do i = j1, ihi iw = iw + 1 if ( i4 .le. n3 .or. i4 .gt. n(m,i,kz) ) then call qchksto( iw, cxx, cx(i1), min(cx(n2),cxd(i)), $ min(cx(n3),cxd(i)) ) else if ( is .eq. 0 ) $ call quadsto( 11, cxx, cx(i1), cx(i2), cx(i3) ) is = 1 call qchksto( iw, cxx, $ cx(i2), cx(i3), min(cx(i4),cxd(i)) ) endif enddo if ( j4 .le. m3 ) then call qchksto( 9, oxx, cof(j1,1), cof(m2,1), cof(m3,1) ) else call quadsto( 9, oxx, cof(j1,1), cof(j2,1), cof(j3,1) ) call qchksto( 10, oxx, cof(j2,1), cof(j3,1), cof(j4,1) ) endif endif c do it = k1, k1 + ip do ir = l1, l1 + iq(it-k1+1) if ( icomax .ge. 0 ) then if ( i4 .le. n3 ) then cof(j4,2) = qchkget( 13, co(m,i1,mo,it,ir,kz), $ co(m,n2,mo,it,ir,kz), $ co(m,j2m(4),j4m(4),it,ir,kz) ) else cof(j4,2) = ( 1. - cfac ) * quadget( 13, $ co(m,i1,mo,it,ir,kz), co(m,i2,mo,it,ir,kz), $ co(m,i3,mo,it,ir,kz) ) $ + cfac * qchkget( 14, co(m,i2,mo,it,ir,kz), $ co(m,i3,mo,it,ir,kz), $ co(m,j2m(4),j4m(4),it,ir,kz) ) endif if ( j4n .gt. 0 ) then if ( jb4 .le. mb3 ) then cof(j4,2) = ( 1. - bfac ) * cof(j4,2) $ + bfac * qchkget( 15, $ co(m,n(m,jb1,kz),jb1,it,ir,kz), $ co(m,n(m,mb2,kz),mb2,it,ir,kz), $ co(m,j2n,j4n,it,ir,kz) ) else cof(j4,2) = ( 1. - bfac ) * cof(j4,2) + bfac $ * ( ( 1. - afac ) * quadget( 15, $ co(m,n(m,jb1,kz),jb1,it,ir,kz), $ co(m,n(m,jb2,kz),mb2,it,ir,kz), $ co(m,n(m,jb3,kz),mb3,it,ir,kz) ) $ + afac * qchkget( 16, $ co(m,n(m,jb2,kz),jb2,it,ir,kz), $ co(m,n(m,jb3,kz),jb3,it,ir,kz), $ co(m,j2n,j4n,it,ir,kz) ) ) endif endif endif if ( icomax .gt. 0 ) then opl(it,ir,kz) = cof(j4,2) else iw = 0 do i = j1, ihi iw = iw + 1 if ( i4 .le. n3 .or. i4 .gt. n(m,i,kz) ) then cof(i,2) = qchkget( iw, co(m,i1,i,it,ir,kz), $ co(m,n2,i,it,ir,kz), $ co(m,min(n3,n(m,i,kz)),i,it,ir,kz) ) else cof(i,2) = ( 1. - cfac ) * quadget( 11, $ co(m,i1,i,it,ir,kz), co(m,i2,i,it,ir,kz), $ co(m,i3,i,it,ir,kz) ) $ + cfac * qchkget( iw, co(m,i2,i,it,ir,kz), $ co(m,i3,i,it,ir,kz), co(m,i4,i,it,ir,kz) ) endif enddo if ( j4 .le. m3 ) then opl(it,ir,kz) = qchkget( 9, cof(j1,2), cof(m2,2), $ cof(m3,2) ) else opl(it,ir,kz) = ( 1. - ofac ) * quadget( 9, $ cof(j1,2), cof(j2,2), cof(j3,2) ) $ + ofac * qchkget( 10, cof(j2,2), cof(j3,2), $ cof(j4,2) ) endif endif c-debug[ c-debug; if ( ioudeb .gt. 7 .or. c-debug; $ .not. abs(opl(it,ir,kz)) .le. oudebl .or. c-debug; $ .not. abs(cof(j4,2)) .le. oudebl .or. c-debug; $ ( icomax .le. 0 .and. c-debug; $ ( .not. abs(cof(j1,2)) .le. oudebl .or. c-debug; $ .not. abs(cof(j2,2)) .le. oudebl .or. c-debug; $ .not. abs(cof(j3,2)) .le. oudebl ) ) ) then c-debug; write(6,*) ' ' c-debug; if ( icomax .le. 0 ) then c-debug; do i = j1,ihi c-debug; if ( i4 .le. n3 .or. i4 .gt. n(m,i,kz) ) then c-debug; write(6,9414) m,it,ir,kz,'C b:',3f12.7,' ',a3,f12.7, c-debug; $ 3(' ',a4,i1,')',f12.7),' --> opl(', c-debug; $ i2,',',i2,') =',f12.7,' region ', c-debug; $ a4) c-debug; endif c-debug] enddo enddo c ! interpolation in region c2: else do it = k1,k1+ip do ir = l1,l1+iq(it-k1+1) b(1) = qchk(is,1,cxx,co(m,nc-2,1,it,ir,kz), $ co(m,nc-1,1,it,ir,kz),co(m,nc,1,it,ir,kz), $ cx(nc-2),cx(nc-1),cx(nc)) b(2) = qchk(is,2,cxx,co(m,n(m,2,kz)-2,2,it,ir,kz), $ co(m,n(m,2,kz)-1,2,it,ir,kz), $ co(m,n(m,2,kz),2,it,ir,kz), $ cx(n(m,2,kz)-2),cx(n(m,2,kz)-1),cxd(2)) b(3) = qchk(is,3,cxx,co(m,nc,1,it,ir,kz), $ co(m,n(m,2,kz),2,it,ir,kz), $ co(m,n(m,3,kz),3,it,ir,kz), $ cxd(1),cxd(2),cxd(3)) opl(it,ir,kz) = qchk(is,4,oxx,b(1),b(2),b(3), $ ox(1),ox(2),oxdp) is = 1 c-debug[ c-debug; if ( .not. abs(opl(it,ir,kz)) .le. oudebl .or. c-debug; $ .not. abs(b(1)) .le. oudebl .or. c-debug; $ .not. abs(b(2)) .le. oudebl .or. c-debug; $ .not. abs(b(3)) .le. oudebl .or. c-debug; $ ioudeb .gt. 5 ) then c-debug; write(6,9413) m,kz,xxc,xxo,xxc+xxo,xxco, c-debug; $ xc(nc),nc,(n(m,j,kz),j=1,nc) c-debug; koudeb = koudeb+1 c-debug; write(6,9414) 1,'co(m,',nc-2,1,it,ir, c-debug; $ co(m,nc-2,1,it,ir,kz),'co(m,',nc-1, c-debug; $ 1,it,ir,co(m,nc-1,1,it,ir,kz), c-debug; $ 'diag(',m,1,it,ir, c-debug; $ co(m,nc,1,it,ir,kz),'cxx',cxx, c-debug; $ ' cx(',nc-2,cx(nc-2),' cx(',nc-1, c-debug; $ cx(nc-1),' cx(',nc,cx(nc) c-debug; write(6,9414) 2,'co(m,',n(m,2,kz)-2,2,it, c-debug; $ ir,co(m,n(m,2,kz)-2,2,it,ir,kz), c-debug; $ 'co(m,',n(m,2,kz)-1,2,it,ir, c-debug; $ co(m,n(m,2,kz)-1,2,it,ir,kz), c-debug; $ 'diag(',m,2,it,ir, c-debug; $ co(m,n(m,2,kz),2,it,ir,kz), c-debug; $ 'cxx',cxx, c-debug; $ ' cx(',n(m,2,kz)-2,cx(n(m,2,kz)-2), c-debug; $ ' cx(',n(m,2,kz)-1,cx(n(m,2,kz)-1), c-debug; $ 'cxd(',2,cxd(2) c-debug; write(6,9414) 3,'diag(',m,1,it,ir, c-debug; $ co(m,nc,1,it,ir,kz),'diag(',m,2,it, c-debug; $ ir,co(m,n(m,2,kz),2,it,ir,kz), c-debug; $ 'diag(',m,3,it,ir, c-debug; $ co(m,n(m,3,kz),3,it,ir,kz),'cxx', c-debug; $ cxx,'cxd(',1,cxd(1),'cxd(',2, c-debug; $ cxd(2),'cxd(',3,cxd(3) c-debug; write(6,9415) b(1),b(2),b(3),'oxx',oxx, c-debug; $ ' ox(',1,ox(1),' ox(',2,ox(2), c-debug; $ 'oxdp',0,oxdp,it,ir,opl(it,ir,kz), c-debug; $ 'c2 ' c-debug; endif c-debug] enddo enddo endif c return c else if ( nc .ge. 5 ) then c__________ ! interpolation in regions c3 to c6: do i = 4,nc-1 c c ! do not go beyond middle (where c3-c6 overlaps o3-o6), and c ! include boundaries (qchk fixes any possible division by 0) c if ( xxc .gt. xcd(i)-small_1m6 .and. $ xxo .gt. xo(i-1)-small_1m6 .and. $ xcd(i-1) .gt. xc(i-1) ) then c oxdp = log10(zzz(kz)+xodp) m1 = i-1 m2 = i-2 c do it = k1,k1+ip do ir = l1,l1+iq(it-k1+1) b(1) = qchk(is,1,cxx, $ co(m,n(m,m2,kz)-2,m2,it,ir,kz), $ co(m,n(m,m2,kz)-1,m2,it,ir,kz), $ co(m,n(m,m2,kz),m2,it,ir,kz), $ cx(n(m,m2,kz)-2),cx(n(m,m2,kz)-1),cxd(m2)) b(2) = qchk(is,2,cxx, $ co(m,n(m,m1,kz)-2,m1,it,ir,kz), $ co(m,n(m,m1,kz)-1,m1,it,ir,kz), $ co(m,n(m,m1,kz),m1,it,ir,kz), $ cx(n(m,m1,kz)-2),cx(n(m,m1,kz)-1),cxd(m1)) b(3) = qchk(is,3,cxx, $ co(m,n(m,m2,kz),m2,it,ir,kz), $ co(m,n(m,m1,kz),m1,it,ir,kz), $ co(m,n(m,i,kz),i,it,ir,kz), $ cxd(m2),cxd(m1),cxd(i)) opl(it,ir,kz) = qchk(is,4,oxx,b(1),b(2),b(3), $ ox(m2),ox(m1),oxdp) is = 1 c-debug[ c-debug; if ( .not. abs(opl(it,ir,kz)) .le. oudebl .or. c-debug; $ .not. abs(b(1)) .le. oudebl .or. c-debug; $ .not. abs(b(2)) .le. oudebl .or. c-debug; $ .not. abs(b(3)) .le. oudebl .or. c-debug; $ ioudeb .gt. 5 ) then c-debug; write(6,9413) m,kz,xxc,xxo,xxc+xxo,xxco, c-debug; $ xc(nc),nc,(n(m,j,kz),j=1,nc) c-debug; koudeb = koudeb+1 c-debug; write(6,9414) 1,'co(m,',n(m,m2,kz)-2, c-debug; $ m2,it,ir, c-debug; $ co(m,n(m,m2,kz)-2,m2,it,ir,kz), c-debug; $ 'co(m,',n(m,m2,kz)-1,m2,it,ir, c-debug; $ co(m,n(m,m2,kz)-1,m2,it,ir,kz), c-debug; $ 'diag(',m,m2,it,ir, c-debug; $ co(m,n(m,m2,kz),m2,it,ir,kz), c-debug; $ 'cxx',cxx,' cx(',n(m,m2,kz)-2, c-debug; $ cx(n(m,m2,kz)-2),' cx(', c-debug; $ n(m,m2,kz)-1,cx(n(m,m2,kz)-1), c-debug; $ 'cxd(',m2,cxd(m2) c-debug; write(6,9414) 2,'co(m,',n(m,m1,kz)-2, c-debug; $ m1,it,ir, c-debug; $ co(m,n(m,m1,kz)-2,m1,it,ir,kz), c-debug; $ 'co(m,',n(m,m1,kz)-1,m1,it,ir, c-debug; $ co(m,n(m,m1,kz)-1,m1,it,ir,kz), c-debug; $ 'diag(',m,m1,it,ir, c-debug; $ co(m,n(m,m1,kz),m1,it,ir,kz), c-debug; $ 'cxx',cxx,' cx(',n(m,m1,kz)-2, c-debug; $ cx(n(m,m1,kz)-2),' cx(', c-debug; $ n(m,m1,kz)-1,cx(n(m,m1,kz)-1), c-debug; $ 'cxd(',m1,cxd(m1) c-debug; write(6,9414) 3,'diag(',m,m2,it,ir, c-debug; $ co(m,n(m,m2,kz),m2,it,ir,kz), c-debug; $ 'diag(',m,m1,it,ir, c-debug; $ co(m,n(m,m1,kz),m1,it,ir,kz), c-debug; $ 'diag(',m,i,it,ir, c-debug; $ co(m,n(m,i,kz),i,it,ir,kz), c-debug; $ 'cxx',cxx,'cxd(',m2,cxd(m2), c-debug; $ 'cxd(',m1,cxd(m1),'cxd(',i,cxd(i) c-debug; write(6,9415) b(1),b(2),b(3),'oxx', c-debug; $ oxx,' ox(',i-2,ox(i-2),' ox(', c-debug; $ i-1,ox(i-1),'oxdp',0,oxdp,it,ir, c-debug; $ opl(it,ir,kz),'c3-6' c-debug; endif c-debug] enddo enddo c return c endif c enddo endif c c ! include boundaries (later, fix any possible division by 0) c if ( xxo .gt. xod(3)-small_1m6 ) then c__________ cxdp = log10(zzz(kz)+xcdp) c ! interpolation in region o1: c c ! include boundaries (qchk & fac fix any possible division by 0) c if ( xxo .gt. xod(2)-small_1m6 ) then c ! handle possibility that xcdp = 0 fac = max(min((cxx-cx(1))/max(cxdp-cx(1),small_1m6),1.),0.) c do it = k1,k1+ip do ir = l1,l1+iq(it-k1+1) b(1) = qchk(is,1,oxx,co(m,1,no-2,it,ir,kz), $ co(m,1,no-1,it,ir,kz),co(m,1,mo,it,ir,kz), $ ox(no-2),ox(no-1),ox(no)) b(2) = qchk(is,2,oxx,co(m,1,mo,it,ir,kz), $ co(m,2,mo,it,ir,kz),co(m,3,mo,it,ir,kz), $ oxd(1),oxd(2),oxd(3)) c ! handle possibility that xcdp = 0 opl(it,ir,kz) = b(1)+(b(2)-b(1))*fac is = 1 c-debug[ c-debug; if ( .not. abs(opl(it,ir,kz)) .le. oudebl .or. c-debug; $ .not. abs(b(1)) .le. oudebl .or. c-debug; $ .not. abs(b(2)) .le. oudebl .or. c-debug; $ ioudeb .gt. 5 ) then c-debug; write(6,9413) m,kz,xxc,xxo,xxc+xxo,xxco, c-debug; $ xc(nc),nc,(n(m,j,kz),j=1,nc) c-debug; koudeb = koudeb+1 c-debug; write(6,9414) 1,'co(m,',1,no-2,it,ir, c-debug; $ co(m,1,no-2,it,ir,kz),'co(m,',1, c-debug; $ no-1,it,ir,co(m,1,no-1,it,ir,kz), c-debug; $ 'digo(',m,no-1,it,ir, c-debug; $ co(m,1,mo,it,ir,kz),'oxx', c-debug; $ oxx,' ox(',no-2,ox(no-2),' ox(', c-debug; $ no-1,ox(no-1),' ox(',no,ox(no) c-debug; write(6,9414) 2,'digo(',m,no-1,it,ir, c-debug; $ co(m,1,mo,it,ir,kz),'digo(',m,no-2, c-debug; $ it,ir,co(m,2,mo,it,ir,kz),'digo(',m, c-debug; $ no-3,it,ir,co(m,3,mo,it,ir,kz), c-debug; $ 'oxx',oxx,'oxd(',1,oxd(1),'oxd(',2, c-debug; $ oxd(2),'oxd(',3,oxd(3) c-debug; write(6,9415) b(1),b(2),0.,'cxx',cxx, c-debug; $ ' cx(',1,cx(1),'cxdp',0,cxdp,'----', c-debug; $ 0,0.,it,ir,opl(it,ir,kz),'o1 ' c-debug; endif c-debug] enddo enddo c ! interpolation in region o2: else do it = k1,k1+ip do ir = l1,l1+iq(it-k1+1) b(1) = qchk(is,1,oxx,co(m,1,no-2,it,ir,kz), $ co(m,1,no-1,it,ir,kz),co(m,1,mo,it,ir,kz), $ ox(no-2),ox(no-1),ox(no)) b(2) = qchk(is,2,oxx,co(m,2,n(m,2,kz)-2,it,ir,kz), $ co(m,2,n(m,2,kz)-1,it,ir,kz), $ co(m,2,mo,it,ir,kz), $ ox(n(m,2,kz)-2),ox(n(m,2,kz)-1),oxd(2)) b(3) = qchk(is,3,oxx,co(m,1,mo,it,ir,kz), $ co(m,2,mo,it,ir,kz),co(m,3,mo,it,ir,kz), $ oxd(1),oxd(2),oxd(3)) opl(it,ir,kz) = qchk(is,4,cxx,b(1),b(2),b(3), $ cx(1),cx(2),cxdp) is = 1 c-debug[ c-debug; if ( .not. abs(opl(it,ir,kz)) .le. oudebl .or. c-debug; $ .not. abs(b(1)) .le. oudebl .or. c-debug; $ .not. abs(b(2)) .le. oudebl .or. c-debug; $ .not. abs(b(3)) .le. oudebl .or. c-debug; $ ioudeb .gt. 5 ) then c-debug; write(6,9413) m,kz,xxc,xxo,xxc+xxo,xxco, c-debug; $ xc(nc),nc,(n(m,j,kz),j=1,nc) c-debug; koudeb = koudeb+1 c-debug; write(6,9414) 1,'co(m,',1,no-2,it,ir, c-debug; $ co(m,1,no-2,it,ir,kz),'co(m,',1, c-debug; $ no-1,it,ir,co(m,1,no-1,it,ir,kz), c-debug; $ 'digo(',m,no-1,it,ir, c-debug; $ co(m,1,mo,it,ir,kz),'oxx', c-debug; $ oxx,' ox(',no-2,ox(no-2),' ox(', c-debug; $ no-1,ox(no-1),' ox(',no,ox(no) c-debug; write(6,9414) 2,'co(m,',2,n(m,2,kz)-2,it, c-debug; $ ir,co(m,2,n(m,2,kz)-2,it,ir,kz), c-debug; $ 'co(m,',2,n(m,2,kz)-1,it,ir, c-debug; $ co(m,2,n(m,2,kz)-1,it,ir,kz), c-debug; $ 'digo(',m,no-2,it,ir, c-debug; $ co(m,2,mo,it,ir,kz),'oxx',oxx, c-debug; $ ' ox(',n(m,2,kz)-2,ox(n(m,2,kz)-2), c-debug; $ ' ox(',n(m,2,kz)-1,ox(n(m,2,kz)-1), c-debug; $ 'oxd(',2,oxd(2) c-debug; write(6,9414) 3,'digo(',m,no-1,it,ir, c-debug; $ co(m,1,mo,it,ir,kz),'digo(',m,no-2, c-debug; $ it,ir,co(m,2,mo,it,ir,kz),'digo(',m, c-debug; $ nc-3,it,ir,co(m,3,mo,it,ir,kz), c-debug; $ 'oxx',oxx,'oxd(',1,oxd(1),'oxd(',2, c-debug; $ oxd(2),'oxd(',3,oxd(3) c-debug; write(6,9415) b(1),b(2),b(3),'cxx',cxx, c-debug; $ ' cx(',1,cx(1),' cx(',2,cx(2), c-debug; $ 'cxdp',0,cxdp,it,ir,opl(it,ir,kz), c-debug; $ 'o2 ' c-debug; endif c-debug] enddo enddo endif c return c else if ( no .ge. 5 ) then c__________ ! interpolation in regions o3 to o6: do i = 4,no-1 c c ! do not go beyond middle (where o3-o6 overlaps c3-c6), and c ! include boundaries (qchk fixes any possible division by 0) c if ( xxo .gt. xod(i)-small_1m6 .and. $ xxc .ge. xc(i-1)-small_1m6 .and. $ xod(i-1) .gt. xo(i-1)-small_1m6 ) then c cxdp = log10(zzz(kz)+xcdp) m2 = i-2 m1 = i-1 c do it = k1,k1+ip do ir = l1,l1+iq(it-k1+1) b(1) = qchk(is,1,oxx, $ co(m,m2,n(m,m2,kz)-2,it,ir,kz), $ co(m,m2,n(m,m2,kz)-1,it,ir,kz), $ co(m,m2,mo,it,ir,kz), $ ox(n(m,m2,kz)-2),ox(n(m,m2,kz)-1),oxd(m2)) b(2) = qchk(is,2,oxx, $ co(m,m1,n(m,m1,kz)-2,it,ir,kz), $ co(m,m1,n(m,m1,kz)-1,it,ir,kz), $ co(m,m1,mo,it,ir,kz), $ ox(n(m,m1,kz)-2),ox(n(m,m1,kz)-1),oxd(m1)) b(3) = qchk(is,3,oxx,co(m,m2,mo,it,ir,kz), $ co(m,m1,mo,it,ir,kz),co(m,i,mo,it,ir,kz), $ oxd(m2),oxd(m1),oxd(i)) opl(it,ir,kz) = qchk(is,4,cxx,b(1),b(2),b(3), $ cx(m2),cx(m1),cxdp) is = 1 c-debug[ c-debug; if ( .not. abs(opl(it,ir,kz)) .le. oudebl .or. c-debug; $ .not. abs(b(1)) .le. oudebl .or. c-debug; $ .not. abs(b(2)) .le. oudebl .or. c-debug; $ .not. abs(b(3)) .le. oudebl .or. c-debug; $ ioudeb .gt. 5 ) then c-debug; write(6,9413) m,kz,xxc,xxo,xxc+xxo,xxco, c-debug; $ xc(nc),nc,(n(m,j,kz),j=1,nc) c-debug; koudeb = koudeb+1 c-debug; write(6,9414) 1,'co(m,',m2, c-debug; $ n(m,m2,kz)-2,it,ir, c-debug; $ co(m,m2,n(m,m2,kz)-2,it,ir,kz), c-debug; $ 'co(m,',m2,n(m,m2,kz)-1,it,ir, c-debug; $ co(m,m2,n(m,m2,kz)-1,it,ir,kz), c-debug; $ 'digo(',m,no-m2,it,ir, c-debug; $ co(m,m2,mo,it,ir,kz),'oxx',oxx, c-debug; $ ' ox(',n(m,m2,kz)-2, c-debug; $ ox(n(m,m2,kz)-2),' ox(', c-debug; $ n(m,m2,kz)-1,ox(n(m,m2,kz)-1), c-debug; $ 'oxd(',m2,oxd(m2) c-debug; write(6,9414) 2,'co(m,',m1, c-debug; $ n(m,m1,kz)-2,it,ir, c-debug; $ co(m,m1,n(m,m1,kz)-2,it,ir,kz), c-debug; $ 'co(m,',m1,n(m,m1,kz)-1,it,ir, c-debug; $ co(m,m1,n(m,m1,kz)-1,it,ir,kz), c-debug; $ 'digo(',m,no-m1,it,ir, c-debug; $ co(m,m1,mo,it,ir,kz),'oxx',oxx, c-debug; $ ' ox(',n(m,m1,kz)-2, c-debug; $ ox(n(m,m1,kz)-2),' ox(', c-debug; $ n(m,m1,kz)-1,ox(n(m,m1,kz)-1), c-debug; $ 'oxd(',m1,oxd(m1) c-debug; write(6,9414) 3,'digo(',m,no-m2,it,ir, c-debug; $ co(m,m2,mo,it,ir,kz),'digo(', c-debug; $ m,no-m1,it,ir, c-debug; $ co(m,m1,mo,it,ir,kz), c-debug; $ 'digo(',m,no-i,it,ir, c-debug; $ co(m,i,mo,it,ir,kz),'oxx',oxx, c-debug; $ 'oxd(',m2,oxd(m2),'oxd(',m1, c-debug; $ oxd(m1),'oxd(',i,oxd(i) c-debug; write(6,9415) b(1),b(2),b(3),'cxx', c-debug; $ cxx,' cx(',m2,cx(m2),' cx(',m1, c-debug; $ cx(m1),'cxdp',0,cxdp,it,ir, c-debug; $ opl(it,ir,kz),'o3-6' c-debug; endif c-debug] enddo enddo c return c endif c enddo c endif c__________ ! else, interpolation in lower left of C-O grid c c.....find index of C grid c (must also allow index = nc, to avoid extrapolation) c ie = 100 * max( xxc , 0. ) + 1 i3 = max( min( indx(ie) + 1 , nc ) , 3 ) i1 = i3-2 i2 = i3-1 c c.....find index of O grid: c must also allow index = no, to avoid extrapolation c ie = 100 * max( xxo , 0. ) + 1 j3 = max( min( indx(ie) + 1 , no ) , 3 ) j1 = j3-2 j2 = j3-1 c ! lower-O part of grid: interpolate C before O: c if ( j3 .lt. no .and. i3 .le. n(m,j3,kz) .and. $ ( xxc .lt. xcd(j3)+small_1m6 .or. xxc .ge. xxo ) ) then c do it = k1,k1+ip do ir = l1,l1+iq(it-k1+1) iw = 0 do jx = j1,j1+2 iw = iw+1 c ! if i3 = n(m,jx,kz), must replace cx(i3) with cxd(jx) b(iw) = qchk(is,iw,cxx,co(m,i1,jx,it,ir,kz), $ co(m,i2,jx,it,ir,kz),co(m,i3,jx,it,ir,kz), $ cx(i1),cx(i2),min(cx(i3),cxd(jx))) enddo iw = iw+1 opl(it,ir,kz) = qchk(is,iw,oxx,b(1),b(2),b(3), $ ox(j1),ox(j2),ox(j3)) is = 1 c-debug[ c-debug; if ( .not. abs(opl(it,ir,kz)) .le. oudebl .or. c-debug; $ .not. abs(b(1)) .le. oudebl .or. c-debug; $ .not. abs(b(2)) .le. oudebl .or. c-debug; $ .not. abs(b(3)) .le. oudebl .or. c-debug; $ ioudeb .gt. 5 ) then c-debug; write(6,9413) m,kz,xxc,xxo,xxc+xxo,xxco, c-debug; $ xc(nc),nc,(n(m,j,kz),j=1,nc) c-debug; koudeb = koudeb+1 c-debug; iw = 0 c-debug; do jx = j1,j1+2 c-debug; iw = iw+1 c-debug; if ( cx(i3) .le. cxd(jx) ) then c-debug; write(6,9414) iw,'co(m,',i1,jx,it,ir, c-debug; $ co(m,i1,jx,it,ir,kz),'co(m,',i2, c-debug; $ jx,it,ir,co(m,i2,jx,it,ir,kz), c-debug; $ 'co(m,',i3,jx,it,ir, c-debug; $ co(m,i3,jx,it,ir,kz), c-debug; $ 'cxx',cxx,' cx(',i1,cx(i1), c-debug; $ ' cx(',i2,cx(i2),' cx(',i3,cx(i3) c-debug; else c-debug; write(6,9414) iw,'co(m,',i1,jx,it,ir, c-debug; $ co(m,i1,jx,it,ir,kz),'co(m,',i2, c-debug; $ jx,it,ir,co(m,i2,jx,it,ir,kz), c-debug; $ 'co(m,',i3,jx,it,ir, c-debug; $ co(m,i3,jx,it,ir,kz),'cxx',cxx, c-debug; $ ' cx(',i1,cx(i1),' cx(',i2, c-debug; $ cx(i2),'cxd(',jx,cxd(jx) c-debug; endif c-debug; enddo c-debug; write(6,9415) b(1),b(2),b(3),'oxx',oxx, c-debug; $ ' ox(',j1,ox(j1),' ox(',j2,ox(j2), c-debug; $ ' ox(',j3,ox(j3),it,ir,opl(it,ir,kz), c-debug; $ 'CloO' c-debug; endif c-debug] enddo enddo c ! else: high-O part of grid: must interpolate O before C: else do it = k1,k1+ip do ir = l1,l1+iq(it-k1+1) iw = 0 do ix = i1,i1+2 iw = iw+1 if ( j3 .lt. n(m,ix,kz) ) then b(iw) = qchk(is,iw,oxx,co(m,ix,j1,it,ir,kz), $ co(m,ix,j2,it,ir,kz),co(m,ix,j3,it,ir,kz), $ ox(j1),ox(j2),ox(j3)) else b(iw) = qchk(is,iw,oxx,co(m,ix,j1,it,ir,kz), $ co(m,ix,j2,it,ir,kz),co(m,ix,mo,it,ir,kz), $ ox(j1),ox(j2),oxd(ix)) endif enddo iw = iw+1 opl(it,ir,kz) = qchk(is,iw,cxx,b(1),b(2),b(3), $ cx(i1),cx(i2),cx(i3)) is = 1 c-debug[ c-debug; if ( .not. abs(opl(it,ir,kz)) .le. oudebl .or. c-debug; $ .not. abs(b(1)) .le. oudebl .or. c-debug; $ .not. abs(b(2)) .le. oudebl .or. c-debug; $ .not. abs(b(3)) .le. oudebl .or. c-debug; $ ioudeb .gt. 5 ) then c-debug; write(6,9413) m,kz,xxc,xxo,xxc+xxo, c-debug; $ xxco,xc(nc),nc,(n(m,j,kz),j=1,nc) c-debug; koudeb = koudeb+1 c-debug; iw = 0 c-debug; do ix = i1,i1+2 c-debug; iw = iw+1 c-debug; if ( j3 .lt. n(m,ix,kz) ) then c-debug; write(6,9414) iw,'co(m,',ix,j1,it,ir, c-debug; $ co(m,ix,j1,it,ir,kz),'co(m,',ix, c-debug; $ j2,it,ir,co(m,ix,j2,it,ir,kz), c-debug; $ 'co(m,',ix,j3,it,ir, c-debug; $ co(m,ix,j3,it,ir,kz), c-debug; $ 'oxx',oxx,' ox(',j1,ox(j1), c-debug; $ ' ox(',j2,ox(j2),' ox(',j3,ox(j3) c-debug; else c-debug; write(6,9414) iw,'co(m,',ix,j1,it,ir, c-debug; $ co(m,ix,j1,it,ir,kz),'co(m,',ix, c-debug; $ j2,it,ir,co(m,ix,j2,it,ir,kz), c-debug; $ 'digo(',m,no-ix,it,ir, c-debug; $ co(m,ix,mo,it,ir,kz),'oxx',oxx, c-debug; $ ' ox(',j1,ox(j1),' ox(',j2, c-debug; $ ox(j2),'oxd(',ix,oxd(ix) c-debug; endif c-debug; enddo c-debug; write(6,9415) b(1),b(2),b(3),'cxx',cxx, c-debug; $ ' cx(',i1,cx(i1),' cx(',i2,cx(i2), c-debug; $ ' cx(',i3,cx(i3),it,ir,opl(it,ir,kz), c-debug; $ 'hi-O' c-debug; endif c-debug] enddo enddo endif c return end c c****************************************************************************** c subroutine t6rinterp(slr,slt) c ============================= c c The purpose of this subroutine is to interpolate in logT6 and logR c NOTE THAT for 2-dimensional quadratic interpolation, IT DOES NOT MATTER c which direction is interpolated first, horizontal or vertical: the c result is the same for interpolated value and derivatives. c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c c COMMON /d_opal_z/ : c dkap = derivative of value returned by quadratic interpolation function QDER c common/d_opal_z/ dkap save /d_opal_z/ c common/bb_opal_z/ xodp,xcdp,xxco,cxx,oxx, $ l1,l2,l3,l4,k1,k2,k3,k4,ip,iq(4),kzf,kzg,kzh,kzf2 save /bb_opal_z/ c-debug[ c-debug; common/outdeb/ ioudeb,oudebl,koudeb c-debug] c c=== c-debug[ c-debug; if ( ioudeb .gt. 5 ) then c-debug; write(6,'(/"----- t6rinterp( slr=",f10.6,", slt=",f9.6, c-debug; $ " ) ----- m",i2," k1:4",4i3," ip,"i2," l1:4",4i3, c-debug; $ " iq(1:",i1,")",4i2)') c-debug; $ slr, slt, m, k1, k2, k3, k4, ip, l1, l2, l3, l4, c-debug; $ ip + 1, ( iq(i), i = 1, ip + 1 ) c-debug; endif c-debug] iu = 0 is = 1 iqp = -9 c ! for each of the 3 or 4 T values, interpolate in R: do kx = k1, k1 + ip c iu = iu + 1 iq_at = iq(iu) c if ( iq_at .ne. iqp ) then is = is + 1 call qderNsto( is, iq_at, slr, $ alr(l1), alr(l2), alr(l3), alr(l4) ) iqp = iq_at endif c ! interpolate in R call qderNget( is, iq_at, opl(kx,l1,1), opl(kx,l2,1), $ opl(kx,l3,1), opl(kx,l4,1), h(iu), q(iu) ) c-debug[ c-debug; if ( ioudeb .gt. 3 .or. .not. abs(h(iu)) .le. oudebl .or. c-debug; $ .not. abs(q(iu)) .le. oudebl ) then c-debug; if ( ioudeb .le. 3 .or. iu .eq. 1 ) write(6,*) ' ' c-debug; write(6,8912) m,kx,slr,h(iu),q(iu), c-debug; $ (kx,j,alr(j),opl(kx,j,1),j=l1,l1+iq(iu)) c-debug; 8912 format(' T6RINTERP(x',i1,',t',i2.2') R',f10.6, c-debug; $ ' : K,dKdR =',2g15.7,' <-- it,ir,R,K:', c-debug; $ 4(i4,i3,f10.6,f11.7)) c-debug; koudeb = koudeb+1 c-debug; endif c-debug] c enddo c c Interpolate in T, getting opacity, T-derivative, interpolated R-derivative c (note that calling qderNsto sets up for quadNget as well as qderNget): c call qderNsto( 1, ip, slt, alt(k1), alt(k2), alt(k3), alt(k4) ) c call qderNget( 1, ip, h(1), h(2), h(3), h(4), opk(m,1), opk(m,2) ) opk(m,3) = quadNget( 1, ip, q(1), q(2), q(3), q(4) ) c opk(m,4) = opk(m,2) - 3.0 * opk(m,3) c c-debug[ c-debug; if ( .not. abs(opk(m,1)) .le. oudebl .or. ioudeb .gt. 2 ) then c-debug; write(6,8913) m, slt,k1,ip,slr,l1,iq(1),iq(2),iq(3),iq(ip+1), c-debug; $ opk(m,1),opk(m,2),opk(m,3),opk(m,4), c-debug; $ (j,alt(j),h(j-k1+1),q(j-k1+1),j=k1,k1+ip) c-debug; 8913 format(/' T6RINTERP(x',i1,') logT6',f10.6, c-debug; $ ' (',i2,'+',i1,') logR',f10.6,' (',i2,'+', c-debug; $ 4i1,') logK',g15.7,' DT',f12.7,' DR',f12.7,' DTro',f12.7/ c-debug; $ ' <-- it,T,K,dKdR',4(i4,f10.6,2f11.7)) c-debug; koudeb = koudeb+1 c-debug; endif c-debug] if ( opk(m,1) .gt. 1.e+5 ) then write(6,10) m,10.**slt,k1,ip,slr,l1,iq(1),iq(2),iq(3), $ iq(ip+1),opk(m,1) 10 format(' '/' T6RINTERP(m=',i1,') T6=',f15.9,':',i2,'+',i1, $ ' logR',f12.7,':',i2,'+',4i1,' logK',e10.3/ $ ' Error -- interpolation indices out of range:', $ ' PLEASE REPORT CONDITIONS') stop ' STOP -- T6RINTERP Error: indices out of range. ' endif c return end c c****************************************************************************** c subroutine sngl_cinterp3(ZM,Z0,Z1,ZP,Z,N0,MXNV,VM,V0,V1,VP, $ VF,DF,D2,XH) c =========================================================== c c Single-precision version, copied from Potekhin-website program condint.f c c Given 4 values of Z and 4 values of V, find VF corresponding to 5th Z c Version 23.05.99 c Output: VF - interpolated value of function c DF - interpolated derivative c D2 - interpolated second derivative c XH - fraction of the path from N0 to N0+1 c c-sngl; implicit double precision (A-H), double precision (O-Z) c if (N0.le.0.or.N0.ge.MXNV) stop $ ' STOP -- SNGL_CINTERP: N0 out of range ' X=Z-Z0 H=Z1-Z0 ! basic interval XH=X/H if (N0.gt.1) then HM=Z0-ZM ! left adjoint interval V01=((V1-V0)/H**2+(V0-VM)/HM**2)/(1./H+1./HM) ! left derivative endif if (N0.lt.MXNV-1) then HP=ZP-Z1 ! right adjoint interval V11=((V1-V0)/H**2+(VP-V1)/HP**2)/(1./H+1./HP) ! right derivative endif if (N0.gt.1.and.N0.lt.MXNV-1) then ! Cubic interpolation C2=3.*(V1-V0)-H*(V11+2.*V01) C3=H*(V01+V11)-2.*(V1-V0) VF=V0+V01*X+C2*XH**2+C3*XH**3 DF=V01+(2.*C2*XH+3.*C3*XH**2)/H D2=(2.*C2+6.*C3*XH)/H**2 else if (N0.eq.1) then ! Quadratic interpolation C2=V0-V1+V11*H if ( Z .ge. Z0 ) then VF=V1-V11*(H-X)+C2*(1.-XH)**2 DF=V11-2.*C2*(1.-XH)/H D2=2.*C2/H**2 else ! or linear extrapolation DF = V11-2.*C2/H ! using quadratic slope at Z0 VF = V0 + ( Z - Z0 ) * DF DF2 = 0.0 endif else ! N0=MXNV-1 C2=V1-V0-V01*H if ( Z .le. Z1 ) then ! Quadratic interpolation VF=V0+V01*X+C2*XH**2 DF=V01+2.*C2*XH/H D2=2.*C2/H**2 else ! or linear extrapolation DF = V01+2.*C2/H ! using quadratic slope at Z1 VF = V1 + ( Z - Z1 ) * DF DF2 = 0.0 endif endif end c c****************************************************************************** c subroutine qzlog4int( zlogd ) c ============================= c c..... this subroutine performs bi-quadratic interpolation of logKappa in the c log10(Z_i+zdel) values stored in the array zvint(nz), for each of the c relevant positions in the C,O-interpolated opacity matrix opl(nt,nr,nz) c (given the input values Z and zdel). Note that this subroutine uses c the quadratic-interpolation function quad. Depending on the number of c Z-values to interpolate among, single-quadratic or linear interpolation c may be used instead. Note that zlogd = log10(Z+zdel). c c NOTE that since errors in the opacities may be large compared to the c opacity differences between opacities at adjacent Z-values, quadratic c interpolation is forced to be monotonic by using values at adjacent c tabulated Z-values as upper and lower limits. No such restriction is c placed on extrapolated values. c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c c COMMON /bb_opal_z/ : some indices & abundances for T6,R and C,O interpolation c common/bb_opal_z/ xodp,xcdp,xxco,cxx,oxx, $ l1,l2,l3,l4,k1,k2,k3,k4,ip,iq(4),kzf,kzg,kzh,kzf2 save /bb_opal_z/ c c-debug[ c-debug; common/outdeb/ ioudeb,oudebl,koudeb c-debug] c=== c ! bi-quadratic interpolation: if ( kzf2 .gt. kzh ) then c call quad4sto( 30, zlogd, zvint(kzf), $ zvint(kzg), zvint(kzh), zvint(kzf2) ) c do it = k1, k1 + ip do ir = l1, l1 + iq(it-k1+1) vkl = opl(it,ir,kzg) vkh = opl(it,ir,kzh) v0 = max( min(vkl,vkh) , min( max(vkl,vkh) , $ quad4get( 30, opl(it,ir,kzf), vkl, $ vkh, opl(it,ir,kzf2) ) ) ) c-debug[ c-debug; if ( ioudeb .gt. 4 .or. .not. abs(v0) .le. oudebl ) then c-debug; if ( ioudeb .le. 4 .or. ( it .eq. k1 .and. c-debug; $ ir .eq. l1 ) ) write(6,*) ' ' c-debug; write(6,8912) m,it,ir,zlogd,v0, c-debug; $ (j,zvint(j),opl(it,ir,j),j=kzf,kzf2) c-debug; 8912 format(' QZLOG4INT(x',i1,',t',i2.2,',r',i2.2,') Z', c-debug; $ f10.6,' : K =',g15.7,' <-- iz,Z,K:', c-debug; $ 4(i4,f10.6,f11.7)) c-debug; koudeb = koudeb+1 c-debug; endif c-debug] opl(it,ir,1) = v0 enddo enddo c ! quadratic interpolation: else if ( kzh .gt. kzg ) then c v1 = zvint(kzf) v2 = zvint(kzg) v3 = zvint(kzh) call quadsto( 30, zlogd, v1, v2, v3 ) c if ( zlogd .le. v2 .and. zlogd .ge. v1 ) then do it = k1, k1 + ip do ir = l1, l1 + iq(it-k1+1) vkl = opl(it,ir,kzf) vkh = opl(it,ir,kzg) v0 = max( min(vkl,vkh) , min( max(vkl,vkh) , $ quadget( 30, vkl, vkh, opl(it,ir,kzh) ) ) ) c-debug[ c-debug; if ( ioudeb .gt. 4 .or. c-debug; $ .not. abs(v0) .le. oudebl ) then c-debug; if ( ioudeb .le. 4 .or. ( it .eq. k1 .and. c-debug; $ ir .eq. l1 ) ) write(6,*) ' ' c-debug; write(6,8912) m,it,ir,zlogd,v0, c-debug; $ (j,zvint(j),opl(it,ir,j),j=kzf,kzh) c-debug; koudeb = koudeb+1 c-debug; endif c-debug] opl(it,ir,1) = v0 enddo enddo else if ( zlogd .ge. v2 .and. zlogd .le. v3 ) then do it = k1, k1 + ip do ir = l1, l1 + iq(it-k1+1) vkl = opl(it,ir,kzg) vkh = opl(it,ir,kzh) v0 = max( min(vkl,vkh) , min( max(vkl,vkh) , $ quadget( 30, opl(it,ir,kzf), vkl, vkh ) ) ) c-debug[ c-debug; if ( ioudeb .gt. 4 .or. c-debug; $ .not. abs(v0) .le. oudebl ) then c-debug; if ( ioudeb .le. 4 .or. ( it .eq. k1 .and. c-debug; $ ir .eq. l1 ) ) write(6,*) ' ' c-debug; write(6,8912) m,it,ir,zlogd,v0, c-debug; $ (j,zvint(j),opl(it,ir,j),j=kzf,kzh) c-debug; koudeb = koudeb+1 c-debug; endif c-debug] opl(it,ir,1) = v0 enddo enddo else do it = k1, k1 + ip do ir = l1, l1 + iq(it-k1+1) v0 = quadget( 30, opl(it,ir,kzf), $ opl(it,ir,kzg), opl(it,ir,kzh) ) c-debug[ c-debug; if ( ioudeb .gt. 4 .or. c-debug; $ .not. abs(v0) .le. oudebl ) then c-debug; if ( ioudeb .le. 4 .or. ( it .eq. k1 .and. c-debug; $ ir .eq. l1 ) ) write(6,*) ' ' c-debug; write(6,8912) m,it,ir,zlogd,v0, c-debug; $ (j,zvint(j),opl(it,ir,j),j=kzf,kzh) c-debug; koudeb = koudeb+1 c-debug; endif c-debug] opl(it,ir,1) = v0 enddo enddo endif c ! linear interpolation: else if ( kzg .gt. kzf ) then c f = ( zvint(kzg) - zlogd ) $ / ( zvint(kzg) - zvint(kzf) ) omf = 1. - f do it = k1, k1 + ip do ir = l1, l1 + iq(it-k1+1) v0 = f * opl(it,ir,kzf) + omf * opl(it,ir,kzg) c-debug[ c-debug; if ( ioudeb .gt. 4 .or. .not. abs(v0) .le. oudebl ) then c-debug; if ( ioudeb .le. 4 .or. ( it .eq. k1 .and. c-debug; $ ir .eq. l1 ) ) write(6,*) ' ' c-debug; write(6,8912) m,it,ir,zlogd,v0, c-debug; $ (j,zvint(j),opl(it,ir,j),j=kzf,kzg) c-debug; koudeb = koudeb+1 c-debug; endif c-debug] opl(it,ir,1) = v0 enddo enddo c ! or no interpolation: else if ( kzf .ne. 1 ) then c do it = k1, k1 + ip do ir = l1, l1 + iq(it-k1+1) opl(it,ir,1) = opl(it,ir,kzf) enddo enddo c endif c return end c c****************************************************************************** c function quadsl(ic,i,x,y1,y2,y3,x1,x2,x3) c ========================================= c c..... this function performs a quadratic interpolation, trying to avoid c spurious wiggles at point where the slope changes by a large amount c parameter ( small_1m6=1.e-6 ) c c Storage for x,dx_i values that need not be computed on each call (see "ic"); c NOTE that this same storage is used by all of QUADSL, QDERSL c common/c_quadsl_opal_z/ xo21(10), xo32(10), x01(10), x02(10), $ x03(10), x0230o32(10), x0202o32(10), x023021o3231(10), $ x0203o31(10), x0201o31(10), x0201o21(10), x0202o21(10), $ x020132o2131(10), ixvs2(10) save /c_quadsl_opal_z/ c___ dimension xx(6) c=== xx(5) = y2 c ! quad may be called many times with same x,x1,x2,x3; c ! compute & store X-deltas only if flag ic says so: if ( ic .eq. 0 ) then c call quadslsto( i, x, x1, x2, x3 ) c c-debug[ else c xx(4) = x xx(2) = x2 c if ( xx(4) .eq. x2 ) then c if ( ixvs2(i) .ne. 0 ) then write(6,100) ixvs2(i), 0, i, x, x1, x2, x3 100 format(' QUADSL Error: ixvs2(i) =',i3, $ ' [should be',i3,']: from i =',i3, $ ' x =',1p,e15.7,' x1,2,3 =',3e15.7) stop ' STOP -- QUADSL Error: bad ixvs2(i) .ne. 0 ' endif c else c xx(1) = x1 xx(3) = x3 c if ( abs( xo21(i) * ( xx(2) - xx(1) ) - 1.0 ) .gt. $ small_1m6 ) then write(6,110) 'xo21', xo21(i), 1.0 / ( xx(2) - xx(1) ), $ i, x, x1, x2, x3 110 format(' QUADSL Error: ',a,'(i) =',1p,e15.7, $ ' [should be ',e15.7,']: from i =',i3, $ ' x =',1p,e15.7,' x1,2,3 =',3e15.7) stop ' STOP -- QUADSL Error: bad xo21(i) ' else if ( abs( xo32(i) * ( xx(3) - xx(2) ) - 1.0 ) .gt. $ small_1m6 ) then write(6,110) 'xo32', xo32(i), 1.0 / ( xx(3) - xx(2) ), $ i, x, x1, x2, x3 stop ' STOP -- QUADSL Error: bad xo32(i) ' else if ( abs( xx(4) - xx(2) - x02(i) ) .gt. $ small_1m6 * x02(i) ) then write(6,110) 'x02', x02(i), xx(4) - xx(2), $ i, x, x1, x2, x3 stop ' STOP -- QUADSL Error: bad x02(i) ' endif c if ( xx(1) .lt. xx(3) ) then if ( xx(4) .lt. xx(2) ) then if ( ixvs2(i) .ne. -1 ) then write(6,100) ixvs2(i), -1, i, x, x1, x2, x3 stop ' STOP -- QUADSL Error: bad ixvs2(i) .ne. -1' endif else if ( ixvs2(i) .ne. 1 ) then write(6,100) ixvs2(i), 1, i, x, x1, x2, x3 stop ' STOP -- QUADSL Error: bad ixvs2(i) .ne. 1 ' endif else if ( xx(4) .gt. xx(2) ) then if ( ixvs2(i) .ne. -1 ) then write(6,100) ixvs2(i), -1, i, x, x1, x2, x3 stop ' STOP -- QUADSL Error: bad ixvs2(i) .ne. -1 ' endif else if ( ixvs2(i) .ne. 1 ) then write(6,100) ixvs2(i), 1, i, x, x1, x2, x3 stop ' STOP -- QUADSL Error: bad ixvs2(i) .ne. 1 ' endif c endif c-debug] endif c if ( ixvs2(i) .eq. 0 ) then quadsl = xx(5) return endif c xx(4) = y1 xx(6) = y3 s21 = ( xx(5) - xx(4) ) * xo21(i) s32 = ( xx(6) - xx(5) ) * xo32(i) as21 = abs( s21 ) as32 = abs( s32 ) c if ( 6.0 * as21 .le. as32 ) then c if ( ixvs2(i) .le. 0 ) then quadsl = x02(i) * s21 + xx(5) else quadsl = x0230o32(i) * s21 + x0202o32(i) * s32 + xx(5) endif c else if ( 2.0 * as21 .lt. as32 ) then c omf_ds = ( 1.5 - as32 / ( 4.0 * as21 ) ) * ( s32 - s21 ) if ( ixvs2(i) .le. 0 ) then quadsl = omf_ds * x0201o31(i) + x01(i) * s21 + xx(4) else quadsl = x0230o32(i) * s21 + x0202o32(i) * s32 $ + omf_ds * x023021o3231(i) + xx(5) endif c else if ( 2.0 * as32 .ge. as21 ) then c quadsl = x0201o31(i) * s32 - x0203o31(i) * s21 + xx(5) c else if ( 6.0 * as32 .gt. as21 ) then c omf_ds = ( 1.5 - as21 / ( 4.0 * as32 ) ) * ( s32 - s21 ) if ( ixvs2(i) .ge. 0 ) then quadsl = omf_ds * x0203o31(i) + x03(i) * s32 + xx(6) else quadsl = x0201o21(i) * s32 - x0202o21(i) * s21 $ - omf_ds * x020132o2131(i) + xx(5) endif c else if ( ixvs2(i) .ge. 0 ) then quadsl = x02(i) * s32 + xx(5) else quadsl = x0201o21(i) * s32 - x0202o21(i) * s21 + xx(5) endif c return end c c****************************************************************************** c function qdersl(ic,i,x,y1,y2,y3,x1,x2,x3) c ========================================= c c..... this function performs a quadratic interpolation, trying to avoid c spurious wiggles at point where the slope changes by a large amount; c it is identical to the function quadsl, except that it also computes c the derivative dkap of the quadratic at the given position x c parameter ( small_1m6=1.e-6 ) c c COMMON /d_opal_z/ : dkap returns the derivative (in interpolation-direction) c common /d_opal_z/ dkap save /d_opal_z/ c c Storage for x,dx_i values that need not be computed on each call (see "ic"); c NOTE that this same storage is used by all of QUADSL, QDERSL c common/c_quadsl_opal_z/ xo21(10), xo32(10), x01(10), x02(10), $ x03(10), x0230o32(10), x0202o32(10), x023021o3231(10), $ x0203o31(10), x0201o31(10), x0201o21(10), x0202o21(10), $ x020132o2131(10), ixvs2(10) save /c_quadsl_opal_z/ c common/c_qdersl_opal_z/ x01o31(10), x30o31(10), x30p20o31(10), $ x02p01o31(10), x30p20o32(10), x02o32two(10), x02p01o21(10), $ x30p2021o3231(10), x02p03o31(10), x02o21two(10), $ x02p0132o2131(10) save /c_qdersl_opal_z/ c___ dimension xx(6) c=== c ! qder may be called many times with same x,x1,x2,x3; c ! compute & store X-deltas only if flag ic says so: if ( ic .eq. 0 ) then c call qderslsto( i, x, x1, x2, x3 ) c c-debug[ else c xx(1) = x1 xx(2) = x2 xx(3) = x3 xx(4) = x c if ( abs( xo21(i) * ( xx(2) - xx(1) ) - 1.0 ) .gt. $ small_1m6 ) then write(6,110) 'xo21', xo21(i), 1.0 / ( xx(2) - xx(1) ), $ i, x, x1, x2, x3 110 format(' QDERSL Error: ',a,'(i) =',1p,e15.7, $ ' [should be ',e15.7,']: from i =',i3, $ ' x =',1p,e15.7,' x1,2,3 =',3e15.7) stop ' STOP -- QDERSL Error: bad xo21(i) ' else if ( abs( xo32(i) * ( xx(3) - xx(2) ) - 1.0 ) .gt. $ small_1m6 ) then write(6,110) 'xo32', xo32(i), 1.0 / ( xx(3) - xx(2) ), $ i, x, x1, x2, x3 stop ' STOP -- QDERSL Error: bad xo32(i) ' endif c if ( xx(4) .eq. xx(2) ) then c if ( ixvs2(i) .ne. 0 ) then write(6,100) ixvs2(i), 0, i, x, x1, x2, x3 100 format(' QDERSL Error: ixvs2(i) =',i3, $ ' [should be',i3,']: from i =',i3, $ ' x =',1p,e15.7,' x1,2,3 =',3e15.7) stop ' STOP -- QDERSL Error: bad ixvs2(i) .ne. 0 ' endif c else c if ( abs( xx(4) - xx(2) - x02(i) ) .gt. $ small_1m6 * x02(i) ) then write(6,110) 'x02', x02(i), xx(4) - xx(2), $ i, x, x1, x2, x3 stop ' STOP -- QDERSL Error: bad x02(i) ' endif c if ( xx(1) .lt. xx(3) ) then if ( xx(4) .lt. xx(2) ) then if ( ixvs2(i) .ne. -1 ) then write(6,100) ixvs2(i), -1, i, x, x1, x2, x3 stop ' STOP -- QDERSL Error: bad ixvs2(i) .ne. -1' endif else if ( ixvs2(i) .ne. 1 ) then write(6,100) ixvs2(i), 1, i, x, x1, x2, x3 stop ' STOP -- QDERSL Error: bad ixvs2(i) .ne. 1 ' endif else if ( xx(4) .gt. xx(2) ) then if ( ixvs2(i) .ne. -1 ) then write(6,100) ixvs2(i), -1, i, x, x1, x2, x3 stop ' STOP -- QDERSL Error: bad ixvs2(i) .ne. -1 ' endif else if ( ixvs2(i) .ne. 1 ) then write(6,100) ixvs2(i), 1, i, x, x1, x2, x3 stop ' STOP -- QDERSL Error: bad ixvs2(i) .ne. 1 ' endif endif c-debug] endif c xx(4) = y1 xx(5) = y2 xx(6) = y3 s21 = ( xx(5) - xx(4) ) * xo21(i) s32 = ( xx(6) - xx(5) ) * xo32(i) as21 = abs( s21 ) as32 = abs( s32 ) c if ( ixvs2(i) .eq. 0 ) then if ( 6.0 * as21 .le. as32 ) then dkap = s21 else if ( 2.0 * as21 .lt. as32 ) then omf = 1.5 - as32 / ( 4.0 * as21 ) dkap = s21 - omf * x01o31(i) * ( s21 - s32 ) else if ( 2.0 * as32 .ge. as21 ) then dkap = x30o31(i) * s21 + x01o31(i) * s32 else if ( 6.0 * as32 .gt. as21 ) then omf = 1.5 - as21 / ( 4.0 * as32 ) dkap = s32 - omf * x30o31(i) * ( s32 - s21 ) else dkap = s32 endif qdersl = xx(5) return endif c if ( 6.0 * as21 .le. as32 ) then c if ( ixvs2(i) .le. 0 ) then qdersl = x02(i) * s21 + xx(5) dkap = s21 else qdersl = x0230o32(i) * s21 + x0202o32(i) * s32 + xx(5) dkap = x30p20o32(i) * s21 + x02o32two(i) * s32 endif c else if ( 2.0 * as21 .lt. as32 ) then c omf_ds = ( 1.5 - as32 / ( 4.0 * as21 ) ) * ( s32 - s21 ) if ( ixvs2(i) .le. 0 ) then qdersl = omf_ds * x0201o31(i) + x01(i) * s21 + xx(4) dkap = s21 + omf_ds * x02p01o31(i) else qdersl = x0230o32(i) * s21 + x0202o32(i) * s32 $ + omf_ds * x023021o3231(i) + xx(5) dkap = x30p20o32(i) * s21 + x02o32two(i) * s32 $ + omf_ds * x30p2021o3231(i) endif c else if ( 2.0 * as32 .ge. as21 ) then c qdersl = x0201o31(i) * s32 - x0203o31(i) * s21 + xx(5) dkap = x30p20o31(i) * s21 + x02p01o31(i) * s32 c else if ( 6.0 * as32 .gt. as21 ) then c omf_ds = ( 1.5 - as21 / ( 4.0 * as32 ) ) * ( s32 - s21 ) if ( ixvs2(i) .ge. 0 ) then qdersl = omf_ds * x0203o31(i) + x03(i) * s32 + xx(6) dkap = s32 + omf_ds * x02p03o31(i) else qdersl = x0201o21(i) * s32 - x0202o21(i) * s21 $ - omf_ds * x020132o2131(i) + xx(5) dkap = x02p01o21(i) * s32 - x02o21two(i) * s21 $ - omf_ds * x02p0132o2131(i) endif c else if ( ixvs2(i) .ge. 0 ) then qdersl = x02(i) * s32 + xx(5) dkap = s32 else qdersl = x0201o21(i) * s32 - x0202o21(i) * s21 + xx(5) dkap = x02p01o21(i) * s32 - x02o21two(i) * s21 endif c return end c c****************************************************************************** c function qchksl(ic,i,x,y1,y2,y3,x1,x2,x3) c ========================================= c c..... this function calls quadsl(ic,i,x,y1,y2,y3,x1,x2,x3) to perform a c quadratic interpolation, but first checks whether any pair of x-values c is too close together to make a quadratic interpolation reasonable; c if this is the case, something more nearly linear is used instead. c c QCHKSL is used only for Ferguson et al. 2005 molecular opacities at the c highest X-interval; thus one can assume x1 < x2 and ( x2 < x3 or x2 = x3 ). c parameter ( ratbeg=0.08, ratful=0.04, ratdel=1./(ratbeg-ratful) ) c common /c_qchksl_opal_z/ x01o21p31(10), facq(10), omfq(10), $ iokq(10) save /c_qchksl_opal_z/ c___ dimension xx(3), yy(3) c=== c ! qchksl may be called many times with same x,x1,x2,x3; c ! compute & store X-deltas only if flag ic says so: if ( ic .eq. 0 ) then c call qchkslsto( i, x, x1, x2, x3 ) c-debug[ else c xx(1) = x1 xx(2) = x2 xx(3) = x3 dxrat = abs( xx(3) - xx(2) ) / abs( xx(3) - xx(1) ) if ( dxrat .ge. ratbeg ) then if ( iokq(i) .ne. 1 ) then write(6,100) iokq(i), 1, i, x, x1, x2, x3 100 format(' QCHKSL Error: iokq(i) =',i3, $ ' [should be',i3,']: from i =',i3, $ ' x =',1p,e15.7,' x1,2,3 =',3e15.7) stop ' STOP -- QCHKSL Error: bad iokq(i) .ne. 1 ' endif else if ( abs( x01o21p31(i) - ( x - xx(1) ) $ / ( ( xx(2) - xx(1) ) + ( xx(3) - xx(1) ) ) ) .gt. $ small_1m6 ) then write(6,110) 'x01o21p31', x01o21p31(i), +( x - xx(1) ) $ / ( ( xx(2) - xx(1) ) + ( xx(3) - xx(1) ) ), $ i, x, x1, x2, x3 110 format(' QCHKSL Error: ',a,'(i) =',1p,e15.7, $ ' [should be ',e15.7,']: from i =',i3, $ ' x =',1p,e15.7,' x1,2,3 =',3e15.7) stop ' STOP -- QCHKSL Error: bad x01o21p31(i) ' endif if ( dxrat .gt. ratful ) then if ( iokq(i) .ne. 0 ) then write(6,100) iokq(i), 1, i, x, x1, x2, x3 stop ' STOP -- QCHKSL Error: bad iokq(i) .ne. 0 ' else if ( abs( facq(i) - (dxrat-ratful)*ratdel ) .gt. $ small_1m6 ) then write(6,110) 'facq', facq(i), +(dxrat-ratful)*ratdel, $ i, x, x1, x2, x3 stop ' STOP -- QCHKSL Error: bad facq(i) ' endif else if ( iokq(i) .ne. -1 ) then write(6,100) iokq(i), -1, i, x, x1, x2, x3 stop ' STOP -- QCHKSL Error: bad iokq(i) .ne. -1 ' endif endif c-debug] endif c if ( iokq(i) .gt. 0 ) then qchksl = quadsl(1,i,x,y1,y2,y3,x1,x2,x3) else yy(1) = y1 yy(2) = y2 yy(3) = y3 if ( iokq(i) .lt. 0 ) then qchksl = yy(1) + x01o21p31(i) $ * ( ( yy(2) - yy(1) ) + ( yy(3) - yy(1) ) ) else qchksl = omfq(i) * ( yy(1) + x01o21p31(i) $ * ( ( yy(2) - yy(1) ) + ( yy(3) - yy(1) ) ) ) $ + facq(i) * quadsl(1,i,x,y1,y2,y3,x1,x2,x3) endif endif c return end c c****************************************************************************** c function quad(ic,i,x,y1,y2,y3,x1,x2,x3) c ======================================= c c..... this function performs a quadratic interpolation. c parameter ( small_1m6=1.e-6 ) c c Storage for x,dx_i values that need not be computed on each call (see "ic"); c NOTE that this same storage is used by all of QUAD, QDER, and QCHK. c common /c3quad_opal_z/ a21(30), a32(30), d21(30), d32(30) save /c3quad_opal_z/ c___ dimension xx(6) c=== xx(5) = y2 c ! quad may be called many times with same x,x1,x2,x3; c ! compute & store X-deltas only if flag ic says so: if ( ic .eq. 0 ) then call quadsto( i, x, x1, x2, x3 ) c-debug[ else xx(4) = x xx(1) = x1 xx(2) = x2 xx(3) = x3 xx(6) = ( xx(4) - xx(2) ) / ( xx(3) - xx(1) ) if ( abs( a21(i) - xx(6) * ( xx(3) - xx(4) ) $ / ( xx(2) - xx(1) ) ) .gt. small_1m6 ) then write(6,110) 'a21', a21(i), xx(6) * ( xx(3) - xx(4) ) $ / ( xx(2) - xx(1) ), i, x, x1, x2, x3 110 format(' QUAD Error: ',a,'(i) =',1p,e15.7, $ ' [should be ',e15.7,']: from i =',i3, $ ' x =',1p,e15.7,' x1,2,3 =',3e15.7) stop ' STOP -- QUAD Error: bad a21(i) ' else if ( abs( a32(i) - xx(6) * ( xx(4) - xx(1) ) $ / ( xx(3) - xx(2) ) ) .gt. small_1m6 ) then write(6,110) 'a32', a32(i), xx(6) * ( xx(4) - xx(1) ) $ / ( xx(3) - xx(2) ), i, x, x1, x2, x3 stop ' STOP -- QUAD Error: bad a32(i) ' endif c-debug] endif c quad = a21(i) * ( xx(5) - y1 ) + a32(i) * ( y3 - xx(5) ) + xx(5) return end c c****************************************************************************** c function qder(ic,i,x,y1,y2,y3,x1,x2,x3) c ======================================= c c..... this function performs a quadratic interpolation; it is identical to the c function quad, except that it also computes the derivative dkap of the c quadratic at the given position x (see common /d_opal_z/ below). c parameter ( small_1m6=1.e-6 ) c c COMMON /d_opal_z/ : dkap returns the derivative (in interpolation-direction) c common /d_opal_z/ dkap save /d_opal_z/ c c Storage for x,dx_i values that need not be computed on each call (see "ic"); c NOTE that this same storage is used by all of QUAD, QDER, and QCHK. c common /c3quad_opal_z/ a21(30), a32(30), d21(30), d32(30) save /c3quad_opal_z/ c___ dimension xx(9) c=== xx(5) = y2 xx(6) = xx(5) - y1 xx(7) = y3 - xx(5) c ! qder may be called many times with same x,x1,x2,x3; c ! compute & store X-deltas only if flag ic says so: if ( ic .eq. 0 ) then call qdersto( i, x, x1, x2, x3 ) c-debug[ else xx(4) = x xx(1) = x1 xx(2) = x2 xx(3) = x3 xx(8) = 1.0 / ( ( xx(3) - xx(1) ) * ( xx(2) - xx(1) ) ) xx(9) = 1.0 / ( ( xx(3) - xx(1) ) * ( xx(3) - xx(2) ) ) if ( abs( a21(i) - ( xx(4) - xx(2) ) $ * ( xx(3) - xx(4) ) * xx(8) ) .gt. small_1m6 ) then write(6,110) 'a21', a21(i), +( xx(4) - xx(2) ) $ * ( xx(3) - xx(4) ) * xx(8), i, x, x1, x2, x3 110 format(' QDER Error: ',a,'(i) =',1p,e15.7, $ ' [should be ',e15.7,']: from i =',i3, $ ' x =',1p,e15.7,' x1,2,3 =',3e15.7) stop ' STOP -- QDER Error: bad a21(i) ' else if ( abs( a32(i) - ( xx(4) - xx(2) ) $ * ( xx(4) - xx(1) ) * xx(9) ) .gt. small_1m6 ) then write(6,110) 'a32', a32(i), +( xx(4) - xx(2) ) $ * ( xx(4) - xx(1) ) * xx(9), i, x, x1, x2, x3 stop ' STOP -- QDER Error: bad a32(i) ' endif c-debug] endif c dkap = d21(i) * xx(6) + d32(i) * xx(7) qder = a21(i) * xx(6) + a32(i) * xx(7) + xx(5) return end c c****************************************************************************** c function qchk(ic,i,x,y1,y2,y3,x1,x2,x3) c ======================================= c c..... this function calls quad(ic,i,x,y1,y2,y3,x1,x2,x3) to perform a c quadratic interpolation, but first checks whether any pair of x-values c is too close together to make a quadratic interpolation reasonable; c if this is the case, something more nearly linear is used instead. c Also, for C or O < 0.0 (i.e., x < x1 < x3, as can occur for CNO-depleted c matter), linear extrapolation is used. Note that opacity derivatives c are not needed for C-O interpolation, and are not computed. c c QCHK is used for interpolating OPAL opacities in C and O, and (when X is c large) for interpolating Ferguson et al. 2005 molecular opacities in X. c c QCHK is really neaded only for Z slightly less than 0.02, 0.05, or 0.07, or c for 0.03 < Z < 0.05 or 0.08 < Z < 0.1, where the C+O=1-X-Z line for one c or more of the X-values passes very close above one of the usual C-O grid c points; this can result in quadratic interpolation errors in the opacities c of more than an order of magnitude. The solution is to avoid using a c quadratic fit if two of the three x-values are too close together. c c NOTE that if a quadratic is fitted through 3 points with a large c interval R=(x2-x1) with values differing by D=(y2-y1), next to a much c smaller interval r=(x3-x2) with values differing by d=(y3-y2), and c the close-together points y2 and y3 have a relative error E, then c at the middle of the large interval R this error is magnified by c a factor of (1/4)(R/r). At the middle of the interval R, the c difference between a linear and a quadratic is (1/4)[D-(R/r)d]; c if this is less than the magnified error (1/4)(R/r)E, i.e., c if E > | (r/R)D - d | , then the linear fit is better. For Z < 0.04, c the opacity errors should be a few percent, and the RELATIVE error c bewteen adjacent nearly-identical compositions may be much smaller: c for example, in G91x35z03, compare the following tables: c TABLE # 7 Grvss'91 (12/92) X=0.3500 Y=0.0200 Z=0.0300 dXc=0.6000 dXo=0.0000 c TABLE # 15 Grvss'91 (12/92) X=0.3500 Y=0.0100 Z=0.0300 dXc=0.6000 dXo=0.0100 c TABLE # 16 Grvss'91 (12/92) X=0.3500 Y=0.0000 Z=0.0300 dXc=0.6100 dXo=0.0100 c Systematic opacity differences between these tables (due to differences c between their compositions) appear to be of order 0.01 or less in c general, and RANDOM errors in these differences appear to be, at most, c of order 0.001 (i.e., 0.2 percent). Here in QCHK, a quadratic-error c magnification of nearly 3 is allowed (R/r=11.5) before beginning to c switch over to linear interpolation; the switch-over is complete at c R/r=24. The ratios used in the code below are actually r/(r+R). c parameter ( small_1m6=1.e-6 ) c parameter ( ratbeg=0.08, ratful=0.04, ratdel=1./(ratbeg-ratful) ) c c Storage for factors that need not be computed on each call; c NOTE that QCHK calls QUAD, and may also call QCHKSTO which calls QUADSTO. c common/c_qchk_opal_z/ facq(30),dxinvq(30),omfq(30), $ iokq(30),iloq(30),i1q(30),i2q(30),lin(30) save /c_qchk_opal_z/ c common /c3quad_opal_z/ a21(30), a32(30), d21(30), d32(30) save /c3quad_opal_z/ c dimension xx(3), yy(3), r(3) c if ( ic .eq. 0 ) then c call qchksto( i, x, x1, x2, x3 ) c c-debug[ else c xx(1) = x1 xx(2) = x2 xx(3) = x3 c if ( x .lt. xx(1) .and. xx(3) - xx(1) .gt. small_1m6 ) then c xloq = max( xx(2) - xx(1) , small_1m6 ) omf = max( 0.0 , min( 1.0 , ( xx(3) - xx(1) ) / xloq ) ) if ( lin(i) .ne. 1 ) then write(6,100) 'lin', lin(i), 1, i, x, x1, x2, x3 100 format(' QCHK Error: ',a,'(i) =',i3, $ ' [should be',i3,']: from i =',i3, $ ' x =',1p,e15.7,' x1,2,3 =',3e15.7) stop ' STOP -- QCHK Error: bad lin(i) .ne. 1 ' else if ( abs( omfq(i) - omf * ( x - xx(1) ) $ / ( xx(3) - xx(1) ) ) .gt. small_1m6 ) then write(6,110) 'omfq', omfq(i), omf * ( x - xx(1) ) $ / ( xx(3) - xx(1) ), i, lin(i), x, x1, x2, x3 110 format(' QCHK Error: ',a,'(i) =',1p,e15.7, $ ' [should be ',e15.7,']: from i =',i3, $ ' lin(i) =',i3,' x =',1p,e15.7,' x1,2,3 =',3e15.7) stop ' STOP -- QCHK Error: bad omfq(i) ' else if ( abs( facq(i) - ( 1. - omf ) $ * ( x - xx(1) ) / xloq ) .gt. small_1m6 ) then write(6,110) 'facq', facq(i), +( 1. - omf ) $ * ( x - xx(1) ) / xloq, i, lin(i), x, x1, x2, x3 stop ' STOP -- QCHK Error: bad facq(i) ' endif c else if ( lin(i) .ne. 0 ) then c write(6,100) 'lin', lin(i), 0, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad lin(i) .ne. 0 ' c else c r(1) = abs( xx(3) - xx(2) ) r(2) = abs( xx(3) - xx(1) ) r(3) = abs( xx(2) - xx(1) ) c dxrat = min(r(1),r(2),r(3))/max(r(1),r(2),r(3)) c if ( dxrat .ge. ratbeg ) then tmp = ( x - xx(2) ) / ( xx(3) - xx(1) ) if ( iokq(i) .ne. 1 ) then write(6,100) 'iokq', iokq(i), 1, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad iokq(i) .ne. 1 ' else if ( abs( a21(i) - tmp * ( xx(3) - x ) $ / ( xx(2) - xx(1) ) ) .gt. small_1m6 ) then write(6,110) 'a21', a21(i), tmp * ( xx(3) - x ) $ / ( xx(2) - xx(1) ), i, lin(i), x, x1, x2, x3 stop ' STOP -- QCHK Error: bad a21(i) ' else if ( abs( a32(i) - tmp * ( x - xx(1) ) $ / ( xx(3) - xx(2) ) ) .gt. small_1m6 ) then write(6,110) 'a32', a32(i), tmp * ( x - xx(1) ) $ / ( xx(3) - xx(2) ), i, lin(i), x, x1, x2, x3 endif else if ( r(3) .lt. min(r(1),r(2)) ) then if ( iloq(i) .ne. 3 ) then write(6,100) 'iloq', iloq(i), 3, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad iloq(i) .ne. 3 ' else if ( i1q(i) .ne. 1 ) then write(6,100) 'i1q', i1q(i), 1, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad i1q(i) .ne. 1 ' else if ( i2q(i) .ne. 2 ) then write(6,100) 'i2q', i2q(i), 2, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad i2q(i) .ne. 2 ' endif else if ( r(2) .lt. r(1) ) then if ( iloq(i) .ne. 2 ) then write(6,100) 'iloq', iloq(i), 2, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad iloq(i) .ne. 2 ' else if ( i1q(i) .ne. 3 ) then write(6,100) 'i1q', i1q(i), 3, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad i1q(i) .ne. 3 ' else if ( i2q(i) .ne. 1 ) then write(6,100) 'i2q', i2q(i), 1, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad i2q(i) .ne. 1 ' endif else if ( iloq(i) .ne. 1 ) then write(6,100) 'iloq', iloq(i), 1, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad iloq(i) .ne. 1 ' else if ( i1q(i) .ne. 2 ) then write(6,100) 'i1q', i1q(i), 2, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad i1q(i) .ne. 2 ' else if ( i2q(i) .ne. 3 ) then write(6,100) 'i2q', i2q(i), 3, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad i2q(i) .ne. 3 ' endif if ( abs( dxinvq(i) - ( x - xx(iloq(i)) ) $ / ( ( xx(i1q(i)) + xx(i2q(i)) ) * 0.5 $ - xx(iloq(i)) ) ) .gt. small_1m6 ) then write(6,110) 'dxinvq', dxinvq(i), $ +( x - xx(iloq(i)) ) $ / ( ( xx(i1q(i)) + xx(i2q(i)) ) * 0.5 $ - xx(iloq(i)) ), i, lin(i), x, x1, x2, x3 stop ' STOP -- QCHK Error: bad dxinvq(i) ' endif if ( dxrat .gt. ratful ) then tmp = ( x - xx(2) ) / ( xx(3) - xx(1) ) if ( iokq(i) .ne. 0 ) then write(6,100) 'iokq', iokq(i), 0, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad iokq(i) .ne. 0 ' else if ( abs( facq(i) - ( dxrat - ratful ) $ * ratdel ) .gt. small_1m6 ) then write(6,110) 'facq', facq(i), +( dxrat - ratful ) $ * ratdel, i, lin(i), x, x1, x2, x3 stop ' STOP -- QCHK Error: bad facq(i) ' else if ( abs( a21(i) - tmp * ( xx(3) - x ) $ / ( xx(2) - xx(1) ) ) .gt. small_1m6 ) then write(6,110) 'a21', a21(i), tmp * ( xx(3) - x ) $ / ( xx(2) - xx(1) ), i, lin(i), x, x1, x2, x3 stop ' STOP -- QCHK Error: bad a21(i) ' else if ( abs( a32(i) - tmp * ( x - xx(1) ) $ / ( xx(3) - xx(2) ) ) .gt. small_1m6 ) then write(6,110) 'a32', a32(i), tmp * ( x - xx(1) ) $ / ( xx(3) - xx(2) ), i, lin(i), x, x1, x2, x3 endif else if ( iokq(i) .ne. -1 ) then write(6,100) 'iokq', iokq(i), -1, i, x, x1, x2, x3 stop ' STOP -- QCHK Error: bad iokq(i) .ne. -1 ' else if ( facq(i) .ne. 0.0 ) then write(6,110) 'facq', facq(i), 0.0, $ i, lin(i), x, x1, x2, x3 stop ' STOP -- QCHK Error: bad facq(i) .ne. 0.0 ' endif endif c endif c-debug] endif c if ( lin(i) .gt. 0 ) then qchk = ( y2 - y1 ) * facq(i) + ( y3 - y1 ) * omfq(i) + y1 else if ( iokq(i) .gt. 0 ) then qchk = a21(i) * ( y2 - y1 ) + a32(i) * ( y3 - y2 ) + y2 else yy(1) = y1 yy(2) = y2 yy(3) = y3 if ( iokq(i) .lt. 0 ) then qchk = ( ( yy(i1q(i)) + yy(i2q(i)) ) * 0.5 $ - yy(iloq(i)) ) * dxinvq(i) + yy(iloq(i)) else qchk = ( ( ( yy(i1q(i)) + yy(i2q(i)) ) * 0.5 $ - yy(iloq(i)) ) * dxinvq(i) + yy(iloq(i)) ) * omfq(i) $ + ( a21(i) * ( yy(2) - yy(1) ) $ + a32(i) * ( yy(3) - yy(2) ) + yy(2) ) * facq(i) endif endif c return end c c****************************************************************************** c c-old; function quad_old(ic,i,x,y1,y2,y3,x1,x2,x3) c =========================================== ! OLD VERSION, INACCURATE; c ! ALLOWS X-VARIATION c..... this function performs a quadratic interpolation. ! FOR ic > 0 c c Storage for dx_i values that need not be computed on each call (see "ic"); c NOTE that this same storage is used by all of QUAD, QDER, and QCHK. c c-old; common /coquad_opal_z/ xx12(30),xx13(30),xx23(30),xx1pxx2(30) c-old; save /coquad_opal_z/ c___ c-old; dimension xx(3),yy(3) c=== c-old; xx(1) = x1 c-old; yy(1) = y1 c-old; yy(2) = y2 c-old; yy(3) = y3 c ! quad may be called many times with same x1,x2,x3; c ! compute & store X-deltas only if flag ic says so: c-old; if ( ic .eq. 0 ) then c-old; xx(2) = x2 c-old; xx(3) = x3 c-old; xx12(i) = 1./(xx(1)-xx(2)) c-old; xx13(i) = 1./(xx(1)-xx(3)) c-old; xx23(i) = 1./(xx(2)-xx(3)) c-old; xx1pxx2(i) = xx(1)+xx(2) c-old; endif c c-old; c3 = ( (yy(1)-yy(2))*xx12(i) - (yy(2)-yy(3))*xx23(i) ) * xx13(i) c-old; c2 = (yy(1)-yy(2))*xx12(i) - xx1pxx2(i) * c3 c-old; c1 = yy(1) - xx(1) * ( c2 + xx(1) * c3 ) c-old; quad_old = c1+x*(c2+x*c3) c-old; return c-old; end c c****************************************************************************** c c-old; function qder_old(ic,i,x,y1,y2,y3,x1,x2,x3) c =========================================== ! OLD VERSION, INACCURATE; c ! ALLOWS X-VARIATION FOR ic > 0 c c..... this function performs a quadratic interpolation; it is identical to the c function quad, except that it also computes the derivative dkap of the c quadratic at the given position x (see common /d_opal_z/ below). c c COMMON /d_opal_z/ : dkap returns the derivative (in interpolation-direction) c c-old; common /d_opal_z/ dkap c-old; save /d_opal_z/ c c Storage for dx_i values that need not be computed on each call (see "ic"); c NOTE that this same storage is used by all of QUAD, QDER, and QCHK. c c-old; common /coquad_opal_z/ xx12(30),xx13(30),xx23(30),xx1pxx2(30) c-old; save /coquad_opal_z/ c___ c-old; dimension xx(3),yy(3) c=== c-old; xx(1) = x1 c-old; yy(1) = y1 c-old; yy(2) = y2 c-old; yy(3) = y3 c ! qder may be called many times with same x1,x2,x3; c ! compute & store X-deltas only if flag ic says so: c-old; if ( ic .eq. 0 ) then c-old; xx(2) = x2 c-old; xx(3) = x3 c-old; xx12(i) = 1./(xx(1)-xx(2)) c-old; xx13(i) = 1./(xx(1)-xx(3)) c-old; xx23(i) = 1./(xx(2)-xx(3)) c-old; xx1pxx2(i) = xx(1)+xx(2) c-old; endif c c-old; c3 = ( (yy(1)-yy(2))*xx12(i) - (yy(2)-yy(3))*xx23(i) ) * xx13(i) c-old; c2 = (yy(1)-yy(2))*xx12(i) - xx1pxx2(i) * c3 c-old; c1 = yy(1) - xx(1) * ( c2 + xx(1) * c3 ) c-old; dkap = c2+(x+x)*c3 c-old; qder_old = c1+x*(c2+x*c3) c-old; return c-old; end c c****************************************************************************** c c-old; function qchk_old(ic,i,x,y1,y2,y3,x1,x2,x3) c =========================================== c c OLD version of qchk, which assumes that x may vary as well as y1, y2, y3 c c-old; parameter ( ratbeg=0.08, ratful=0.04, ratdel=1./(ratbeg-ratful) ) c c Storage for factors that need not be computed on each call (see "ic"); c NOTE that QCHK calls QUAD: the QUAD/QDER storage is controlled by "ic" too. c c-old; common/coqchk_opal_z/ facq(30),iokq(30),iloq(30),i1q(30),i2q(30), c-old; $ dxinvq(30),xloq(30),flin2(30),flin3(30),lin(30) c-old; save /coqchk_opal_z/ c___ c-old; dimension xx(3),yy(3),r(3) c=== c ! qchk may be called many times with same x1,x2,x3; c ! compute & store X-deltas only if flag ic says so: c-old; if ( ic .eq. 0 ) then c-old; xx(1) = x1 c-old; xx(2) = x2 c-old; xx(3) = x3 c-old; r(1) = abs(xx(3)-xx(2)) c-old; r(2) = abs(xx(3)-xx(1)) c-old; r(3) = abs(xx(2)-xx(1)) c-old; if ( xx(3) - xx(1) .gt. 1.e-6 ) then c-old; lin(i) = 1 c-old; omf = max( 0. , min( 1. , c-old; $ ( xx(3) - xx(1) ) / max( xx(2) - xx(1) , 1.e-6 ) ) ) c-old; flin3(i) = omf / ( xx(3) - xx(1) ) c-old; flin2(i) = ( 1. - omf ) / max( xx(2) - xx(1) , 1.e-6 ) c-old; else c-old; lin(i) = 0 c-old; endif c-old; dxrat = min(r(1),r(2),r(3))/max(r(1),r(2),r(3)) c-old; if ( dxrat .ge. ratbeg ) then c-old; iokq(i) = 1 c-old; else c-old; if ( r(3) .lt. min(r(1),r(2)) ) then c-old; iloq(i) = 3 c-old; else if ( r(2) .lt. r(1) ) then c-old; iloq(i) = 2 c-old; else c-old; iloq(i) = 1 c-old; endif c-old; i1q(i) = mod(iloq(i),3)+1 c-old; i2q(i) = 6-i1q(i)-iloq(i) c-old; xloq(i) = xx(iloq(i)) c-old; dxinvq(i) = 1./((xx(i1q(i))+xx(i2q(i)))*.5-xloq(i)) c-old; if ( dxrat .gt. ratful ) then c-old; iokq(i) = 0 c-old; facq(i) = (dxrat-ratful)*ratdel c-old; else c-old; iokq(i) = -1 c-old; facq(i) = 0. c-old; endif c-old; endif c-old; endif c c-old; if ( x .lt. x1 ) then c-old; if ( lin(i) .gt. 0 ) then c-old; qchk = ( ( y2 - y1 ) * flin2(i) + ( y3 - y1 ) * flin3(i) ) c-old; $ * ( x - x1 ) + y1 c-old; return c-old; endif c-old; endif c c-old; if ( iokq(i) .gt. 0 ) then c-old; qchk = quad_old(ic,i,x,y1,y2,y3,x1,x2,x3) c-old; else c-old; yy(1) = y1 c-old; yy(2) = y2 c-old; yy(3) = y3 c-old; if ( iokq(i) .lt. 0 ) then c-old; qchk = ((yy(i1q(i))+yy(i2q(i)))*.5-yy(iloq(i))) c-old; $ *(x-xloq(i))*dxinvq(i)+yy(iloq(i)) c-old; else c-old; qchk = (((yy(i1q(i))+yy(i2q(i)))*.5-yy(iloq(i))) c-old; $ *(x-xloq(i))*dxinvq(i)+yy(iloq(i)))*(1.-facq(i)) c-old; $ +facq(i)*quad_old(ic,i,x,y1,y2,y3,x1,x2,x3) c-old; endif c-old; endif c c-old; return c-old; end c c****************************************************************************** c function qzinter(ic,i,z,nmorez,f1,f2,f3,f4,z1,z2,z3,z4,zdel) c ============================================================ c c..... this function performs linear, quadratic, or bi-quadratic interpolation, c of logKappa in log(Z+zdel), for nmorez = 1, 2, or 3, respectively; c inputs are Z, nmorez = one less than the number of Z-values to c interpolate among, logKappa values f1 thru f4, Z-values z1 thru z4, and c zdel = 0.001 to make things work correctly near Z = 0. Note that this c function is also sometimes used to interpolate in X or C or O. It makes c use of the quadratic-interpolation function quad. c c Storage for values that need not be computed on each call: c common/qzint_opal_z/ v1(15), v2(15), v3(15), v4(15), v5(15) save /qzint_opal_z/ c=== if ( ic .eq. 0 ) then if ( nmorez .gt. 0 ) then c-debug[ if ( zdel .lt. 0.000001 .or. zdel .gt. 0.1011 ) stop $ ' STOP -- QZINTER: bad Zdel value. ' c-debug] v5(i) = log10(z+zdel) v1(i) = log10(z1+zdel) v2(i) = log10(z2+zdel) if ( nmorez .eq. 1 ) then v3(i) = ( v2(i) - v5(i) ) / ( v2(i) - v1(i) ) v4(i) = 1. - v3(i) else v3(i) = log10(z3+zdel) if ( nmorez .eq. 2 ) then call quadsto( i, v5(i), v1(i), v2(i), v3(i) ) else v4(i) = log10(z4+zdel) call quad4sto( i, v5(i), v1(i), v2(i), v3(i), v4(i) ) endif endif endif c-debug[ c-debug; else if ( nmorez .gt. 0 ) then c-debug; if ( max( abs( v1(i) - log10(z1+zdel) ) , c-debug; $ abs( v2(i) - log10(z2+zdel) ) , c-debug; $ abs( v5(i) - log10(z+zdel) ) ) .gt. 1.e-5 ) stop c-debug; $ ' STOP -- QZINTER: Error: expected same X-values. ' c-debug; if ( nmorez .eq. 1 ) then c-debug; if ( abs( v3(i) - (v2(i)-v5(i))/(v2(i)-v1(i)) ) .gt. c-debug; $ 1.e-5 ) stop c-debug; $ ' STOP -- QZINTER: Error: expected same X-values. ' c-debug; else c-debug; if ( abs( v3(i) - log10(z3+zdel) ) .gt. 1.e-5 ) stop c-debug; $ ' STOP -- QZINTER: Error: expected same X-values. ' c-debug; if ( nmorez .ge. 3 ) then c-debug; if ( abs( v4(i) - log10(z4+zdel) ) .gt. 1.e-5 ) stop c-debug; $ ' STOP -- QZINTER: Error: expected same X-values. ' c-debug; endif c-debug; endif c-debug] endif c if ( nmorez .le. 0 ) then qzinter = f1 else if ( nmorez .eq. 1 ) then qzinter = max( min(f1,f2) , min( max(f1,f2) , $ v3(i) * f1 + v4(i) * f2 ) ) else if ( nmorez .eq. 2 ) then if ( v5(i) .lt. v2(i) ) then vlo = min(f1,f2) vhi = max(f1,f2) else vlo = min(f2,f3) vhi = max(f2,f3) endif qzinter = max( vlo , min( vhi , quadget(i,f1,f2,f3) ) ) else qzinter = max( min(f2,f3) , min( max(f2,f3) , $ quad4get(i,f1,f2,f3,f4) ) ) endif c return end c c****************************************************************************** c function mixfind(iu,iofe,igetzxi,irew,itab,l,zget,xget,cget,oget) c ================================================================= c parameter ( small_1m5=1.e-5 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( ks81=ntm-3, ks83=ks81+1, ks60=ks81-21, ks61=ks60+1, $ alrlo=-8.0, flogtlo=3.75, flogt60=6.0, flogt81=8.1 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c character*2 cel_opalmixes(nel_zmix) character*8 cfile_opalmixes(n_zmixes) common/opalmixes/ xiz_mix(nel_zmix),fninz_mix(nel_zmix), $ bracketife_mix(nel_zmix),bracketofe_opalmixes(n_zmixes), $ xofe_opalmixes(n_zmixes),xiz_opalmixes(nel_zmix,n_zmixes), $ fninz_opalmixes(nel_zmix,n_zmixes), $ cel_opalmixes,cfile_opalmixes save /opalmixes/ c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c___ character*255 cin character*1 ch(255) equivalence (ch(1),cin) c-debug-chk[ c-debug-chk; common /mixfind_opal_debug_chk/ iout_debug_chk(-10:10) c-debug-chk;c--- c-debug-chk; data iout_debug_chk / 21 * 99999 / c-debug-chk] c=== ifound = 0 cin = ' ' c ! if must rewind to beginning of file: if ( irew .ne. 0 ) then c rewind(iu) l = 0 c ! else, if must get Xi/Z values: else if ( igetzxi .ne. 0 ) then c do while( cin(1:31) .ne. ' Element Abundance - relative' ) l = l + 1 read(iu,'(a255)',end=900) cin enddo sum_X = 0. sum_XoverA = 0. kel = 1 c ! begin loop to get Xi/Z values do while( kel .le. nel_zmix ) l = l + 1 read(iu,'(a255)',end=900) cin if ( cin(1:16) .eq. ' Table Summaries' ) goto 50 ke = 255 do while( ke .gt. 1 .and. ch(ke) .eq. ' ' ) ke = ke-1 enddo kb = 1 do while( kb .le. ke .and. ch(kb) .eq. ' ' ) kb = kb+1 enddo if ( cin(kb:kb+1) .eq. cel_opalmixes(kel) ) then c ! get Ni if ( ke .lt. kb+20 ) goto 50 read(cin(ke-8:ke),'(f9.6)',err=50) vx c ! last may be atomic wt if ( vx .gt. 1.000001 ) then ke = ke-9 do while( ke .gt. 1 .and. ch(ke) .eq. ' ' ) ke = ke-1 enddo if ( ke .lt. kb+20 ) goto 50 read(cin(ke-8:ke),'(f9.6)',err=50) vx endif sum_X = sum_X + vx sum_XoverA = sum_XoverA + vx / atwt_opalGS98(kel) c ! get Xi ke = ke-9 do while( ke .gt. 1 .and. ch(ke) .eq. ' ' ) ke = ke-1 enddo if ( ke .lt. kb+11 ) goto 50 read(cin(ke-7:ke),'(f8.6)',err=50) vn c if ( iofe .le. 0 ) then if ( igetzxi .gt. 0 ) then c-debug-chk[ c-debug-chk; if ( iout_debug_chk(iofe) .gt. 0 ) then c-debug-chk; if ( kel .eq. 1 ) write(6,3813) iofe, c-debug-chk; $ cfile_opalGS98(-iofe) c-debug-chk; 3813 format(' '/' Mix in GS98hz and in file',i3, c-debug-chk; $ ' = ',a40/ c-debug-chk; $ ' i el GS98:Ni GS98:Xi', c-debug-chk; $ ' stored:Ni stored:Xi read:Ni ', c-debug-chk; $ ' read:Xi sto[i/Fe]'/ c-debug-chk; $ ' -- -- --------- ---------', c-debug-chk; $ ' --------- --------- ---------', c-debug-chk; $ ' --------- --------') c-debug-chk; write(6,3814) kel, cel_opalmixes(kel), c-debug-chk; $ fninz_opalGS98(kel,1), c-debug-chk; $ xiz_opalGS98(kel,1), c-debug-chk; $ fninz_opalGS98(kel,-iofe), c-debug-chk; $ xiz_opalGS98(kel,-iofe), vn, vx, c-debug-chk; $ log10( ( c-debug-chk; $ max(fninz_opalGS98(kel,-iofe),1.e-36) c-debug-chk; $ * fninz_opalGS98(kel_fe,1) ) c-debug-chk; $ / ( max(fninz_opalGS98(kel_fe,-iofe), c-debug-chk; $ 1.e-36) * fninz_opalGS98(kel,1) ) ) c-debug-chk; 3814 format(i3,': ',a2,' --',6f10.7,f9.5) c-debug-chk; endif c-debug-chk] xiz_opalGS98(kel,-iofe) = vx fninz_opalGS98(kel,-iofe) = vn else if ( max( abs( fninz_opalGS98(kel,-iofe) - vn ) $ , abs( xiz_opalGS98(kel,-iofe) - vx ) ) $ .gt. 0.000015 ) then if ( iofe .lt. -1 .and. $ cfile_opalGS98(-iofe) .eq. ' ' ) then io_t = 4 else io_t = -iofe endif write(6,35) cel_opalmixes(kel), $ cfile_opalGS98(io_t)(1: $ lnblnk(cfile_opalGS98(io_t))), $ vx,xiz_opalGS98(kel,-iofe), $ vn,fninz_opalGS98(kel,-iofe) 35 format(' '/' READCO: Warning: stored value', $ ' differs from new Xi/Z for ',a2, $ ' in alt-file:'/' ',a/ $ ' new Xi/Z',f9.6,' vs.',f9.6, $ ' , new Ni/Nz',f9.6,' vs.',f9.6/' ') endif else if ( igetzxi .gt. 0 ) then xiz_opalmixes(kel,iofe) = vx fninz_opalmixes(kel,iofe) = vn c-debug-chk[ c-debug-chk; if ( iout_debug_chk(iofe) .gt. 0 ) then c-debug-chk; if ( kel .eq. 1 ) write(6,3813) iofe, c-debug-chk; $ cfile_opalmixes(iofe) c-debug-chk; write(6,3814) kel, cel_opalmixes(kel), c-debug-chk; $ fninz_opalmixes(kel,1), c-debug-chk; $ xiz_opalmixes(kel,1), c-debug-chk; $ fninz_opalmixes(kel,iofe), c-debug-chk; $ xiz_opalmixes(kel,iofe), vn, vx, c-debug-chk; $ log10( c-debug-chk; $ ( max(fninz_opalmixes(kel,iofe),1.e-36) c-debug-chk; $ * fninz_opalmixes(kel_fe,1) ) c-debug-chk; $ / ( max(fninz_opalmixes(kel_fe,iofe), c-debug-chk; $ 1.e-36) * fninz_opalmixes(kel,1) ) ) c-debug-chk; endif c-debug-chk] else if ( max( abs( fninz_opalmixes(kel,iofe) - vn ) , $ abs( xiz_opalmixes(kel,iofe) - vx ) ) $ .gt. 0.000015 ) then write(6,40) cel_opalmixes(kel),cfile_opalmixes(iofe), $ vx,xiz_opalmixes(kel,iofe), $ vn,fninz_opalmixes(kel,iofe) 40 format(' '/' READCO: Warning: new Xi/Z for ',a2, $ ' in ',a8,' mix differs from stored value:'/ $ ' new Xi/Z',f9.6,' vs.',f9.6, $ ' , new Ni/Nz',f9.6,' vs.',f9.6/' ') c c-dont; goto 60 endif kel = kel+1 endif c ! end of loop to get Xi/Z values enddo c ! check Xi vs Ni; get xO/xFe and [O/Fe] if ( igetzxi .gt. 0 ) then kel_err = 0 if ( iofe .le. 0 ) then do kel = 1, nel_zmix if ( abs( xiz_opalGS98(kel,-iofe) $ / ( atwt_opalGS98(kel) * sum_XoverA ) $ - fninz_opalGS98(kel,-iofe) ) .gt. 0.00001 ) then kel_err = kel_err + 1 write(6,4613) kel, cel_opalmixes(kel), iofe, $ fninz_opalGS98(kel,-iofe), $ xiz_opalGS98(kel,-iofe) $ / ( atwt_opalGS98(kel) * sum_XoverA ) 4613 format(' READCO: Error in element',i3, $ ' = "',a2,'" when reading in mix',i3,':'/ $ ' number fraction',f10.6,' does not match', $ f10.6,' = (Xi/Ai) / [Sum{Xi/Ai}]') endif xiz_opalGS98(kel,-iofe) = $ xiz_opalGS98(kel,-iofe) / sum_X fninz_opalGS98(kel,-iofe) = xiz_opalGS98(kel,-iofe) $ / ( atwt_opalGS98(kel) * sum_XoverA ) enddo c-debug-chk[ c-debug-chk; if ( iout_debug_chk(iofe) .gt. 0 ) then c-debug-chk; write(6,3815) xofe_opalGS98(1), c-debug-chk; $ bracketofe_opalGS98(1), c-debug-chk; $ xofe_opalGS98(-iofe), c-debug-chk; $ bracketofe_opalGS98(-iofe), c-debug-chk; $ fninz_opalGS98(kel_o,-iofe) c-debug-chk; $ / max(fninz_opalGS98(kel_fe,-iofe),1.e-36), c-debug-chk; $ log10( ( fninz_opalGS98(kel_o,-iofe) c-debug-chk; $ / max(fninz_opalGS98(kel_fe,-iofe),1.e-36) ) c-debug-chk; $ / xofe_opalGS98(1) ) c-debug-chk; 3815 format('O/Fe,[O/Fe]',6f10.6/' ') c-debug-chk; iout_debug_chk(iofe) = iout_debug_chk(iofe) - 1 c-debug-chk; endif c-debug-chk] xofe_opalGS98(-iofe) = fninz_opalGS98(kel_o,-iofe) $ / max( fninz_opalGS98(kel_fe,-iofe) , 1.e-36 ) if ( iofe .ne. 0 ) $ bracketofe_opalGS98(-iofe) = log10( max( 1.e-36 , $ xofe_opalGS98(-iofe) / xofe_opalGS98(1) ) ) else do kel = 1, nel_zmix if ( abs( xiz_opalmixes(kel,iofe) $ / ( atwt_opalGS98(kel) * sum_XoverA ) $ - fninz_opalmixes(kel,iofe) ) .gt. 0.00001 ) then kel_err = kel_err + 1 write(6,4613) kel, cel_opalmixes(kel), iofe, $ fninz_opalmixes(kel,iofe), $ xiz_opalmixes(kel,iofe) $ / ( atwt_opalGS98(kel) * sum_XoverA ) endif xiz_opalmixes(kel,iofe) = $ xiz_opalmixes(kel,iofe) / sum_X fninz_opalmixes(kel,iofe) = xiz_opalmixes(kel,iofe) $ / ( atwt_opalGS98(kel) * sum_XoverA ) enddo c-debug-chk[ c-debug-chk; if ( iout_debug_chk(iofe) .gt. 0 ) then c-debug-chk; write(6,3815) xofe_opalmixes(1), c-debug-chk; $ bracketofe_opalmixes(1), c-debug-chk; $ xofe_opalmixes(iofe), c-debug-chk; $ bracketofe_opalmixes(iofe), c-debug-chk; $ fninz_opalmixes(kel_o,iofe) c-debug-chk; $ / max(fninz_opalmixes(kel_fe,iofe),1.e-36), c-debug-chk; $ log10( ( fninz_opalmixes(kel_o,iofe) c-debug-chk; $ / max(fninz_opalmixes(kel_fe,iofe),1.e-36) ) c-debug-chk; $ / xofe_opalmixes(1) ) c-debug-chk; iout_debug_chk(iofe) = iout_debug_chk(iofe) - 1 c-debug-chk; endif c-debug-chk] xofe_opalmixes(iofe) = fninz_opalmixes(kel_o,iofe) $ / max( fninz_opalmixes(kel_fe,iofe) , 1.e-36 ) bracketofe_opalmixes(iofe) = log10( max( 1.e-36 , $ xofe_opalmixes(iofe) / xofe_opalmixes(1) ) ) endif if ( kel_err .ne. 0 ) stop $ ' STOP -- READCO: Incompatible Ni vs. Xi read in. ' endif c ! no read error: jump to continuation goto 60 c ! if error reading Xi/Z values, say so 50 write(6,20) iofe, kel 20 format(' '/' READCO: Warning: error reading mix',i3, $ ': Z-abundance fractions at element',i3/' ') if ( igetzxi .ge. 9 ) stop $ ' STOP -- READCO: Cannot get mix from user [O/Fe]-file. ' c c ! continuation 60 continue c ! if reading meteoritic mix, we are done if ( iofe .eq. 0 ) then mixfind = 1 return endif c ! end of reading Xi/Z values in file header endif c ! find start of tables if ( irew .ne. 0 .or. igetzxi .ne. 0 ) then do while( cin(1:30) .ne. '******************************' ) l = l + 1 read(iu,'(a255)',end=900) cin enddo igetzxi = 0 endif c ! look for mix with required composition: do while ( ifound .eq. 0 ) l = l + 1 read(iu,'(a255)',end=900) cin if ( cin(1:7) .eq. 'TABLE #' ) then ke = 90 do while( ke .gt. 1 .and. ch(ke) .eq. ' ' ) ke = ke-1 enddo if ( ke .lt. 60 ) goto 900 read(cin(ke-48:ke),100) xat,yat,zat,cat,oat 100 format(3(3x,f6.4),2(5x,f6.4)) if ( max( abs(zat-zget) , abs(xat-xget) , abs(cat-cget), $ abs(oat-oget) ) .lt. 0.000001 ) ifound = -1 endif enddo c ! found required mix: read its table number read(cin(8:10),105) itabat 105 format(i3) c ! if it does not consecutively follow previous table, may need c ! to rewind back to beginning of file for next composition irew = 0 if ( itabat .ne. itab+1 ) irew = 1 itab = itabat c ! check log R values in table head do i = 1,3 l = l + 1 read(iu,'(a255)',end=900) cin enddo l = l + 1 read(iu,110,err=900,end=900) cin(1:4),(alrf(i),i=1,nrm) 110 format(a4,f6.1,18f7.1) c ! this may or may not be useful/correct if ( cin(1:4) .ne. 'logT' .or. $ abs(alrf(1)-alrlo) .gt. small_1m5 ) goto 900 c do k = 2,nrm if ( abs(alrf(k)-alrf(k-1)-0.5) .gt. small_1m5 ) stop $ ' STOP -- READCO: bad log R value in table read in. ' enddo c ! read blank line before first table line l = l + 1 read(iu,'(a255)',end=900) cin c ! table header lines appear correct: ifound = iabs( ifound ) c ! return 900 mixfind = ifound c-debug-chk[ c-debug-chk; if ( ifound .eq. 0 ) c-debug-chk; $ write(6,1739) iu,itab,irew,zget,xget,cget,oget c-debug-chk; 1739 format(' '/' MIXFIND: unit',i3,' after TABLE',i3, c-debug-chk; $ ', irew=',i2,': could not find mix Z=',f10.7, c-debug-chk; $ ' X=',f10.7,' C=',f10.7,' O=',f10.7) c-debug-chk] if ( ifound .eq. 0 ) irew = 1 return end c c****************************************************************************** c subroutine chk_dir_name( cdirin, copdir, kope ) c =============================================== c character*(*) cdirin character*255 copdir c character*1 cb(6) common /chkpoc/ cb save /chkpoc/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c--- c-dir; logical lxst c=== last = lnblnk( cdirin ) ibeg = max( 1 , non_blank_begin(cdirin) ) c kope = last - ibeg + 1 c if ( kope .eq. 0 ) then c copdir = ' ' c else c if ( level_err .gt. 0 ) then iblank = num_blanks_contained( cdirin ) if ( iblank .gt. 0 ) then write(6,10) iblank, cdirin(ibeg:last) 10 format(' WARNING:',i5,' blanks contained in', $ ' directory name:'/' ',a) if ( level_err .ge. 2 ) then kope = -9 return endif endif endif c if ( cdirin(last:last) .ne. cb(1) .and. $ cdirin(last:last) .ne. cb(2) ) kope = kope + 1 c if ( kope .gt. 246 ) then write(6,20) kope, cdirin(ibeg:last) 20 format(' Error: length',i5, $ ' exceeds 246 for directory name:'/' ',a) kope = -9 return endif c copdir = cdirin(ibeg:) c if ( kope .gt. last - ibeg + 1 ) then if ( cb(2) .ne. ']' ) then copdir(kope:kope) = cb(1) else i = kope - 1 do while ( i .gt. 0 .and. $ copdir(max(1,i):max(1,i)) .ne. '[' ) if ( copdir(i:i) .eq. cb(1) ) then write(6,30) copdir(:kope-1) 30 format(' Error: the character immediately foll', $ 'owing ":" must be "[" in directory name:'/ $ ' 'a) kope = -9 return else if ( copdir(i:i) .eq. cb(2) ) then write(6,40) copdir(:kope-1) 40 format(' Error: the character "]" must not occur', $ ' before the end of the directory name:'/ $ ' 'a) kope = -9 return endif i = i - 1 enddo if ( i .gt. 0 ) then copdir(kope:kope) = cb(2) else copdir(kope:kope) = cb(1) endif endif endif c c NOTE that some systems return FALSE for the existence of a directory, so c one cannot check for the directory's existence. c c-dir; call inqfil( copdir, lxst ) c-dir; if ( .not. lxst ) then c-dir; write(6,90) copdir(:kope) c-dir; 90 format(' Error: directory does not exist:'/' ',a) c-dir; kope = -9 c-dir; return c-dir; endif c endif c return end c c****************************************************************************** c subroutine chk_ofe_alt_file( k_ofe ) c ==================================== c c For non-GN93 mixes, the "[O/Fe] > 0" filename may or may not end in 'hz' c so check this (by checking which version of the file exists on disk) c and set cfile_opal_used(n_zmixes) accordingly. c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c character*255 cfile_opal_used(-1:n_totmix) common /c_mixfiles_used_opal_z/ cfile_opal_used save /c_mixfiles_used_opal_z/ c character*255 copdir common/opdir/ copdir save /opdir/ c common/recoin_opal_z/ itimeco,mxzero,mx03,kope,igznotgx save /recoin_opal_z/ c character*511 ctmp c if ( cfile_opalGS98(k_ofe) .eq. ' ' ) then cfile_opal_used(n_zmixes) = cfile_opalGS98(4) else cfile_opal_used(n_zmixes) = cfile_opalGS98(k_ofe) endif c ctmp = copdir ctmp(kope+1:) = cfile_opal_used(n_zmixes) c call open_chk_zip( -99999, ctmp, igzip, '???' ) c if ( igzip .eq. -99999 ) then c last = lnblnk( cfile_opal_used(n_zmixes) ) iadd = 0 c if ( last .ge. 2 ) then if ( cfile_opal_used(n_zmixes)(last-1:last) .eq. $ 'hz' ) then if ( last .gt. 2 ) iadd = -1 else if ( last .le. 253 ) then iadd = 1 endif else iadd = 1 endif c if ( iadd .lt. 0 ) then ctmp(kope+last-1:) = ' ' call open_chk_zip( -99999, ctmp, igzip, '???' ) else if ( iadd .gt. 0 ) then ctmp(kope+last+1:) = 'hz' call open_chk_zip( -99999, ctmp, igzip, '???' ) endif c if ( igzip .ne. -99999 ) then if ( iadd .lt. 0 ) then cfile_opal_used(n_zmixes)(last-1:) = ' ' else if ( iadd .gt. 0 ) then cfile_opal_used(n_zmixes)(last+1:) = 'hz' endif endif c endif c return end c c****************************************************************************** c subroutine index_co_deltas( iset, kxhz, jx, jc, jo ) c ==================================================== c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( mx_hi=2*mx, mx_m1=mx-1, mo_m1=mo-1, mo_m2=mo-2, $ mo_m10=mo-mx_hi, mo_p1=mo+1, mc_m1=mc-1, mc_m2=mc-2, $ mc_p7=mc+mx+2 ) c if ( iset .le. 0 .or. iset .gt. 5 .or. kxhz .le. 0 .or. $ kxhz .gt. mx_hi .or. mx .ne. 5 ) stop $ ' INDEX_DELTAS: Error: bad inputs: cannot happen. ' c if ( iset .eq. 2 ) then if ( kxhz .le. 5 ) then jx = kxhz jc = mc jo = mo_m2 else jx = kxhz - 5 jc = mc_m1 jo = mo_m1 endif else if ( iset .eq. 3 ) then jx = mx if ( kxhz .le. 5 ) then jc = mc jo = kxhz else jc = mc_m1 jo = kxhz - 5 endif else if ( iset .eq. 4 ) then jx = mx if ( kxhz .le. 5 ) then jc = kxhz jo = mo_m1 else jc = kxhz - 5 jo = mo_m2 endif else if ( iset .eq. 5 ) then if ( kxhz .le. 5 ) then jx = mx jc = mc_m2 jo = mo_p1 - kxhz else jx = mx_m1 jc = min( mc_p7 - kxhz , mc ) jo = min( mo_m10 + kxhz , mo_m1 ) endif else jc = mc if ( kxhz .le. 5 ) then jx = kxhz jo = mo else jx = kxhz - 5 jo = mo_m1 endif endif c return end c c****************************************************************************** c subroutine finish_cno c ===================== c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c parameter ( mx_hi=2*mx, mo_m1=mo-1, mo_m2=mo-2 ) c common/a_opal_z/ indx(101),t6list(nt),alr(nr),n(mx,mo,nz), $ alt(nt),dfs(nt),dfsr(nr),b(3),m,mf,xa(8),alrf(nrm), $ flogtin(ntm),dfsx(mx),oxf(mx,mc,nz),cxf(mx,mo,nz), $ xcdf(mx,mo,nz),xodf(mx,mc,nz),itime,cxdf(mx,mo,nz), $ oxdf(mx,mc,nz),q(4),h(4),xcd(mc),xod(mc),xc(mc),xo(mo), $ xcs(mc),xos(mo),cxd(mc),oxd(mo),cx(mc),ox(mo),zzz(nz),xxh, $ xx(mx),nc,no,zsto(nz),zvint(nz),dfsz(nz),zacc(nz), $ zlow,zmiddle,zhigh,zlo_ex,zhi_ex,numz save /a_opal_z/ c common /a_co_opal_z/ co(mx,mc,mo,nt,nr,nz), $ opk(mx,4),opl(nt,nr,nz),cof(nt,nr) save /a_co_opal_z/ c common /xhi_opal_z/ xhi_in(mx_hi), xcno_use(mx_hi,nz), $ xhi_use(mx_hi,nz), xxx_cno(mx_hi), xxx_hi(mx_hi), $ nx_hi(nz), ireq_hi(mx_hi), khighx(nz), kavail_xhi, kuse_xhi, $ kdo_xhi, kavail_cno, kuse_cno, kdo_cno, kavail_user, $ kuse_user, kdo_user save /xhi_opal_z/ c parameter ( nel_zmix=19, n_zmixes=5, kel_o=3, kel_fe=nel_zmix-1 ) c character*2 cel_opalmixes(nel_zmix) character*8 cfile_opalmixes(n_zmixes) common/opalmixes/ xiz_mix(nel_zmix),fninz_mix(nel_zmix), $ bracketife_mix(nel_zmix),bracketofe_opalmixes(n_zmixes), $ xofe_opalmixes(n_zmixes),xiz_opalmixes(nel_zmix,n_zmixes), $ fninz_opalmixes(nel_zmix,n_zmixes), $ cel_opalmixes,cfile_opalmixes save /opalmixes/ c parameter ( n_totmix = n_zmixes + 5, n_cnobeg = n_zmixes + 1 ) c character*255 cfile_opalGS98(0:n_totmix) common /opalGS98mixes/ bracketofe_opalGS98(0:n_totmix), $ xofe_opalGS98(0:n_totmix),xiz_opalGS98(nel_zmix,0:n_totmix), $ fninz_opalGS98(nel_zmix,0:n_totmix),atwt_opalGS98(nel_zmix), $ cfile_opalGS98 save /opalGS98mixes/ c common /cno_delta_opal_z/ fcno_mul(4), fninz_cno(nel_zmix,5), $ xiz_cno(nel_zmix,5), d_fninz_user(nel_zmix), $ fcno_fac(0:3,4), fninz_heavy, xiz_heavy, d_fninz_u_heavy, $ s_ninzai_mix, ds_ninzai_u, fn_o_over_cno, fninz_co_mix save /cno_delta_opal_z/ c common /c_level_err_opal_z/ level_err save /c_level_err_opal_z/ c___ parameter ( ncno2 = n_cnobeg + 1, ncno3 = ncno2 + 1, $ ncno4 = ncno3 + 1 ) c dimension cno_del_chk(2:4,4) c=== c c If user-specified opacity shifts were read in and the error-check level = 2, c then check the composition difference relative to the standard opacity file: c if ( kavail_user .gt. 0 ) then c del_max = 0.0 do i = 1, nel_zmix fninz_cno(i,5) = fninz_opalGS98(i,n_totmix) xiz_cno(i,5) = xiz_opalGS98(i,n_totmix) d_fninz_user(i) = fninz_opalGS98(i,n_totmix) $ - fninz_opalGS98(i,n_cnobeg) del_max = max( del_max , abs( d_fninz_user(i) ) ) enddo c if ( del_max .lt. 0.000015 .and. level_err .gt. 0 ) then write(6,10) 10 format(' '/' WARNING: user-specified OPAL opacity', $ ' interpolation file has a'/ $ ' composition identical to that', $ ' of the standard opacity file.'/' ') else if ( del_max .lt. 0.001 .and. level_err .ge. 2 ) then write(6,20) del_max 20 format(' '/' WARNING: user-specified OPAL opacity', $ ' interpolation file has a composition'/ $ ' similar to that of the standard', $ ' opacity file: max delta =',1p,e9.2/' ') endif c endif c c If CNO-interpolation opacity shifts were read in, check them and compute c some useful multiplicative factors: c if ( kavail_cno .gt. 0 ) then c ! check for similar C,N,O,Ne compositions: del_12 = 0.0 del_13 = 0.0 del_14 = 0.0 del_23 = 0.0 del_34 = 0.0 del_24 = 0.0 c do i = 1, 4 c ! for linear-dep check cno_del_chk(2,i) = fninz_opalGS98(i,ncno2) $ - fninz_opalGS98(i,n_cnobeg) cno_del_chk(3,i) = fninz_opalGS98(i,ncno3) $ - fninz_opalGS98(i,n_cnobeg) cno_del_chk(4,i) = fninz_opalGS98(i,ncno4) $ - fninz_opalGS98(i,n_cnobeg) c c ! check for very similar pairs of compositions c del_12 = max( del_12 , abs( cno_del_chk(2,i) ) ) del_13 = max( del_13 , abs( cno_del_chk(3,i) ) ) del_14 = max( del_14 , abs( cno_del_chk(4,i) ) ) del_23 = max( del_23 , abs( fninz_opalGS98(i,ncno3) $ - fninz_opalGS98(i,ncno2) ) ) del_34 = max( del_34 , abs( fninz_opalGS98(i,ncno4) $ - fninz_opalGS98(i,ncno3) ) ) del_24 = max( del_24 , abs( fninz_opalGS98(i,ncno2) $ - fninz_opalGS98(i,ncno4) ) ) c ! are all of C,N,O,Ne varied? if ( max( abs( cno_del_chk(2,i) ) , $ abs( cno_del_chk(3,i) ) , $ abs( cno_del_chk(4,i) ) ) .lt. 0.05 ) kavail_cno = 0 c enddo c if ( min( del_12 , del_13 , del_14 , $ del_23 , del_34 , del_24 ) .lt. 0.05 ) kavail_cno = 0 c c ! check for linear dependence among CNO-mixes lindep = 0 c if ( kavail_cno .gt. 0 ) then c do k = 3, 4 i = 1 do while ( i .lt. kel_o .and. $ abs( cno_del_chk(2,i) ) .lt. 0.009 ) i = i + 1 enddo f = cno_del_chk(k,i) / cno_del_chk(2,i) if ( max( $ abs( f * cno_del_chk(2,1) - cno_del_chk(k,1) ) , $ abs( f * cno_del_chk(2,2) - cno_del_chk(k,2) ) , $ abs( f * cno_del_chk(2,kel_o) $ - cno_del_chk(k,kel_o) ) ) .lt. 0.005 ) lindep = 1 enddo c if ( lindep .eq. 0 ) then c g = cno_del_chk(2,1) * cno_del_chk(3,2) $ - cno_del_chk(3,1) * cno_del_chk(2,2) if ( abs( g ) .lt. 2.5d-5 ) then lindep = 1 else f = ( cno_del_chk(3,2) * cno_del_chk(4,1) $ - cno_del_chk(4,2) * cno_del_chk(3,1) ) / g g = ( cno_del_chk(2,1) * cno_del_chk(4,2) $ - cno_del_chk(4,1) * cno_del_chk(2,2) ) / g if ( abs( f * cno_del_chk(2,3) + g * cno_del_chk(3,3) $ - cno_del_chk(4,3) ) .lt. 0.005 ) lindep = 1 endif c endif c endif c ! Bad CNO? if ( kavail_cno .eq. 0 ) then c if ( level_err .gt. 0 ) write(6,30) 30 format(' WARNING: CNO-interpolation in OPAL', $ ' opacities is NOT POSSIBLE: the C,N,O,Ne'/ $ ' abundances are too similar in the', $ ' specified CNO-interpolation opacity files.') if ( level_err .ge. 2 ) stop $ ' STOP -- READCO Error: bad CNO-interpolation files. ' c c ! or low main CNO? else if ( fninz_opalGS98(1,n_cnobeg) .lt. 0.05 .or. $ fninz_opalGS98(2,n_cnobeg) .lt. 0.01 .or. $ fninz_opalGS98(kel_o,n_cnobeg) .lt. 0.2 ) then c kavail_cno = 0 if ( level_err .gt. 0 ) write(6,40) 40 format(' WARNING: CNO-interpolation in OPAL', $ ' opacities is NOT POSSIBLE: the "standard"'/ $ ' CNO-opacity-file has low abundance(s) of C,N,O =', $ 1p,3e9.2) if ( level_err .ge. 2 ) stop $ ' STOP -- READCO Error: bad "standard"-CNO-file. ' c c ! enhanced C,O or c ! depleted Ne? else if ( fninz_opalGS98(1,n_cnobeg) .lt. 0.999 * max( $ fninz_opalGS98(1,ncno2) , fninz_opalGS98(1,ncno3) , $ fninz_opalGS98(1,ncno4) ) .or. $ fninz_opalGS98(kel_o,n_cnobeg) .lt. 0.999 * max( $ fninz_opalGS98(kel_o,ncno2) , $ fninz_opalGS98(kel_o,ncno3) , $ fninz_opalGS98(kel_o,ncno4) ) .or. $ fninz_opalGS98(4,n_cnobeg) .gt. 1.001 * min( $ fninz_opalGS98(4,ncno2) , fninz_opalGS98(4,ncno3) , $ fninz_opalGS98(4,ncno4) ) ) then c kavail_cno = 0 if ( level_err .gt. 0 ) write(6,50) 50 format(' WARNING: CNO-interpolation in OPAL', $ ' opacities is NOT POSSIBLE: these CNO-'/ $ ' interpolation files should NOT have', $ ' C or O enhancements or Ne depletions.') if ( level_err .ge. 2 ) stop $ ' STOP -- READCO Error: bad CNO-interpolation files. ' c else if ( lindep .gt. 0 ) then c kavail_cno = 0 if ( level_err .gt. 0 ) write(6,60) 60 format(' WARNING: CNO-interpolation in OPAL', $ ' opacities is NOT POSSIBLE: compositions of'/ $ ' the CNO-interpolation files', $ ' are linearly dependent in {C,N,O}-space.') if ( level_err .ge. 2 ) stop $ ' STOP -- READCO Error: bad CNO-interpolation files. ' c else c ! Else: O.K. so far; check elements heavier than Ne: del_12 = 0.0 del_13 = 0.0 del_14 = 0.0 del_23 = 0.0 del_34 = 0.0 del_24 = 0.0 del_max = 0.0 c do i = 5, nel_zmix c ! sums of diffs del_12 = del_12 + fninz_opalGS98(i,n_cnobeg) $ - fninz_opalGS98(i,ncno2) del_13 = del_13 + fninz_opalGS98(i,n_cnobeg) $ - fninz_opalGS98(i,ncno3) del_14 = del_14 + fninz_opalGS98(i,n_cnobeg) $ - fninz_opalGS98(i,ncno4) del_23 = del_23 + fninz_opalGS98(i,ncno3) $ - fninz_opalGS98(i,ncno2) del_34 = del_34 + fninz_opalGS98(i,ncno4) $ - fninz_opalGS98(i,ncno3) del_24 = del_24 + fninz_opalGS98(i,ncno2) $ - fninz_opalGS98(i,ncno4) c ! max diff del_max = max( abs( fninz_opalGS98(i,n_cnobeg) $ - fninz_opalGS98(i,ncno2) ) , $ abs( fninz_opalGS98(i,n_cnobeg) $ - fninz_opalGS98(i,ncno3) ) , $ abs( fninz_opalGS98(i,n_cnobeg) $ - fninz_opalGS98(i,ncno4) ) , del_max ) c enddo c del_sum = max( abs(del_12) , abs(del_13) , abs(del_14) , $ abs(del_23) , abs(del_34) , abs(del_24) ) c ! Bad heavies? if ( del_sum .gt. 0.001 .or. del_max .gt. 0.05 ) then c kavail_cno = 0 if ( level_err .gt. 0 ) write(6,70) del_sum, del_max 70 format(' WARNING: CNO-interpolation in OPAL', $ ' opacities is NOT POSSIBLE: C+N+O+Ne sums'/ $ ' differ by',1p,e9.2, $ ' > 0.001, OR max heavy-element-delta of',e9.2, $ ' > 0.05') if ( level_err .ge. 2 ) stop $ ' STOP -- READCO Error: bad CNO-interp-files. ' c ! Else: O.K. else c ! composition of main-CNO file same as OPAL mix used? if ( max( $ abs( fninz_opalGS98(1,n_cnobeg) - fninz_mix(1) ) , $ abs( fninz_opalGS98(2,n_cnobeg) - fninz_mix(2) ) , $ abs( fninz_opalGS98(kel_o,n_cnobeg) $ - fninz_mix(kel_o) ) , $ abs( fninz_opalGS98(4,n_cnobeg) - fninz_mix(4) ) ) $ .lt. 0.001 ) then c ! no CNO-modifications necessary do k = 1, 4 c fcno_mul(k) = 1.0 c j = k + n_zmixes c do i = 1, nel_zmix fninz_cno(i,k) = fninz_opalGS98(i,j) xiz_cno(i,k) = xiz_opalGS98(i,j) enddo c enddo c ! Else: if composition differs from OPAL mix used: else c ! get modified CNO-mixes do i = 1, nel_zmix fninz_cno(i,1) = fninz_mix(i) fninz_cno(i,2) = fninz_mix(i) fninz_cno(i,3) = fninz_mix(i) fninz_cno(i,4) = fninz_mix(i) enddo c ! and CNO-modification factors do k = 2, 4 c j = k + n_zmixes c f_c = min( 1.0 , fninz_opalGS98(1,j) $ / fninz_opalGS98(1,n_cnobeg) ) f_n = min( 1.0 , fninz_opalGS98(2,j) $ / fninz_opalGS98(2,n_cnobeg) ) f_o = min( 1.0 , fninz_opalGS98(kel_o,j) $ / fninz_opalGS98(kel_o,n_cnobeg) ) c fninz_cno(1,k) = f_c * fninz_mix(1) fninz_cno(kel_o,k) = f_o * fninz_mix(kel_o) c if ( f_n .lt. 1.0 ) then c fninz_cno(2,k) = f_n * fninz_mix(2) fninz_cno(4,k) = fninz_mix(4) $ + ( 1. - f_c ) * fninz_mix(1) $ + ( 1. - f_n ) * fninz_mix(2) $ + ( 1. - f_o ) * fninz_mix(kel_o) c fcno_mul(k) = ( fninz_cno(4,k) - fninz_mix(4) ) $ / ( ( 1. - f_c ) $ * fninz_opalGS98(1,n_cnobeg) $ + ( 1. - f_n ) $ * fninz_opalGS98(2,n_cnobeg) $ + ( 1. - f_o ) $ * fninz_opalGS98(kel_o,n_cnobeg) ) c else c del_co_orig = $ ( 1. - f_c ) * fninz_opalGS98(1,n_cnobeg) $ + ( 1. - f_o ) $ * fninz_opalGS98(kel_o,n_cnobeg) fad_ne = max( 0.0 , min( 1.0 , $ ( fninz_opalGS98(4,j) $ - fninz_opalGS98(4,n_cnobeg) ) $ / del_co_orig ) ) del_co = ( 1. - f_c ) * fninz_mix(1) $ + ( 1. - f_o ) * fninz_mix(kel_o) fninz_cno(2,k) = fninz_mix(2) $ + ( 1. - fad_ne ) * del_co fninz_cno(4,k) = fninz_mix(4) + fad_ne * del_co c fcno_mul(k) = del_co / del_co_orig c endif c sum_aini = 0.0 do i = 1, nel_zmix xiz_cno(i,k) = fninz_cno(i,k) * atwt_opalGS98(i) sum_aini = sum_aini + xiz_cno(i,k) enddo do i = 1, nel_zmix xiz_cno(i,k) = xiz_cno(i,k) / sum_aini enddo c enddo c endif c x1 = fninz_cno(1,1) x2 = fninz_cno(1,2) x3 = fninz_cno(1,3) x4 = fninz_cno(1,4) c y1 = fninz_cno(2,1) y2 = fninz_cno(2,2) y3 = fninz_cno(2,3) y4 = fninz_cno(2,4) c z1 = fninz_cno(3,1) z2 = fninz_cno(3,2) z3 = fninz_cno(3,3) z4 = fninz_cno(3,4) c d = ( x2 - x1 ) * ( ( y3 - y1 ) * ( z4 - z1 ) $ - ( y4 - y1 ) * ( z3 - z1 ) ) $ + ( x3 - x1 ) * ( ( y4 - y1 ) * ( z2 - z1 ) $ - ( y2 - y1 ) * ( z4 - z1 ) ) $ + ( x4 - x1 ) * ( ( y2 - y1 ) * ( z3 - z1 ) $ - ( y3 - y1 ) * ( z2 - z1 ) ) c if ( d .eq. 0.0 ) stop $ ' STOP -- READCO Error: CNO-interp: D = 0. ' c fcno_fac(0,1) = ( x2 * ( y3 * z4 - y4 * z3 ) $ + x3 * ( y4 * z2 - y2 * z4 ) $ + x4 * ( y2 * z3 - y3 * z2 ) ) / d fcno_fac(1,1) = ( y2 * ( z4 - z3 ) $ + y3 * ( z2 - z4 ) + y4 * ( z3 - z2 ) ) / d fcno_fac(2,1) = ( x2 * ( z3 - z4 ) $ + x3 * ( z4 - z2 ) + x4 * ( z2 - z3 ) ) / d fcno_fac(3,1) = ( x2 * ( y4 - y3 ) $ + x3 * ( y2 - y4 ) + x4 * ( y3 - y2 ) ) / d c fcno_fac(0,2) = ( x1 * ( y4 * z3 - y3 * z4 ) $ + x3 * ( y1 * z4 - y4 * z1 ) $ + x4 * ( y3 * z1 - y1 * z3 ) ) / d fcno_fac(1,2) = ( y1 * ( z3 - z4 ) $ + y3 * ( z4 - z1 ) + y4 * ( z1 - z3 ) ) / d fcno_fac(2,2) = ( x1 * ( z4 - z3 ) $ + x3 * ( z1 - z4 ) + x4 * ( z3 - z1 ) ) / d fcno_fac(3,2) = ( x1 * ( y3 - y4 ) $ + x3 * ( y4 - y1 ) + x4 * ( y1 - y3 ) ) / d c fcno_fac(0,3) = ( x1 * ( y2 * z4 - y4 * z2 ) $ + x2 * ( y4 * z1 - y1 * z4 ) $ + x4 * ( y1 * z2 - y2 * z1 ) ) / d fcno_fac(1,3) = ( y1 * ( z4 - z2 ) $ + y2 * ( z1 - z4 ) + y4 * ( z2 - z1 ) ) / d fcno_fac(2,3) = ( x1 * ( z2 - z4 ) $ + x2 * ( z4 - z1 ) + x4 * ( z1 - z2 ) ) / d fcno_fac(3,3) = ( x1 * ( y4 - y2 ) $ + x2 * ( y1 - y4 ) + x4 * ( y2 - y1 ) ) / d c fcno_fac(0,4) = ( x1 * ( y3 * z2 - y2 * z3 ) $ + x2 * ( y1 * z3 - y3 * z1 ) $ + x3 * ( y2 * z1 - y1 * z2 ) ) / d fcno_fac(1,4) = ( y1 * ( z2 - z3 ) $ + y2 * ( z3 - z1 ) + y3 * ( z1 - z2 ) ) / d fcno_fac(2,4) = ( x1 * ( z3 - z2 ) $ + x2 * ( z1 - z3 ) + x3 * ( z2 - z1 ) ) / d fcno_fac(3,4) = ( x1 * ( y2 - y3 ) $ + x2 * ( y3 - y1 ) + x3 * ( y1 - y2 ) ) / d c endif c endif c endif c ! get number and mass fraction heavier than Ne (in Z) fninz_heavy = 0.0 xiz_heavy = 0.0 d_fninz_u_heavy = 0.0 s_ninzai_mix = fninz_mix(1) * atwt_opalGS98(1) $ + fninz_mix(2) * atwt_opalGS98(2) $ + fninz_mix(3) * atwt_opalGS98(3) $ + fninz_mix(4) * atwt_opalGS98(4) ds_ninzai_u = d_fninz_user(1) * atwt_opalGS98(1) $ + d_fninz_user(2) * atwt_opalGS98(2) $ + d_fninz_user(3) * atwt_opalGS98(3) $ + d_fninz_user(4) * atwt_opalGS98(4) do i = 5, nel_zmix fninz_heavy = fninz_heavy + fninz_mix(i) xiz_heavy = xiz_heavy + xiz_mix(i) d_fninz_u_heavy = d_fninz_u_heavy + d_fninz_user(i) s_ninzai_mix = s_ninzai_mix + fninz_mix(i) * atwt_opalGS98(i) ds_ninzai_u = ds_ninzai_u + d_fninz_user(i) * atwt_opalGS98(i) enddo fn_o_over_cno = fninz_mix(3) $ / ( fninz_mix(1) + fninz_mix(2) + fninz_mix(3) ) fninz_co_mix = fninz_mix(1) + fninz_mix(3) c ! set internal CNO-interp flags kdo_cno = kavail_cno * kuse_cno kdo_user = kavail_user * kuse_user c ! set flag "finshed reading opacities" itime = 12345678 c return end c c****************************************************************************** c SUBROUTINE SPLINE(X,Y,N,Y2) c =========================== c___ PARAMETER ( NMAX=100 ) C DIMENSION X(N),Y(N),Y2(N),U(NMAX) C C FIRST DERIVATIVES AT END POINTS USING CUBIC FIT C=== YP1 = ((Y(3)-Y(1))*(X(2)-X(1))**2 $ -(Y(2)-Y(1))*(X(3)-X(1))**2)/ $ ((X(3)-X(1))*(X(2)-X(1))*(X(2)-X(3))) YPN = ((Y(N-2)-Y(N))*(X(N-1)-X(N))**2 $ -(Y(N-1)-Y(N))*(X(N-2)-X(N))**2)/ $ ((X(N-2)-X(N))*(X(N-1)-X(N))*(X(N-1)-X(N-2))) C Y2(1) = -0.5 U(1) = (3./(X(2)-X(1)))*((Y(2)-Y(1))/(X(2)-X(1))-YP1) DO I = 2,N-1 SIG = (X(I)-X(I-1))/(X(I+1)-X(I-1)) P = SIG*Y2(I-1)+2. Y2(I) = (SIG-1.)/P U(I) = (6.*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1)) $ /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P ENDDO QN = 0.5 UN = (3./(X(N)-X(N-1)))*(YPN-(Y(N)-Y(N-1))/(X(N)-X(N-1))) Y2(N) = (UN-QN*U(N-1))/(QN*Y2(N-1)+1.) DO K = N-1,1,-1 Y2(K) = Y2(K)*Y2(K+1)+U(K) ENDDO RETURN END c c****************************************************************************** c SUBROUTINE SPLINT(XA,YA,N,Y2A,X,Y,YP) c ===================================== c___ DIMENSION XA(N),YA(N),Y2A(N) C=== KLO = 1 KHI = N do while( KHI-KLO .GT. 1 ) K = (KHI+KLO)/2 IF ( XA(K) .GT. X ) THEN KHI = K ELSE KLO = K ENDIF enddo H = XA(KHI)-XA(KLO) IF ( H .EQ. 0. ) STOP ' STOP -- SPLINT: Bad XA input. ' A = (XA(KHI)-X)/H B = (X-XA(KLO))/H Y = A*YA(KLO)+B*YA(KHI)+ $ ((A**3-A)*Y2A(KLO)+(B**3-B)*Y2A(KHI))*(H**2)/6. YP = 0.05* ( (-YA(KLO)+YA(KHI))/H $ + ( -(3*A**2-1)*Y2A(KLO) $ +(3*B**2-1)*Y2A(KHI) )*H/6. ) RETURN END c c****************************************************************************** c SUBROUTINE FITY c =============== C C THIS ROUTINE MAKES SPLINE FITS FOR F AND FX, AND OBTAINS C FY AND FXY C ! modified: COMMON/CST_OPAL_Z/ NRL,RLS,nset,tmax save /CST_OPAL_Z/ C PARAMETER ( IPR=20 ) C COMMON/CF_OPAL_Z/ F(85,IPR),FX(85,IPR),FY(85,IPR),FXY(85,IPR) save /CF_OPAL_Z/ c___ DIMENSION A(IPR),B(IPR),AD(IPR),BD(IPR) C=== ! modified: DO I = 1,nset DO J = 1,NRL A(J) = F(I,J) B(J) = FX(I,J) ENDDO C CALL GETD(A,NRL,AD,AP1,APN) CALL GETD(B,NRL,BD,BP1,BPN) C FY(I,1) = AP1 FY(I,NRL) = APN FXY(I,1) = BP1 FXY(I,NRL) = BPN DO J = 2,NRL-1 FY(I,J) = -A(J)+A(J+1)-2.*AD(J)-AD(J+1) FXY(I,J) = -B(J)+B(J+1)-2.*BD(J)-BD(J+1) ENDDO ENDDO C RETURN END c c****************************************************************************** c SUBROUTINE FITX c =============== C C THIS ROUTINE IS USED ONLY AFTER SMOOTHING. C ITS FUNCTION IS TO RECOMPUTE FX USING SMOOTHED F. C PARAMETER ( IPR=20 ) C ! modified: COMMON/CST_OPAL_Z/ NRL,RLS,nset,tmax save /CST_OPAL_Z/ c COMMON/CF_OPAL_Z/ F(85,IPR),FX(85,IPR),FY(85,IPR),FXY(85,IPR) save /CF_OPAL_Z/ C___ DIMENSION A(85),D(85) C=== DO J = 1,NRL C ! modified: DO I = 1,nset A(I) = F(I,J) ENDDO C ! modified: CALL GETD(A,nset,D,AP1,APN) FX(1,J) = AP1 C ! modified: FX(nset,J) = APN C ! modified: DO I = 2,nset-1 FX(I,J) = -A(I)+A(I+1)-2.*D(I)-D(I+1) ENDDO ENDDO C RETURN END C c****************************************************************************** c SUBROUTINE GETD(F,N,D,FP1,FPN) c ============================== C C SIMPLIFIED CODE FOR SPLINE COEFFICIENTS, FOR CASE OF INTERVALS OF UNITY. C___ DIMENSION F(N),D(N),T(85) C=== FP1 = (-11.*F(1)+18.*F(2)-9.*F(3)+2.*F(4))/6. FPN = (11.*F(N)-18.*F(N-1)+9.*F(N-2)-2.*F(N-3))/6. C D(1) = -.5 T(1) = .5*(-F(1)+F(2)-FP1) C DO J = 2,N-1 D(J) = -1./(4.+D(J-1)) T(J) = -D(J)*(F(J-1)-2.*F(J)+F(J+1)-T(J-1)) ENDDO C D(N) = (FPN+F(N-1)-F(N)-T(N-1))/(2.+D(N-1)) C DO J = N-1,1,-1 D(J) = D(J)*D(J+1)+T(J) ENDDO C RETURN END C c****************************************************************************** c SUBROUTINE INTERP(FLT,FLRHO,G,DGDT,DGDRHO,IERR) c =============================================== C C GIVEN F,FX,FY AND FXY ON THE GRID POINTS, THIS ROUTINE C DOES BI-CUBIC INTERPOLATIONS USING METHODS DESCRIBED IN C Numerical Recipes, PP. 118 TO 120 C PARAMETER ( IPR=20 ) C ! modified: COMMON/CST_OPAL_Z/ NRL,RLS,nset,tmax save /CST_OPAL_Z/ C COMMON/CF_OPAL_Z/ F(85,IPR),FX(85,IPR),FY(85,IPR),FXY(85,IPR) save /CF_OPAL_Z/ c___ DIMENSION B(16) LOGICAL IERR C C EXTREME LIMITS ALLOWED ARE:- C (3.800-0.0125) TO (8.000+0.0125) FOR LOG10(T) C (RLS-0.125) TO (RLE+0.1254) FOR LOG10(R) C (ALLOWING FOR SMALL EXTRAPOLATIONS BEYOND TABULAR VALUES) C C FUNCTION DEFINITIONS FOR CUBIC EXPANSION C=== FF(S,T) = B( 1)+T*(B( 2)+T*(B( 3)+T*B( 4))) $ + S*( B( 5)+T*(B( 6)+T*(B( 7)+T*B( 8))) $ + S*( B( 9)+T*(B(10)+T*(B(11)+T*B(12))) $ + S*( B(13)+T*(B(14)+T*(B(15)+T*B(16))) ) ) ) C FFX(S,T) = B( 5)+T*(B( 6)+T*(B( 7)+T*B( 8))) $ + S*( 2*(B( 9)+T*(B(10)+T*(B(11)+T*B(12)))) $ + S*( 3*(B(13)+T*(B(14)+T*(B(15)+T*B(16)))) ) ) C FFY(S,T) = B( 2)+S*(B( 6)+S*(B(10)+S*B(14))) $ + T*( 2*(B( 3)+S*(B( 7)+S*(B(11)+S*B(15)))) $ + T*( 3*(B( 4)+S*(B( 8)+S*(B(12)+S*B(16)))) ) ) C C Note that statement function FFXY is never used, and thus can be omitted. C c-noneed[ ! FFXY is never used! c-noneed; FFXY(S,T) = B( 6)+T*(2*B( 7)+3*T*B( 8)) c-noneed; $ +S*( 2*B(10)+T*(4*B(11)+6*T*B(12)) c-noneed; $ +S*( 3*B(14)+T*(6*B(15)+9*T*B(16)) )) c-noneed] C C BEGINNING OF EXECUTABLE STATEMENTS C=== c-old; IERR = .FALSE. c ! values to use if there is an error-return: IERR = .TRUE. G = 9.999 DGDT = 9.999 DGDRHO = 9.999 C X = 20.*(FLT-3.800)+1. c-less-accurate; FLR = FLRHO+18.-3.*FLT FLR = FLRHO - 3. * ( FLT - 6. ) Y = 2.*( FLR - RLS )+1. C IF ( X .LT. 2. ) THEN c-old; IF ( X .LT. 0.75 ) THEN c-old; IERR = .TRUE. c-old; ELSE c-old; I = 1 c-old; ENDIF IF ( X .LT. 0.75 ) RETURN I = 1 ELSE IF ( X .GT. 84. ) THEN c-old; IF ( X .GT. 85.25 ) THEN c-old; IERR = .TRUE. c-old; ELSE c-old; I = 84 c-old; ENDIF IF ( X .GT. 85.25 ) RETURN I = 84 ELSE I = X ENDIF U = X-I C IF ( Y .LT. 2. ) THEN c-old; IF ( Y .LT. 0.75 ) THEN c-old; IERR = .TRUE. c-old; ELSE c-old; J = 1 c-old; ENDIF IF ( Y .LT. 0.75 ) RETURN J = 1 ELSE IF ( Y .GT. NRL-1 ) THEN c-old; IF ( Y .GT. NRL+.25 ) THEN c-old; IERR = .TRUE. c-old; ELSE c-old; J = NRL-1 c-old; ENDIF IF ( Y .GT. NRL+.25 ) RETURN J = NRL - 1 ELSE J = Y ENDIF V = Y-J C c-old; IF ( IERR ) THEN c-old; RETURN c-old; ENDIF C C GIVEN FUNCTIONS AND DERIVATIVES AT GRID POINTS, COMPUTE COEFFICIENTS. c B(1) = F(I,J) B(2) = FY(I,J) B(3) = 3*(-F(I,J)+F(I,J+1))-2*FY(I,J)-FY(I,J+1) B(4) = 2*(F(I,J)-F(I,J+1))+FY(I,J)+FY(I,J+1) C B(5) = FX(I,J) B(6) = FXY(I,J) B(7) = 3*(-FX(I,J)+FX(I,J+1))-2*FXY(I,J)-FXY(I,J+1) B(8) = 2*(FX(I,J)-FX(I,J+1))+FXY(I,J)+FXY(I,J+1) C B(9) = 3*(-F(I,J)+F(I+1,J))-2*FX(I,J)-FX(I+1,J) B(10) = 3*(-FY(I,J)+FY(I+1,J))-2*FXY(I,J)-FXY(I+1,J) B(11) = 9*(F(I,J)-F(I+1,J)+F(I+1,J+1)-F(I,J+1)) $ +6*(FX(I,J)-FX(I,J+1)+FY(I,J)-FY(I+1,J)) $ +4*FXY(I,J) $ +3*(FX(I+1,J)-FX(I+1,J+1)-FY(I+1,J+1)+FY(I,J+1)) $ +2*(FXY(I,J+1)+FXY(I+1,J)) $ +FXY(I+1,J+1) B(12) = 6*(-F(I,J)+F(I+1,J)-F(I+1,J+1)+F(I,J+1)) $ +4*(-FX(I,J)+FX(I,J+1)) $ +3*(-FY(I,J)+FY(I+1,J)+FY(I+1,J+1)-FY(I,J+1)) $ +2*(-FX(I+1,J)+FX(I+1,J+1)-FXY(I,J)-FXY(I,J+1)) $ -FXY(I+1,J)-FXY(I+1,J+1) C B(13) = 2*(F(I,J)-F(I+1,J))+FX(I,J)+FX(I+1,J) B(14) = 2*(FY(I,J)-FY(I+1,J))+FXY(I,J)+FXY(I+1,J) B(15) = 6*(-F(I,J)+F(I+1,J)-F(I+1,J+1)+F(I,J+1)) $ +4*(-FY(I,J)+FY(I+1,J)) $ +3*(-FX(I,J)-FX(I+1,J)+FX(I+1,J+1)+FX(I,J+1)) $ +2*(FY(I+1,J+1)-FY(I,J+1)-FXY(I,J)-FXY(I+1,J)) $ -FXY(I+1,J+1)-FXY(I,J+1) B(16) = 4*(F(I,J)-F(I+1,J)+F(I+1,J+1)-F(I,J+1)) $ +2*(FX(I,J)+FX(I+1,J)-FX(I+1,J+1)-FX(I,J+1) $ +FY(I,J)-FY(I+1,J)-FY(I+1,J+1)+FY(I,J+1)) $ +FXY(I,J)+FXY(I+1,J)+FXY(I+1,J+1)+FXY(I,J+1) C C GET G=LOG10(ROSS), DGDT=d LOG10(ROSS)/d LOG10(T), C DGDRHO=d LOG10(ROSS)/d LOG10(RHO) c G = FF(U,V) DGDT = 20.*FFX(U,V)-6.*FFY(U,V) DGDRHO = 2.*FFY(U,V) c IERR = .FALSE. C RETURN END c c****************************************************************************** c SUBROUTINE SMOOTH c ================= C C THIS SUBROUTINE USES A 2-DIMENSIONAL GENERALISATION OF THE SMOOTHING C TECHNIQUES DESCRIBED ON PP. 644 TO 649 OF Numerical Recipes. C C CONSIDER THE 25 POINTS DEFINED BY C I+n, n=-2,-1,0,1,2 AND J+m, m=-2,-1,0,1,2. C THE FUNCTION TO BE SMOOTHED IS FITTED TO A BI-CUBIC, INVOLVING C 16 COEFFICIENTS, USING TECHNIQUES OF LEAST-SQUARES. THE SMOOTHED C FUNCTION (TEMPORARILY STORED IN FXY) IS GIVEN BY THE FITTED VALUE C AT THE POINT I AND J. C C THE FITTING IS SHIFTED FOR POINTS CLOSE TO BOUNDARIES. C C PARAMETER ( IPR=20 ) C ! modified COMMON/CST_OPAL_Z/ NRL,RLS,nset,tmax save /CST_OPAL_Z/ c COMMON/CF_OPAL_Z/ F(85,IPR),FX(85,IPR),FY(85,IPR),FXY(85,IPR) save /CF_OPAL_Z/ C___ DIMENSION GAM(6),BET(11),ALP(11) c--- DATA GAM/+0.0073469388,-0.0293877551,-0.0416326531, $ +0.1175510204,+0.1665306122,+0.2359183673/ DATA BET/ $ -0.0048979592,-0.0661224490,-0.0293877551,+0.0195918367, $ 0.2644897959,+0.1175510204,-0.0783673469,+0.0277551020, $ 0.3746938776,+0.1665306122,-0.1110204082/ DATA ALP/ $ -0.0844897959,-0.0048979592,+0.0073469388,+0.0012244898, $ 0.3379591837,+0.0195918367,-0.0293877551,+0.4787755102, $ 0.0277551020,-0.0416326531,-0.0069387755/ C=== DO I = 3,nset-2 C J = 1 FXY(I,J) = $ ALP(1)*( F(I-2,J )+F(I+2,J ) ) $ +ALP(2)*( F(I-2,J+1)+F(I+2,J+1)+F(I-2,J+3)+F(I+2,J+3) $ +F(I-1,J+4)+F(I+1,J+4) ) $ +ALP(3)*( F(I-2,J+2)+F(I+2,J+2) ) $ +ALP(4)*( F(I-2,J+4)+F(I+2,J+4) ) $ +ALP(5)*( F(I-1,J )+F(I+1,J ) ) $ +ALP(6)*( F(I-1,J+1)+F(I+1,J+1)+F(I-1,J+3)+F(I+1,J+3) ) $ +ALP(7)*( F(I-1,J+2)+F(I+1,J+2) ) $ +ALP(8)* F(I ,J ) $ +ALP(9)*( F(I ,J+1)+F(I ,J+3) ) $ +ALP(10)* F(I ,J+2) +ALP(11)*F(I ,J+4) C J = 2 FXY(I,J) = $ BET(1)*( F(I-2,J-1)+F(I+2,J-1)+F(I-2,J+3)+F(I+2,J+3) ) $ +BET(2)*( F(I-2,J )+F(I+2,J ) ) $ +BET(3)*( F(I-2,J+1)+F(I+2,J+1) ) $ +BET(4)*( F(I-2,J+2)+F(I+2,J+2)+F(I-1,J-1)+F(I+1,J-1) $ +F(I-1,J+3)+F(I+1,J+3) ) $ +BET(5)*( F(I-1,J )+F(I+1,J ) ) $ +BET(6)*( F(I-1,J+1)+F(I+1,J+1) ) $ +BET(7)*( F(I-1,J+2)+F(I+1,J+2) ) $ +BET(8)*( F(I ,J-1)+F(I ,J+3) ) $ +BET(9)*F(I ,J ) +BET(10)*F(I ,J+1) +BET(11)*F(I ,J+2) C DO J = 3,NRL-2 FXY(I,J) = $ GAM(1)*( F(I-2,J-2)+F(I-2,J+2)+F(I+2,J-2)+F(I+2,J+2) ) $ +GAM(2)*( F(I-2,J+1)+F(I-2,J-1)+F(I-1,J-2)+F(I-1,J+2) $ +F(I+1,J-2)+F(I+1,J+2)+F(I+2,J-1)+F(I+2,J+1) ) $ +GAM(3)*( F(I-2,J )+F(I+2,J )+F(I ,J-2)+F(I ,J+2) ) $ +GAM(4)*( F(I-1,J-1)+F(I-1,J+1)+F(I+1,J-1)+F(I+1,J+1) ) $ +GAM(5)*( F(I-1,J )+F(I ,J-1)+F(I ,J+1)+F(I+1,J ) ) $ +GAM(6)* F(I ,J ) ENDDO C J = NRL-1 FXY(I,J) = $ BET(1)*( F(I-2,J+1)+F(I+2,J+1)+F(I-2,J-3)+F(I+2,J-3) ) $ +BET(2)*( F(I-2,J )+F(I+2,J ) ) $ +BET(3)*( F(I-2,J-1)+F(I+2,J-1) ) $ +BET(4)*( F(I-2,J-2)+F(I+2,J-2)+F(I-1,J+1)+F(I+1,J+1) $ +F(I-1,J-3)+F(I+1,J-3) ) $ +BET(5)*( F(I-1,J )+F(I+1,J ) ) $ +BET(6)*( F(I-1,J-1)+F(I+1,J-1) ) $ +BET(7)*( F(I-1,J-2)+F(I+1,J-2) ) $ +BET(8)*( F(I ,J+1)+F(I ,J-3) ) $ +BET(9)*F(I ,J ) +BET(10)*F(I ,J-1) +BET(11)*F(I ,J-2) C J = NRL FXY(I,J) = $ ALP(1)*( F(I-2,J )+F(I+2,J ) ) $ +ALP(2)*( F(I-2,J-1)+F(I+2,J-1)+F(I-2,J-3)+F(I+2,J-3) $ +F(I-1,J-4)+F(I+1,J-4) ) $ +ALP(3)*( F(I-2,J-2)+F(I+2,J-2) ) $ +ALP(4)*( F(I-2,J-4)+F(I+2,J-4) ) $ +ALP(5)*( F(I-1,J )+F(I+1,J ) ) $ +ALP(6)*( F(I-1,J-1)+F(I+1,J-1)+F(I-1,J-3)+F(I+1,J-3) ) $ +ALP(7)*( F(I-1,J-2)+F(I+1,J-2) ) $ +ALP(8)* F(I ,J ) $ +ALP(9)*( F(I ,J-1)+F(I ,J-3) ) $ +ALP(10)* F(I ,J-2) +ALP(11)*F(I ,J-4) C ENDDO C ! modified DO I = 3,nset-2 DO J = 1,NRL F(I,J) = FXY(I,J) ENDDO ENDDO C RETURN END C c****************************************************************************** c subroutine opaltab c ================== C C CODE FOR FITTING AND SMOOTHING OPAL DATA. ADAPTED FROM A CODE C WRITTEN BY MIKE SEATON (obtained june 1993) C C OPAL DATA. C ASSUMES FIRST T6 = .0056341325 = 10.**(3.75-6.) ; LAST T6 = tmax = 10. C USES RECTANGULAR ARRAY FOR VARIABLES T6 AND LOG10(R) C C (1) NSM=NUMBER OF PASSES THROUGH SMOOTHING FILTER. C USE OF NSM=1 OR 2 IS RECOMMENDED. C NO SMOOTHING WITH NSM=0 C (2) RANGE FOR LOG10(R), C RLS=FIRST VALUE, RLE=LAST VALE C (RLS MUST BE FIRST VALUYE IN TABLE) C C SUBROUTINE INTERP C AFTER PROCESSING, DATA ARE IN A FORM FOR USE OF C SUBROUTINE INTERP C WHICH GIVES LOG(ROSS) AND TWO FIRST DERIVATIVES FOR ANY C VALUES OF LOG(T) AND LOG(RHO). SEE BELOW FOR FURTHER C EXPLANATION. C C OUTPUT FOR THE CASE OF NSM .GT. 0. C INTERP IS USED TO OBTAIN SMOOTHED DATA INTERPOLATED C BACK TO THE ORIGINAL OPAL MESH. C C THE SUBROUTINES SPLINE AND SPLINT ARE ADAPTED FROM THOSE GIVE BY C W.H. Press, S.A. Teulolsky, W.T. Vettering and B.P. Flannery, C "Numerical Recipes in FORTRAN", 2nd edn., 1992, C.U.P. C OTHER REFERENCES ARE MADE TO METHODS DESCRIBED IN THAT BOOK. C PARAMETER ( IP=100, IPR=20 ) c parameter ( nz=5, mx=5, mc=8, mo=8, nrm=19, nrb=1, nre=19, $ nr=nre+1-nrb, ntm=70, ntb=1, nt=ntm+1-ntb, nrm_p1=nrm+1 ) c common/alink_opal_z/ NTEMP,NSM,nrlow,nrhigh,RLE,t6arr(100), $ coff(100,nrm) save /alink_opal_z/ c ! modified: COMMON/CST_OPAL_Z/ NRL,RLS,nset,tmax save /CST_OPAL_Z/ c COMMON/CF_OPAL_Z/ F(85,IPR),FX(85,IPR),FY(85,IPR),FXY(85,IPR) save /CF_OPAL_Z/ c___ DIMENSION U(IP),ROSSL(IP,IPR),V(IP),V2(IP) c c-noneed; CHARACTER*1 HEAD(100) c LOGICAL IERR C=== NRL = int(2.*(RLE-RLS)+1.00001) C C STORE LOG10(T) IN U AND LOG10(ROSS) IN ROSSL C CHECK FIRST VALUE OF T6 c do j = 1,NRL ROSSL(1,j) = coff(1,j) enddo c T6 = t6arr(1) U(1) = 6.+LOG10(T6) c C SET ROSSL UP TO T6=t6arr(nset) c NTEMP = 1 do while( T6 .LT. Tmax ) NTEMP = NTEMP+1 do j = 1,NRL ROSSL(NTEMP,j) = coff(NTEMP,j) enddo T6 = t6arr(NTEMP) U(NTEMP) = 6.+LOG10(T6) enddo c IF ( NTEMP .GT. IP ) THEN PRINT*,' OPALTAB: REQUIRE PARAMETER IP OF AT LEAST ',NTEMP STOP ' STOP -- OPALTAB ERROR: NTEMP > IP . ' ENDIF C C C DEFINE VARIABLES C X=20.0*(LOG10(T)-3.80)+1 C Y=2.0*(LOG10(R)-RLS)+1 C USE INDICES I=1 TO nset AND J=1 TO NRL C X AND Y ARE SUCH THAT, ON MESH-POINT (I,J), X=I AND Y=J C OBTAIN:- C F(I,J)=LOG10(ROSS) C FX(I,J)=dF/dX C FY(I,J)=dF/dY C FXY(I,J)=ddF/dXdY C C C FIRST GET F AND FX, INTERPOLATING FROM OPAL T6 TO C INTERVAL OF 0.05 IN LOG10(T). c DO J = 1,NRL c C FOR EACH LOG10(R), STORE LOG10(ROSS) IN V(I) c DO I = 1,NTEMP V(I) = ROSSL(I,J) ENDDO C C GET FIRST DERIVATIVES AT END POINTS: done in SPLINE, using cubic fit C C GET SECOND DERIVATIVES FOR SPLINE FIT: done by SPLINE c CALL SPLINE(U,V,NTEMP,V2) C C INTERPOLATE TO LOG10(T)=FLT, FLT=3.8(0.05)8.0 c ! modified: DO I = 1,nset FLT = 3.75+0.05*I CALL SPLINT(U,V,NTEMP,V2,FLT,F(I,J),FX(I,J)) ENDDO C ENDDO C C OPTION FOR SMOOTHING C IF ( NSM .GT. 0 ) THEN DO NS = 1,NSM CALL SMOOTH ENDDO CALL FITX ENDIF C C GET FY AND FXY C CALL FITY C C THE ARRAYS F, FX, FY AND FXY ARE NOW STORED C C CAN NOW DO INTERPOLATIONS USING C CALL INTERP(FLT,FLRHO,G,DGDT,DGDRHO,IERR) C INPUT IS FLT=LOG10(T), FLRHO=LOG10(RHO) C OUTPUT IS G=LOG10(ROSS) C DGDT=dG/d(LOG10(T)) C DGDRHO=dG/d(LOG10(RHO)) C IERR=.TRUE. IF INPUT FLT, FLRHO ARE OUT-OF-RANGE, C ELSE IERR=.FALSE. C C INTERPOLATE BACK TO OPAL POINTS C IF ( NSM .GT. 0 ) THEN c do il = 1,NRL coff(1,il) = ROSSL(1,il) enddo c DO K = 2,NTEMP FLT = U(K) DO IL = nrlow,nrhigh FLR = RLS+.5*(IL-1) FLRHO = FLR-18.+3.*FLT CALL INTERP(FLT,FLRHO,G,DGDT,DGDRHO,IERR) IF ( IERR ) THEN stop ' STOP -- OPALTAB: INTERP T/rho range error. ' ENDIF V(IL) = G ENDDO do il = nrlow,nrhigh coff(K,il) = V(il) enddo ENDDO c ENDIF C return END c c*********************************************************************** c subroutine open_chk_zip( iu, fname, igzip, cmsg ) c ================================================= c c Open a file, possibly decompressing it first. c If iu < 0, then it is not a fatal error if file is not found. c If iu < -99, then do not actually open or decompress the file. c c Return igzip = -99999 if file is not found c igzip = 0 if file is not compressed c igzip = 1 if file is gzip-compressed ("*.gz") c igzip = 2 if file is bzip2-compressed ("*.bz2") c igzip = -1 if file is compressed ("*.Z") c character*(*) fname character*(*) cmsg c character*511 ctmp c logical lxst c=== last = lnblnk( fname ) c if ( last .le. 0 ) stop $ ' STOP -- OPEN_CHK_ZIP Error: blank file name. ' c call inqfil( fname, lxst ) c if ( lxst ) then igzip = 0 if ( iu .lt. -99 ) return else if ( last .gt. 497 ) then stop ' STOP -- OPEN_CHK_ZIP Error: file name too long. ' else ctmp = fname(1:last) // '.gz' call inqfil( ctmp, lxst ) if ( lxst ) then igzip = 1 if ( iu .lt. -99 ) return ctmp = 'gunzip ' // fname(1:last) // '.gz' call system( ctmp ) else ctmp = fname(1:last) // '.Z' call inqfil( ctmp, lxst ) if ( lxst ) then igzip = -1 if ( iu .lt. -99 ) return ctmp = 'uncompress ' // fname(1:last) // '.Z' call system( ctmp ) else ctmp = fname(1:last) // '.bz2' call inqfil( ctmp, lxst ) if ( lxst ) then igzip = 2 if ( iu .lt. -99 ) return ctmp = 'bunzip2 ' // fname(1:last) // '.bz2' call system( ctmp ) else if ( iu .lt. 0 ) then igzip = -99999 return else write(6,'(" ",a)') cmsg write(6,'(" ",a)') fname stop ' STOP -- OPEN_CHK_ZIP Error: file not found. ' endif endif endif endif c if ( iu .gt. -100 ) call opoldr( iabs(iu), fname ) c return end c c************************************************************************ c subroutine close_chk_zip( iu, fname, igzip ) c ============================================ c character*(*) fname c character*511 ctmp c close(iu) c if ( igzip .gt. 1 ) then c ctmp = 'bzip2 ' // fname call system( ctmp ) c else if ( igzip .gt. 0 ) then c ctmp = 'gzip ' // fname call system( ctmp ) c else if ( igzip .lt. 0 ) then c ctmp = 'compress ' // fname call system( ctmp ) c endif c return end c c************************************************************************ c subroutine quadslsto( i, x, x1, x2, x3 ) c ======================================== c c Storage for x,dx_i values that need not be computed on each call (see "ic"); c NOTE that this same storage is used by all of QUADSL, QDERSL c common/c_quadsl_opal_z/ xo21(10), xo32(10), x01(10), x02(10), $ x03(10), x0230o32(10), x0202o32(10), x023021o3231(10), $ x0203o31(10), x0201o31(10), x0201o21(10), x0202o21(10), $ x020132o2131(10), ixvs2(10) save /c_quadsl_opal_z/ c dimension xx(4) c xx(4) = x xx(2) = x2 c if ( xx(4) .eq. xx(2) ) then c ixvs2(i) = 0 c else c xx(1) = x1 xx(3) = x3 c xo21(i) = 1.0 / ( xx(2) - xx(1) ) xo32(i) = 1.0 / ( xx(3) - xx(2) ) c x02(i) = xx(4) - xx(2) c tmp = x02(i) / ( xx(3) - xx(1) ) x0201o31(i) = tmp * ( xx(4) - xx(1) ) x0203o31(i) = tmp * ( xx(4) - xx(3) ) c if ( xx(1) .lt. xx(3) ) then c if ( xx(4) .lt. xx(2) ) then c ixvs2(i) = -1 c x01(i) = xx(4) - xx(1) c tmp = x02(i) * xo21(i) x0201o21(i) = tmp * x01(i) x0202o21(i) = tmp * x02(i) c x020132o2131(i) = x0201o21(i) * ( xx(3) - xx(2) ) $ / ( xx(3) - xx(1) ) c else c ixvs2(i) = 1 c x03(i) = xx(4) - xx(3) c tmp = x02(i) * xo32(i) x0230o32(i) = ( xx(3) - xx(4) ) * tmp x0202o32(i) = x02(i) * tmp c x023021o3231(i) = x0230o32(i) * ( xx(2) - xx(1) ) $ / ( xx(3) - xx(1) ) c endif c else if ( xx(4) .gt. xx(2) ) then c ixvs2(i) = -1 c x01(i) = xx(4) - xx(1) c tmp = x02(i) * xo21(i) x0201o21(i) = tmp * x01(i) x0202o21(i) = tmp * x02(i) c x020132o2131(i) = x0201o21(i) * ( xx(3) - xx(2) ) $ / ( xx(3) - xx(1) ) c else c ixvs2(i) = 1 c x03(i) = xx(4) - xx(3) c tmp = x02(i) * xo32(i) x0230o32(i) = ( xx(3) - xx(4) ) * tmp x0202o32(i) = x02(i) * tmp c x023021o3231(i) = x0230o32(i) * ( xx(2) - xx(1) ) $ / ( xx(3) - xx(1) ) c endif c endif c return end c c************************************************************************ c function quadslget( i, y1, y2, y3 ) c =================================== c c..... this function performs a quadratic interpolation, trying to avoid c spurious wiggles at point where the slope changes by a large amount c common/c_quadsl_opal_z/ xo21(10), xo32(10), x01(10), x02(10), $ x03(10), x0230o32(10), x0202o32(10), x023021o3231(10), $ x0203o31(10), x0201o31(10), x0201o21(10), x0202o21(10), $ x020132o2131(10), ixvs2(10) save /c_quadsl_opal_z/ c if ( ixvs2(i) .eq. 0 ) then quadslget = y2 return endif c s21 = ( y2 - y1 ) * xo21(i) s32 = ( y3 - y2 ) * xo32(i) as21 = abs( s21 ) as32 = abs( s32 ) c if ( 6.0 * as21 .le. as32 ) then c if ( ixvs2(i) .le. 0 ) then quadslget = x02(i) * s21 + y2 else quadslget = x0230o32(i) * s21 + x0202o32(i) * s32 + y2 endif c else if ( 2.0 * as21 .lt. as32 ) then c omf_ds = ( 1.5 - as32 / ( 4.0 * as21 ) ) * ( s32 - s21 ) if ( ixvs2(i) .le. 0 ) then quadslget = omf_ds * x0201o31(i) + x01(i) * s21 + y1 else quadslget = x0230o32(i) * s21 + x0202o32(i) * s32 $ + omf_ds * x023021o3231(i) + y2 endif c else if ( 2.0 * as32 .ge. as21 ) then c quadslget = x0201o31(i) * s32 - x0203o31(i) * s21 + y2 c else if ( 6.0 * as32 .gt. as21 ) then c omf_ds = ( 1.5 - as21 / ( 4.0 * as32 ) ) * ( s32 - s21 ) if ( ixvs2(i) .ge. 0 ) then quadslget = omf_ds * x0203o31(i) + x03(i) * s32 + y3 else quadslget = x0201o21(i) * s32 - x0202o21(i) * s21 $ - omf_ds * x020132o2131(i) + y2 endif c else if ( ixvs2(i) .ge. 0 ) then quadslget = x02(i) * s32 + y2 else quadslget = x0201o21(i) * s32 - x0202o21(i) * s21 + y2 endif c return end c c****************************************************************************** c subroutine qderslsto( i, x, x1, x2, x3 ) c ======================================== c c Storage for x,dx_i values that need not be computed on each call; c NOTE that this same storage is used by all of QUADSL, QDERSL, QCHKSL c common/c_quadsl_opal_z/ xo21(10), xo32(10), x01(10), x02(10), $ x03(10), x0230o32(10), x0202o32(10), x023021o3231(10), $ x0203o31(10), x0201o31(10), x0201o21(10), x0202o21(10), $ x020132o2131(10), ixvs2(10) save /c_quadsl_opal_z/ c c Storage for quantities needed for derivatives c common/c_qdersl_opal_z/ x01o31(10), x30o31(10), x30p20o31(10), $ x02p01o31(10), x30p20o32(10), x02o32two(10), x02p01o21(10), $ x30p2021o3231(10), x02p03o31(10), x02o21two(10), $ x02p0132o2131(10) save /c_qdersl_opal_z/ c dimension xx(6) c xx(1) = x1 xx(2) = x2 xx(3) = x3 xx(4) = x c xo21(i) = 1.0 / ( xx(2) - xx(1) ) xo32(i) = 1.0 / ( xx(3) - xx(2) ) c xx(5) = 1.0 / ( xx(3) - xx(1) ) c if ( xx(4) .eq. xx(2) ) then c ixvs2(i) = 0 c x01o31(i) = ( xx(4) - xx(1) ) * xx(5) x30o31(i) = ( xx(3) - xx(4) ) * xx(5) c else c x02(i) = xx(4) - xx(2) c xx(6) = x02(i) * xx(5) x0201o31(i) = xx(6) * ( xx(4) - xx(1) ) x0203o31(i) = xx(6) * ( xx(4) - xx(3) ) c x30p20o31(i) = ( ( xx(3) - xx(4) ) - x02(i) ) * xx(5) x02p01o31(i) = ( x02(i) + ( xx(4) - xx(1) ) ) * xx(5) c if ( xx(1) .lt. xx(3) ) then c if ( xx(4) .lt. xx(2) ) then c ixvs2(i) = -1 c x01(i) = xx(4) - xx(1) c xx(6) = x02(i) * xo21(i) x0201o21(i) = xx(6) * x01(i) x0202o21(i) = xx(6) * x02(i) c xx(6) = ( xx(3) - xx(2) ) * xx(5) x020132o2131(i) = x0201o21(i) * xx(6) c x02p01o21(i) = ( x02(i) + x01(i) ) * xo21(i) x02o21two(i) = 2.0 * x02(i) * xo21(i) c x02p0132o2131(i) = x02p01o21(i) * xx(6) c else c ixvs2(i) = 1 c x03(i) = xx(4) - xx(3) c xx(6) = x02(i) * xo32(i) x0230o32(i) = ( xx(3) - xx(4) ) * xx(6) x0202o32(i) = x02(i) * xx(6) c xx(6) = ( xx(2) - xx(1) ) * xx(5) x023021o3231(i) = x0230o32(i) * xx(6) c x30p20o32(i) = ( ( xx(3) - xx(4) ) - x02(i) ) * xo32(i) x02o32two(i) = 2.0 * x02(i) * xo32(i) c x30p2021o3231(i) = x30p20o32(i) * xx(6) c x02p03o31(i) = ( x02(i) + x03(i) ) * xx(5) c endif c else if ( xx(4) .gt. xx(2) ) then c ixvs2(i) = -1 c x01(i) = xx(4) - xx(1) c xx(6) = x02(i) * xo21(i) x0201o21(i) = xx(6) * x01(i) x0202o21(i) = xx(6) * x02(i) c xx(6) = ( xx(3) - xx(2) ) * xx(5) x020132o2131(i) = x0201o21(i) * xx(6) c x02p01o21(i) = ( x02(i) + x01(i) ) * xo21(i) x02o21two(i) = 2.0 * x02(i) * xo21(i) c x02p0132o2131(i) = x02p01o21(i) * xx(6) c else c ixvs2(i) = 1 c x03(i) = xx(4) - xx(3) c xx(6) = x02(i) * xo32(i) x0230o32(i) = ( xx(3) - xx(4) ) * xx(6) x0202o32(i) = x02(i) * xx(6) c xx(6) = ( xx(2) - xx(1) ) * xx(5) x023021o3231(i) = x0230o32(i) * xx(6) c x30p20o32(i) = ( ( xx(3) - xx(4) ) - x02(i) ) * xo32(i) x02o32two(i) = 2.0 * x02(i) * xo32(i) c x30p2021o3231(i) = x30p20o32(i) * xx(6) c x02p03o31(i) = ( x02(i) + x03(i) ) * xx(5) c endif c endif c return end c c****************************************************************************** c subroutine qderslget( i, y1, y2, y3, y, dydx ) c ============================================== c c..... this subroutine performs a quadratic interpolation, trying to avoid c spurious wiggles at point where the slope changes by a large amount; c it is identical to the function quadsl, except that it also computes c the derivative dydx of the quadratic at x, as well as y c c Storage for x,dx_i values that need not be computed on each call (see "ic"); c NOTE that this same storage is used by all of QUADSL, QDERSL c common/c_quadsl_opal_z/ xo21(10), xo32(10), x01(10), x02(10), $ x03(10), x0230o32(10), x0202o32(10), x023021o3231(10), $ x0203o31(10), x0201o31(10), x0201o21(10), x0202o21(10), $ x020132o2131(10), ixvs2(10) save /c_quadsl_opal_z/ c common/c_qdersl_opal_z/ x01o31(10), x30o31(10), x30p20o31(10), $ x02p01o31(10), x30p20o32(10), x02o32two(10), x02p01o21(10), $ x30p2021o3231(10), x02p03o31(10), x02o21two(10), $ x02p0132o2131(10) save /c_qdersl_opal_z/ c s21 = ( y2 - y1 ) * xo21(i) s32 = ( y3 - y2 ) * xo32(i) as21 = abs( s21 ) as32 = abs( s32 ) c if ( ixvs2(i) .eq. 0 ) then if ( 6.0 * as21 .le. as32 ) then dydx = s21 else if ( 2.0 * as21 .lt. as32 ) then omf = 1.5 - as32 / ( 4.0 * as21 ) dydx = s21 - omf * x01o31(i) * ( s21 - s32 ) else if ( 2.0 * as32 .ge. as21 ) then dydx = x30o31(i) * s21 + x01o31(i) * s32 else if ( 6.0 * as32 .gt. as21 ) then omf = 1.5 - as21 / ( 4.0 * as32 ) dydx = s32 - omf * x30o31(i) * ( s32 - s21 ) else dydx = s32 endif y = y2 return endif c if ( 6.0 * as21 .le. as32 ) then c if ( ixvs2(i) .le. 0 ) then y = x02(i) * s21 + y2 dydx = s21 else y = x0230o32(i) * s21 + x0202o32(i) * s32 + y2 dydx = x30p20o32(i) * s21 + x02o32two(i) * s32 endif c else if ( 2.0 * as21 .lt. as32 ) then c omf_ds = ( 1.5 - as32 / ( 4.0 * as21 ) ) * ( s32 - s21 ) if ( ixvs2(i) .le. 0 ) then y = omf_ds * x0201o31(i) + x01(i) * s21 + y1 dydx = s21 + omf_ds * x02p01o31(i) else y = x0230o32(i) * s21 + x0202o32(i) * s32 $ + omf_ds * x023021o3231(i) + y2 dydx = x30p20o32(i) * s21 + x02o32two(i) * s32 $ + omf_ds * x30p2021o3231(i) endif c else if ( 2.0 * as32 .ge. as21 ) then c y = x0201o31(i) * s32 - x0203o31(i) * s21 + y2 dydx = x30p20o31(i) * s21 + x02p01o31(i) * s32 c else if ( 6.0 * as32 .gt. as21 ) then c omf_ds = ( 1.5 - as21 / ( 4.0 * as32 ) ) * ( s32 - s21 ) if ( ixvs2(i) .ge. 0 ) then y = omf_ds * x0203o31(i) + x03(i) * s32 + y3 dydx = s32 + omf_ds * x02p03o31(i) else y = x0201o21(i) * s32 - x0202o21(i) * s21 $ - omf_ds * x020132o2131(i) + y2 dydx = x02p01o21(i) * s32 - x02o21two(i) * s21 $ - omf_ds * x02p0132o2131(i) endif c else if ( ixvs2(i) .ge. 0 ) then y = x02(i) * s32 + y2 dydx = s32 else y = x0201o21(i) * s32 - x0202o21(i) * s21 + y2 dydx = x02p01o21(i) * s32 - x02o21two(i) * s21 endif c return end c c************************************************************************ c subroutine qchkslsto( i, x, x1, x2, x3 ) c ======================================== c c QCHKSL is used only for Ferguson et al. 2005 molecular opacities at the c highest X-interval; thus one can assume x1 < x2 and ( x2 < x3 or x2 = x3 ). c parameter ( ratbeg=0.08, ratful=0.04, ratdel=1./(ratbeg-ratful) ) c common /c_qchksl_opal_z/ x01o21p31(10), facq(10), omfq(10), $ iokq(10) save /c_qchksl_opal_z/ c dxrat = abs( x3 - x2 ) / abs( x3 - x1 ) if ( dxrat .ge. ratbeg ) then iokq(i) = 1 call quadslsto( i, x, x1, x2, x3 ) else x01o21p31(i) = ( x - x1 ) $ / ( ( x2 - x1 ) + ( x3 - x1 ) ) if ( dxrat .gt. ratful ) then iokq(i) = 0 facq(i) = ( dxrat - ratful ) * ratdel omfq(i) = 1.0 - facq(i) call quadslsto( i, x, x1, x2, x3 ) else iokq(i) = -1 facq(i) = 0. endif endif c return end c c************************************************************************ c function qchkslget( i, y1, y2, y3 ) c =================================== c c..... if x2 was not too close to x3, then this function calls c quadslget(i,y1,y2,y3) to perform a quadratic interpolation; c if x2 and x3 were too close together to make a quadratic interpolation c reasonable, something more nearly linear is used instead. c common /c_qchksl_opal_z/ x01o21p31(10), facq(10), omfq(10), $ iokq(10) save /c_qchksl_opal_z/ c if ( iokq(i) .gt. 0 ) then qchkslget = quadslget( i, y1, y2, y3 ) else if ( iokq(i) .lt. 0 ) then qchkslget = y1 + x01o21p31(i) $ * ( ( y2 - y1 ) + ( y3 - y1 ) ) else qchkslget = omfq(i) * ( y1 + x01o21p31(i) $ * ( ( y2 - y1 ) + ( y3 - y1 ) ) ) $ + facq(i) * quadslget( i, y1, y2, y3 ) endif c return end c c************************************************************************ c subroutine qchksto( i, x, x1, x2, x3 ) c -------------------------------------- c c NOTE that if a quadratic is fitted through 3 points with a large c interval R=(x2-x1) with values differing by D=(y2-y1), next to a much c smaller interval r=(x3-x2) with values differing by d=(y3-y2), and c the close-together points y2 and y3 have a relative error E, then c at the middle of the large interval R this error is magnified by c a factor of (1/4)(R/r). At the middle of the interval R, the c difference between a linear and a quadratic is (1/4)[D-(R/r)d]; c if this is less than the magnified error (1/4)(R/r)E, i.e., c if E > | (r/R)D - d | , then the linear fit is better. In QCHKGET, a c quadratic-error magnification of nearly 3 is allowed (R/r=11.5) before c beginning to switch over to linear interpolation; the switch-over is c complete at R/r=24. The ratios used in the code are actually r/(r+R). c parameter ( small_1m6=1.e-6 ) c parameter ( ratbeg=0.08, ratful=0.04, ratdel=1./(ratbeg-ratful) ) c c Storage for factors that need not be computed on each call. c common/c_qchk_opal_z/ facq(30),dxinvq(30),omfq(30), $ iokq(30),iloq(30),i1q(30),i2q(30),lin(30) save /c_qchk_opal_z/ c c NOTE that QCHKSTO may store the same values as QUADSTO; if this is so, c then QCHKGET will use these stored values in the same manner as QUADGET. c common /c3quad_opal_z/ a21(30), a32(30), d21(30), d32(30) save /c3quad_opal_z/ c dimension xx(3), r(3) c xx(1) = x1 xx(2) = x2 xx(3) = x3 c ! linear extrapolation for x < x1 < x3: c if ( x .lt. xx(1) .and. xx(3) - xx(1) .gt. small_1m6 ) then c lin(i) = 1 c xloq = max( xx(2) - xx(1) , small_1m6 ) omf = max( 0.0 , min( 1.0 , ( xx(3) - xx(1) ) / xloq ) ) omfq(i) = omf * ( x - xx(1) ) / ( xx(3) - xx(1) ) facq(i) = ( 1. - omf ) * ( x - xx(1) ) / xloq c return c endif c ! otherwise: lin(i) = 0 c r(1) = abs( xx(3) - xx(2) ) r(2) = abs( xx(3) - xx(1) ) r(3) = abs( xx(2) - xx(1) ) c dxrat = min(r(1),r(2),r(3))/max(r(1),r(2),r(3)) c if ( dxrat .ge. ratbeg ) then iokq(i) = 1 tmp = ( x - xx(2) ) / ( xx(3) - xx(1) ) a21(i) = tmp * ( xx(3) - x ) / ( xx(2) - xx(1) ) a32(i) = tmp * ( x - xx(1) ) / ( xx(3) - xx(2) ) else if ( r(3) .lt. min(r(1),r(2)) ) then iloq(i) = 3 i1q(i) = 1 i2q(i) = 2 dxinvq(i) = ( x - xx(3) ) $ / ( ( xx(1) + xx(2) ) * 0.5 - xx(3) ) else if ( r(2) .lt. r(1) ) then iloq(i) = 2 i1q(i) = 3 i2q(i) = 1 dxinvq(i) = ( x - xx(2) ) $ / ( ( xx(3) + xx(1) ) * 0.5 - xx(2) ) else iloq(i) = 1 i1q(i) = 2 i2q(i) = 3 dxinvq(i) = ( x - xx(1) ) $ / ( ( xx(2) + xx(3) ) * 0.5 - xx(1) ) endif if ( dxrat .gt. ratful ) then iokq(i) = 0 facq(i) = ( dxrat - ratful ) * ratdel omfq(i) = 1. - facq(i) tmp = ( x - xx(2) ) / ( xx(3) - xx(1) ) a21(i) = tmp * ( xx(3) - x ) / ( xx(2) - xx(1) ) a32(i) = tmp * ( x - xx(1) ) / ( xx(3) - xx(2) ) else iokq(i) = -1 facq(i) = 0. omfq(i) = 1. endif endif c return end c c************************************************************************ c function qchkget( i, y1, y2, y3 ) c --------------------------------- c c..... if x < x1 < x3, then linear extrapolation is used (using values at x1 c and x3; value at x2 is ignored, unless x2 > x3, which should not be); c otherwise: c if x2 was not too close to either x3 or x1, then this function calls c quadget(i,y1,y2,y3) to perform a quadratic interpolation; c if x2 and x3 (or x2 and x1) were too close together to make a quadratic c interpolation reasonable, something more nearly linear is used instead. c common/c_qchk_opal_z/ facq(30),dxinvq(30),omfq(30), $ iokq(30),iloq(30),i1q(30),i2q(30),lin(30) save /c_qchk_opal_z/ c common /c3quad_opal_z/ a21(30), a32(30), d21(30), d32(30) save /c3quad_opal_z/ c dimension yy(3) c if ( lin(i) .gt. 0 ) then qchkget = ( y2 - y1 ) * facq(i) + ( y3 - y1 ) * omfq(i) + y1 else if ( iokq(i) .gt. 0 ) then qchkget = a21(i) * ( y2 - y1 ) + a32(i) * ( y3 - y2 ) + y2 else yy(1) = y1 yy(2) = y2 yy(3) = y3 if ( iokq(i) .lt. 0 ) then qchkget = ( ( yy(i1q(i)) + yy(i2q(i)) ) * 0.5 $ - yy(iloq(i)) ) * dxinvq(i) + yy(iloq(i)) else qchkget = ( ( ( yy(i1q(i)) + yy(i2q(i)) ) * 0.5 $ - yy(iloq(i)) ) * dxinvq(i) + yy(iloq(i)) ) * omfq(i) $ + ( a21(i) * ( yy(2) - yy(1) ) $ + a32(i) * ( yy(3) - yy(2) ) + yy(2) ) * facq(i) endif endif c return end c c************************************************************************ c subroutine qderNsto( i, nmore, x, x1, x2, x3, x4 ) c -------------------------------------------------- c common /cNquad_opal_z/ f21(30), f32(30), f43(30), $ g21(30), g32(30), g43(30) save /cNquad_opal_z/ c ! 4-point interpolation: if ( nmore .eq. 3 ) then c t2 = x - x2 c t21 = ( x3 - x1 ) * ( x2 - x1 ) t32 = ( x3 - x1 ) * ( x3 - x2 ) c a21 = t2 * ( x3 - x ) / t21 a32 = t2 * ( x - x1 ) / t32 d21 = ( ( x3 - x ) - t2 ) / t21 d32 = ( t2 + ( x - x1 ) ) / t32 c xinv32 = 1.0 / ( x3 - x2 ) c fhi = t2 * xinv32 flo = 1.0 - fhi c t3 = x - x3 c u32 = ( x4 - x2 ) * ( x3 - x2 ) u43 = ( x4 - x2 ) * ( x4 - x3 ) c b32 = t3 * ( x4 - x ) / u32 b43 = t3 * t2 / u43 e32 = ( ( x4 - x ) - t3 ) / u32 e43 = ( t2 + t3 ) / u43 c f21(i) = flo * a21 f43(i) = fhi * b43 c f32(i) = fhi + ( b32 - a32 ) * fhi + a32 c g21(i) = flo * d21 - a21 * xinv32 g43(i) = fhi * e43 + b43 * xinv32 c g32(i) = ( 1.0 + b32 - a32 ) * xinv32 $ + ( e32 - d32 ) * fhi + d32 c ! 3-point interp, or extrap: else if ( nmore .eq. 2 ) then c fhi = ( x - x3 ) / ( x3 - x2 ) c if ( fhi .ge. 1.0 ) then c f21(i) = 0.0 f32(i) = fhi + 1.0 c g21(i) = 0.0 g32(i) = 1.0 / ( x3 - x2 ) c else if ( fhi .gt. 0.0 ) then c t1 = ( fhi - 1.0 ) / ( x3 - x1 ) tmp = t1 * ( fhi - 1.0 ) * ( x - x3 ) t2 = ( x2 - x3 ) / ( x2 - x1 ) c f21(i) = t2 * tmp f32(i) = fhi + 1.0 + tmp c tmp = t1 * ( fhi + fhi + fhi - 1.0 ) c g21(i) = t2 * tmp g32(i) = tmp + 1.0 / ( x3 - x2 ) c else c flo = ( x - x1 ) / ( x2 - x1 ) c if ( flo .le. -1.0 ) then c f21(i) = flo - 1.0 f32(i) = 0.0 c g21(i) = 1.0 / ( x2 - x1 ) g32(i) = 0.0 c else if ( flo .lt. 0.0 ) then c t1 = ( flo + 1.0 ) / ( x3 - x1 ) tmp = t1 * ( flo + 1.0 ) * ( x - x1 ) t2 = ( x1 - x2 ) / ( x3 - x2 ) c f21(i) = flo - 1.0 + tmp f32(i) = t2 * tmp c tmp = t1 * ( flo + flo + flo + 1.0 ) c g21(i) = tmp + 1.0 / ( x2 - x1 ) g32(i) = t2 * tmp c else c t2 = x - x2 c t21 = ( x3 - x1 ) * ( x2 - x1 ) t32 = ( x3 - x1 ) * ( x3 - x2 ) c f21(i) = t2 * ( x3 - x ) / t21 f32(i) = t2 * ( x - x1 ) / t32 c g21(i) = ( ( x3 - x ) - t2 ) / t21 g32(i) = ( ( x - x1 ) + t2 ) / t32 c endif c endif c ! 2-point interp/extrap: else c f21(i) = ( x - x1 ) / ( x2 - x1 ) g21(i) = 1.0 / ( x2 - x1 ) c endif c return end c c************************************************************************ c subroutine qderNget( i, nmore, y1, y2, y3, y4, y, dydx ) c -------------------------------------------------------- c common /cNquad_opal_z/ f21(30), f32(30), f43(30), $ g21(30), g32(30), g43(30) save /cNquad_opal_z/ c ! 4-point interpolation: if ( nmore .eq. 3 ) then c y21 = y2 - y1 y32 = y3 - y2 y43 = y4 - y3 y = f21(i) * y21 + f32(i) * y32 + f43(i) * y43 + y2 dydx = g21(i) * y21 + g32(i) * y32 + g43(i) * y43 c ! 3-pt interp/extrap else if ( nmore .eq. 2 ) then c y21 = y2 - y1 y32 = y3 - y2 y = f21(i) * y21 + f32(i) * y32 + y2 dydx = g21(i) * y21 + g32(i) * y32 c ! 2-point interp/extrap: else c y21 = y2 - y1 y = f21(i) * y21 + y1 dydx = g21(i) * y21 c endif c return end c c************************************************************************ c subroutine quadNsto( i, nmore, x, x1, x2, x3, x4 ) c -------------------------------------------------- c common /cNquad_opal_z/ f21(30), f32(30), f43(30), $ g21(30), g32(30), g43(30) save /cNquad_opal_z/ c ! 4-point interpolation: if ( nmore .eq. 3 ) then c t2 = x - x2 c a = t2 / ( x3 - x1 ) a21 = a * ( x3 - x ) / ( x2 - x1 ) a32x32 = a * ( x - x1 ) c fhi = t2 / ( x3 - x2 ) c b = ( x - x3 ) / ( x4 - x2 ) b32x32 = b * ( x4 - x ) b43 = b * t2 / ( x4 - x3 ) c f21(i) = ( 1.0 - fhi ) * a21 f43(i) = fhi * b43 c f32(i) = ( t2 + ( b32x32 - a32x32 ) * fhi + a32x32 ) $ / ( x3 - x2 ) c ! 3-point interp, or extrap: else if ( nmore .eq. 2 ) then c fhi = ( x - x3 ) / ( x3 - x2 ) c if ( fhi .ge. 1.0 ) then c f21(i) = 0.0 f32(i) = fhi + 1.0 c else if ( fhi .gt. 0.0 ) then c tmp = ( fhi - 1.0 ) * ( fhi - 1.0 ) $ * ( x - x3 ) / ( x3 - x1 ) f21(i) = tmp * ( x2 - x3 ) / ( x2 - x1 ) f32(i) = fhi + 1.0 + tmp c else c flo = ( x - x1 ) / ( x2 - x1 ) c if ( flo .le. -1.0 ) then c f21(i) = flo - 1.0 f32(i) = 0.0 c else if ( flo .lt. 0.0 ) then c tmp = ( flo + 1.0 ) * ( flo + 1.0 ) $ * ( x - x1 ) / ( x3 - x1 ) f21(i) = flo - 1.0 + tmp f32(i) = tmp * ( x1 - x2 ) / ( x3 - x2 ) c else c tmp = ( x - x2 ) / ( x3 - x1 ) f21(i) = tmp * ( x3 - x ) / ( x2 - x1 ) f32(i) = tmp * ( x - x1 ) / ( x3 - x2 ) c endif c endif c ! 2-point interp/extrap: else c f21(i) = ( x - x1 ) / ( x2 - x1 ) c endif c return end c c************************************************************************ c function quadNget( i, nmore, y1, y2, y3, y4 ) c --------------------------------------------- c common /cNquad_opal_z/ f21(30), f32(30), f43(30), $ g21(30), g32(30), g43(30) save /cNquad_opal_z/ c ! 4-point interpolation: if ( nmore .eq. 3 ) then c quadNget = f21(i) * ( y2 - y1 ) + f32(i) * ( y3 - y2 ) $ + f43(i) * ( y4 - y3 ) + y2 c ! 3-point interp, or extrap: else if ( nmore .eq. 2 ) then c quadNget = f21(i) * ( y2 - y1 ) + f32(i) * ( y3 - y2 ) + y2 c else c ! 2-point interp/extrap: quadNget = f21(i) * ( y2 - y1 ) + y1 c endif c return end c c************************************************************************ c subroutine qder4sto( i, x, x1, x2, x3, x4 ) c ------------------------------------------- c c This uses the same formulae as QUAD4STO below, but also takes derivatives. c c Storage for x,dx_i values that need not be computed on each QDER4GET call; c NOTE that this same storage is used by QUAD4GET as well. c common /c4quad_opal_z/ f21(30), f32(30), f43(30), $ g21(30), g32(30), g43(30) save /c4quad_opal_z/ c t2 = x - x2 c t21 = ( x3 - x1 ) * ( x2 - x1 ) t32 = ( x3 - x1 ) * ( x3 - x2 ) c a21 = t2 * ( x3 - x ) / t21 a32 = t2 * ( x - x1 ) / t32 d21 = ( ( x3 - x ) - t2 ) / t21 d32 = ( t2 + ( x - x1 ) ) / t32 c xinv32 = 1.0 / ( x3 - x2 ) c fhi = t2 * xinv32 flo = 1.0 - fhi c t3 = x - x3 c u32 = ( x4 - x2 ) * ( x3 - x2 ) u43 = ( x4 - x2 ) * ( x4 - x3 ) c b32 = t3 * ( x4 - x ) / u32 b43 = t3 * ( x - x2 ) / u43 e32 = ( ( x4 - x ) - t3 ) / u32 e43 = ( ( x - x2 ) + t3 ) / u43 c f21(i) = flo * a21 f43(i) = fhi * b43 c f32(i) = fhi + ( b32 - a32 ) * fhi + a32 c g21(i) = flo * d21 - a21 * xinv32 g43(i) = fhi * e43 + b43 * xinv32 c g32(i) = ( 1.0 + b32 - a32 ) * xinv32 + ( e32 - d32 ) * fhi + d32 c return end c c************************************************************************ c subroutine qder4get( i, y1, y2, y3, y4, y, dydx ) c ------------------------------------------------- c c..... this function performs a quadratic interpolation on values stored by c QDER4STO; it is identical to the function QUAD4GET, except that it also c computes the derivative dydx of the quadratic at the given position x. c common /c4quad_opal_z/ f21(30), f32(30), f43(30), $ g21(30), g32(30), g43(30) save /c4quad_opal_z/ c y21 = y2 - y1 y32 = y3 - y2 y43 = y4 - y3 c y = f21(i) * y21 + f32(i) * y32 + f43(i) * y43 + y2 c dydx = g21(i) * y21 + g32(i) * y32 + g43(i) * y43 c return end c c************************************************************************ c subroutine quad4sto( i, x, x1, x2, x3, x4 ) c ------------------------------------------- c c Storage for x,dx_i values that need not be computed on each QUAD4GET call; c NOTE that this same storage is used by QDER4GET as well. c c x - x2 / x3 - x x - x1 \ c L = y2 + ------- ( ------- ( y2 - y1 ) + ------- ( y3 - y2 ) ) c x3 - x1 \ x2 - x1 x3 - x2 / c c x - x3 / x4 - x x - x2 \ c H = y3 + ------- ( ------- ( y3 - y2 ) + ------- ( y4 - y3 ) ) c x4 - x2 \ x3 - x3 x4 - x3 / c c equivalent x - x2 / x4 - x x - x3 \ c equivalent H = y2 + ------- ( ------- ( y3 - y2 ) + ------- ( y4 - y2 ) ) c equivalent x4 - x3 \ x3 - x2 x4 - x2 / c c x3 - x x - x2 c y = ------- L + ------- H c x3 - x2 x3 - x2 c common /c4quad_opal_z/ f21(30), f32(30), f43(30), $ g21(30), g32(30), g43(30) save /c4quad_opal_z/ c t2 = x - x2 c a = t2 / ( x3 - x1 ) a21 = a * ( x3 - x ) / ( x2 - x1 ) a32x32 = a * ( x - x1 ) c fhi = t2 / ( x3 - x2 ) c b = ( x - x3 ) / ( x4 - x2 ) b32x32 = b * ( x4 - x ) b43 = b * t2 / ( x4 - x3 ) c f21(i) = ( 1.0 - fhi ) * a21 f43(i) = fhi * b43 c f32(i) = ( t2 + ( b32x32 - a32x32 ) * fhi + a32x32 ) $ / ( x3 - x2 ) c return end c c************************************************************************ c function quad4get( i, y1, y2, y3, y4 ) c -------------------------------------- c c this function performs a quadratic interpolation on values stored by QUADSTO. c common /c4quad_opal_z/ f21(30), f32(30), f43(30), $ g21(30), g32(30), g43(30) save /c4quad_opal_z/ c quad4get = f21(i) * ( y2 - y1 ) + f32(i) * ( y3 - y2 ) $ + f43(i) * ( y4 - y3 ) + y2 c return end c c************************************************************************ c subroutine qdersto( i, x, x1, x2, x3 ) c -------------------------------------- c c Storage for x,dx_i values that need not be computed on each QDERGET call; c NOTE that this same storage is used by all of QUAD, QDER, and QCHK. c c x - x2 / x3 - x x - x1 \ c y = y2 + ------- ( ------- ( y2 - y1 ) + ------- ( y3 - y2 ) ) c x3 - x1 \ x2 - x1 x3 - x2 / c c = y2 + a21(i) * ( y2 - y1 ) + a32(i) * ( y3 - y2 ) c c dy ( x3 - x ) - ( x - x2 ) ( x - x1 ) + ( x - x2 ) c -- = ------------------------- (y2-y1) + ------------------------- (y3-y2) c dx ( x3 - x1 ) * ( x2 - x1 ) ( x3 - x1 ) * ( x2 - x1 ) c c = d21(i) * ( y2 - y1 ) + d32(i) * ( y3 - y2 ) c common /c3quad_opal_z/ a21(30), a32(30), d21(30), d32(30) save /c3quad_opal_z/ c t2 = x - x2 t21 = ( x3 - x1 ) * ( x2 - x1 ) t32 = ( x3 - x1 ) * ( x3 - x2 ) c a21(i) = t2 * ( x3 - x ) / t21 a32(i) = t2 * ( x - x1 ) / t32 d21(i) = ( ( x3 - x ) - t2 ) / t21 d32(i) = ( ( x - x1 ) + t2 ) / t32 c return end c c************************************************************************ c subroutine qderget( i, y1, y2, y3, y, dydx ) c -------------------------------------------- c c..... this function performs a quadratic interpolation on values stored by c QDERSTO; it is identical to the function QUADGET, except that it also c computes the derivative dydx of the quadratic at the given position x. c common /c3quad_opal_z/ a21(30), a32(30), d21(30), d32(30) save /c3quad_opal_z/ c y21 = y2 - y1 y32 = y3 - y2 c dydx = d21(i) * y21 + d32(i) * y32 y = a21(i) * y21 + a32(i) * y32 + y2 c return end c c************************************************************************ c subroutine quadsto( i, x, x1, x2, x3 ) c -------------------------------------- c c Storage for x,dx_i values that need not be computed on each QUADGET call; c NOTE that this same storage is used by all of QUAD, QDER, and QCHK. c c x - x2 / x3 - x x - x1 \ c y = y2 + ------- ( ------- ( y2 - y1 ) + ------- ( y3 - y2 ) ) c x3 - x1 \ x2 - x1 x3 - x2 / c c = y2 + a21(i) * ( y2 - y1 ) + a32(i) * ( y3 - y2 ) c common /c3quad_opal_z/ a21(30), a32(30), d21(30), d32(30) save /c3quad_opal_z/ c tmp = ( x - x2 ) / ( x3 - x1 ) a21(i) = tmp * ( x3 - x ) / ( x2 - x1 ) a32(i) = tmp * ( x - x1 ) / ( x3 - x2 ) c return end c c************************************************************************ c function quadget( i, y1, y2, y3 ) c --------------------------------- c c this function performs a quadratic interpolation on values stored by QUADSTO. c common /c3quad_opal_z/ a21(30), a32(30), d21(30), d32(30) save /c3quad_opal_z/ c quadget = a21(i) * ( y2 - y1 ) + a32(i) * ( y3 - y2 ) + y2 c return end c c************************************************************************ c function num_blanks_contained( fname ) c ====================================== c c Count the number of blanks between first and last non-blank characters c character*(*) fname c character*1 ctab common /c_ctab/ ctab save /c_ctab/ c iblank = 0 c if ( lnblnk(fname) .gt. 0 ) then c do i = non_blank_begin(fname), lnblnk(fname) if ( fname(i:i) .eq. ' ' .or. fname(i:i) .eq. ctab ) $ iblank = iblank + 1 enddo c endif c num_blanks_contained = iblank c return end c c************************************************************************ c function non_blank_begin( fname ) c ================================= c c Find the first non-blank character in the input character variable c character*(*) fname c character*1 ctab common /c_ctab/ ctab save /c_ctab/ c last = lnblnk( fname ) c if ( last .le. 1 ) then i = last else i = 1 do while ( i .lt. last .and. $ ( fname(i:i) .eq. ' ' .or. fname(i:i) .eq. ctab ) ) i = i + 1 enddo endif c non_blank_begin = i c return end c c************************************************************************ c NOTE that the subroutines below have alternate parts, all but one c commented out, for various flavors of UNIX and for VMS (the Linux c versions should actually work for any flavor of UNIX). c*********************************************************************** c subroutine opoldr(iu,fname) c =========================== c c Open an old formatted file: c character*(*) fname c character*1 cb(6) common /chkpoc/ cb save /chkpoc/ c c-linux[ character*255 fnalt c-linux] c c For Linux: get home directory name if necessary, and open the file c with the err= keyword to prevent coredump c (actually, this should work on any Unix system, provided that the c environment variable HOME is correctly defined as the home directory): c-linux[ call linux_get_home_dir(fname,fnalt,ialt) c if ( ialt .gt. 0 ) then open(iu,file=fnalt,form='FORMATTED',status='OLD', $ iostat=ioperr,err=900) else open(iu,file=fname,form='FORMATTED',status='OLD', $ iostat=ioperr,err=900) endif c return c 900 write(6,910) ioperr,iu,fname(:lnblnk(fname)) 910 format(' '/' Error',i12,' opening unit',i3,' with old file:'/ $ ' ',a) stop ' STOP -- OPOLDR: Error opening old file. ' c-linux] c c For Sun UNIX: open the file: c-sun[ c-sun; open(iu,file=fname,form='FORMATTED',status='OLD') c-sun; return c-sun] c c For VMS, or for Iris UNIX: open the file as read-only: c-vms-iris[ c-vms-iris; open(iu,file=fname,form='FORMATTED',status='OLD', c-vms-iris; $ readonly) c-vms-iris; return c-vms-iris] c end c c************************************************************************ c subroutine opoluf(iu,fname) c =========================== c c Open an old unformatted file: c character*(*) fname c c For Linux: open the file, with the err= keyword to prevent coredump: c-linux[ character*255 fnalt c call linux_get_home_dir(fname,fnalt,ialt) c if ( ialt .gt. 0 ) then open(iu,file=fnalt,form='UNFORMATTED',status='OLD', $ iostat=ioperr,err=900) else open(iu,file=fname,form='UNFORMATTED',status='OLD', $ iostat=ioperr,err=900) endif c return c 900 write(6,910) ioperr,iu,fname(:lnblnk(fname)) 910 format(' '/' Error',i12,' opening unit',i3, $ ' with old unformatted file:'/' ',a) stop ' STOP -- OPOLUF: Error opening old unformatted file. ' c-linux] c c For Sun UNIX: open the file: c-sun[ c-sun; open(iu,file=fname,form='UNFORMATTED',status='OLD') c-sun; return c-sun] c c For VMS or Iris UNIX: open the file as read-only: c-vms-iris[ c-vms-iris; open(iu,file=fname,form='UNFORMATTED',status='OLD', c-vms-iris; $ readonly) c-vms-iris; return c-vms-iris] c end c c************************************************************************ c subroutine opneuf(iu,fname) c =========================== c c Open a new unformatted file: c character*(*) fname c c For Linux: open the file, with the err= keyword to prevent coredump: c-linux[ character*255 fnalt c call linux_get_home_dir(fname,fnalt,ialt) c if ( ialt .gt. 0 ) then open(iu,file=fnalt,form='UNFORMATTED',status='UNKNOWN', $ iostat=ioperr,err=900) else open(iu,file=fname,form='UNFORMATTED',status='UNKNOWN', $ iostat=ioperr,err=900) endif c return c 900 write(6,910) ioperr,iu,fname(:lnblnk(fname)) 910 format(' '/' Error',i12,' opening unit',i3, $ ' with new unformatted file:'/' ',a) stop ' STOP -- OPNEUF: Error opening new unformatted file. ' c-linux] c c For UNIX: open the file status UNKNOWN so not an error if file exists: c-sun-iris[ c-sun-iris; open(iu,file=fname,form='UNFORMATTED',status='UNKNOWN') c-sun-iris; return c-sun-iris] c c For VMS: open the file status NEW: c-vms[ c-vms; open(iu,file=fname,form='UNFORMATTED',status='NEW') c-vms; return c-vms] c end c c************************************************************************ c subroutine inqfil(fname,lxst) c ============================= c character*(*) fname logical lxst c c For Linux: get home directory name, if necessary c (actually, this should work on any Unix system, provided that the c environment variable HOME is correctly defined as the home directory): c-linux[ character*255 fnalt c call linux_get_home_dir(fname,fnalt,ialt) c if ( ialt .gt. 0 ) then inquire( file = fnalt, exist = lxst ) else inquire( file = fname, exist = lxst ) endif c-linux] c c Anything else: just look for filename as is: c-sun-vms-iris[ c-sun-vms-iris; inquire( file = fname , exist = lxst ) c-sun-vms-iris] c return end c c************************************************************************ c c-linux[ subroutine linux_get_home_dir(fname,fnalt,ialt) c =============================================== c c For Linux, at least with fort77, the prefix '~' in a filename is not c recognized as "home directory": get it from HOME environment variable. c (Actually, this should work on any Unix system, provided that the c environment variable HOME is correctly defined as the home directory.) c character*(*) fname character*(*) fnalt c if ( len(fname) .ge. 2 .and. fname(1:2) .eq. '~/' ) then c ialt = 1 call getenv( 'HOME' , fnalt ) i = lnblnk(fnalt) if ( lnblnk(fname) + i - 1 .gt. len(fnalt) ) then write(6,900) lnblnk(fname) + i - 1, len(fnalt), $ fnalt(1:i), fname(2:lnblnk(fname)) 900 format(' '/' Error: filename has',i6, $ ' characters >',i6,' --- too long:'/' ',a,a) stop ' STOP -- LINUX_GET_HOME_DIR: filename too long. ' endif fnalt(i+1:) = fname(2:) c else c ialt = 0 c endif c return end c-linux] c c************************************************************************ c c-linux[ function lnblnk(fname) c ====================== c c Needed for fort77 under Linux, since fort77 linker can't find lnblnk_ c character*(*) fname c character*1 ctab common /c_ctab/ ctab save /c_ctab/ c i = len(fname) c do while( i .gt. 1 .and. $ ( fname(i:i) .eq. ' ' .or. fname(i:i) .eq. ctab ) ) i = i - 1 enddo if ( fname(i:i) .eq. ' ' .or. fname(i:i) .eq. ctab ) i = i - 1 c lnblnk = i c return end c-linux] c c************************************************************************ c