c ********************************************************************
c
      program galaxy
c
c
c ********************************************************************
c
c                     POPULATION SYNTHESIS CODE
c
c                     VERSION 7.0.0 (JANUARY 2014)
c
c THIS PROGRAM COMPUTES OBSERVABLE PARAMETERS ASSOCIATED WITH MASSIVE
c STARS FORMED IN A BURST OF STAR FORMATION. THE STRUCTURE OF THE PROGRAM
c IS MODULAR, ALL CALCULATIONS ARE DONE IN SUBROUTINES WHICH ARE CALLED
c FOR EACH TIME STEP. THE MAIN PROGRAM ONLY LOOPS THROUGH THE DURATION
c OF THE BURST. 
c
c THERE ARE THE FOLLOWING SUBROUTINES AND FUNCTIONS:
c
c AGECHECK:     DOES SOME SLIGHT MANIPULATION OF THE EVOLUTIONARY TRACKS TO 
c               PREVENT THE INTERPOLATION ROUTINES FROM CRASHING.
c CHOOSEWR:     SELECTS THE CORRECT MODEL FROM HILLIER'S/HAMANN'S SUITE OF
c               WR ATMOSPHERES. 
c CHOOSE_ATM:   DETERMINES NEAREST NEIGHBOR LEJEUNE MODEL.
c COLORS:       COMPUTES SYNTHETIC COLORS IN SEVERAL WIDE-BAND FILTERS FROM
c               THE SYNTHETIC CONTINUUM FLUXES.
c CONTINUUM:    COMPUTES THE NEBULAR CONTINUUM (FF+FB+2PHOT).
c DENSITY:      COMPUTES THE MASS NORMALIZATION FOR A SPECIFIED IMF AND SFR AND
c               CALCULATES THE STELLAR NUMBER DENSITIES IN EACH MASS INTERVAL.
c ERRPRI:       RETURNS THE NAME OF THE SUBROUTINE IN WHICH AN ERROR OCCURRED.
c FABIO:        RETURNS FLUXES FROM THE IFA ATMOSPHERES FOR A GIVEN 
c               TEFF AND LOG.
c FLIN:         LINEAR INTER/EXTRA-POLATION BETWEEN TWO POINTS.
c FLIWGT:       INTEGRATION ROUTINE USING TRAPEZ METHOD.
c FUSESYN:      COMPUTES THE SYNTHETIC UV LINES FOR A POPULATION OF STARS
c               BETWEEN 1000 AND 1200 A. 
c GET_ISO:      DETERMINES AN ISOCHRONE FOR A GIVEN AGE.
c GET_WRTYPE:   DETERMINES STELLAR TYPES (Of, WNE, WNL, WC4-9, WO).
c GRID_POWC:    RENORMALIZES THE POTSDAM WC FLUXES
c GRID_POWN:    RENORMALIZES THE POTSDAM WN FLUXES
c HAMANN:       CALCULATES THE FLUXES FROM THE POTSDAM WR GRID.
c HILLIER:      CALCULATES THE FLUXES FROM JOHN HILLIER'S WR ATMOSPHERES.
c HIRES:        CALCULATES A THEORETICAL OPTICAL HIGH-RESOLUTION SPECTRUM.
c IFA_SPECTRUM: CALCULATES A SYNTHETIC UV SPECTRUM FROM THE THEORETICAL
c               IFA ATMOPSHERES.
c INIT_WRLINEFL:INITIALIZES WR LINE FLUXES
c INPUT:        READS IN THE INPUT PARAMETERS FROM A FILE AND PASSES THE VALUES
c               TO THE INDIVIDUAL SUBROUTINES.
c INTRPL:       SPLINE INTERPOLATION USING AKIMA METHOD.
c IONIZE:       COMPUTES THE NUMBER OF IONIZING PHOTONS.
c ISMIN:        DETERMINE SMALLEST INDEX IN TABLE.
c ISMAX:        DETERMINE LARGEST INDEX IN TABLE.
c KURUCZ:       RETURNS FLUXES FROM THE LEJEUNE ATMOSPHERES FOR A GIVEN 
c               TEFF AND LOG.
c LINESYN:      COMPUTES THE SYNTHETIC UV LINES FOR A POPULATION OF STARS
c               LONGWARD OF 12OO A. 
c LINTERP:      LINEAR INTERPOLATION ROUTINE (1-D, ARBITRARY NUMBER OF POINTS;
c               ORDER INCR. OR DECREASING). 
c LOCATE:       SEARCH IN ORDERED TABLE (NUMREC MODIFIED).
c LUCIMARA:     RETURNS FLUXES FROM THE HIGH-RESOLUTION LIBRARY FOR A GIVEN 
c               TEFF AND LOG.
c MK_ATMO:      FINDS THE BEST MATCH FOR TEFF AND LOG G IN PAULDRACH'S 
c               ATMOSPHERE GRID.
c NEAR:         SEARCHES SPECTRAL TYPE INDEX IN THE TABLE EXTRAPOLATED FROM 
c               SCHMIDT-KALER.
c NUCLEO:       COMPUTES THE CHEMICAL YIELDS DUE TO STELLAR WINDS AND SNE.
c OUTPUT:       CREATES AN OUTPUT FILE WITH THE MODEL PARAMETERS.
c PAULDRACH:    COMPUTES OB STAR FLUXES FROM ADI PAULDRACH'S NLTE MODELS.
c PLANCK:       CALCULATES THE PLANCK FUNCTION.
c POLIN2:       2-DIMENSIONAL INTERPOLATION ROUTINE (NUMREC).
c POLINT:       POLYNOMIAL INTER/EXTRA-POLATION (NUMREC).
c POS:          DETERMINES POSITION IN AN ARRAY.
c RADINT:       DETERMINES THE WR CORE RADIUS IN HILLIER'S MODELS.
c READ_TRACKS:  SELECTS AND READS RECENT GENEVA STELLAR EVOLUTION TRACKS.
c RECI_POLINT:  QUADRATIC INTERPOLATION (USES LOCATE, POLINT).
c RENORM_AT:    CHECKS AND RENORMALIZES THE ATMOSPHERE MODELS.
c RENORM_WERNER:CHECKS AND RENORMALIZES THE SCHMUTZ ATMOSPHERE MODELS.
c RENORM_PAULDRACH:CHECKS AND RENORMALIZES THE PAULDRACH ATMOSPHERE MODELS.
c SPECSYN:      COMPUTES A SYNTHETIC SED FOR A POPULATION OF STARS.
c SP_FEATURE:   RETURNS SELECTED SPECTRAL FEATURES. CALLED WITHIN SUBROUTINE
c               SPECSYN.
c SPECTYPE:     ASSIGNS SPECTRAL TYPES TO EACH POSITION IN THE HRD.
c STARPARA:     INTERPOLATES IN THE ARRAYS CONTAINING THE EVOLUTIONARY MODELS
c               AND RETURNS THE STELLAR PARAMETERS FOR EACH TIME STEP.
c STARPARA_ISO: SAME AS STARPARA BUT USING INTERPOLATION DONE BY
c               ISOCHRONE ROUTINE.
c SUPERNOVA:    COMPUTES THE SUPERNOVA RATE.
c TEMP_ADJUST:  ADJUSTS THE CORE TEMPERATURES OF THE WR STARS IN THE 
c               EVOLUTION MODELS. 
c TOTAL_FLUX:   DETERMINES THE NORMALIZATION FACTOR OF ANY ATMOSPHERE MODEL
c               WITH RESPECT TO ITS EXPECTED EMISSION BY STEFAN-BOLTZMAN LAW.
c WERNER:       INTERPOLATES IN W. SCHMUTZ'S WR ATMOSPHERES AND RETURNS
c               THE STELLAR FLUX AS A FUNCTION OF TEFF AND WIND DENSITY.
c WIDTH:        CALCULATION OF THE EQUIVALENT WIDTHS OF NEBULAR RECOMBINATION
c               LINES.
c WINDPOWER:    COMPUTES THE POWER AND ENERGY INPUT INTO THE ISM DUE TO
c               STELLAR WINDS.
c WIND1,2,3,4:  COMPUTES MASS-LOSS RATES AND TERMINAL VELOCITIES FOR 4
c               DIFFERENT MODEL ASSUMPTIONS.
c WRLINES_EW:   CALCULATES EQUIVALENT WIDTHS OF WR EMISSION LINES
c YNTER2:       GENERAL 2-D INTERPOLATION ROUTINE.
c YNTER2X:      ANOTHER 2-D INTERPOLATION (USED BY SP_FEATURE).
c YNTRA:        1-DIMENSIONAL LINEAR INTERPOLATION ROUTINE.
c YPARINTERP:   PARABOLIC INTERPOLATION ROUTINE.
c
c THESE ARE THE VARIABLES AND ARRAYS USED IN THE CODE:
c
c A:        MASS NORMALIZATION CONSTANT IN THE IMF.
c ABSBOL:   ABSOLUTE BOLOMETRIC MAGNITUDE OF THE SYNTHETIC SPECTRUM.
c ABSB:     ABSOLUTE B MAGNITUDE OF THE SYNTHETIC SPECTRUM.
c ABSV:     ABSOLUTE V MAGNITUDE OF THE SYNTHETIC SPECTRUM.
c ACCOMP:   PERCENTAGE OF ACCOMPLISHED CALCULATIONS.
c AGE1:     VECTOR OF DIMENSION NTRACKS CONTAINING THE AGES OF THE STARS OF ALL
c           MASSES GIVEN IN THE GENEVA MODELS.
c AGE2:     VECTOR OF DIMENSION NPTRACK CONTAINING THE NUMBER OF TIME POINTS
c           IN THE GENEVA MODELS. CONTAINS THE STELLAR AGES FOR EACH MASS POINT
c           DEFINED VIA CMASS.
c ALLSPE:   NUMBER OF STARS SUMMED OVER ALL SPECTRAL TYPES.
c ALLO:     NUMBER OF O STARS.
c ALLWR:    TOTAL NUMBER OF WOLF-RAYET STARS.
c ALLWN:    NUMBER OF WN STARS.
c ALLWC:    NUMBER OF WC STARS.
c ALOGL1:   SAME AS AGE1 BUT FOR THE LUMINOSITIES.
c ALOGL2:   SAME AS AGE2 BUT FOR THE LUMINOSITIES.
c ALOGT1:   SAME AS AGE1 BUT FOR THE EFFECTIVE TEMPERATURES.
c ALOGT2:   SAME AS AGE2 BUT FOR THE EFFECTIVE TEMPERATURES.
c AMASS1:   SAME AS AGE1 BUT FOR THE CURRENT MASSES.
c AMASS2:   SAME AS AGE2 BUT FOR THE CURRENT MASSES.
c AMDOT1:   SAME AS AGE1 BUT FOR THE CURRENT MASS-LOSS RATES.
c AMDOT2:   SAME AS AGE2 BUT FOR THE CURRENT MASS-LOSS RATES.
c ANUMB:    ACCUMULATOR OF DIMENSION 135 COUNTING THE STARS OF EACH SPECTRAL
c           TYPE.
c BGCON:    CONTINUUM LUMINOSITY [ERG/S/A] AT BR_GAMMA.
c BGLUM:    EMISSION LINE LUMINOSITY OF BR_GAMMA [ERG/S].
c BGWID:    EQUIVALENT WIDTH OF NEBULAR BR_GAMMA EMISSION [A].
c BHCUT:    UPPER CUT-OFF MASS FOR A SUPERNOVA EXPLOSION. STARS WITH MASSES
c           ABOVE BHCUT FORM A BLACK HOLE.
c BI:       VECTOR OF DIMENSION 135 CONTAINING SCHMIDT-KALER'S VALUES FOR LBOL.
c BLOGG:    LOG G OF THE CURRENT TIME AND MASS STEP.
c BMDOT:    SAME AS TEMP BUT FOR THE CURRENT MASS-LOSS RATES FROM THE GENEVA
c           TRACKS.
c BOL:      SAME AS TEMP BUT FOR THE STELLAR LUMINOSITIES.
c CA:       STRENGTH OF THE CA II TRIPLET IN ANGSTROMS (ALL STARS INCLUDED).
c CA1:      SAME AS CO1 BUT FOR THE CA TRIPLET (ALL STARS).
c CA2:      SAME AS CO2 BUT FOR THE CA TRIPLET (ALL STARS).
c CA3:      SAME AS CO1 BUT FOR THE CA TRIPLET (TEFF < 7200).
c CA4:      SAME AS CO2 BUT FOR THE CA TRIPLET (TEFF < 7200).
c CA5:      STRENGTH OF THE CA II TRIPLET IN ANGSTROMS (ONLY STARS WITH 
c           TEFF < 7200 K INCLUDED).
c CBV:      COLOR (B - V).
c CMASS:    VECTOR OF DIMENSION DIM, WHERE DIM IS THE NUMBER OF MASS INTERVALS
c           CHOSEN FOR THE PARTICULAR RUN. CONTAINS THE ZAMS MASS.
c CNR:      CARBON TO NITROGEN SURFACE ABUNDANCE RATIO.
c CO:       CO INDEX.
c CO1:      ACCUMULATOR USED FOR THE CALCULATION OF CO. VECTOR OF DIM = NPGRID.
c CO2:      ACCUMULATOR USED FOR THE CALCULATION OF CO.
c CO162:    CO 1.62 MU FEATURE IN ANGSTROMS. 
c CO162A:   SAME AS  CO1 BUT FOR THE CO 1.62 FEATURE.
c CO162B:   SAME AS  CO2 BUT FOR THE CO 1.62 FEATURE.
c CO162DATA:ARRAY OF DIMENSION 8X5X6X7 CONTAINING LIVIA'S CO 1.62 INDICES
c           FOR SOLAR ABUNDANCE RATIOS.
c CO162NSDATA:ARRAY OF DIMENSION 8X5X6X7 CONTAINING LIVIA'S CO 1.62 INDICES
c           FOR NON-SOLAR ABUNDANCE RATIOS.
c CO229:    CO 2.29 MU FEATURE IN ANGSTROMS. 
c CO229A:   SAME AS  CO1 BUT FOR THE CO 2.29 FEATURE.
c CO229B:   SAME AS  CO2 BUT FOR THE CO 2.29 FEATURE.
c CO229DATA:ARRAY OF DIMENSION 8X5X6X7 CONTAINING LIVIA'S CO 2.29 INDICES
c           FOR SOLAR ABUNDANCE RATIOS.
c CO229NSDATA:ARRAY OF DIMENSION 8X5X6X7 CONTAINING LIVIA'S CO 2.29 INDICES
c           FOR NON-SOLAR ABUNDANCE RATIOS.
c COHER:    (CARBON+OXYGEN)/HELIUM SURFACE ABUNDANCE RATIO.
c CONTI:    VECTOR OF DIMENSION 26 CONTAINING THE NEBULAR CONTINUUM [ERG/SEC/A].
c COTEST:   THRESHOLD FOR LOG G TO DELIMIT THE PARAMETER SPACE OF THE 
c           PAULDRACH ATMOSPHERES.
c COUNT:    VECTOR OF DIMENSION 11 USED AS A COUNTER FOR THE HILLIER ATMOSPHERES.
c CRITMA:   LOWEST MASS OF STARS EXPLODING AS SUPERNOVAE.
c CUB:      COLOR (U - B).
c CUV1V:    COLOR (UV1 - V). 
c CUV2V:    COLOR (UV2 - V).
c CVR:      COLOR (V - R). 
c CVI:      COLOR (V - I). 
c CVJ:      COLOR (V - J). 
c CVH:      COLOR (V - H).
c CVK:      COLOR (V - K). 
c CVL:      COLOR (V - L). 
c D_C:      ARRAY OF DIMENSION 50 X 100 CONTAINING THE C SURFACE ABUNDANCE ON THE
c           EVOLUTIONARY TRACKS.
c D_H:      ARRAY OF DIMENSION 50 X 100 CONTAINING THE H SURFACE ABUNDANCE ON THE
c           EVOLUTIONARY TRACKS.
c D_HE:     ARRAY OF DIMENSION 50 X 100 CONTAINING THE HE SURFACE ABUNDANCE ON 
c           THE EVOLUTIONARY TRACKS.
c D_MDOT:   ARRAY OF DIMENSION 50 X 100 CONTAINING THE LOGARITHM OF THE MASS LOSS
c           RATE ON THE EVOLUTIONARY TRACKS.
c D_N:      ARRAY OF DIMENSION 50 X 100 CONTAINING THE N SURFACE ABUNDANCE ON THE
c           EVOLUTIONARY TRACKS.
c D_O:      ARRAY OF DIMENSION 50 X 100 CONTAINING THE O SURFACE ABUNDANCE ON THE
c           EVOLUTIONARY TRACKS.
c D_TSTAR:  ARRAY OF DIMENSION 50 X 100 CONTAINING THE LOGARITHM OF THE CORE
c           TEMPERATURE OF WR STARS ON THE EVOLUTIONARY TRACKS.
c DA:       ARRAY OF DIMENSION 50 X 100 CONTAINING THE AGE POINTS ON THE EVOLUTIONARY
c           TRACKS.
c DELM:     WIDTH OF THE MASS INTERVAL IN THE MASS SPECTRUM.
c DENS:     VECTOR OF DIMENSION 2000 CONTAINING THE STELLAR NUMBER DENSITIES IN
c           EACH MASS INTERVAL.
c DL:       ARRAY OF DIMENSION 50 X 100 CONTAINING THE LUMINOSITY POINTS ON THE 
c           EVOLUTIONARY TRACKS.
c DLA:      LOGARITHM OF DA.
c DLM:      LOGARITHM OF DM.
c DM:       VECTOR OF DIMENSION 50 CONTAINING THE ZAMS MASSES OF THE EVOLUTIONARY 
c           TRACKS (SOLAR MASSES).
c DM_REV:   SAME AS DM, BUT IN REVERSE ORDER (NEEDED FOR YNTRA).
c DMAS:     LOGARITHM OF XMAS.
c DIMIN:    DISTANCE TO THE NEAREST NEIGHBOR IN SPECTYPE (ALONG WITH DI)
c DOMA:     LOWER MASS CUT-OFF OF THE IMF.
c DT:       ARRAY OF DIMENSION 50 X 100 CONTAINING THE TEFF POINTS ON THE EVOLUTIONARY
c           TRACKS.
c F1DATA:   VECTOR OF DIMENSION 1221 CONTAINING THE FLUX DIVIDED BY THE
c           PHOTON ENERGY AT EACH WAVELENGTH.
c F_CONT:   CONTINUUM FLUX LEVEL AT THE WAVELENGTH OF A WR LINE.
c F_T_G:    VECTOR OF DIMENSION 33 CONTAINING THE FLUXES OF THE PAULDRACH 
c           ATMOSPHERES AT ONE WAVELENGTH. UNITS: ERG/S/CM/CM/A.
c FACTOR:   BIAS FACTOR USED FOR THE ADJUSTMENT OF THE WR TEMPERATURES.
c FDATA:    VECTOR OF DIMENSION 1221 CONTAINING THE FLUX MULTIPLIED BY THE 
c           FILTER PROFILE AT EACH WAVELENGTH.
c FFAC:     VECTOR OF DIMENSION 860 OR 1415 CONTAINING THE FLUX SCALING FACTOR 
c           FOR THE UV SYNTHETIC LINES.
c FEATURE:  VECTOR OF DIMENSION NPGRID USED TO CALCULATE SELECTED SPECTRAL
c           FEATURES.
c FL(2):    ARRAY OF DIMENSION 1221,300 CONTAINING THE ORIGINAL HILLIER
c           ATMOSPHERES OF WN (WC) STARS.
c FL_POT_WC:ARRAY OF DIMENSION 15000,12 CONTAINING THE 12 POTSDAM WC
c           MODELS.
c FL_POT_WN:ARRAY OF DIMENSION 15000,12 CONTAINING THE 12 POTSDAM WN
c           MODELS.
c FLAi:     FLUX BETWEEN 228A, 504A, 912A AND INFINITY.
c FLAM:     VECTOR OF DIMENSION 1221 CONTAINING THE FLUX OF THE LEJEUNE
c           ATMOSPHERES AT EACH WAVELENGTH. UNITS: ERG/S/CM/CM/A.
c FLAM_HIRES:VECTOR OF DIMENSION 13323 CONTAINING THE FLUX OF THE HIGH-
c           RESOLUTION LIBRARY AT EACH WAVELENGTH. UNITS: ERG/S/CM/CM/A. "_L"
c           AND "_C" DENOTE THE LINE AND CONTINUUM FLUXES, RESPECTIVELY.
c FLAM_IFA: VECTOR OF DIMENSION 4354 CONTAINING THE FLUX OF THE IFA
c           ATMOSPHERES AT EACH WAVELENGTH. UNITS: ERG/S/CM/CM/A. "_L"
c           AND "_C" DENOTE THE LINE AND CONTINUUM FLUXES, RESPECTIVELY.
c FLAM_POWR:VECTOR OF DIMENSION 15000 CONTAINING THE FLUX OF THE POTSDAM
c           WR ATMOSPHERES SCALED BY RADIUS.UNITS: ERG/S/CM/CM/A.
c FLAMPAUL: ARRAY OF DIMENSION 1221,33 CONTAINING THE FLUXES FROM PAULDRACHS
c           MODEL ATMOSPHERES FOR ALL WAVELENGTHS.
c FLAM1:    ARRAY OF DIMENSION 1221,600 CONTAINING THE FLUXES FROM LEJEUNE'S
c           MODEL ATMOSPHERES FOR ALL WAVELENGTHS.
c FLAM1_HIRES:ARRAY OF DIMENSION 13323,416 CONTAINING THE FLUXES FROM THE HIGH-
c           RESOLUTION LIBRARY FOR ALL WAVELENGTHS. "_L" AND "C" DENOTE
c           THE LINE AND THE CONTINUUM SPECTRA, RESPECTIVELY.
c FLAM1_IFA:ARRAY OF DIMENSION 4354,83 CONTAINING THE FLUXES FROM THE IFA
c           MODEL ATMOSPHERES FOR ALL WAVELENGTHS. "_L" AND "C" DENOTE
c           THE LINE AND THE CONTINUUM SPECTRA, RESPECTIVELY..
c FLAM2:    ARRAY OF DIMENSION 1221,12,10. CONTAINS THE FLUXES OF WERNER'S
c           MODELS FOR 1221 WAVELENGTHS, 12 TEMPERATURES, AND 10 DENSITIES.
c           BETA=1.
c FLAM4:    ARRAY OF DIMENSION 1221,11,8. CONTAINS THE FLUXES OF WERNER'S
c           MODELS FOR 1221 WAVELENGTHS, 11 TEMPERATURES, AND 8 DENSITIES.
c           BETA=2.
c FLI:      ARRAY OF DIMENSION (450,860) CONTAINING THE FLUX 
c           IN THE SYNTHETIC UV LINES FOR ALL STARS AT EACH WAVELENGTH. 
c           UNITS ARE ERG/SEC/CM/CM/A.
c FLI1:     ARRAY OF DIMENSION (450,1415) CONTAINING THE FLUX 
c           IN THE SYNTHETIC fuse LINES FOR ALL STARS AT EACH WAVELENGTH. 
c           UNITS ARE ERG/SEC/CM/CM/A.
c FLU_228:  FLUX IN THE HE II CONTINUUM.
c FLU_504:  FLUX IN THE HE I CONTINUUM.
c FLU_912:  FLUX IN THE H I CONTINUUM.
c FLUNEB:   VECTOR OF DIMENSION 1221 CONTAINING THE NEBULAR CONTINUUM AFTER
c           CONVERSION INTO ERG/SEC/A. USED IN SPECSYN.
c FLUNEB_HIRES:VECTOR OF DIMENSION 13323 CONTAINING THE NEBULAR CONTINUUM AFTER
c           CONVERSION INTO ERG/SEC/A. USED IN HIRES.
c FLUNEB_IFA:VECTOR OF DIMENSION 4354 CONTAINING THE NEBULAR CONTINUUM AFTER
c           CONVERSION INTO ERG/SEC/A. USED IN IFA_SPECTRUM.
c FLUNEB2:  VECTOR OF DIMENSION 860 OR 1415 CONTAINING THE NEBULAR CONTINUUM 
c           AFTER CONVERSION INTO ERG/SEC/A. USED IN LINESYN OR FUSESYN.
c FLUX:     ARRAY OF DIMENSION NPGRID,1221 CONTAINING THE EMERGENT FLUXES OF
c           THE LEJEUNE MODELS FOR ONE GENERATION OF STARS AS A FUNCTION OF 
c           MASS AND FREQUENCY.
c FLUX_HIRES:ARRAY OF DIMENSION NPGRID,13323 CONTAINING THE SYNTHETIC SPECTRUM
c           FROM THE HIGH-RES MODELS FOR ONE GENERATION OF STARS. "_L" AND "_C" 
c           ARE FOR THE LINE AND CONTINUOUS SPECTRA, RESPECTIVELY.
c FLUX_IFA: ARRAY OF DIMENSION NPGRID,4354 CONTAINING THE SYNTHETIC UV SPECTRUM
c           FROM THE IFA MODELS FOR ONE GENERATION OF STARS. "_L" AND "_C" 
c           ARE FOR THE LINE AND CONTINUOUS SPECTRA, RESPECTIVELY. 
c FLUXL/C:  ARRAY OF DIMENSION (NPGRID,860 OR 1415 OR 786) CONTAINING THE 
c           SYNTHETIC UV LINE FLUXES/SYNTHETIC CONTINUUM FROM ONE GENERATION 
c           OF STARS AS A FUNCTION OF MASS AND WAVELENGTH.
c FNUi:     FLUX DIVIDED BY PHOTON ENERGY BETWEEN 228A, 504A, 912A AND INFINITY.
c FREEFLUX: VECTOR OF DIMENSION 14 OR 8 CONTAINING THE ATMOSPHERE FLUXES AT LINE
c           FREE WAVELENGTH POINTS.
c FREELAM:  VECTOR OF DIMENSION 14 OR 8 CONTAINING THE WAVELENGTH POINTS OF LINE
c           FREE CONTINUUM.
c FREQ:     VECTOR OF DIMENSION 1221 CONTAINING THE FREQUENCY GRID OF THE 
c           ATMOSPHERES.
c GAMMA:    EMISSION COEFFICIENT FOR HI + HEI + 2-PHOTONS 
c           [ERG/CM/CM/CM/SEC/HZ]). DIMENSION 26.
c GAMMA0:   EDDINGTON FACTOR.
c GLOG:     VECTOR CONTAINING THE VALUES OF LOG G OF THE AVAILABLE LEJEUNE 
c           OR IFA MODELS.
c GLOG_P:   VECTOR CONTAINING THE VALUES OF LOG G OF THE AVAILABLE PAULDRACH 
c           MODELS.
c GRAV:     VECTOR OF DIMENSION DIM1, WHERE DIM1 IS THE SAME AS IN CMASS.
c           CONTAINS THE INTERPOLATED GRAVITIES FOR EACH TIME STEP.
c HACON:    CONTINUUM LUMINOSITY [ERG/S/A] AT H_ALPHA.
c HALUM:    EMISSION LINE LUMINOSITY OF H_ALPHA [ERG/S].
c HAWID:    EQUIVALENT WIDTH OF NEBULAR H_ALPHA EMISSION [A].
c HBCON:    CONTINUUM LUMINOSITY [ERG/S/A] AT H_BETA.
c HBLUM:    EMISSION LINE LUMINOSITY OF H_BETA [ERG/S].
c HBWID:    EQUIVALENT WIDTH OF NEBULAR H_BETA EMISSION [A].
c IATMOS:   INDEX TO DETERMINE WHICH MODEL ATMOSPHERE IS TO BE USED FOR THE
c           SYNTHESIZED SPECTRUM.
c ICHOIC:   FLAG TO DISTINGUISH BETWEEN POWER, MOMENTUM, AND MASS-LOSS RATE.
c ICOUNT:   RUNNING INDEX TO COUNT THE TOTAL NUMBER OF TIME STEPS.
c IDISCONT: INDEX ON THE ISOCHRONE WHERE A DISCONTINUITY IS ENCOUNTERED.
c IFLAG:    FLAG TO INDICATE THAT A STAR IS A WR STAR.
c ILIB:     FLAG TO SELECT THE OPTICAL HIGH-RESOLUTION LIBRARY.
c ILINE:    FLAG FOR THE CHOICE OF THE UV SPECTRAL LIBRARY.
c ILOG:     INTEGER ARRAY OF DIMENSION 8 BY 30 WITH LOG G OF KURUCZ'S MODELS.
c IMATCH:   INDEX OF THE INTERPOLATED VECTOR IN YNTRA.
c IMODEL:   SELECTED ATMOSPHERE FROM LEJEUNE'S SET.
c IMUTURB:  INTEGER VARIABLE FOR THE MICROTURBUTLENT VELOCITY (1-6 KM/S).
c INSABUND: FLAG TO INDICATE SOLAR (=0) OR NON-SOLAR (=1) ABUNDANCE RATIOS.
c IOi:      FLAGS TO INDICATE THE DESIRED OUTPUT.
c ISEL:     FLAG TO SELECT SPECTRAL FEATURES FOR CALCULATION WITH SP_FEATURE.
c ISF:      FLAG TO INDICATE IF THE TOTAL MASS IS PRESPECIFIED OR CALCULATED 
c           VIA THE SFR.
c ITBIV:    NUMBER OF STEPS AS GIVEN IN THE INPUT FILE.
c IWIND:    FLAG INDICATING THE STELLAR WIND MODEL.
c IWR:      INDEX DESCRIBING THE SUBTYPE OF A WR STAR.
c IWRSCALE: SWITCH INDICATING THAT THE WR MASS-LOSS RATES ARE Z DEPENDENT.
c IWRT:     SWITCH INDICATING THAT THE WR CORE TEMPERATURES SHOULD BE SCALED.
c IZ:       PARAMETER RELATED TO THE METALLICITY OF THE MODEL: 
c           GENEVA STD: 11=0.001; 12=0.004; 13=0.008; 14=0.020; 15=0.040  
c           GENEVA HIGH:21=0.001; 22=0.004; 23=0.008; 24=0.020; 25=0.040
c           PADOVA STD: 31=0.0004; 32=0.004; 33=0.008; 34=0.020; 35=0.050
c           PADOVA HIGHM: 41=0.0004; 42=0.004; 43=0.008; 44=0.020; 45=0.050
c           GENEVA 2013 V=0:  51=TBD; 52=0.002; 53=TBD; 54=0.014; 55=TBD
c	    GEVEVA 2013 V=0.4:61=TBD; 62=0.002; 63=TBD; 64=0.014; 55=TBD
c JCOUNT:   RUNNING INDEX TO INDICATE THE CRITICAL MASS FOR A SUPERNOVA 
c           EXPLOSION.
c JMG:      FLAG TO INDICATE THE DESIRED MASS GRID.
c JMP:      NUMBER OF POINTS ON THE EVOLUTIONARY TRACKS PRESENTLY USED.
c JTIME:    FLAG TO CHOOSE A LOGARITHMIC OR LINEAR TIME SCALE.
c KMAX_POWR:NUMBER OF DATA POINTS IN THE POTSDAM WR ATMOSPHERES.
c KSIZE:    ARRAY CONTAINING THE NUMBER OF DATA POINTS IN EACH FILTER PROFILE.
c LMAX:     HIGHEST TRACK NUMBER USED IN THE CALCULATION (CURRENTLY = NPGRID).
c LMIN:     LOWEST TRACK NUMBER USED IN THE CALCULATION (CURRENTLY = 1).
c LTYPE:    INDICATES THE STELLAR TYPE IN WIND1,2,3,4. (1 FOR OB, 2 FOR RSG,
c           3 FOR LBV, 4 FOR WR).
c NAME:     MODEL DESIGNATION AS SPECIFIED IN INPUT FILE
c NFLAG:    FLAG USED TO COMPUTE TYPMA.
c NINTERV   NUMBER OF INTERVALS FOR A MULTI-POWER-LAW IMF
c NISO:     ACTUAL NUMBER OF DATA POINTS ON AN ISOCHRONE.
c NLEJ:     NUMBER OF ATMOSPHERE MODELS IN LEJEUNE'S FILE.
c NLEJ_LU   SAME FOR THE HIGH-RES SPECTRA.
c NMA:      NUMBER OF EVOLUTIONARY TRACKS PRESENTLY USED.
c NMAXINT:  NUMBER OF EXPONENTS IN THE MULTI-POWER-LAW IMF.
c NMAXINT1: NUMBER OF MASS LIMITS IN THE MULTI-POWER-LAW IMF.
c NMOD(2):  NUMBER OF WN (WC) ATMOSPHERES IN HILLIER'S AND HAMANN'S GRID.
c NONMONO:  FLAG TO INDICATE NON-MONOTONIC LIFETIMES.
c NPGRID:   NUMBER OF MASS POINTS IN THE ISOCHRONE MODELS,
c NPISO:    MAXIMUM NUMBER OF DATA POINTS ON THE ISOCHRONES.
c NPTRACK:  MAXIMUM NUMBER OF TIME POINTS ON ONE EVOLUTIONARY TRACK.
c NTRACKS:  MAXIMUM NUMBER OF TRACKS IN THE EVOLUTIONARY TABLES.
c NWRLINES: NUMBER OF SYNTHESIZED WR LINES (=9).
c NWRTYPES: NUMBER OF DIFFERENT WR SUBTYPES USED TO CALCULATE THE LINES (=11).
c ORIGG:    VECTOR OF DIM 5 CONTAINING LIVIA'S LOG G VALUES.
c ORIGT:    VECTOR OF DIM 8 CONTAINING LIVIA'S TEMPERATURES.
c PBCON:    CONTINUUM LUMINOSITY [ERG/S/A] AT PA_BETA.
c PBLUM:    EMISSION LINE LUMINOSITY OF PA_BETA [ERG/S].
c PBWID:    EQUIVALENT WIDTH OF NEBULAR PA_BETA EMISSION [A].
c PHOT_228: NUMBER OF IONIZING PHOTONS IN THE HE II CONTINUUM.
c PHOT_504: NUMBER OF IONIZING PHOTONS IN THE HE I CONTINUUM.
c PHOT_912: NUMBER OF IONIZING PHOTONS IN THE H I CONTINUUM.
c POW:      VECTOR OF DIMENSION DIM1, WHERE DIM1 IS THE SAME AS IN CMASS.
c           USED AS ACCUMULATOR TO COMPUTE THE SUPERNOVA POWER.
c PROF:     TRANSMISSION FOR EACH, INDIVIDUAL FILTER PROFILE.
c PROFIL:   FILTER PROFILE REBINNED TO THE WAVELENGTH GRID OF THE SYNTHETIC
c           SPECTRUM.
c R_POT_WC: VECTOR OF DIM 12 CONTAINING THE RADII OF THE HAMANN WC'S.
c R_POT_WN: VECTOR OF DIM 12 CONTAINING THE RADII OF THE HAMANN WN'S.
c RADC/N:   VECTOR OF DIMENSION 10(11) CONTAINING THE RADII OF HILLIER'S
c           WC (WN) ATMOSPHERES.
c RADIUS:   STELLAR RADIUS IN CGS UNITS FROM STEFAN-BOLTZMANN LAW.
c RADLUM:   TOTAL BOLOMETRIC LUMINOSITY [ERG/SEC].
c RGRID1:   VECTOR OF DIMENSION 10 CONTAINING THE VALUES OF RT IN THE TABLE
c           FOR BETA = 1.
c RGRID2:   VECTOR OF DIMENSION 8 CONTAINING THE VALUES OF RT IN THE TABLE
c           FOR BETA = 2.
c RT:       TRANSFORMED RADIUS OF WR STARS AS A MEASURE OF WIND DENSITY.
c SFR:      STAR FORMATION RATE [SOLAR MASSES PER YEAR].
c SI159:    SI 1.59 MU FEATURE IN ANGSTROMS. 
c SI159A:   SAME AS  CO1 BUT FOR THE SI 1.59 FEATURE.
c SI159B:   SAME AS  CO2 BUT FOR THE SI 1.59 FEATURE.
c SI159DATA:ARRAY OF DIMENSION 8X5X6X7 CONTAINING LIVIA'S SI 1.59 INDICES
c           FOR-SOLAR ABUNDANCE RATIOS.
c SI159NSDATA:ARRAY OF DIMENSION 8X5X6X7 CONTAINING LIVIA'S SI 1.59 INDICES
c           FOR NON-SOLAR ABUNDANCE RATIOS.
c SIBEN:    TOTAL KINETIC ENERGY DUE TO TYPE IB SUPERNOVAE.
c SIBPOW:   TOTAL KINETIC POWER DUE TO TYPE IB SUPERNOVAE.
c SIIEN:    TOTAL KINETIC ENERGY DUE TO ALL SUPERNOVAE.
c SIIPOW:   TOTAL KINETIC POWER DUE TO ALL SUPERNOVAE.
c SN:       VECTOR OF DIMENSION DIM1, WHERE DIM1 IS THE SAME AS IN CMASS.
c           SUPERNOVA RATE DUE TO ALL STARS WITH MASS CMASS.
c SNi:      SUPERNOVA RATE, KINETIC POWER AND ENERGY FOR ALL SN'S AND IB'S
c           AND TOTAL POWER ENERGY INCLUDING STARS AFTER CONVERSION TO USUAL 
c           UNITS (I=1-8).
c SNCUT:    LOWER MASS LIMIT FOR A STAR TO EXPLODE AS A SUPERNOVA. STARS
c           EQUAL TO AND ABOVE SNCUT EXPLODE AS SUPERNOVAE.
c SNR:      TOTAL SUPERNOVA RATE IN LOG (EVENTS PER YEAR).
c SNR1:     TOTAL SUPERNOVA RATE USED DURING THE CALCULATION OF TYPMA.
c STFLUX:   VECTOR OF DIMENSION 1221 CONTAINING THE SYNTHETIC LEJEUNE 
c           SPECTRUM FROM ALL STARS WITHOUT NEBULAR CONTINUUM.
c STFLUX_HIRES:VECTOR OF DIMENSION 13323 CONTAINING THE SYNTHETIC HIGH-RES
c           SPECTRUM FROM ALL STARS WITH NEBULAR CONTINUUM. "_L" AND "_C" DENOTE
c           THE LINE AND CONTINUOUS SPECTRA, RESPECTIVELY.
c STFLUX_IFA:VECTOR OF DIMENSION 4354 CONTAINING THE SYNTHETIC IFA SPECTRUM
c           FROM ALL STARS WITH NEBULAR CONTINUUM. "_L" AND "_C" DENOTE
c           THE LINE AND CONTINUOUS SPECTRA, RESPECTIVELY.
c SWITCH:   FLAG INDICATING IF A TRACK CONTAINS MASS-LOSS RATES.
c T_POT_WC: VECTOR OF DIM 12 CONTAINING TEFF OF THE HAMANN WC STARS.
c T_POT_WN: VECTOR OF DIM 12 CONTAINING TEFF OF THE HAMANN WN STARS.
c TBACK:    USED TO DEFINE THE LOGARITHMIC TIME STEP.
c TBIV:     TIME-STEP AS GIVEN IN THE INPUT FILE.
c TCHECK:   DETERMINES WHEN SPECSYN IS CALLED.
c TDEL:     TIME STEP FOR THE CALCULATION OF THE SYNTHETIC SPECTRUM.
c TEFF:     EFFECTIVE TEMPERATURE OF THE CURRENT TIME AND MASS STEP.
c TEM:      VECTOR CONTAINING THE VALUES OF TEFF OF THE AVAILABLE LEJEUNE 
c           OR IFA MODELS. ALSO USED FOR THE HILLIER WN MODELS (WITH _HI).
c TEM2:     SAME AS TEM, BUT FOR WC STARS.
c TEM_P:    VECTOR CONTAINING THE VALUES OF TEFF OF THE AVAILABLE PAULDRACH 
c           MODELS.
c TEMP:     VECTOR OF DIMENSION DIM1, WHERE DIM1 IS THE SAME AS IN CMASS.
c           CONTAINS THE INTERPOLATED EFFECTIVE TEMPERATURES FOR EACH
c           TIME STEP.
c TFLUXL/C: VECTOR OF DIMENSION 860 CONTAINING THE SYNTHETIC UV 
c           LINES/SYNTHETIC CONTINUUM FROM ALL STARS (WITH 
c           THE NEBULAR CONTINUUM).
c TFLUXL/C_FU: VECTOR OF DIMENSION 1415 CONTAINING THE SYNTHETIC FUSE 
c           LINES/SYNTHETIC CONTINUUM FROM ALL STARS (WITH 
c           THE NEBULAR CONTINUUM).
c TI:       VECTOR OF DIMENSION 135 CONTAINING SCHMIDT-KALER'S VALUES FOR TEFF.
c TIEMPO1:  USED TO DEFINE THE LOGARITHMIC TIME STEP.
c TIME:     ELAPSED TIME IN YEARS.
c TIME1:    FIRST TIME STEP TO BE EXECUTED IN YEARS.
c TINTER:   NUMBER OF TIME STEPS FOR THE LOGARITHMIC SCALE
c TITLE_TRACKS: TITLE DESCRIBING THE EVOLUTIONARY TRACKS.
c TMASS:    TOTAL MASS [Ms] RELEASED BY STELLAR WINDS AND SUPERNOVAE.
c TMAX:     LAST TIME STEP TO BE EXECUTED IN YEARS.
c TOFLUX:   VECTOR OF DIMENSION 1221 CONTAINING THE SYNTHETIC SPECTRUM
c           FROM ALL STARS PLUS THE NEBULAR CONTINUUM.
c TOFLUX_IFA: VECTOR OF DIMENSION 4354 CONTAINING THE SYNTHETIC UV SPECTRUM
c           FROM THE IFA MODELS FOR ALL STARS. "_L" AND "_C" ARE FOR THE
c           LINE AND CONTINUOUS SPECTRA, RESPECTIVELY. THE NEBULAR 
c           CONTINUUM IS INCLUDED.
c TOFLUX_HIRES: VECTOR OF DIMENSION 13323 CONTAINING THE SYNTHETIC SPECTRUM
c           FROM THE HIGH-RES MODELS FOR ALL STARS. "_L" AND "_C" ARE FOR THE
c           LINE AND CONTINUOUS SPECTRA, RESPECTIVELY. THE NEBULAR 
c           CONTINUUM IS INCLUDED.
c TOFLUXL/C:VECTOR OF DIMENSION 860 CONTAINING THE SYNTHETIC UV 
c           LINES/SYNTHETIC CONTINUUM FROM ALL STARS (WITHOUT 
c           NEBULAR CONTINUUM).
c TOFLUXL/C_FU:VECTOR OF DIMENSION 1415 CONTAINING THE SYNTHETIC FUSE 
c           LINES/SYNTHETIC CONTINUUM FROM ALL STARS (WITHOUT 
c           NEBULAR CONTINUUM).
c TOMA:     TOTAL MASS [SOLAR MASSES] LOCKED IN STARS.
c TONUM:    TOTAL NUMBER OF STARS FORMED OVER ALL MASS INTERVALS.
c TSTEP:    INCREMENT OF THE TIME STEP.
c TT_STAR:  VECTOR OF DIMENSION NPGRID USED TO ADJUST THE WR CORE TEMPERATURE
c           FOR LINKING THEM TO THE HILLIER ATMOSPHERES.
C TVAR:     INITIAL TIME STEP FOR LOGARITHMIC AND LINEAR SCALES
c TYPMA:    TYPICAL MASS OF A SUPERNOVA PROGENITOR.
c UPMA:     UPPER MASS CUT-OFF OF THE IMF.
c VALUE1:   FILTER-PROFILE INTEGRATED FLUXES. 
c VINF:     WIND TERMINAL VELOCITIES USED FOR WIND POWER.
c WAVE:     VECTOR OF DIMENSION 1221 CONTAINING THE WAVELENGTH POINTS 
c           IN THE LEJEUNE MODEL ATMOSPHERES.
c WAVE1:    VECTOR OF DIMENSION 1221 CONTAINING THE WAVELENGTH POINTS 
c           IN THE SCHMUTZ MODEL ATMOSPHERES.
c WAVE_HIRES:VECTOR OF DIMENSION 13323 CONTAINING THE WAVELENGTH POINTS 
c           IN THE HIGH-RESOLUTION LIBRARY. 
c WAVE_IFA: VECTOR OF DIMENSION 4354 CONTAINING THE WAVELENGTH POINTS 
c           IN THE IFA MODEL ATMOSPHERES.
c WAVE_POWR:VECTOR OF DIMENSION 15000 CONTAINING THE WAVELENGTH POINTS 
c           IN THE HAMANN MODEL ATMOSPHERES.
c WAVE_POT_WC: ARRAY OF DIMENSION 15000,12 CONTAINING THE WAVELENGTHS OF
c           THE 12 POTSDAM WC ATMOSPHERES. 
c WAVE_POT_WN: ARRAY OF DIMENSION 15000,12 CONTAINING THE WAVELENGTHS OF
c           THE 12 POTSDAM WN ATMOSPHERES. 
c WAVEL:    VECTOR OF DIMENSION 860 OR 1415 CONTAINING THE WAVELENGTH POINTS 
c           IN THE SYNTHETIC UV LINES.
c WCWN:     WC/WN NUMBER RATIO.
c WEN:      KINETIC WIND ENERGY OF ALL STARS [ERG].
c WMOM:     KINETIC WIND MOMENTUM OF ALL STARS [DYN].
c WMOM1:    KINETIC WIND MOMENTUM OF O STARS [DYN].
c WMOM2:    KINETIC WIND MOMENTUM OF RED SUPERGIANTS [DYN].
c WMOM3:    KINETIC WIND MOMENTUM OF LBVS [DYN].
c WMOM4:    KINETIC WIND MOMENTUM OF WR STARS [DYN].
c WPOW:     KINETIC WIND POWER OF ALL STARS [ERG/S].
c WPOW1:    KINETIC WIND POWER OF O STARS [ERG/S].
c WPOW2:    KINETIC WIND POWER OF RED SUPERGIANTS [ERG/S].
c WPOW3:    KINETIC WIND POWER OF LBVS [ERG/S].
c WPOW4:    KINETIC WIND POWER OF WR STARS [ERG/S].
c WR_LSSP:  SYNTHESIZED WR LINE FLUXES OF THE TOTAL POPULATION.
c WR_WSSP:  EQUIVALENT WIDTH OF SYNTHESIZED WR LINE.
c WRFLUXES: INPUT LINE FLUXES FOR WR LINES [ERG/S]. 
c WRIDENT:  IDENTIFIER OF WR LINES.
c WRNUMB:   ACCUMULATOR OF DIMENSION 5 CONTING THE WR STARS IN EACH SUBTYPE
c WRO:      WR/O RATIO.
c WRSNR:    SUPERNOVA RATE DUE TO WR STARS ALONE.
c X1:       SAME AS AGE1 BUT FOR THE HYDROGEN CONTENT AT THE SURFACE.
c X2:       SAME AS AGE2 BUT FOR THE HYDROGEN CONTENT AT THE SURFACE.
c X_C:      VECTOR OF DIMENSION 1000 CONTAINING THE C SURFACE ABUNDANCE POINTS 
c           ON THE ISOCHRONES.
c X_H:      VECTOR OF DIMENSION 1000 CONTAINING THE H SURFACE ABUNDANCE POINTS 
c           ON THE ISOCHRONES.
c X_HE:     VECTOR OF DIMENSION 1000 CONTAINING THE HE SURFACE ABUNDANCE POINTS 
c           ON THE ISOCHRONES.
c X_MDOT:   VECTOR OF DIMENSION 1000 CONTAINING THE MASS-LOSS RATE POINTS 
c           ON THE ISOCHRONES.
c X_N:      VECTOR OF DIMENSION 1000 CONTAINING THE N SURFACE ABUNDANCE POINTS 
c           ON THE ISOCHRONES.
c X_O:      VECTOR OF DIMENSION 1000 CONTAINING THE O SURFACE ABUNDANCE POINTS 
c           ON THE ISOCHRONES.
c X_TSTAR:  VECTOR OF DIMENSION 1000 CONTAINING THE WR CORE TEMPERATURE POINTS 
c           ON THE ISOCHRONES.
c XC121:    SAME AS AGE1 BUT FOR THE CARBON CONTENT AT THE SURFACE.
c XC122:    SAME AS AGE2 BUT FOR THE CARBON CONTENT AT THE SURFACE.
c XC12S:    VECTOR OF DIMENSION DIM1, WHERE DIM IS THE SAME AS IN CMASS.
c           CONTAINS THE INTERPOLATED CARBON CONTENT FOR EACH TIME STEP.
c XFE:      MASS FRACTION OF IRON AT THE STELLAR SURFACE.
c XGRID:    WAVELENGTH POINTS FOR EACH, INDIVIDUAL FILTER PROFILE.
c XL:       VECTOR OF DIMENSION 1000 CONTAINING THE LUMINOSITY POINTS ON THE 
c           ISOCHRONES.
c XLAi:     WAVELENGTH GRID BETWEEN 228A, 504A, 912A AND INFINITY.
c XLAM_WRLINES: WAVELENGTH OF WR LINES [ANGSTROM].
c XLOSS:    STELLAR MASS-LOSS RATE USED FOR WIND POWER.
c XLYA:     LYMAN ALPHA EQUIVALENT WIDTH
c XLYA1:    ACCUMULATOR USED FOR THE CALCULATION OF L-ALPHA. VECTOR OF DIM = NPGRID.
c XLYA2:    ACCUMULATOR USED FOR THE CALCULATION OF L-ALPHA.
c XLYMAN:   12 BY 23 ARRAY CONTAINING THE ATMOSPHERE VALUES OF 
c           LYMAN-ALPHA AS A FUNTION OF LOG G AND TEFF.
c XLYMAN_T: VECTOR OF DIMENSION 23 CONTAINING THE TEFF VALUES OF XLYMAN.
c XLYMAN_G: VECTOR OF DIMENSION 12 CONTAINING THE LOG G VALUES OF XLYMAN.
c XMACT:    LOGARITHM OF XMINIT.
c XMAG:     VECTOR OF DIMENSION 12 CONTAINING COMPUTED MAGNITUDES WITHOUT 
c           NORMALIZATION TO VEGA. 
c XMAS:     ARRAY OF DIMENSION 50 X 100 CONTAINING THE MASS POINTS ON THE EVOLUTIONARY
c           TRACKS.
c XMASLIM:  MASS LIMITS FOR THE IMF IF A MULTI-POWER-LAW IS USED.
c XMG:      MASS FRACTION OF MAGNESIUM AT THE STELLAR SURFACE.
c XMHIGH:   UPPER VALUE OF THE IMF MASS INTERVAL TO CALCULATE THE STAR
c           DENSITY. 
c XMINIT:   VECTOR OF DIMENSION 1000 CONTAINING THE ZAMS MASSES ON THE EVOLUTIONARY 
c           ISOCHRONES (SOLAR MASSES).
c XMLOW:    LOWER VALUE OF THE IMF MASS INTERVAL TO CALCULATE THE STAR 
c           DENSITY. 
c XMWR:     MASS LIMIT FOR WR FORMATION
c XN141:    SAME AS AGE1 BUT FOR THE NITROGEN CONTENT AT THE SURFACE.
c XN142:    SAME AS AGE2 BUT FOR THE NITROGEN CONTENT AT THE SURFACE.
c XN14S:    VECTOR OF DIMENSION DIM1, WHERE DIM IS THE SAME AS IN CMASS.
c           CONTAINS THE INTERPOLATED NITROGEN CONTENT FOR EACH TIME STEP.
c XNE:      MASS FRACTION OF NEON AT THE STELLAR SURFACE.
c XNUi:     FREQUENCY GRID BETWEEN 228A, 504A, 912A AND INFINITY.
c XO161:    SAME AS AGE1 BUT FOR THE OXYGEN CONTENT AT THE SURFACE.
c XO162:    SAME AS AGE2 BUT FOR THE OXYGEN CONTENT AT THE SURFACE.
c XO16S:    VECTOR OF DIMENSION DIM1, WHERE DIM IS THE SAME AS IN CMASS.
c           CONTAINS THE INTERPOLATED OXYGEN CONTENT FOR EACH TIME STEP.
c XPONENT:  POWER LAW EXPONENTS OF THE IMF.
c XPROF:    ARRAY CONTAINING THE WAVELENGTHS OF THE FILTER PROFILES.
c XRANGE:   VECTOR OF DIMENSION 26 CONTAINING THE WAVELENGTH GRID FOR THE
c           EMISSION COEFFICIENT [A].
c XS:       MASS FRACTION OF SULFUR AT THE STELLAR SURFACE.
c XSI:      MASS FRACTION OF SILICON AT THE STELLAR SURFACE.
c XSURF:    VECTOR OF DIMENSION DIM1, WHERE DIM IS THE SAME AS IN CMASS.
c           CONTAINS THE INTERPOLATED HYDROGEN CONTENT FOR EACH
c           TIME STEP.
c XT:       VECTOR OF DIMENSION 1000 CONTAINING THE LOG TEFF POINTS ON THE 
c           ISOCHRONES.
c Y1:       SAME AS AGE1 BUT FOR THE HELIUM CONTENT AT THE SURFACE.
c Y2:       SAME AS AGE2 BUT FOR THE HELIUM CONTENT AT THE SURFACE.
c YIELD:    TOTAL MASS LOSS [MS/YR] FROM WINDS AND SUPERNOVAE.
c YIELD1:   MASS LOSS FROM WINDS.
c YIELD2:   MASS LOSS FROM SUPERNOVAE.
c YIExx:    MASS LOSS DUE TO INDIVIDUAL ELEMENTS IN STELLAR WINDS AND 
C           SUPERNOVAE.
c YIExx1:   MASS LOSS DUE TO INDIVIDUAL ELEMENTS IN STELLAR WINDS.
c YIExx2:   MASS LOSS DUE TO INDIVIDUAL ELEMENTS IN SUPERNOVAE.
c YMASS:    ARRAY OF DIMENSION 5 x 12 CONTAINING THE 12 STARTING STELLAR
c           MASSES GENERATING THE SUPERNOVAE YIELDS FOR 5 METALLICITIES
c Yxx:      ARRAY OF DIMENSION 5 x 12 CONTAINING THE YIELDS FROM INDIVIDUAL
c           ELEMENTS FOR 5 METALLICITIES AND 12 STARTING STELLAR MASSES
c YxxN:     LINEARLY INTERPOLATED YIELDS FOR INDIVIDUAL ELEMENTS FOR A
c           CERTAIN MASS AT A PREDEFINED METALLICITY
c YPROF:    ARRAY CONTAINING THE TRANSMISSIONS OF THE FILTERS.
c YSURF:    VECTOR OF DIMENSION DIM1, WHERE DIM IS THE SAME AS IN CMASS.
c           CONTAINS THE INTERPOLATED HELIUM CONTENT FOR EACH TIME STEP.
c Z:        METALLICITY; 5 DISCRETE VALUES ARE PERMITTED.
c ZLAGE:    LOG(AGE) OF LAST POINT OF EACH TRACK.
c ZMASS:    VECTOR OF DIMENSION DIM1, WHERE DIM IS THE SAME AS IN CMASS.
c           CONTAINS THE INTERPOLATED CURRENT MASSES FOR EACH TIME STEP.
c ZMETAL:   FLAG TO INDICATE THE METALLICITY TO CALCULATE WR LINES.
c 
c *****************************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
        character*100 file_wn,file_wc,file_pown,file_powc
        character*80 file_name
	character namfi3*3
	character nam*3
	character*6 wrident
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
     	common/lejeuneinput/tem,glog,nlej,flam1,wave
     	common/wernerinput/wave1,flam2,flam4,tgrid1,tgrid2,
     *                     rgrid1,rgrid2
     	common/nearinput/tip,bip
     	parameter (nwrlines  = 9,nwrtypes  = 11 ) 
        common/wrlines/wrfluxes(nwrtypes,nwrlines),
     *         xlam_wrlines(nwrlines),wr_lssp(nwrlines),
     *         wr_wssp(nwrlines),wrident(nwrlines)
	dimension wave(1221),flam2(1221,12,10),tgrid1(12),
     *            rgrid1(10),tgrid2(11),rgrid2(8),
     *            flam4(1221,11,8),wave1(1221),tem(600),glog(600),
     *            flam1(1221,600),tip(445),bip(445),wrnumb(5),
     *            anumb(445),stflux(1221),toflux(1221),fluneb(1221),
     *            origt(8),origg(5),co162data(8,5,6,5),
     *            co229data(8,5,6,5),si159data(8,5,6,5),
     *            co162nsdata(8,5,6,5),co229nsdata(8,5,6,5),
     *            si159nsdata(8,5,6,5),flampaul(1221,33),
     *            tem_p(33),glog_p(33),alum_p(33),wave_wm(1221),
     *            count(12),tem_hi(12),tem2_hi(12),
     *            wave_hi(1221),fl(1221,12),fl2(1221,12),
     *            stflux_hires_l(13323),stflux_hires_c(13323),
     *            toflux_hires_l(13323),toflux_hires_c(13323),
     *            fluneb_hires(13323),wave_hires(13323),
     *            flam1_hires_l(13323,416),flam_hires_l(13323),
     *            flam1_hires_c(13323,416),flam_hires_c(13323),
     *		  tem_luci(416),glog_luci(416),fli(450,860),
     *            tofluxl(860),tofluxc(860),tfluxl(860),
     *            tfluxc(860),fluneb2(860),fli1(450,1415),
     *            tofluxl_fu(1415),tofluxc_fu(1415),
     *            tfluxl_fu(1415),tfluxc_fu(1415),
     *            fluneb2_fu(1415),wave_ifa(4200),
     *            stflux_ifa_l(4200),stflux_ifa_c(4200),
     *            toflux_ifa_l(4200),toflux_ifa_c(4200),
     *            fluneb_ifa(4200),flam1_ifa_l(4200,86),
     *            tem_ifa(86),glog_ifa(86),flam1_ifa_c(4200,86),
     *            flam_ifa_l(4200),flam_ifa_c(4200),
     *		  xlyman_t(23),xlyman_g(12),xlyman(12,23), 
     *		  i_pot(12),t_pot_wn(12),t_pot_wc(12),r_pot_wn(12),
     *		  r_pot_wc(12),wave_pot_wn(15000,12),
     *            wave_pot_wc(15000,12),fl_pot_wn(15000,12),
     *		  fl_pot_wc(15000,12),i_wn(12),i_wc(12)                	
     	common/spectype_r/allspe,allwr,allwn,allwc,allo,anumb,wrnumb
     	common/supernova_r/critma,critma_new,critup,critup_new,
     *                  	siben,siien
	common/nucleo_r/critma1,critma_new1,critup1,critup_new1,
     *		yield,yieh,yiehe,yiec,yien,yieo,yiemg,yiesi,
     *	        yies,yiefe,yield1,yieh1,yiehe1,yiec1,yien1,
     *		yieo1,yiemg1,yiesi1,yies1,yiefe1,tmass
     	common/windpower_r/wpow,wpow1,wpow2,wpow3,wpow4,
     *                     wmom,wmom1,wmom2,wmom3,wmom4,wen
	common/specsyn_r/stflux,toflux,fluneb,co2,ca2,ca4,
     *        	ca5,co,ca,co162,co162b,co229,co229b,si159,
     *	        si159b,xlya,xlya2  
    	common/sp_feature_r/co162data,co229data,si159data,
     *                      co162nsdata,co229nsdata,si159nsdata,
     *                      origg,origt,xlyman_t,xlyman_g,xlyman
        common/ifa_spectrum_r/stflux_ifa_l,stflux_ifa_c,
     *          toflux_ifa_l,toflux_ifa_c,fluneb_ifa
        common/hires_r/stflux_hires_l,stflux_hires_c,toflux_hires_l,
     *                 toflux_hires_c,fluneb_hires
        common/wmbasicinput/tem_p,alum_p,glog_p,flampaul,wave_wm
	common/cmfgeninput/count,tem_hi,tem2_hi,wave_hi,fl,fl2
	common/powrinput/i_pot,t_pot_wn,t_pot_wc,r_pot_wn,r_pot_wc,
     *                 wave_pot_wn,wave_pot_wc,fl_pot_wn,fl_pot_wc,
     *		       i_wn,i_wc
        common/flux_hires/wave_hires,flam_hires_l,flam_hires_c,
     *                    flam1_hires_l,flam1_hires_c,nlej_lu,
     *                    tem_luci,glog_luci
        common/flux_ifa/wave_ifa,flam1_ifa_l,flam1_ifa_c,nlej_ifa,
     *                    tem_ifa,glog_ifa,flam_ifa_l,flam_ifa_c
        common/uvtemplate/fli
        common/fusetemplate/fli1
        common/linesyn_r/tofluxl,tofluxc,tfluxl,tfluxc,fluneb2
        common/fusesyn_r/tofluxl_fu,tofluxc_fu,tfluxl_fu,tfluxc_fu,
     *                   fluneb2_fu
        data np,np1/860,1415/
c
      time=0.
      icount = 1
c
c GET THE INPUT PARAMETERS
c
      call input(time)
c
c START OF MAIN LOOP:
c
c
c READ_TRACKS READS THE EVOLUTIONARY TRACKS.
c THE CHOICE OF THE APPROPRIATE TRACK IS MADE WITHIN THE SUBROUTINE ITSELF.
c THE TRACKS ARE READ IN ONLY DURING THE FIRST TIME STEP.
c
      call read_tracks
c
c PICK THE CORRECT METALLICITY.
c
	if(iz.eq.11.or.iz.eq.21.or.iz.eq.31.or.iz.eq.41) namfi3='m13'
	if(iz.eq.12.or.iz.eq.22.or.iz.eq.32.or.iz.eq.42) namfi3='m07'
	if(iz.eq.13.or.iz.eq.23.or.iz.eq.33.or.iz.eq.43) namfi3='m04'
	if(iz.eq.14.or.iz.eq.24.or.iz.eq.34.or.iz.eq.44) namfi3='p00'
	if(iz.eq.15.or.iz.eq.25.or.iz.eq.35.or.iz.eq.45) namfi3='p03'
	if(iz.eq.51.or.iz.eq.61) namfi3='m13'
	if(iz.eq.52.or.iz.eq.62) namfi3='m07'
	if(iz.eq.53.or.iz.eq.63) namfi3='m04'
	if(iz.eq.54.or.iz.eq.64) namfi3='p00'
	if(iz.eq.55.or.iz.eq.65) namfi3='p03'
c	
        if(iz.eq.11.or.iz.eq.21.or.iz.eq.31.or.iz.eq.41) nam='001'
        if(iz.eq.12.or.iz.eq.22.or.iz.eq.32.or.iz.eq.42) nam='004'
        if(iz.eq.13.or.iz.eq.23.or.iz.eq.33.or.iz.eq.43) nam='008'
        if(iz.eq.14.or.iz.eq.24.or.iz.eq.34.or.iz.eq.44) nam='020'
        if(iz.eq.15.or.iz.eq.25.or.iz.eq.35.or.iz.eq.45) nam='040'
        if(iz.eq.51.or.iz.eq.61) nam='001'
	if(iz.eq.52.or.iz.eq.62) nam='004'
	if(iz.eq.53.or.iz.eq.63) nam='008'
	if(iz.eq.54.or.iz.eq.64) nam='020'
	if(iz.eq.55.or.iz.eq.65) nam='040'
        if(iwrscale.lt.0) nam='020' 	
c
c DURING THE FIRST ITERATION VARIOUS INPUT FILES ARE OPENED AND READ.
c FIRST THE LEJEUNE ATMOSPHERES.
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
        file_name='lejeune/lcb97_'//namfi3//'.flu'
        open(unit=20,file=file_name,status='old',err=999)
        read(20,10) (wave(i),i=1,1221)
        do 1100 j=1,600
        read(20,13,end=999) ndummy,tem(j),glog(j),zdummy
        read(20,12) (flam1(i,j),i=1,1221)
1100    continue
999     close(unit=20)
	nlej=j-1
c
10      format(8f10.0)
13      format(i6,f8.0,2f6.2)
12      format(7e11.4)
c
c NEXT THE SCHMUTZ WR ATMOPSPHERES. READ THE DATA FROM THE TWO FILES 
c CONTAINING WR ATMOSPHERES FOR BETA =1 AND 2, RESPECTIVELY.
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
        open(unit=9,file='lejeune/wr_beta1.fluxes',status='old')
	do 1 i=1,12
	do 2 j=1,10
	do 3 k=1,1221
	read(9,*) wave1(k),flam2(k,i,j),tgrid1(i),rgrid1(j)
3	continue
2	continue
1	continue
	close(unit=9)
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
        open(unit=9,file='lejeune/wr_beta2.fluxes',status='old')
	do 6 i=1,11
	do 7 j=1,8
	do 8 k=1,1221
	read(9,*) wave1(k),flam4(k,i,j),tgrid2(i),rgrid2(j)
8	continue
7	continue
6	continue
	close(unit=9)
c
c  FILE CONTAINING THE SPECTRAL TYPE VERSUS TEFF CALIBRATION.
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
      open(unit=10,file='auxil/schkal.dat',status='old')
      do 499 i=1,445
      read(10,*) bip(i),tip(i)
499   continue
      close(unit=10)
c
c READ IN THE IR FEATURE DATA FILES.
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
        open(unit=15,file='auxil/irfeatures.dat',status='old')
        read(15,*) (origt(ll),ll=1,8)
        read(15,*) (origg(ll),ll=1,5)
        read(15,*) ((((co162data(jj,ll,ii,kk),ll=1,5),kk=1,5),jj=1,8),
     *ii=1,6)
        read(15,*) ((((co229data(jj,ll,ii,kk),ll=1,5),kk=1,5),jj=1,8),
     *ii=1,6)
        read(15,*) ((((si159data(jj,ll,ii,kk),ll=1,5),kk=1,5),jj=1,8),
     *ii=1,6)
        read(15,*) ((((co162nsdata(jj,ll,ii,kk),ll=1,5),kk=1,5),jj=1,8),
     *ii=1,6)
        read(15,*) ((((co229nsdata(jj,ll,ii,kk),ll=1,5),kk=1,5),jj=1,8),
     *ii=1,6)
        read(15,*) ((((si159nsdata(jj,ll,ii,kk),ll=1,5),kk=1,5),jj=1,8),
     *ii=1,6)
	close(unit=15)  	
c
c READ IN THE LYMAN-ALPHA DATA FILE.
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
        open(unit=15,file='auxil/lymanalpha.txt',status='old')
        read(15,*) (xlyman_g(l),l=1,12)
        read(15,*) (xlyman_t(m),m=1,11)
        read(15,*) (xlyman_t(m),m=12,23)
        read(15,*) ((xlyman(l,m),l=1,12),m=1,23)
	close(unit=15) 
c	
c THE WMBASIC ROUTINE CLOSELY MIRROS THE ORIGINAL KURUCZ
c AND WERNER SUBROUTINES SO THEY CAN BE FOLLOWED EASILY.  THE NEW GRIDS 
c FOLLOW SCHAERER'S COSTAR FLUX FILES WITH A TWO COLUMN ASCII LAYOUT,
c RATHER THAN THE MORE COMPACT LEJEUNE STYLE GRID.  THIS IS BECAUSE IT IS
c A REASONABLY SMALL GRID, AND EASIER TO READ IN OTHER LANGUAGES (I.E. C).
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
      file_name = 'lejeune/WMbasic_OB_Z'//nam//'.dat'
      open (unit=11,file=file_name,status='old',err=100)

      do i=1,12
        read(11,'( )')
      enddo
      do i=1,33
        read(11,*)xcx,tem_p(i),alum_p(i),glog_p(i)
        tem_p(i)=10.**tem_p(i)
        do j=1,1221
          read(11,*)wave_wm(j),flampaul(j,i)
          if (flampaul(j,i).lt.1.e-30)then
            flampaul(j,i)=1.e-30
          endif
          flampaul(j,i)=flampaul(j,i)*4.0*3.14142
        enddo
        read(11,'( )')
      enddo
100	close(unit=11)
c    
c NEXT READ THE HILLIER MODELS.
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c                 
      file_wn='lejeune/CMFGEN_WN_Z'//nam//'.dat'
      file_wc='lejeune/CMFGEN_WC_Z'//nam//'.dat'
c 
c NEW GRID OF HILLIER MODELS
c
      nmod=12
      nmod2=12
      open(unit=49,file=file_wn,status='old')
      open(unit=48,file=file_wc,status='old')
c
c THE WN GRID
c
      do i=1,13
        read(49,'(a)')break
      enddo
      do j=1,nmod
        read(49,*)count(j),tem_hi(j)
        do i=1,1221
          read(49,*)wave_hi(i),fl(i,j)
        enddo
        read(49,'(a)')break
      enddo
c
	close(unit=49)
c
c THE WC GRID
c
      do i=1,13
        read(48,'(a)')break
      enddo
      do j=1,nmod2
        read(48,*)count(j),tem2_hi(j)
        do i=1,1221
          read(48,*)wave_hi(i),fl2(i,j)
        enddo
        read(48,'(a)')break
      enddo       
c
	close(unit=48)
c
c NEXT READ THE POTSDAM WR MODELS. THESE MODELS ARE PULLED FROM
c THE WEBSITE DISCUSSED IN HAMANN & GRAEFENER (2004). THE MODELS
c COVER 950 (WN) OR 900 (WC) TO 3000 ANGSTROMS AT HIGH SPECTRAL
c RESOLUTION AND ARE EXTENDED DOWN TO 900 A USING LOW-RES SEDS.
c THEY ARE INTENDED FOR USE WITH THE UV HIGH-RES LIBRARY. THE
c FILE STRUCTURE AND NOMENCLATURE CLOSELY FOLLOWS THE CMFGEN
c MODELS.
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c                 
      file_PoWN='lejeune/PoWR-WN-Z'//nam//'.txt'
      file_PoWC='lejeune/PoWR-WC-Z'//nam//'.txt'
c 
      open(unit=47,file=file_PoWN,status='old')
      open(unit=46,file=file_PoWC,status='old')
c
c THE WN GRID
c
      do i=1,10
        read(47,'(a)')break
      enddo
      do j=1,12
        read(47,*)i_pot(j),t_pot_wn(j),r_pot_wn(j)
        read(47,*)i_wn(j)
        i_wn(j)=i_wn(j)+1
        do i=1,i_wn(j)
          read(47,*)wave_pot_wn(i,j),fl_pot_wn(i,j)
        enddo
      enddo
c
	close(unit=47)
c
c THE WC GRID
c
      do i=1,10
        read(46,'(a)')break
      enddo
      do j=1,12
        read(46,*)i_pot(j),t_pot_wc(j),r_pot_wc(j)
        read(46,*)i_wc(j)
        i_wc(j)=i_wc(j)+1
        do i=1,i_wc(j)
          read(46,*)wave_pot_wc(i,j),fl_pot_wc(i,j)
        enddo
      enddo       
c
	close(unit=46)
c
c READ THE WAVELENGTH GRID FOR THE HIRES MODELS
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
        file_name='lejeune/allstarswave.txt'
        open(unit=30,file=file_name,status='old')
	do 501 i=1,13321,7
        read(30,101) (wave_hires(i+j), j=0,6)
501     continue
101     format(7f11.3)
	do 5010 ii=13322,13322
	  read(30,1010) (wave_hires(ii+jj),jj=0,1)
5010    continue
1010    format(3f11.3)
        close(unit=30) 
c      
c READ IN THE HIGH-RESOLUTION LIBRARY
c
c PICK THE CORRECT METALLICITY.
c
	if(ilib.eq.1) namfi3='m10'
	if(ilib.eq.2) namfi3='m05'
	if(ilib.eq.3) namfi3='p00'
	if(ilib.eq.4) namfi3='p03'
c
c PICK THE CORRECT NUMBER OF MODELS
c	
	if(ilib.eq.1) nmodels=415
	if(ilib.eq.2) nmodels=409
	if(ilib.eq.3) nmodels=416
	if(ilib.eq.4) nmodels=411
c 
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
        file_name='lejeune/allstarsflux_'//namfi3//'.txt'
       open(unit=20,file=file_name,status='old',err=699)
        do 1002 j=1,nmodels
        read(20,143,end=699) tem_luci(j),glog_luci(j)
	  do 500 i=1,13321,7
        read(20,142) flam1_hires_l(i,j),flam1_hires_l(i+1,j),
     *            flam1_hires_l(i+2,j),flam1_hires_l(i+3,j),
     *            flam1_hires_l(i+4,j),flam1_hires_l(i+5,j),
     *            flam1_hires_l(i+6,j)
500     continue
	  do 5000 ii=13322,13322
	  read(20,120)flam1_hires_l(ii,j),
     *       flam1_hires_l(ii+1,j)
5000    continue  
1002    continue
699     close(unit=20)
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
        file_name='lejeune/allstarscont_'//namfi3//'.txt'
        open(unit=21,file=file_name,status='old',err=998)
        do 2002 j=1,nmodels
        read(21,143,end=998) tem_luci(j),glog_luci(j)
	  do 571 i=1,13321,7
        read(21,142) flam1_hires_c(i,j),flam1_hires_c(i+1,j),
     *            flam1_hires_c(i+2,j),flam1_hires_c(i+3,j),
     *            flam1_hires_c(i+4,j),flam1_hires_c(i+5,j),
     *            flam1_hires_c(i+6,j)
571     continue
	  do 5001 ii=13322,13322
	  read(21,120) flam1_hires_c(ii,j),
     *       flam1_hires_c(ii+1,j)
5001    continue        
2002    continue
c
998     close(unit=21)
c
c SET FLAG AFTER MODELS HAVE BEEN READ
c
        nlej_lu=j-1
c
143      format(f8.0,f6.2)
142      format(7e11.3)
120     format(2e11.3)
c
c
c READ THE TEMPLATE SPECTRA FOR THE UV LINE SYNTHESIS
c
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
      if(iline.eq.1) then
      open(unit=15,file='auxil/sp.dat',status='old')
      do 86 j=1,450
      do 87 k=1,np,5
      read(15,88) fli(j,k),fli(j,k+1),fli(j,k+2),
     *            fli(j,k+3),fli(j,k+4)
88    format(5(f8.4,2x))
      if(fli(j,k)  .le.0.) fli(j,k)  =1.e-30
      if(fli(j,k+1).le.0.) fli(j,k+1)=1.e-30
      if(fli(j,k+2).le.0.) fli(j,k+2)=1.e-30
      if(fli(j,k+3).le.0.) fli(j,k+3)=1.e-30
      if(fli(j,k+4).le.0.) fli(j,k+4)=1.e-30
87    continue
86    continue
      close(unit=15)
      endif
c
      if(iline.eq.2) then
      open(unit=15,file='auxil/sp_low.dat',status='old')
      do 860 j=1,450
      do 870 k=1,np,5
      read(15,880) fli(j,k),fli(j,k+1),fli(j,k+2),
     *            fli(j,k+3),fli(j,k+4)
880   format(5(f8.4,2x))
      if(fli(j,k)  .le.0.) fli(j,k)  =1.e-30
      if(fli(j,k+1).le.0.) fli(j,k+1)=1.e-30
      if(fli(j,k+2).le.0.) fli(j,k+2)=1.e-30
      if(fli(j,k+3).le.0.) fli(j,k+3)=1.e-30
      if(fli(j,k+4).le.0.) fli(j,k+4)=1.e-30
870   continue
860   continue
      close(unit=15)
      endif
c
c READ THE FUSE TEMPLATE SPECTRA.
c
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
      if(iline.eq.1) then
      open(unit=15,file='auxil/fuse_high.dat',status='old')
      do 76 j=1,450
      do 77 k=1,np1,5
      read(15,78) fli1(j,k),fli1(j,k+1),fli1(j,k+2),
     *            fli1(j,k+3),fli1(j,k+4)
78    format(5(f8.4,2x))
      if(fli1(j,k)  .le.0.) fli1(j,k)  =1.e-30
      if(fli1(j,k+1).le.0.) fli1(j,k+1)=1.e-30
      if(fli1(j,k+2).le.0.) fli1(j,k+2)=1.e-30
      if(fli1(j,k+3).le.0.) fli1(j,k+3)=1.e-30
      if(fli1(j,k+4).le.0.) fli1(j,k+4)=1.e-30
77    continue
76    continue
      close(unit=15)
      endif
c
      if(iline.eq.2) then
      open(unit=15,file='auxil/fuse_low.dat',status='old')
      do 760 j=1,450
      do 770 k=1,np1,5
      read(15,780) fli1(j,k),fli1(j,k+1),fli1(j,k+2),
     *            fli1(j,k+3),fli1(j,k+4)
780   format(5(f8.4,2x))
      if(fli1(j,k)  .le.0.) fli1(j,k)  =1.e-30
      if(fli1(j,k+1).le.0.) fli1(j,k+1)=1.e-30
      if(fli1(j,k+2).le.0.) fli1(j,k+2)=1.e-30
      if(fli1(j,k+3).le.0.) fli1(j,k+3)=1.e-30
      if(fli1(j,k+4).le.0.) fli1(j,k+4)=1.e-30
770   continue
760   continue
      close(unit=15)
      endif
c
c READ THE WAVELENGTH GRID FOR THE IFA ATMOSPHERES.
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
        file_name='lejeune/ifa_wave.txt'
        open(unit=30,file=file_name,status='old')
	do 591 i=1,4200,7
        read(30,181) (wave_ifa(i+j), j=0,6)
591     continue
181     format(7f11.3)
        close(unit=30)
c
c READ THE IFA MODEL ATMOSPHERES.
c
c PICK THE CORRECT METALLICITY.
c
	if(iz.eq.11.or.iz.eq.21.or.iz.eq.31.or.iz.eq.41) namfi3='m13'
	if(iz.eq.12.or.iz.eq.22.or.iz.eq.32.or.iz.eq.42) namfi3='m07'
	if(iz.eq.13.or.iz.eq.23.or.iz.eq.33.or.iz.eq.43) namfi3='m04'
	if(iz.eq.14.or.iz.eq.24.or.iz.eq.34.or.iz.eq.44) namfi3='p00'
	if(iz.eq.15.or.iz.eq.25.or.iz.eq.35.or.iz.eq.45) namfi3='p03'
	if(iz.eq.51.or.iz.eq.61) namfi3='m13'
	if(iz.eq.52.or.iz.eq.62) namfi3='m07'
	if(iz.eq.53.or.iz.eq.63) namfi3='m04'
	if(iz.eq.54.or.iz.eq.64) namfi3='p00'
	if(iz.eq.55.or.iz.eq.65) namfi3='p03'
c
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c
        file_name='lejeune/ifa_line_'//namfi3//'.txt'
        open(unit=20,file=file_name,status='old',err=399)
        do 1001 j=1,86
        read(20,136,end=399) tem_ifa(j),glog_ifa(j)
	  do 552 i=1,4200,7
        read(20,126) flam1_ifa_l(i,j),flam1_ifa_l(i+1,j),
     *            flam1_ifa_l(i+2,j),flam1_ifa_l(i+3,j),
     *            flam1_ifa_l(i+4,j),flam1_ifa_l(i+5,j),
     *            flam1_ifa_l(i+6,j)
552     continue
1001    continue
399     close(unit=20)
c
        file_name='lejeune/ifa_cont_'//namfi3//'.txt'
        open(unit=21,file=file_name,status='old',err=398)
        do 2001 j=1,86
        read(21,136,end=398) tem_ifa(j),glog_ifa(j)
	  do 551 i=1,4200,7
        read(21,126) flam1_ifa_c(i,j),flam1_ifa_c(i+1,j),
     *            flam1_ifa_c(i+2,j),flam1_ifa_c(i+3,j),
     *            flam1_ifa_c(i+4,j),flam1_ifa_c(i+5,j),
     *            flam1_ifa_c(i+6,j)
551     continue
2001    continue
398     close(unit=21)
c
        nlej_ifa=j-1
c
136     format(f11.0,f11.3)
126     format(7e11.3)
c
c
c INITIAL VALUES FOR THE SUPERNOVA RATE CALCULATION. MUST BE DONE HERE.
c CRITUP AND CRITMA DEFINE THE UPPER AND LOWER LIMITS OF THE MASS RANGE 
c OVER WHICH SN WERE COUNTED IN THE PREVIOUS TIME STEP.
c CRITMA_NEW AND CRITUP_NEW ARE USED TO CONSTRUCT THE SAME LIMITS FOR 
c THE CURRENT TIME STEP.
c
c THE USE OF CRITMA AND CRITUP ALLOWS US TO TREAT THE CASE WHERE THE
c (TOTAL) LIFETIME IS EITHER A MONOTONIC FUNCTION OF INITIAL MASS (NORMAL)
c OR IF IT HAS ONE LOCAL MINIMUM (AS FOUND IN HIGH MASS LOSS MODELS
c AT HIGH METALLICITY).
c
      critma = 1.e36  
      critma_new = critma
      critup = -1.
      critup_new = critup
c
c THE FOLLOWING SET IS USED IN THE SUBROUTINE NUCLEO
c
      critma1 = 1.e36  
      critma_new1 = critma1
      critup1 = -1.
      critup_new1 = critup1     
c
1000	continue
c
c COMPUTE THE MASS NORMALIZATION AND THE STELLAR NUMBER DENSITIES.
c INTERPOLATE IN THE EVOLUTIONARY TRACKS TO OBTAIN THE STELLAR PARAMETERS 
c FOR EACH TIME STEP. IF ISOCHRONE SYNTHESIS WITH A VARIABLE MASS GRID IS 
c SELECTED, THE DENSITIES MUST BE COMPUTED AFTER THE CALL TO STARPARA_ISO.
c
      if (jmg.eq.0.or.jmg.eq.1) then 
	call density(time,icount)
        call starpara(time,icount)
      endif
c
      if (jmg.eq.2) then 
        call density(time,icount)
        call starpara_iso(time,icount)
      endif
c
      if (jmg.eq.3) then 
        call starpara_iso(time,icount)
	call density(time,icount)
      endif

c
c MAKE AN ADJUSTMENT TO THE WR TEMPERATURES
c
      if (jmg.eq.2.or.jmg.eq.3) then
         call temp_adjust(iwrt,iatmos)
      endif

c
c COMPUTE THE POWER AND ENERGY OF STELLAR WINDS
c

      if(io4.ge.0) call windpower(time,icount)

c
c COMPUTE THE SUPERNOVA RATE IF DESIRED. WARNING: THIS CALL MUST BE AFTER THE
c CALL TO WIND POWER. OTHERWISE THE SUM OF THE SN+WIND POWER CANNOT BE
c CALCULATED CORRECTLY!
c
      if(io2.ge.0) call supernova(time,icount)

c
c GET THE SPECTRAL TYPES OF ALL STARS IN THE HRD
c

      if(io5.ge.0) call spectype(time,icount)

c
c COMPUTE THE YIELDS OF H, HE, AND SELECTED HEAVY ELEMENTS
c
   
      if(io6.ge.0) call nucleo(time,icount) 
c
c COMPUTE A SYNTHETIC SPECTRUM FOR THE STARBURST
c
      if(io7.ge.0) call specsyn(time,icount)

c
c COMPUTE THE SYNTHETIC ULTRAVIOLET LINES
c

      if(io8.ge.0) call linesyn(time,icount)

c
c COMPUTE THE FUSE SPECTRUM
c

      if(io12.ge.0) call fusesyn(time,icount)

c
c COMPUTE THE OPTICAL HIGH RESOLUTION SPECTRUM 
c
      if(io13.ge.0) call hires(time,icount)

c
c COMPUTE A THEORETICAL LINE SPECTRUM WITH THE IFA LIBRARY
c
      if(io15.ge.0) call ifa_spectrum(time,icount)
c
c LOOP TO RUN TIME IN LOGARITHMIC STEPS.
c
      if(jtime.eq.0) then
       tstep=tvar
      else
       tiempo1=tiempo1+tvar
       tback=tiempo1-tvar
       tstep=(10.**tiempo1)-(10.**tback)
      endif
      icount=icount+1
	time=time+tstep

	 if(jtime.eq.0) then
         if(time.gt.tmax) goto 9999
      else
	 iexit=ifix(tinter)+1
	 if(iexit.lt.icount) goto 9999
      endif

      goto 1000
c
c END OF MAIN LOOP
c
9999    continue
c
c
c        if(io1.ge.0 .and. io7.ge.0)   write(980,612)
c612 	   format('</quanta>')        
c        if(io2.ge.0)   write(970,613)
c613 	   format('</SNRate>')        
c        if(io4.ge.0)   write(950,614)
c614 	   format('</Power>')  
c        if(io6.ge.0)   write(930,615)
c615 	   format('</Yields>')  
c        if(io9.ge.0 .and. io7.ge.0)   write(890,616)
c616 	   format('</color>')        
c        if(io10.ge.0 .and. io7.ge.0)   write(880,617)
c617 	   format('</EWidth>')        
c        if(io11.ge.0 .and. io7.ge.0)   write(870,618)
c618 	   format('</Features>') 
c        if(io14.ge.0 .and. io7.ge.0)   write(840,619)
c619 	   format('</WRLines>')                                   
c        if(io7.ge.0)   write(920,607)
c607 	   format('</spectrum>')        
c	 if(io8.ge.0)   write(910,608)
c608 	   format('</line>')
c        if(io12.ge.0)   write(860,609)
c609 	   format('</OVI>')
c	if(io13.ge.0)   write(820,610)
c610 	   format('</Hires>')
c	if(io15.ge.0)   write(830,611)
c611 	   format('</Ifaspec>')
c	if(io5.ge.0)   write(940,620)
c620 	   format('</SP>')
c
c
c
c CREATE AN OUTPUT FILE WITH THE MODEL PARAMETERS.
c
      call output
c
      stop
      end
c
c
c *******************************************************************
c *******************************************************************
c *******************************************************************
c
      subroutine input(time)
c
c GET THE INPUT PARAMETERS FROM AN INPUT FILE AND PASS THEM OVER TO
c THE OTHER SUBROUTINES VIA COMMON "PARAMETERS".
c
c *******************************************************************
c
c
	implicit real*4    (a-h,o-z)      
        character*20 name
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
        parameter (npgrid = 3000) 
        dimension cmass(npgrid)
c
      read(1,10001) name,isf,toma,sfr,ninterv,(xponent(i),i=1,Nmaxint),
     *              (xmaslim(i),i=1,Nmaxint1),sncut,
     *              bhcut,iz,iwind,time1,jtime,tbiv,itbiv,tmax,jmg,lmin,
     *              lmax,tdel,iatmos,ilib,iline,ivt,irsg,io1,io2,io3,
     *              io4,io5,io6,io7,io8,io9,io10,io11,io12,io13,io14,
     *              io15
	close(unit=1)
10001 format(/,a20,//,i3,//,f12.2,//,f12.2,//,i3,//,10f12.2,
     *       //,11f12.2,//,f12.2,//,f12.2,////////,i3,//,i3,//,
     *       f12.2,//,i3,//,f12.2,//,i8,//,f12.2,/,/,/,i3,//,
     *       2i4,//,f12.2,//,i3,/,/,/,i3,//,i3,//,2i4,//,15i3)
c 
      time1=time1*1.0e6
      tmax=tmax*1.0e6
c
c SET THE INITIAL TIME. START WITH THE INITIAL TIME TIME1 IF THE BURST IS
c INSTANTANEOUS. IF SF IS CONTINUOUS, THE FIRST TIME STEP MUST BE CLOSE TO 0.
c NOTE: GET_ISO WILL CRASH IF TIME1 = 0!
c
      if (isf.le.0) then
         time=time1
      else
         time=1.e-5
         time1=time
      endif
c
c THE FOLLOWING STATEMENT MAKES SURE THE JOB WILL NOT TAKE UNACCEPTABLY
c LONG. IT IS ONLY IMPLEMENTED ON THE WEB SERVER.
c
c	if(tmax.gt.9.99e8) then
c		jtime = 1
c		write(6,32)
c32		format(' TIME STEP CHANGED TO LOGARITHMIC IF ',
c     *                'TMAX >= 1 GYR! OTHERWISE THE JOB TAKES ',
c     *                'TOO LONG!')		
c	endif	
c
c DEFINE THE TIME STEP FOR TWO OPTIONS: LINEAR AND LOGARITHMIC.
c
      if (jtime.eq.0) then
       tvar=tbiv*1.0e6
       tstep=tvar
      else
       tinter=float(itbiv)
       tiempo1=alog10(time1)
       tmaxim=alog10(tmax)
       tvar=(tmaxim-tiempo1)/tinter
       tmax=10.**(tmaxim+tvar)
       tstep=1.e4
      endif
c
      tdel=tdel*1.0e6
      toma=toma*1.0e6
c
c  MASS LIMITS FOR THE IMF.
c
      upma = xmaslim(Ninterv+1)
      doma = xmaslim(1)
c
c A FEW CONSISTENCY CHECKS. THERE ARE NO SPECTRAL LIBRARIES FOR 
c SOME CHEMICAL COMPOSITIONS IN THE PADOVA TRACKS (Z=0.0004 AND 
c 0.05). THE CODE USES THE SAME VALUE FOR THE CHEMICAL COMPOSITION 
c AS IN THE GENEVA TRACKS (Z=0.001 AND 0.04) TO LINK THE LIBRARIES
c TO TRACKS. 
c
	if(iz.eq.11.or.iz.eq.21.or.iz.eq.31.or.iz.eq.41) z=0.05
	if(iz.eq.12.or.iz.eq.22.or.iz.eq.32.or.iz.eq.42) z=0.2
	if(iz.eq.13.or.iz.eq.23.or.iz.eq.33.or.iz.eq.43) z=0.4
	if(iz.eq.14.or.iz.eq.24.or.iz.eq.34.or.iz.eq.44) z=1.0
	if(iz.eq.15.or.iz.eq.25.or.iz.eq.35.or.iz.eq.45) z=2.0
	if(iz.eq.51.or.iz.eq.61) z=0.2 ! update in the future
	if(iz.eq.52.or.iz.eq.62) z=0.2	
	if(iz.eq.53.or.iz.eq.63) z=1.0 ! update in the future
	if(iz.eq.54.or.iz.eq.64) z=1.0
	if(iz.eq.55.or.iz.eq.65) z=1.0 ! update in the future
c
	if(iz.eq.51.or.iz.eq.61) then
		write(6,202)
202		format(' METALLICITY RESET to Z=0.002!')
	endif
c
	if(iz.eq.53.or.iz.eq.63) then
		write(6,203)
203		format(' METALLICITY RESET to Z=0.014!')
	endif
c
	if(iz.eq.55.or.iz.eq.65) then
		write(6,203)
	endif
c
	if (iatmos.lt.1 .or. iatmos.gt.5) then
		write(6,20)
20		format(' PICK THE CORRECT MODEL ATMOSPHERE!')
		goto 7777
	endif
c
c IT IS BEST TO USE JMG=3 WITH THE PADOVA TRACKS, WHICH INCLUDE STARS
c DOWN TO 0.15 M. THE FIXED GRIDS END AT 1 M.
c
	if (jmg.lt.3 .and. (iz.eq.31 .or. iz.eq.32 .or. iz.eq.33
     *    .or. iz.eq.34 .or. iz.eq.35 .or. iz.eq.41 .or.
     *     iz.eq.42 .or. iz.eq.43 .or. iz.eq.44 .or. iz.eq.45))
     *     then
	  write(6,40)
40	  format(' INFO: JMG SHOULD BE 3 FOR THE PADOVA TRACKS.',
     *         ' THE 0, 1, 2 GRIDS TERMINATE AT 1 M!')
	endif
c
	if (iatmos.lt.4 .and. 
     *   (io8.ge.0.or.io12.ge.0.or.io13.ge.0.or.io15.ge.0)) then
		write(6,201)
201		format(' INFO: HILLIER USED FOR LINE SPECTRA!')
	endif
c
c LINKING THE UCL WR MODEL ATMOSPHERES TO THE GENEVA TRACKS 
c REQUIRES CARE.  SMITH ET AL. (2002) FIND THAT AN EMPIRICAL 
c SCALING OF THE EVOLUTIONARY TEMPERATURES GIVES THE BEST RESULTS. 
c THIS IS DONE IN THE SUBROUTINE TEMP_ADJUST. HOWEVER, THIS CAN BE 
c MANUALLY OVERRRIDEN BY CHANGING IWRT FROM ITS DEFAULT VALUE > 0 
c TO A VALUE <= 0. ALONG THE SAME LINES, IT IS POSSIBLE TO TURN OFF
c THE DEFAULT SCALING OF MDOT WITH Z IN THE UCL WR ATMOSPHERES. IF
c SO, THE SOLAR Z MODELS ARE ALWAYS USED. THE DEFAULT IS IWRSCALE=1,
c I.E., SCALING OF THE MASS-LOSS RATE. A VALUE <=0 TURNS OFF THIS
c FEATURE. 
c
	if (iatmos.ge.4)then
                iwrt=1
                iwrscale=1
      endif
c
c A FEW MORE CHECKS.....
c
	if(iz.lt.11 .or. 
     *    (15.lt.iz.and.iz.lt.21) .or. (25.lt.iz.and.iz.lt.31).or.
     *    (35.lt.iz.and.iz.lt.41) .or. (45.lt.iz.and.iz.lt.51).or.
     *    (55.lt.iz.and.iz.lt.61) .or.iz.gt.65) then
		write(6,21)
21		format(' THIS METALLICITY IS NOT AVAILABLE!')
		goto 7777
	endif
c
	if(io9.ge.0 .and. io7.lt.0) then
		write(6,22)
22		format(' CANNOT COMPUTE SYNTHETIC COLORS!')
	endif
c
	if(io10.ge.0 .and. io7.lt.0) then
		write(6,23)
23		format(' CANNOT COMPUTE EQUIVALENT WIDTHS!')
	endif
c
	if(io10.ge.0 .and. io1.lt.0) then
		write(6,23)
	endif
c
	if((io7.ge.0 .or. io8.ge.0) .and. io1.lt.0) then
		write(6,24)
24		format(' INFO: NO NEBULAR CONTINUUM!')
	endif
c
	if(io7.lt.0 .and. io8.ge.0 .and. io1.ge.0) then
		write(6,24)
	endif
c
	if(io11.ge.0 .and. io7.lt.0) then
		write(6,25)
25		format(' CANNOT COMPUTE SPECTRAL FEATURES!')
	endif
c
	if(io14.ge.0 .and. io7.lt.0) then
		write(6,27)
27             format(' CANNOT COMPUTE WR EMISSION LINES!')
	endif
c
        if (ivt.lt.1.or.ivt.gt.6.or.irsg.lt.0.or.irsg.gt.1) then
           write(6,28)
28        format('RSG FEATURE: INCORRECT RANGE FOR INPUT ',
     *            'PARAMETERS!')
        endif
c
	if(io3.ge.0 .and. jmg.eq.3) then
	     write(6,29)
 29          format(' INFO: NO HRD FOR ISOCHRONE SYNTHESIS!')
	endif
c
	if(jmg.gt.3.or.jmg.lt.0) then
		write(6,30)
 30             format(' JMG MUST BE 0, 1, 2, OR 3!')
	endif
c
	if(io1.ge.0 .and. io7.lt.0) then
	     write(6,24)
	endif
c
	if((io7.ge.0 .or. io12.ge.0) .and. io1.lt.0) then
		write(6,24)
	endif
c
	if(io7.lt.0 .and. io12.ge.0 .and. io1.ge.0) then
		write(6,24)
	endif
c
	if((io7.ge.0 .or. io15.ge.0) .and. io1.lt.0) then
		write(6,24)
	endif
c
	if(io7.lt.0 .and. io15.ge.0 .and. io1.ge.0) then
		write(6,24)
	endif
c
	if((io7.ge.0 .or. io13.ge.0) .and. io1.lt.0) then
		write(6,24)
	endif
c
	if(iline.lt.1 .or. iline.gt.2) then
		write(6,31)
 31             format(' ILINE MUST BE 1 OR 2!')
		goto 7777
 	endif
c
	if(upma.gt.120.) then
		upma=120.
		write(6,331)
331		format(' IMF UPPER MASS SET TO 120 (MAXIMUM ALLOWED)!')
	endif
c
	if(iwind.lt.0 .or. iwind.gt.3) then
		write(6,34)
 34             format(' IWIND MUST BE 0,1,2, or 3!')
		goto 7777
 	endif
c
	if(ilib.lt.1 .or. ilib.gt.4) then
		write(6,35)
 35             format(' ILIB MUST BE 1,2,3, or 4!')
		goto 7777
 	endif
c			
	return
c
7777	stop
	end
c
c ********************************************************************
c ********************************************************************
c ********************************************************************
c
      subroutine density(time,icount)
c
c COMPUTE THE MASS NORMALIZATION AND THE STELLAR NUMBER DENSITIES IN EACH
c MASS INTERVAL FOR EACH TIME STEP.
c DENS(I) IS THE TOTAL NUMBER OF STARS IN THE MASS INTERVAL
c CMASS(I)+-DELM FORMED AT THE TIME (TIME)
c
c ********************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
        common/stars/dens,tonum
        parameter (npgrid = 3000) 
        dimension cmass(npgrid),a(nmaxint)
        dimension dens(npgrid),aic(nmaxint)
c
c THE TOTAL MASS IS COMPUTED FROM THE STAR FORMATION RATE IF A STAR
c FORMATION RATE IS SPECIFIED. ELSE, THE TOTAL MASS IS SIMPLY TAKEN FROM
c THE INPUT FILE.
c
	if(isf.le.0) goto 950
c
	toma=sfr*tstep
c
950	continue
c
c MORE OPTIONS FOR THE IMF. A MULTI-POWER LAW IMF CAN BE USED.
c THE NORMALIZATION CONSTANTS ARE CALCULATED. UPDATED BY RALPH SUTHERLAND.
c
       aic(1) = 1.0
       if ( Ninterv .gt. 1) then
       do k= 2, Ninterv
         aic(k)=aic(k-1)*xmaslim(k)**(xponent(k)-xponent(k-1))
       enddo
       endif
c
       sum=0.0
       do i=1,Ninterv
c
        if (xponent(i).eq.2.) then
        sumando=log(xmaslim(i+1))-log(xmaslim(i))
        else
         sumando = (xmaslim(i+1)**(2.0-xponent(i))- 
     *              xmaslim(i)**(2.0-xponent(i)))/(2.-xponent(i))
        endif
c      
       sum=sum+aic(i)*sumando
c
       enddo
       
       s=toma/sum
       do i=1,Ninterv
        a(i)=aic(i)*s
       enddo
c
c SET UP THE MASS GRID:
c      JMG=0 - SMALL GRID FOR THE GENEVA TRACKS.
c      JMG=1 - LARGE GRID FOR THE GENEVA TRACKS.
c      JMG=2 - ISOCHRONE SYNTHESIS WITH LARGE GRID FOR THE GENEVA TRACKS. 
c      JMG=3 - ISOCHRONE SYNTHESIS WITH VARIABLE GRID; IN THIS CASE THE
c              INPUT VALUES FOR LMIN, LMAX HAVE NO INFLUENCE. THEY WILL BE SET
c              LATER AUTOMATICALLY. SAME FOR CMASS. (IN STARPARA_ISO). THIS 
c              CASE WORKS FOR BOTH THE GENEVA AND THE PADOVA TRACKS.
c
	if(jmg.eq.3) goto 65
c
      if(jmg) 60,61,60
61     if(lmin.eq.0) lmin=1
       if(lmax.eq.0) lmax=24
       delm=2.5
      goto 62
60     if(lmin.eq.0) lmin=1
       if(lmax.eq.0) lmax=120
       delm=0.5
62    continue
c
c DEFINITION OF THE MASS INTERVALS. TWO GRIDS ARE POSSIBLE FOR NON-ISOCHRONE
c SYNTHESIS: ONE WITH 24 TRACKS AND DELTA M = 5, AND ONE WITH 120 TRACKS AND 
c DELTA M = 1. IF DELTA M = 5, THE LOWEST POSSIBLE MASS IS 5 SOLAR MASSES. FOR 
c DELTA M = 1 THE LOWEST MASS IS 1 SOLAR MASS.
c
      do 63 i=lmin,lmax
       cmass(i) = 120.-(i-1)*2.*delm
63    continue
c
c NOW PROVISION IS MADE THAT THE SELECTED EVOLUTIONARY TRACKS ARE IN
c AGREEMENT WITH THE MASS LIMITS OF THE IMF. NOTE THAT SPECIFYING 
c INDIVIDUAL TRACKS IN THE INPUT FILE (E.G. LMIN=LMAX=1) HAS NO
c INFLUENCE ON THE IMF CALCULATION. THE MASS NORMALIZATION ENTIRELY
c DEPENDS ON UPMA AND DOMA. THIS IS DESIRABLE BECAUSE INDIVIDUAL TRACKS
c WILL ONLY BY SPECIFIED FOR CERTAIN TEST CASES BUT EVEN IN THOSE CASES
c ONE MAY WANT THE MASS NORMALIZATION TO BE OK.
c
      do 64 i=lmin,lmax
       if(upma.le.cmass(i)) lmin=i
       if(doma.le.cmass(i)) lmax=i
64    continue
c
65	continue
c
c THE TOTAL NUMBER OF STARS FORMED IN THE MASS INTERVAL CMASS +/- DELM
c IS CALCULATED. THE INTEGRATION IS DONE ANALYTICALLY. XPONENT(NMAXINT) = 1 IS
c TREATED SEPARATELY. WE DISTINGUISH BETWEEN THE CASES WITH FIXED (SMALL OR
c LARGE) MASS GRID AND VARIABLE MASS GRID (FOR FULL ISOCHRONE SYNTHESIS).
c
       do 3 i=lmin,lmax
          if (jmg.ge.0.and.jmg.le.2) then
c
c FIXED MASS GRID
c
             xmhigh = cmass(i)+delm
             xmlow  = cmass(i)-delm
c
c THE MASS INTERVALS AT THE UPPER AND LOWER INTEGRATION LIMITS ARE CUT
c IN HALF.
c
           if(lmin.ne.lmax) then
	      if(i.eq.lmin) xmhigh = xmhigh -delm
	      if(i.eq.lmax) xmlow  = xmlow  +delm
	   endif
c
          else if(jmg.eq.3) then
c
c VARIABLE MASS GRID. NOTE: THE VARIABLE MASS GRID IS IN INCREASING MASS 
c - OPPOSITE TO THE FIXED MASS GRID !!
c
c Really should have a proper bin edges array defined, but can 
c speeed this up a but as it stands - RSS
c
             if (i.eq.lmin) then
c               Special case for interval at lower integration limit
                xmhigh = 0.5*(cmass(i)+cmass(i+1))
                xmlow  = cmass(i)
             else if (i.eq.lmax) then
c               Special case for interval at upper integration limit
                xmhigh = cmass(i)
                xmlow  = 0.5*(cmass(i-1)+cmass(i))
             else
c               General case
                xmhigh = 0.5*(cmass(i)+cmass(i+1))
                xmlow  = 0.5*(cmass(i-1)+cmass(i))
             endif
          endif
c
c THE STAR NUMBER (OR DENSITY) FOR ANY POWER LAW IMF IS 
c CALCULATED HERE. THIS PART WAS UPDATED BY JUN YIN (SHANGHAI).
c
	do j=1,Ninterv
C 
         if(xmlow.lt.xmaslim(j).and.xmaslim(j).lt.xmhigh.and.j.ne.1)then
 
          if (xponent(j-1).eq.1.) then
           dens(i)=a(j-1)*(log(xmaslim(j))-log(xmlow)) + 
     *             a(j)/(1.-xponent(j))*
     *             (xmhigh**(1.-xponent(j))-
     *             xmaslim(j)**(1.-xponent(j)))
          else if (xponent(j).eq.1.) then
           dens(i)=a(j-1)/(1.-xponent(j-1))*(xmaslim(j)**(1.-xponent(j
     *             -1))-xmlow**(1.-xponent(j-1))) + 
     *             a(j)*(log(xmhigh)-log(xmaslim(j))) 
          else 
           dens(i)=a(j-1)/(1.-xponent(j-1))*(xmaslim(j)**
     *             (1.-xponent(j-1))-xmlow**(1.-xponent(j-1))) + 
     *             a(j)/(1.-xponent(j))*(xmhigh**(1.-xponent(j))-
     *             xmaslim(j)**(1.-xponent(j)))  
         endif   
c 
        elseif (xmaslim(j).le.xmlow.and.xmhigh.le.xmaslim(j+1)) then
c 
         if (xponent(j).eq.1.) then
           dens(i)=a(j)*(log(xmhigh)-log(xmlow))
         else 
           dens(i)=a(j)/(1.-xponent(j))*(xmhigh**(1.-xponent(j))-
     *             xmlow**(1.-xponent(j))) 
         endif
c 
        endif
c 
        enddo
c
3	continue
c
c THE TOTAL NUMBER OF STARS FORMED IN ALL MASS INTERVALS IS COMPUTED  
c
c temp variable to check mass integral
c
	tomas = 0.
        tonum=0.
c
      do 100 i=lmax,lmin,-1
        tonum = tonum + dens(i)
        tomas = tomas + dens(i)*cmass(i)
100   continue
c      
c Uncomment to check integrals
c
c	write(22,*)  'Totals:', tonum,'stars ', tomas,'mass (approx)'
c
      return
      end
c
c
c ****************************************************************************
c ****************************************************************************
c ****************************************************************************
c
	subroutine read_tracks
c 
c READS DIFFERENT SETS OF EVOLUTIONARY TRACKS FROM GENEVA 1992-1994, 
c 2013 AND PADOVA 1993-1994, AND PADOVA 2000 WHITH MASS LOSS FOR THE TP-AGB STARS.
c ALSO SETS UP THE MASS LIMIT FOR WR FORMATION (XMWR) FOR ALL SETS OF TRACKS.
c
c ****************************************************************************
c
        implicit real*4    (a-h,o-z)
        character*20 name
        character*50 filetrck
        character*2  switch
        character*80 title_tracks
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        parameter (ntracks = 50, nptrack = 500)
	common/tracks/dm(ntracks)       ,
     *                dlm(ntracks)      ,
     *                da(ntracks,nptrack)   ,
     *                dla(ntracks,nptrack)  ,
     *                xmas(ntracks,nptrack) ,
     *                dmas(ntracks,nptrack) ,
     *                dl(ntracks,nptrack)   ,
     *                dt(ntracks,nptrack)   ,
     *                d_h(ntracks,nptrack)  ,
     *                d_he(ntracks,nptrack) ,
     *                d_c(ntracks,nptrack)  ,
     *                d_n(ntracks,nptrack)  ,
     *                d_o(ntracks,nptrack)  ,
     *                d_tstar(ntracks,nptrack) ,
     *                d_mdot(ntracks,nptrack)  ,
     *                nma               ,
     *                jmp               ,
     *                title_tracks       
c
c PICK THE CORRECT FILE FOR EACH METALLICITY AND MASS LOSS RATE AND DEFINE THE
c WOLF-RAYET MASS.
c THE WOLF-RAYET MASS LIMIT FOR THE PADOVA TRACKS IS THE SAME AS IN THE 
c GENEVA TRACKS WITH HIGH MASS LOSS. BE AWARE ABOUT THE IMPLICATIONS.
c *** THE FILE NAME IS LOCATION DEPENDENT ***
c  
c GENEVA WITH STD MASS LOSS
c
      if (iz.eq.11) then
         filetrck='tracks/modc001.dat'    
         xmwr = 80.
      else if (iz.eq.12) then
         filetrck='tracks/modc004.dat'
         xmwr = 52.
      else if (iz.eq.13) then
         filetrck='tracks/modc008.dat'
         xmwr = 42.
      else if (iz.eq.14) then
         filetrck='tracks/modc020.dat'
         xmwr = 32.
      else if (iz.eq.15) then
         filetrck='tracks/modc040.dat'
         xmwr = 25.
c  
c GENEVA WITH HIGH MASS LOSS
c
      else if (iz.eq.21) then
         filetrck='tracks/mode001.dat'
         xmwr = 61.
      else if (iz.eq.22) then
         filetrck='tracks/mode004.dat'
         xmwr = 42.
      else if (iz.eq.23) then
         filetrck='tracks/mode008.dat'
         xmwr = 35.
      else if (iz.eq.24) then
         filetrck='tracks/mode020.dat'
         xmwr = 25.
      else if (iz.eq.25) then
         filetrck='tracks/mode040.dat'
         xmwr = 21.
c
c PADOVA TRACKS
c
      else if (iz.eq.31) then
         filetrck='tracks/mods0004.dat'
         xmwr = 61.
      else if (iz.eq.32) then
         filetrck='tracks/mods004.dat'
         xmwr = 42.
      else if (iz.eq.33) then
         filetrck='tracks/mods008.dat'
         xmwr = 35.
      else if (iz.eq.34) then
         filetrck='tracks/mods020.dat'
         xmwr = 25.
      else if (iz.eq.35) then
         filetrck='tracks/mods050.dat'
         xmwr = 21.
c
c PADOVA TRACKS WITH AGB STARS
c
      else if (iz.eq.41) then
         filetrck='tracks/modp0004.dat'
         xmwr = 61.
      else if (iz.eq.42) then
         filetrck='tracks/modp004.dat'
         xmwr = 42.
      else if (iz.eq.43) then
         filetrck='tracks/modp008.dat'
         xmwr = 35.
      else if (iz.eq.44) then
         filetrck='tracks/modp020.dat'
         xmwr = 25.
      else if (iz.eq.45) then
         filetrck='tracks/modp050.dat'
         xmwr = 21.                 
c  
c GENEVA (2013) TRACKS WITH V=0
c
      else if (iz.eq.51) then
         filetrck='tracks/Z0020v00.txt'
         xmwr = 84.
      else if (iz.eq.52) then
         filetrck='tracks/Z0020v00.txt'
         xmwr = 84.
      else if (iz.eq.53) then
         filetrck='tracks/Z0140v00.txt'
         xmwr = 25.
      else if (iz.eq.54) then
         filetrck='tracks/Z0140v00.txt'
         xmwr = 25.
      else if (iz.eq.55) then
         filetrck='tracks/Z0140v00.txt'
         xmwr = 25.
c  
c GENEVA (2013) TRACKS WITH V=0.4*BREAK-UP
c
      else if (iz.eq.61) then
         filetrck='tracks/Z0020v40.txt'
         xmwr = 55.
      else if (iz.eq.62) then
         filetrck='tracks/Z0020v40.txt'
         xmwr = 55.
      else if (iz.eq.63) then
         filetrck='tracks/Z0140v40.txt'
         xmwr = 20.
      else if (iz.eq.64) then
         filetrck='tracks/Z0140v40.txt'
         xmwr = 20.
      else if (iz.eq.65) then
         filetrck='tracks/Z0140v40.txt'
         xmwr = 20.                  
      endif
c
c INITIALIZE ALL VARIABLES.
c
      do ki=1,ntracks
         dm(ki)  = 0.d+0
         dlm(ki) = 0.d+0
	 do km=1,nptrack
            da(ki,km)   = 0.d+0
            dla(ki,km)  = 0.d+0
            xmas(ki,km) = 0.d+0
            dmas(ki,km) = 0.d+0
            dl(ki,km)   = 0.d+0
            dt(ki,km)   = 0.d+0
            d_h(ki,km)  = 0.d+0
            d_he(ki,km) = 0.d+0
            d_c(ki,km)  = 0.d+0
            d_n(ki,km)  = 0.d+0
            d_o(ki,km)  = 0.d+0
            d_tstar(ki,km) = 0.d+0
            d_mdot(ki,km)  = 0.d+0
         enddo
      enddo
c
c NOW READ FILE.
c
      open (unit=12,file=filetrck,status='old')
      read(12,400) title_tracks
      read(12,401)
      read(12,402) nma,jmp
      do ki=1,nma
         read(12,401)
         read(12,403) dm(ki),switch
          if (ki.gt.1) then
            if (dm(ki).ge.dm(ki-1)) then
               call errpri('READ_TRACKS: TRACKS NOT OF DECREASING M !')
            endif
         endif
	 dlm(ki) = log10(dm(ki))
         read(12,401)
         ilines = jmp
         do km=1,ilines
            if (switch.eq.'WR') then ! read additional information (Tstar, Mdot)
               read(12,4050) i,da(ki,km),xmas(ki,km),dl(ki,km),
     *                   dt(ki,km),d_h(ki,km),d_he(ki,km),d_c(ki,km),
     *                   d_n(ki,km),d_o(ki,km),
     *                   d_tstar(ki,km),d_mdot(ki,km)
c 
            elseif (switch.eq.'RO') then ! read the 2013 Geneva tracks
               read(12,*) i,da(ki,km),xmas(ki,km),dl(ki,km),
     *                   dt(ki,km),d_h(ki,km),d_he(ki,km),d_c(ki,km),
     *                   d_n(ki,km),d_o(ki,km),
     *                   d_tstar(ki,km),d_mdot(ki,km)  
c
            elseif (switch.eq.'ML') then ! read additional information (Mdot)
               read(12,4045) i,da(ki,km),xmas(ki,km),dl(ki,km),
     *                   dt(ki,km),d_h(ki,km),d_he(ki,km),d_c(ki,km),
     *                   d_n(ki,km),d_o(ki,km),
     *                   d_mdot(ki,km) 
                         d_tstar(ki,km)=dt(ki,km) 
c
            else	
               read(12,4040) i,da(ki,km),xmas(ki,km),dl(ki,km),
     *                   dt(ki,km),d_h(ki,km),d_he(ki,km),d_c(ki,km),
     *                   d_n(ki,km),d_o(ki,km)
                         d_tstar(ki,km)=dt(ki,km)      
            endif
c
            if (km.eq.1.and.i.ne.km) then 
               call errpri('READ_TRACKS: POINT MISSING ON TRACK !')
            endif
c
            dmas(ki,km) = log10(xmas(ki,km))
            dla(ki,km)  = log10(da(ki,km))
            if(d_mdot(ki,km).gt.-0.1)  d_mdot(ki,km)=-30.
c
         enddo
c
c MAKE SURE ALL ARRAYS HAVE THE SAME NUMBER OF DATA EVEN IF THEY WERE NOT 
c INCLUDED IN THE TABLES.
c
         if (ilines.eq.jmp-3) then
            do km=ilines+1,jmp
               da(ki,km)   = da(ki,ilines)
               xmas(ki,km) = xmas(ki,ilines)
               dl(ki,km)   = dl(ki,ilines)
               dt(ki,km)   = dt(ki,ilines)
               d_h(ki,km)  = d_h(ki,ilines)
               d_he(ki,km) = d_he(ki,ilines)
               d_c(ki,km)  = d_c(ki,ilines)
               d_n(ki,km)  = d_n(ki,ilines)
               d_o(ki,km)  = d_o(ki,ilines)
               d_tstar(ki,km)  = d_o(ki,ilines)
               d_mdot(ki,km)   = d_o(ki,ilines)
               dmas(ki,km) = log10(xmas(ki,ilines))
               dla(ki,km)  = log10(da(ki,ilines))
            enddo
         endif
c
c         if (ki.gt.1) then
c           if (da(ki,jmp).lt.da(ki-1,jmp)) then
c           call errpri('READ_TRACKS: LIFETIMES NOT INCREASING WITH M !')
c		write(6,406) ki
c           endif
c         endif
c
      enddo
      close(12)
c
c A FEW MANIPULATIONS ARE DONE: IN ALL TRACKS THE FIRST SET OF ENTRIES IS 
c ASSUMED TO HAVE ABOUT T = 0. TWO MORE ENTRIES ARE ADDED AT THE END OF THE 
c STELLAR LIFETIME. THIS SERVES AS A FLAG TO INDICATE THAT THE STARS HAVE 
c VANISHED FROM THE HRD.
c
      do i=1,nma
         da(i,1)      = 1.e-3
         da(i,jmp+1)  = da(i,jmp) + 100.0
         da(i,jmp+2)  = 10.**6   * da(i,jmp+1)
         dla(i,jmp+1) = log10(da(i,jmp+1))
         dla(i,jmp+2) = log10(da(i,jmp+2))
         dl(i,jmp+1)  = -20.
         dl(i,jmp+2)  = -20.
         do j=1,2
            dt(i,jmp+j)      = dt(i,jmp)
            d_h(i,jmp+j)     = d_h(i,jmp)
            d_he(i,jmp+j)    = d_he(i,jmp)
            d_c(i,jmp+j)     = d_c(i,jmp)
            d_n(i,jmp+j)     = d_n(i,jmp)
            d_o(i,jmp+j)     = d_o(i,jmp)
            d_tstar(i,jmp+j) = d_tstar(i,jmp)
            dt(i,jmp+j)      = dt(i,jmp)
            xmas(i,jmp+j)    = xmas(i,jmp)
            dmas(i,jmp+j)    = log10(xmas(i,jmp))
            d_mdot(i,jmp+j)  = d_mdot(i,jmp)
         enddo
      enddo
c
c INDICATE THAT THERE ARE TWO ADDITIONAL POINTS.
c
      jmp = jmp + 2
c
  400 format(a80)
  401 format(1x)
  402 format(1x,i3,2x,i3)
  403 format(1x,f8.3,a2)
 4040 format(i2,1pe14.7,0p,f9.4,2f6.3,5f9.6)
 4045 format(i2,1pe14.7,0p,f9.4,2f6.3,5f9.6,f7.3)
 4050 format(i2,1pe14.7,0p,f9.4,2f6.3,5f9.6,2f7.3)
 4051 format(i2,1pe14.7,0p,f9.4,2f6.3,5f9.6,2f7.3)
  406 format(' INDEX OF TRACK: ', i3)
c    
      return
      end
c
c
c ********************************************************************
c ********************************************************************
c ********************************************************************
c
      subroutine starpara(time_in,icount)
c
c INTERPOLATES IN THE EVOLUTIONARY MODELS AND CALCULATES VARIOUS STELLAR 
c PARAMETERS FOR A SPECIFIED MASS GRID AND FOR EACH TIME STEP. THIS METHOD
c IS ONLY USED FOR NON-ISOCHRONE SYNTHESIS. IF THE ISOCHRONE SYNTHESIS 
c METHOD IS CHOSEN, STARPARA_ISO IS USED. VARIOUS INTERPOLATION SCHEMES
c ARE USED TO OBTAIN AGES, EFFECTIVE TEMPERATURES, LUMINOSITIES,
c ETC. FOR EACH MASS POINT. IT HAS BEEN VERIFIED THAT THE INTERPOLATION
c GIVES SATISFACTORY RESULTS. SUBSEQUENTLY, WE INTERPOLATE AGAIN IN THESE
c VALUES TO OBTAIN THE EFFECTIVE TEMPERATURES, LUMINOSITIES, ETC. FOR EACH
c TIME STEP. 
c
c ********************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
	character*9 str_date
        character*8 str_time
	character*10 zone
        integer*4 date_time(8)
        character*80 title_tracks
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        parameter (npgrid = 3000)
        common/mgrid/cmass,lmin,lmax,delm
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),cmass(npgrid),tt_star(npgrid)
        parameter (ntracks = 50, nptrack = 500)
	common/tracks/dm(ntracks)       ,
     *                dlm(ntracks)      ,
     *                da(ntracks,nptrack)   ,
     *                dla(ntracks,nptrack)  ,
     *                xmas(ntracks,nptrack) ,
     *                dmas(ntracks,nptrack) ,
     *                dl(ntracks,nptrack)   ,
     *                dt(ntracks,nptrack)   ,
     *                d_h(ntracks,nptrack)  ,
     *                d_he(ntracks,nptrack) ,
     *                d_c(ntracks,nptrack)  ,
     *                d_n(ntracks,nptrack)  ,
     *                d_o(ntracks,nptrack)  ,
     *                d_tstar(ntracks,nptrack) ,
     *                d_mdot(ntracks,nptrack)  ,
     *                nma               ,
     *                jmp               ,
     *                title_tracks       
        common/age/age2
        dimension age1(ntracks),age2(nptrack),alogl1(ntracks),
     *            alogl2(nptrack),alogt1(ntracks),alogt2(nptrack),
     *            amass1(ntracks),amass2(nptrack),x1(ntracks),
     *            x2(nptrack),y1(ntracks),y2(nptrack),
     *            xc121(ntracks),xc122(53),xn141(ntracks),
     *            xn142(nptrack),xo161(ntracks),xo162(nptrack),
     *            amdot1(ntracks),amdot2(nptrack),dm_rev(ntracks)
c
c AT THE FIRST TIME STEP A HEADER FOR THE OUTPUT FILE IS GENERATED.
c
      if(icount.gt.1 .or. io3.lt.0) goto 598
      write(96,596) name
596   format(' MODEL DESIGNATION: ',a20)
      call date_and_time(str_date,str_time,zone,date_time)
      write(96,597) str_date,str_time
597   format(' MODEL GENERATED ON ',a9,' AT ',a8,/)
      write(96,595)
595   format(/,'              EVOLUTIONARY TRACKS IN THE',
     *        ' HERTZSPRUNG-RUSSELL DIAGRAM')
      write(96,594)
594   format(/,'    M=120        M=100         M=80         M=60',
     *          '         M=50         M=40         M=30',  
     *          '         M=25         M=20         M=15')
598   continue
c
c INTERPOLATE IN THE EVOLUTIONARY TRACKS.
c
      do 102 l=lmin,lmax
      do 100 j=1,jmp
      mm=0
      do 101 i=nma,1,-1
      mm=mm+1
      age1(mm)=da(i,j)
      alogl1(mm)=dl(i,j)
      alogt1(mm)=10.**dt(i,j)
      amass1(mm)=xmas(i,j)
      amdot1(mm)=d_mdot(i,j)
      x1(mm)=d_h(i,j)
      y1(mm)=d_he(i,j)
      xc121(mm)=d_c(i,j)
      xn141(mm)=d_n(i,j)
      xo161(mm)=d_o(i,j)
      dm_rev(mm)=dm(i)
101   continue
c
      age2(j) =  reci_polint(cmass(l),nma,dm_rev,age1)
      if(age2(j) .le. 0.) age2(j)=1.
      alogl2(j)= reci_polint(cmass(l),nma,dm_rev,alogl1)
      alogt2(j)= alog10(yntra(cmass(l),dm_rev,alogt1,nma))
      amass2(j)= reci_polint(cmass(l),nma,dm_rev,amass1)
      amdot2(j)= reci_polint(cmass(l),nma,dm_rev,amdot1)
      x2(j)= yntra(cmass(l),dm_rev,x1,nma)
      y2(j)= yntra(cmass(l),dm_rev,y1,nma)
      xc122(j)= yntra(cmass(l),dm_rev,xc121,nma)
      xn142(j)= yntra(cmass(l),dm_rev,xn141,nma)
      xo162(j)= yntra(cmass(l),dm_rev,xo161,nma)
100   continue
c
      call agecheck(time_in,jmp)
c
      if(time_in.le.age2(1)) then
      temp(l)=alogt2(1)
      bol(l)=alogl2(1)
      zmass(l)=amass2(1)
      bmdot(l)=amdot2(1)
      xsurf(l)=x2(1)
      ysurf(l)=y2(1)
      xc12s(l)=xc122(1)
      xn14s(l)=xn142(1)
      xo16s(l)=xo162(1)
      goto 102
      endif
c
c WHEN THE STARS LEAVE THE MAIN SEQUENCE, THE PARAMETERS
c TEMP AND BOL ARE INTERPOLATED WITH A SPLINE SUBROUTINE.
c OTHERWISE, A LINEAR INTERPOLATION IS USED.
c
      if(time_in.ge.age2(13) .and. time_in.lt.age2(51)) then
c
         call intrpl(jmp,age2,alogt2,1,time_in,temp(l))
         call intrpl(jmp,age2,alogl2,1,time_in,bol(l))
      else
         temp(l)=yntra(time_in,age2,alogt2,jmp)
         bol(l)=yntra(time_in,age2,alogl2,jmp)
      endif
c
      zmass(l)=yntra(time_in,age2,amass2,jmp)
      bmdot(l)=yntra(time_in,age2,amdot2,jmp)
      xsurf(l)=yntra(time_in,age2,x2,jmp)
      ysurf(l)=yntra(time_in,age2,y2,jmp)
      xc12s(l)=yntra(time_in,age2,xc122,jmp)
      xn14s(l)=yntra(time_in,age2,xn142,jmp)
      xo16s(l)=yntra(time_in,age2,xo162,jmp)

c
102   continue
c
c WRITE THE OUTPUT. M = 120, 100, 80, 60, 50, 40, 30, 25, 20, 15
c ARE SELECTED FOR BOTH MASS GRIDS. THE ABS() IS NECESSARY IN ORDER
c TO GET RID OF THE "-" WHEN THE STARS HAVE BOL=-20. THE OUTPUT
c WOULD NOT FIT INTO 132 COLUMNS.
c
      if(io3.ge.0 .and. jmg.eq.0)
     *      write(96,200) temp(1),abs(bol(1)),temp(5),abs(bol(5)),
     *      temp(9),abs(bol(9)),temp(13),abs(bol(13)),temp(15),
     *      abs(bol(15)),temp(17),abs(bol(17)),temp(19),
     *      abs(bol(19)),temp(20),abs(bol(20)),temp(21),
     *      abs(bol(21)),temp(22),abs(bol(22))
      if(io3.ge.0 .and. jmg.eq.1)
     *      write(96,200) temp(1),abs(bol(1)),temp(21),
     *      abs(bol(21)),temp(41),abs(bol(41)),temp(61),
     *      abs(bol(61)),temp(71),abs(bol(71)),temp(81),
     *      abs(bol(81)),temp(91),abs(bol(91)),temp(96),
     *      abs(bol(96)),temp(101),abs(bol(101)),temp(106),
     *      abs(bol(106))
200   format(f6.3,f7.3,f6.3,f7.3,f6.3,f7.3,f6.3,f7.3,f6.3,f7.3,
     *       f6.3,f7.3,f6.3,f7.3,f6.3,f7.3,f6.3,f7.3,f6.3,f7.3)
c
c
c WRITE OUT UNDERLYING ISOCHRONE (IF DESIRED)
c
c Write output as in iso.f (except photometric data):
c      open  (16,file='isochrone_lmassgrid.dat',status='unknown')
c      write (16,210) log10(time_in)
c      write (16,211) title_tracks
c      write (16,211) 'title not read from file'
c      write (16,220)
c      do jj=lmin,lmax
c         write (16,110) jj,cmass(jj),temp(jj),0.,0.,0.,
c     &                  0.,0.,bol(jj),zmass(jj),
c     &                  xsurf(jj),ysurf(jj),xc12s(jj),xn14s(jj),
c     &                  xo16s(jj),temp(jj),bmdot(jj)         
c      enddo
c
c
  110 format(1x,i4,f10.4,8f9.4,f10.4,5f9.4,2f8.3)
  210 format ('#  Isochrone for log(age)=',f7.3)
  211 format ('#   Tracks used: ',a80)
  220 format ('#   n    M_init   logTeff  Mbol     Mv       U-B      B-
     &V      logg     logL     M_act     X        Y        C12      N14
     &     O16      logT*  logMdot',/,
     &        '#----1------2--------3-------4-------5--------6--------7
     &--------8--------9--------10-------11-------12-------13-------14--
     &-----15--------16------17---')  
c
c
c
      return
      end
c
c *******************************************************************
c *******************************************************************
c *******************************************************************
c
	subroutine starpara_iso(time_in,icount)
c
c THIS SUBROUTINE IS EQUIVALENT TO "STARPARA" BUT INTERPOLATING THE STELLAR
c PARAMETERS FROM ISOCHRONES. THERE ARE TWO CASES: ONE FOR A FIXED MASS GRID,
c AND THE OTHER FOR A VARIABLE MASS GRID.
c
c *****************************************************************************
c
        implicit real*4    (a-h,o-z)
        character*20 name
	character*80 str_date
        integer pos
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
	parameter (npgrid = 3000) 
        common/mgrid/cmass,lmin,lmax,delm
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *         bmdot(npgrid),cmass(npgrid),tt_star(npgrid)
	parameter (npiso = 3000)  
        common/isochrone/xminit(npiso)  ,
     *                xmact(npiso)      ,
     *                xl(npiso)         ,
     *                xt(npiso)         ,
     *                x_h(npiso)        ,
     *                x_he(npiso)       ,
     *                x_c(npiso)        ,
     *                x_n(npiso)        ,
     *                x_o(npiso)        ,
     *                x_tstar(npiso)    ,
     *                x_mdot(npiso)     ,
     *                niso              ,
     *                idiscont           
c
c AT THE FIRST TIME STEP A HEADER FOR THE OUTPUT FILE IS GENERATED.
c
      if(icount.gt.1 .or. io3.lt.0 .or. jmg.eq.3) goto 598   
      write(96,196) name
196   format(' MODEL DESIGNATION: ',a20)
         call fdate(str_date)
      write(96,597) str_date
597   format(' MODEL GENERATED: ', a24)  
      write(96,595)
595   format(/,'              EVOLUTIONARY TRACKS IN THE',
     *        ' HERTZSPRUNG-RUSSELL DIAGRAM')
      write(96,594)
594   format(/,'    M=120        M=100         M=80         M=60',
     *          '         M=50         M=40         M=30',  
     *          '         M=25         M=20         M=15')
598   continue
c
c TWO DIFFERENT WAYS ARE USED COMPUTE STELLAR PARAMETERS:
c 1) JMG=2: THIS ROUTINE IS CALLED USING A FIXED MASS GRID (LARGE). 
c    THE STELLAR PARAMETERS ARE DERIVED BY USING THE FULL ISOCHRONE
c    (WITH A CALL TO GET_ISO) WHICH IS THEN REBINNED TO THE
c    COARSER FIXED MASS GRID.
c 2) JMG=3: IN THIS CASE THE FULL MASS GRID FROM THE ISOCHRONE
c    ROUTINE IS USED. THIS GRID IS NOT FIXED IN MASS.
c
      if (jmg.eq.2) then
        call get_iso(time_in,doma,upma,jmg,sncut,icount)
c
c REBIN THE DATA FROM THE FINER GRID TO THE INTERNAL CMASS GRID.
c
         nused = lmax - lmin + 1
         call linterp(xminit,xt,niso,cmass(lmin),temp(lmin),nused)
         call linterp(xminit,xl,niso,cmass(lmin),bol(lmin),nused)
         call linterp(xminit,xmact,niso,cmass(lmin),zmass(lmin),nused)
         call linterp(xminit,x_mdot,niso,cmass(lmin),bmdot(lmin),nused)
         call linterp(xminit,x_h,niso,cmass(lmin),xsurf(lmin),nused)
         call linterp(xminit,x_he,niso,cmass(lmin),ysurf(lmin),nused)
         call linterp(xminit,x_c,niso,cmass(lmin),xc12s(lmin),nused)
         call linterp(xminit,x_n,niso,cmass(lmin),xn14s(lmin),nused)
         call linterp(xminit,x_o,niso,cmass(lmin),xo16s(lmin),nused)

c
      else if (jmg.eq.3) then
         call get_iso(time_in,doma,upma,jmg,sncut,icount)
c
c DETERMINE INDEX CORRESPONDING TO LOWER MASS CUT-OFF.
c
         lmin = pos(doma,xminit,niso)
         if (doma.ne.xminit(lmin)) then
            lmin = lmin + 1
         endif
c
c DETERMINE UPPER INDEX AND CHECK COMPATIBILITY WITH UPPER MASS CUT-OFF.
c
         lmax = niso - lmin + 1
         imax = pos(upma,xminit,niso)
         if (imax.eq.niso-1) then 
            if (upma.ge.xminit(niso)) then
               lmax = niso
            endif
         else
            lmax = imax
         endif
         if (lmax.gt.npgrid) then
            call errpri('STARPARA_ISO: ADJUST NPGRID !')
         endif

c            
c COPY VALUES FROM ISOCHRONE WITH VARIABLE MASS GRID INTO VARIABLES USED IN 
c OTHER SUBROUTINES.
c
         do i=lmin,lmax
            cmass(i) = xminit(i)  
            temp(i)  = xt(i)   
            tt_star(i)= x_tstar(i)         
            bol(i)   = xl(i)
            zmass(i) = xmact(i)
            bmdot(i) = x_mdot(i)
            xsurf(i) = x_h(i)
            ysurf(i) = x_he(i)
            xc12s(i) = x_c(i)
            xn14s(i) = x_n(i)
            xo16s(i) = x_o(i)
         enddo
      endif
c
c WRITE THE OUTPUT. M = 120, 100, 80, 60, 50, 40, 30, 25, 20, 15
c ARE SELECTED. THE ABS() IS NECESSARY IN ORDER TO GET RID OF THE "-" WHEN 
c THE STARS HAVE BOL=-20. THE OUTPUT WOULD NOT FIT INTO 132 COLUMNS.
c
      if(io3.ge.0 .and. jmg.eq.2) 
     *      write(96,200) temp(1),abs(bol(1)),temp(21),
     *      abs(bol(21)),temp(41),abs(bol(41)),temp(61),
     *      abs(bol(61)),temp(71),abs(bol(71)),temp(81),
     *      abs(bol(81)),temp(91),abs(bol(91)),temp(96),
     *      abs(bol(96)),temp(101),abs(bol(101)),temp(106),
     *      abs(bol(106))
200   format(f6.3,f7.3,f6.3,f7.3,f6.3,f7.3,f6.3,f7.3,f6.3,f7.3,
     *       f6.3,f7.3,f6.3,f7.3,f6.3,f7.3,f6.3,f7.3,f6.3,f7.3)
c
c
c WRITE OUT UNDERLYING ISOCHRONE (IF DESIRED)
c    
c Write output as in iso.f (except photometric data):
c      open  (17,file='isochrone_starpara.dat',status='unknown')
c      write (17,210) log10(time_in)
c      write (17,211) title_tracks
c      write (17,211) 'title not read from file'
c      write (17,220)
c      do jj=lmin,lmax
c         write (17,110) jj,cmass(jj),temp(jj),0.,0.,0.,
c     &                  0.,0.,bol(jj),zmass(jj),
c     &                  xsurf(jj),ysurf(jj),xc12s(jj),xn14s(jj),
c     &                  xo16s(jj),temp(jj),bmdot(jj)         
c      enddo
c
c
c  110 format(1x,i4,f10.4,8f9.4,f10.4,5f9.4,2f8.3)      
c  210 format ('#  Isochrone for log(age)=',f7.3)
c  211 format ('#   Tracks used: ',a80)
c  220 format ('#   n    M_init   logTeff  Mbol     Mv       U-B      B-
c     &V      logg     logL     M_act     X        Y        C12      N14
c     &     O16      logT*  logMdot',/,
c     &        '#----1------2--------3-------4-------5--------6--------7
c     &--------8--------9--------10-------11-------12-------13-------14--
c     &-----15--------16------17---')  
c
c
c
      return
      end
c
c ****************************************************************************
c ****************************************************************************
c ****************************************************************************
c

      subroutine get_iso(age_in,xmlow,xmup,jmg,sncut,icount)
c
c THIS SUBROUTINE DETERMINES AN ISOCHRONE FOR A GIVEN AGE. THE ISOCHRONE IS
c DETERMINED FOR A MASS RANGE RESULTING FROM THE INTERSECTION OF THE TOTAL
c AVAILABLE RANGE AND THE RANGE GIVEN BY [XMLOW,XMUP] TO SAVE COMPUTING TIME.
c IT IS BASED ON A PROGRAM ORIGINALLY WRITTEN BY GEORGES MEYNET.
c
c ****************************************************************************
c
	implicit real*4    (a-h,o-z)
	integer pos
        character*80    title_tracks
        parameter (ntracks = 50, nptrack = 500)
	common/tracks/dm(ntracks)       ,
     *                dlm(ntracks)      ,
     *                da(ntracks,nptrack)   ,
     *                dla(ntracks,nptrack)  ,
     *                xmas(ntracks,nptrack) ,
     *                dmas(ntracks,nptrack) ,
     *                dl(ntracks,nptrack)   ,
     *                dt(ntracks,nptrack)   ,
     *                d_h(ntracks,nptrack)  ,
     *                d_he(ntracks,nptrack) ,
     *                d_c(ntracks,nptrack)  ,
     *                d_n(ntracks,nptrack)  ,
     *                d_o(ntracks,nptrack)  ,
     *                d_tstar(ntracks,nptrack) ,
     *                d_mdot(ntracks,nptrack)  ,
     *                nma               ,
     *                jmp               ,
     *                title_tracks       
	parameter (npiso = 3000)  
        common/isochrone/xminit(npiso)  ,
     *                xmact(npiso)      ,
     *                xl(npiso)         ,
     *                xt(npiso)         ,
     *                x_h(npiso)        ,
     *                x_he(npiso)       ,
     *                x_c(npiso)        ,
     *                x_n(npiso)        ,
     *                x_o(npiso)        ,
     *                x_tstar(npiso)    ,
     *                x_mdot(npiso)     ,
     *                niso              ,
     *                idiscont           
	dimension yl(2),yt(2),ym(2),y_h(2),y_he(2),y_c(2),
     *          y_n(2),y_o(2),y_ts(2),y_md(2)
        dimension va(nptrack)
        logical lpartop
        save deumaspre1,deumasNMpre1
c
c INITIALIZE TOLERANCES FOR MASS STEP
c
	aglog = log10(age_in)
        agt   = 0.010
        xmint = 0.003
        agl   = 0.050
        xminl = 0.005
        delm_max = 1.0d0
        delm_min = 9.0d-5
        delm_sn = 9.0d-6
c
c CHOICE OF THE APPROPRIATE MASS RANGE.
c
      if (jmg.eq.2) then
         premas = dm(nma)*1.d0
         deumas = dm(1)*1.d0
      else
         premas = max(dm(nma)*1.d0,xmlow*1.d0) 
         deumas = min(dm(1)*1.d0,xmup*1.d0)   
      endif
c     
c CALCULATION OF THE ISOCHRONE.
c
      idone = 0
      idoneNM = 0
      nonmono  = 0
      idiscont = 0
      i=1
      deltam=0.d+0
      xm2w=premas
      if (niso .ge. 1) xminit(niso)=xm2w
      niso=1
      deumas1=deumas
      if(icount.eq.1) then
         deumaspre1=deumas1
         deumasNM1=deumas1+2.
         deumasNMpre1=deumasNM1
      endif
c
c MAKE SURE WE DO NOT LOSE ANY STAR!   
c
      do while (xminit(niso).le.deumas)
         xminit(i)=xm2w
         m=pos(xm2w,dm,nma)
	  do k=1,jmp
            lpartop=.false.
            va(k)=YPARINTERP(log10(xm2w),dlm,dla,nma,
     $           ntracks,lpartop,k,nptrack)
            if(k.gt.1) then
               if(va(k).lt.va(k-1))then
                  va(k)=10.d0**va(k-1)
                  va(k)=log10(va(k)+1.d-1)
               endif
            endif
            if (va(1).ge.aglog) then
               yt(1)=dt(m,1)
               yt(2)=dt(m+1,1)
               yl(1)=dl(m,1)
               yl(2)=dl(m+1,1)
               ym(1)=dmas(m,1)
               ym(2)=dmas(m+1,1)
               y_h(1)=d_h(m,1)
               y_h(2)=d_h(m+1,1)
               y_he(1)=d_he(m,1)
               y_he(2)=d_he(m+1,1)
               y_c(1)=d_c(m,1)
               y_c(2)=d_c(m+1,1)
               y_n(1)=d_n(m,1)
               y_n(2)=d_n(m+1,1)
               y_o(1)=d_o(m,1)
               y_o(2)=d_o(m+1,1)
               y_ts(1)=d_tstar(m,1)
               y_ts(2)=d_tstar(m+1,1)
               y_md(1)=d_mdot(m,1)
               y_md(2)=d_mdot(m+1,1)
c              POINTS 1 AND 2 WILL BE USED FOR INTERPOLATION
               goto 18
            else
                if (k.gt.jmp-2) then
                  if (aglog.ge.va(jmp-2)) then
                     diff=0.d0
c                    SELECT POINTS JMP AND JMP-1 FOR INTERPOLATION
		     k_select=jmp
                     goto 15
                  elseif (aglog.gt.va(jmp)) then
c
		     if (nonmono.eq.0) then
                        print *,'WARNING: NON-MONOTONIC LIFETIME FROM '
     *                         ,xm2w,' MSUN !'
                        print *,'ERROR IN GET_ISO: SEE WARNING ABOVE !'
		        nonmono  = 1	
			idiscont = i -1 
			xminit(i) = xminit(i-1)
			xt(i)     = xt(i-1) 
			xl(i)     = xl(i-1)
			xmact(i)  = xmact(i-1)
			x_h(i)    = x_h(i-1)
			x_he(i)   = x_he(i-1)
			x_c(i)    = x_c(i-1)
			x_n(i)    = x_n(i-1)
			x_o(i)    = x_o(i-1)
			x_tstar(i) = x_tstar(i-1)
			x_mdot(i)  = x_mdot(i-1)
                        i = i + 1
                     endif
                     goto 40
                  endif
               endif
               if (aglog.lt.va(k)) then
                  vak=10.d0**va(k)
                  vakm1=10.d0**va(k-1)
                  diff=(age_in*1.d0-vakm1)/(vak-vakm1)
c                 SELECT POINTS K AND K-1 FOR INTERPOLATION
                  k_select=k
                  goto 15
                endif
            endif
          enddo
c
15    continue
        k = k_select
c      
          do l=1,2
              ll=m+l-1 		
              ym(l)=xmas(ll,k-1)+((xmas(ll,k)-xmas(ll,k-1))*diff)
              ym(l)=log10(ym(l))
              yt(l)=dt(ll,k-1)+((dt(ll,k)-dt(ll,k-1))*diff)
              yl(l)=dl(ll,k-1)+((dl(ll,k)-dl(ll,k-1))*diff)
              y_h(l)=d_h(ll,k-1)+((d_h(ll,k)-d_h(ll,k-1))*diff)
              y_he(l)=d_he(ll,k-1)+((d_he(ll,k)-d_he(ll,k-1))*diff)
              y_c(l)=d_c(ll,k-1)+((d_c(ll,k)-d_c(ll,k-1))*diff)
              y_n(l)=d_n(ll,k-1)+((d_n(ll,k)-d_n(ll,k-1))*diff)
              y_o(l)=d_o(ll,k-1)+((d_o(ll,k)-d_o(ll,k-1))*diff)
              y_ts(l)=d_tstar(ll,k-1) +
     *                ((d_tstar(ll,k)-d_tstar(ll,k-1))*diff)
              y_md(l)=d_mdot(ll,k-1)  +
     *                ((d_mdot(ll,k) -d_mdot(ll,k-1)) *diff)
          enddo
c
c WE DERIVE ALL DESIRED QUANTITIES FOR THE ISOCHRONE POINT.
c
18        ff       = (log10(xm2w)-dlm(m))/(dlm(m+1)-dlm(m))
          xl(i)    = yl(1)+ (yl(2)-yl(1))*ff
          if (xl(i).lt.-3.) then
            xl(i)  = -20.
          endif
          xt(i)    = yt(1)+ (yt(2)-yt(1))*ff
          xmlog    = ym(1)+ (ym(2)-ym(1))*ff
          xmact(i) = 10.**xmlog
          x_h(i)    = y_h(1)+ (y_h(2)-y_h(1))*ff
          x_he(i)   = y_he(1)+ (y_he(2)-y_he(1))*ff
          x_c(i)    = y_c(1)+ (y_c(2)-y_c(1))*ff
          x_n(i)    = y_n(1)+ (y_n(2)-y_n(1))*ff
          x_o(i)    = y_o(1)+ (y_o(2)-y_o(1))*ff
          x_tstar(i) = y_ts(1)+ (y_ts(2)-y_ts(1))*ff
          x_mdot(i)  = y_md(1)+ (y_md(2)-y_md(1))*ff
c
c NOW PREPARE THE STEP IN MASS.
c
          niso = i
          if (i.eq.1) then
            deltam=(dm(m)*1.d0-dm(m+1)*1.d0)/10.d+0
            i = i+1
          elseif (nonmono.eq.1) then 
            i = i+1         
            xminit(i) = xminit(i-1)
            xt(i)     = xt(i-1) 
            xl(i)     = xl(i-1)
            xmact(i)  = xmact(i-1)
            x_h(i)    = x_h(i-1)
            x_he(i)   = x_he(i-1)
            x_c(i)    = x_c(i-1)
            x_n(i)    = x_n(i-1)
            x_o(i)    = x_o(i-1)
            x_tstar(i) = x_tstar(i-1)
            x_mdot(i)  = x_mdot(i-1)
            i = i+1         
            nonmono = 0 
            print *,'NON-MONOTONIC LIFETIME ENDS AT',xm2w, ' MSUN'
          else
              if(i.gt.1) then
                 if(xl(i-1).gt.-5..and.xl(i).lt.-5.
     *                .and.xminit(i).gt.sncut-1.)then
                    if(xminit(i)-xminit(i-1).gt.delm_min) then
                       xm2w=xm2w-deltam
                       deltam=deltam/1.2d+0
                       goto 40
                    endif
                    deumas1=xm2w
                 endif
                 if(xl(i-1).lt.-5..and.xl(i).gt.-5.
     *                .and.xminit(i).gt.sncut-1.)then
                    if(xminit(i)-xminit(i-1).gt.delm_min) then
                       xm2w=xm2w-deltam
                       deltam=deltam/1.2d+0
                       goto 40
                    endif
                    deumasNM1=xm2w
                 endif
              endif
             
              if(xm2w.gt.deumas1.and.xm2w.le.deumaspre1
     *            .and.deumaspre1.gt.sncut.and.
     *             deumas1.lt.deumaspre1) then
                deltam=(deumaspre1-deumas1)/10.0
                if(deltam.gt.delm_max)deltam=delm_max
                if(deltam.lt.delm_sn)deltam=delm_sn
                if(xm2w.lt.deumaspre1
     *               .and.xm2w+deltam.gt.deumaspre1.and.
     *               idone.eq.0) then
                   deltam=deumaspre1-xm2w
                   idone=1
                endif
                i=i+1
                goto 40
              else
                if(xm2w.gt.deumaspre1.and.xm2w.le.deumasNM1) then
                   if(xm2w.lt.deumasNMpre1) then
                      xl(i)=-50.
                      deltam=delm_max
                      i=i+1
                      goto 40
                   else
                      deltam=(deumasNM1-deumasNMpre1)/10.0
                      if(deltam.gt.delm_max)deltam=delm_max
                      if(deltam.lt.delm_sn)deltam=delm_sn
                      if(xm2w.lt.deumasNM1
     *                     .and.xm2w+deltam.gt.deumasNM1.and.
     *                     idoneNM.eq.0.and.xm2w.gt.sncut-1.) then
                         deltam=deumasNM1-xm2w
                         idoneNM=1
                      endif
                      i=i+1
                      goto 40
                   endif
                endif
              endif
c
              distl = abs(xl(i)-xl(i-1))
              distt = abs(xt(i)-xt(i-1))
              if ((distl.gt.agl.or.distt.gt.agt).or.
     *            (deltam.gt.delm_max)) then
                if (deltam.lt.delm_min) then
                  if(xl(i-1).gt.-5..and.xl(i).lt.-5.
     *                 .and.xminit(i-1).gt.sncut-1.
     *                 .or.xm2w.gt.deumaspre1) then
                     if(deltam.lt.delm_sn) then
                        i = i + 1
                        deltam=delm_sn
                     else
                        xm2w=xm2w-deltam
                        deltam=deltam/1.2d+0
                     endif
                  else
                     i=i+1
                     deltam=delm_min
                  endif
                else
c 
c DELTAM IS DIVIDED BY 6 FOR BETTER MASS RESOLUTION.
c
                  xm2w=xm2w-deltam
                  deltam=deltam/6.0d+0
                endif
              elseif (distl.lt.xminl.and.distt.lt.xmint) then
                 i = i + 1
                 if ((xm2w+10.d0*deltam).lt.deumas) then
                   deltam=10.d0*deltam
                   if(deltam.gt.delm_max) deltam=delm_max
                 endif
              else
                 i = i+1
c            calculate exactly up to upper mass 
                 if (xm2w+deltam.gt.deumas.and.xm2w.lt.deumas.and.
     *                idone.eq.0) then
                   deltam = deumas - xm2w
                   idone = 1    ! this step must be done only once - signal
                 endif
              endif
          endif
   40     continue	
          if(xm2w.ge.deumas) idone = idone+1
          if (deltam.lt.0.d0) deltam=delm_min
	  xm2w = xm2w + deltam
c
          if (deltam.lt.0.d0) call errpri('GET_ISO: DELTAM.LT.0')
          if (i.gt.npiso)  call errpri('GET_ISO: I.GT.NPISO')
      enddo	
c
      niso=niso-1
      deumaspre1=deumas1
      deumasNMpre1=deumasNM1

c
c WRITE OUT UNDERLYING ISOCHRONE (IF DESIRED)
c
c      if (jmg.ne.13) goto 100
c      title_tracks = 'title not read from file'
c Write output as in iso.f (except photometric data):
c      open  (15,file='isochrone.dat',status='unknown')
c      aglogdum=SNGL(aglog)
c      aglogdum=aglog
c      write (15,210) aglogdum 
c      write (15,211) title_tracks
c      write (15,220)
c      do jj=1,niso
c        xr = (log10(3.8268D+33) + xl(jj) - log10(7.124654D-4)
c     &        - 4.d+0 * xt(jj))/2.d+0
c        xg = log10(6.6732D-08)+log10(1.9892D+33) 
c     &        + log10(xmact(jj)) - 2.d+0*xr
c        if (jj.eq.idiscont.or.jj.eq.(idiscont+1)) then
c            write (15,110) jj,xminit(jj),xt(jj),0.,0.,0.,
c     &                     0.,xg,xl(jj),xmact(jj),
c     &                     x_h(jj),x_he(jj),x_c(jj),x_n(jj),x_o(jj),
c     &                     x_tstar(jj),x_mdot(jj)         
c         endif
c         write (15,110) jj,xminit(jj),xt(jj),0.,0.,0.,
c     &                  0.,xg,xl(jj),xmact(jj),
c     &                  x_h(jj),x_he(jj),x_c(jj),x_n(jj),x_o(jj),
c     &                  x_tstar(jj),x_mdot(jj)         
c      enddo
c
c  110 format(1x,i4,f10.4,8f9.4,f10.4,5f9.4,2f7.3)      
c  110 format(1x,i4,f10.4,8f9.4,f10.4,5f9.4,2f8.3)      
c  210 format ('#  Isochrone for log(age)=',f7.3)
c  211 format ('#   Tracks used: ',a80)
c  220 format ('#   n    M_init   logTeff  Mbol     Mv       U-B      B-
c     &V      logg     logL     M_act     X        Y        C12      N14
c     &     O16      logT*  logMdot',/,
c     &        '#----1------2--------3-------4-------5--------6--------7
c     &--------8--------9--------10-------11-------12-------13-------14--
c     &-----15--------16------17---')  

 100  continue
c
c
	return
        end
c
c ****************************************************************************
c ****************************************************************************
c ****************************************************************************
c
      subroutine agecheck(time,jmp)
c
c THIS SUBROUTINE CHECKS IF THE ARRAY AGE2 IS IN STRICTLY MONOTONIC
c ORDER. THIS MAY NOT BE THE CASE FOR ALL TIME POINTS SO THAT
c THEY HAVE TO BE SLIGHTLY ADJUSTED. OTHERWISE THE INTERPOLATION ROUTINE
c MAY CRASH.
c 
c *******************************************************************
c
	implicit real*4    (a-h,o-z)      
        common/age/age2
	parameter(nptrack=500)
        dimension age2(nptrack)
c
      do 10 i=jmp,2,-1
      if(age2(i-1)/age2(i).ge.1.0) age2(i-1)=age2(i)/1.000001
10    continue
c
      return
      end
c
c *********************************************************************
c *********************************************************************
c *********************************************************************
c
      subroutine temp_adjust(iwrt,iatmos)
c
c THIS SUBROUTINE ADJUSTS THE WR CORE TEMPERATURES OF THE EVOLUTIONARY
c TRACKS. THIS IS REQUIRED FOR CONSISTENCY WITH THE WR ATMOSPHERES.
c
c **********************************************************************
c
	implicit real*4    (a-h,o-z)      
        common/mgrid/cmass,lmin,lmax,delm
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        parameter (npgrid = 3000) 
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),cmass(npgrid),tt_star(npgrid)
c
c NOTE: THIS FACTOR MARKS THE BIAS BETWEEN THE TWO WR TEMPERATURES
c A FACTOR OF 0.5 GIVES AN EQUAL BIAS, WHILE 0.7 GIVES A 70% BIAS
c TOWARDS THE HOTTER CORE TEMP.
c
      factor = 0.6
c
c SMITH, NORRIS & CROWTHER USE A VALUE OF 0.6

      do 10 l=lmin,lmax
        if(xn14s(l).eq.0.) xn14s(l)=1.e-6
        cnr=xc12s(l)/xn14s(l)
        coher=((xc12s(l)/12.)+(xo16s(l)/16.))/(ysurf(l)/4.)
        if(xsurf(l).lt.0.1 .and. iwrt.gt.0 .and.
     *     iatmos.ge.4) then
          t1=10.0**(temp(l))
          t2=10.0**(tt_star(l))
          temp(l)=t2+(factor-1.0)*(t2-t1)
          temp(l)=log10(temp(l))
        else
	  continue
        endif        
       
 10   continue
      return
      end
c
c *********************************************************************
c *********************************************************************
c *********************************************************************
c
      subroutine supernova(time_in,icount)
c
c CALCULATION OF THE SUPERNOVA RATE. EVERY STAR WHICH DISAPPEARS FROM THE
c EVOLUTIONARY TRACKS IS ASSUMED TO EXPLODE AS A SUPERNOVA. SUPERNOVAE FROM
c WR STARS ARE CALLED TYPE IB. UNITS ARE LOG(EVENTS/YEAR). SIMULTANEOUSLY,
c THE KINETIC POWER ASSOCIATED WITH ALL EXPLOSIONS DURING A TIME STEP
c IS COMPUTED. UNITS: ERG/SEC. A  GENERIC VALUE OF 1 X 10**51 ERG IS 
c ASSIGNED TO EACH EVENT (SEE MCKEE IN ASP CONF. SER. VOL.12). THE KINETIC
c POWER IS INTEGRATED OVER TIME TO OBTAIN THE TOTAL ENERGY INJECTED IN
c THE ISM (ERG). WE ALSO COMPUTE THE CRITICAL STELLAR MASS CRITMA
c ABOVE WHICH ALL STARS HAVE ALREADY EXPLODED AS SUPERNOVAE, AS WELL AS
c THE TYPICAL MASS OF A PROGENITOR.
c
c DEBUGGED BY RALPH SUTHERLAND.
c
c ********************************************************************
c
	implicit real*4   (a-h,o-z)      
	  integer pos 
	  character*20 name
 	  character*80 str_date
        parameter (yearseconds = 3.15576e7)
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        common/stars/dens,tonum
        common/windpower_r/wpow,wpow1,wpow2,wpow3,wpow4,
     *                     wmom,wmom1,wmom2,wmom3,wmom4,wen       
        parameter (npgrid = 3000) 
     	common/supernova_r/critma,critma_new,critup,critup_new,
     *                  	siben,siien
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),cmass(npgrid),sn(npgrid),dens(npgrid),
     *          pow(npgrid),snr_temp(npgrid),cm_temp(npgrid),
     *         tt_star(npgrid)
c
c AT THE FIRST TIME STEP A HEADER FOR THE OUTPUT FILE IS GENERATED.
c
      if(icount.gt.1) goto 98
      write(97,196) name
196   format(' MODEL DESIGNATION: ',a20)
         call fdate(str_date)
      write(97,597) str_date
597   format(' MODEL GENERATED: ', a24)
      write(97,195)
195   format(/,'              RESULTS FOR THE',
     *        ' SUPERNOVA RATE')
      write(97,193)
193   format(/,'                     ALL SUPERNOVAE         '
     *        ,'      TYPE IB SUPERNOVAE            '
     *        ,'   ALL SUPERNOVAE           STARS + SUPERNOVAE')
      write(97,194)
194   format('    TIME       TOTAL RATE  POWER   ENERGY    '
     *        ,'TOTAL RATE  POWER   ENERGY   '
     *        ,'TYPICAL MASS   LOWEST PROG. MASS    POWER   ENERGY')
c

c      write(970,960)
c960   format('<SNRate>')
c      write(970,961) name
c961    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c         call fdate(str_date)
c      write(970,5971) str_date
c5971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')    
c      write(970,951)
c951    format('  <Title>SUPERNOVA RATE</Title>')
c      write(970,941)
c941    format('  <Columns>TRate/TPower/TEnerg/'
c     *      ,'IbRate/IbPow/IbEner/TypMas/MinMas/'
c     *      ,'AllPow/AllEne</Columns>')
c          
c
98    continue
c
      if (icount .eq. 1 ) then
           deltat = time_in
      else
           deltat = tstep
      endif
c
c ALL SUPERNOVA ACCUMULATORS ARE RESET AT THE FIRST (1ST) TIME STEP.
c
      snr    = 0.
      sner   = 0.
      wrsnr  = 0.
      siipow = 0.
      sibpow = 0.

      if(icount.eq.1) then
        siien = 0.
        siben = 0.
      endif
c
c OTHER INITIALIZATIONS
      isnr = 0
c
c CALCULATION OF THE SUPERNOVA RATE PER YEAR AND THE KINETIC ENERGY
c
      if(jmg.eq.3) then
	 lstart = lmax
	 lend   = lmin
	 lstep  = -1
      else
	 lstart = lmin
	 lend   = lmax
	 lstep  = 1
      endif
c
c LOOP OVER ALL MASSES: MUST BE FROM HIGH TO LOW MASSES. SKIP CASES
c WHICH ARE NOT SNE (GOTO 121).
c
      do l=lstart,lend,lstep
	 if (bol(l).gt.-10.or.cmass(l).gt.bhcut) goto 121
c SIGNAL FOR NON_MONOTONIC LIFE TIME
         if (cmass(l).lt.sncut) then
            if (isf.le.0) critma_new = cmass(l)
            goto 121
         endif
c
c DETERMINES SN TYPE: IB (iflag=1) OR II (iflag=0)
c
	 iflag=0
	 if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr)
     *      iflag=1
c
c POSSIBLE SUPERNOVA EVENT RATE
c
        sner = dens(l)/deltat
c
c
c UPDATE VALUES OF critup_new AND critma_new FOR INSTANTANEOUS BURSTS.
c IF WE ARE IN A MASS INTERVAL ALREADY COUNTED IN THE PREVIOUS TIME STEP,
c DO NOT COUNT THE SN AGAIN. THEREFORE sn(l) AND pow(l) ARE SET TO ZERO. 
c 
	 if (isf.le.0) then
            if (critup_new.lt.0.) then
               critup_new=cmass(l)  
            else 
               if (cmass(l).ge.critup_new) then
                  if (critma.gt.sncut.and.l.ne.lstart) then
                     ! regular case
                     critup_new = cmass(l)
                  else 
                     ! no SN are alive anymore. Do not allow to update
                     ! upper limit...
                     critup_new = 1.e+36
                     critup = critup_new
                  endif
               endif
            endif
c
	       if (cmass(l).ge.critma.and.cmass(l).le.critup) then
	           sner  = 0.d0
	       else
               critma_new = cmass(l)
            endif
	 endif
c
         if (isf.gt.0.and.cmass(l).lt.critma) then
            critma_new = cmass(l) 
         endif
c
c GET SN RATE, POWER AND ENERGY FROM ACTUAL sner
c
         sn(l) = sner
         pow(l)= sn(l)/yearseconds
         energ = sn(l)*deltat
c
	 snr = snr + sn(l)
	 siipow = siipow + pow(l)
	 siien  = siien  + energ
	 if(iflag.eq.1) wrsnr = wrsnr + sn(l)
	 if(iflag.eq.1) sibpow= sibpow+ pow(l)
	 if(iflag.eq.1) siben = siben + energ
c
c PREPARE FOR THE DETERMINATION OF THE TYPICAL SN MASS.
c
         if (sn(l).ne.0.) then
            isnr = isnr + 1
            snr_temp(isnr) = snr   ! store cumulative SNR 
            cm_temp(isnr) = cmass(l)
         endif
c     
121	 continue
      enddo

122   continue
      critma = critma_new   
      critup = critup_new   
c
      sn1  =alog10(snr  +1.e-30)
      sn2  =alog10(wrsnr+1.e-30)
      sn3  =alog10(siipow+1.e-30) + 51.00
      sn4  =alog10(sibpow+1.e-30) + 51.00
      sn5  =alog10(siien +1.e-30) + 51.00
      sn6  =alog10(siben +1.e-30) + 51.00
      sn7  =alog10(siipow+1.e-30+wpow*1.e-16) +51.00
      sn8  =alog10(siien+1.e-30+wen*1.e-16)   +51.00
      if(sn3 .le.21.) sn3=-30.
      if(sn4 .le.21.) sn4=-30.
      if(sn5 .le.21.) sn5=-30.
      if(sn6 .le.21.) sn6=-30.
      if(sn7 .le.21. .or. io4.lt.0) sn7=-30.
      if(sn8 .le.21. .or. io4.lt.0) sn8=-30.
c
c COMPUTE THE TYPICAL PROGENITOR MASS OF A SUPERNOVA. snr_temp MUST
c BE MONOTONIC.
c
      if (snr.ne.0.) then
         itemp = pos(snr/2.,snr_temp,isnr)
         if (isnr.eq.1) then
            typma = cm_temp(isnr)
        else
            typma = cm_temp(itemp)
         endif
      else
         typma = 0.
      endif
c
      critma_out = critma
      if (critma_out.gt.upma)  critma_out=0.
      if (critma_out.lt.sncut) critma_out=0.
       write(97,90) time_in, 
     *	      sn1,sn3,sn5,sn2,sn4,sn6,typma,critma_out,sn7,sn8
90     format(1x,e11.3,2x,3f9.3,3x,3f9.3,3x,
     *         f8.1,8x,f8.1,8x,3f9.3)
c
c      	   write(970,600)
c600 	   format('  <datarow>')
c	   write(970,601) time_in
c601	   format('    <Time>',e10.5,'</Time>')
c	   write(970,603) sn1
c603	   format('    <TRate>',f9.3,'</TRate>')
c	   write(970,604) sn3
c604	   format('    <TPower>',f9.3,'</TPower>')
c	   write(970,605) sn5
c605	   format('    <TEnerg>',f9.3,'</TEnerg>')
c      	   write(970,613) sn2
c613	   format('    <IbRate>',f9.3,'</IbRate>')
c	   write(970,614) sn4
c614	   format('    <IbPow>',f9.3,'</IbPow>')
c	   write(970,615) sn6
c615	   format('    <IbEner>',f9.3,'</IbEner>')
c	   write(970,624) typma
c624	   format('    <TypMas>',f8.1,'</TypMas>')
c	   write(970,625) critma_out
c625	   format('    <MinMas>',f8.1,'</MinMas>')
c	   write(970,623) sn7
c623	   format('    <AllPow>',f9.3,'</AllPow>')
c	   write(970,634) sn8
c634	   format('    <AllEne>',f9.3,'</AllEne>')
c      	   write(970,606)
c606 	   format('  </datarow>')     
c
      return
      end
c
c *********************************************************************
c *********************************************************************
c *********************************************************************
c
      subroutine spectype(time_in,icount)
c
c THIS SUBROUTINE ASSIGNS SPECTRAL TYPES TO EACH POSITION IN THE HRD. THE
c SPECTRAL TYPE CALIBRATION IS FROM SCHMIDT-KALER. THE NEAREST NEIGHBOR
c SEARCH IS DONE LINEARLY IN TEFF AND LOGARITHMICALLY IN LBOL IN ORDER TO
c GIVE HIGHER WEIGHT TO TEFF. WR STARS ARE DEFINED AS OBJECTS WITH HYDROGEN
c CONTENT LESS THAN 0.4 AND LOG TEFF > 4.4 AND M_INITIAL >= M_WR, WHERE 
C M_WR=MASS LIMIT FOR WR FORMATION.
c
c *********************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
	character*80 str_date
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
        common/stars/dens,tonum
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        parameter (npgrid = 3000)
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *         bmdot(npgrid),cmass(npgrid),dens(npgrid),tt_star(npgrid)
        dimension anumb(445),wrnumb(5)
        common/spectype_r/allspe,allwr,allwn,allwc,allo,anumb,wrnumb
c
c AT THE FIRST TIME STEP A HEADER FOR THE OUTPUT FILE IS GENERATED.
c
      if(icount.gt.1) goto 98
      write(94,196) name
196   format(' MODEL DESIGNATION: ',a20)
         call fdate(str_date)
      write(94,497) str_date
497   format(' MODEL GENERATED: ', a24)
      write(94,95)
95    format(/,'              RESULTS FOR THE',
     *        ' SPECTRAL TYPE CALIBRATION -- 1')
      write(94,94)
94    format(/,'   TIME         ALL SP         O          WR',
     *     '          WN          WC          WR/O       WC/WN  ')
c     
c      write(940,960)
c960   format('<SP>')
c      write(940,961) name
c961    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c         call fdate(str_date)
c      write(940,5971) str_date
c5971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')    
c      write(940,951)
c951    format('  <Title>NUMBER OF O AND WR STARS</Title>')
c      write(940,941)
c941    format('  <Columns>ALL/OStar/WRStar/WNStar/WCStar/'
c     *             ,'WR_O/WC_WN</Columns>')
c           
      write(90,196) name
         call fdate(str_date)
      write(90,497) str_date      
      write(90,93)
93    format(/,'              RESULTS FOR THE',
     *        ' SPECTRAL TYPE CALIBRATION -- 2')
98    continue
c
c IF THERE IS NO CONTINUOUS STAR FORMATION, THE SPECTRAL TYPE ACCUMULATORS
c ARE RESET FOR EACH TIME STEP, OTHERWISE WE KEEP THEM.
c
       if(isf.gt.0 .and. icount.gt.1) then
678	      continue
	else       
              do 100 k=1,445
	      anumb(k)=0.
100           continue
	      do 102 l=1,5
	      wrnumb(l)=0.
102	      continue
        endif        
              allspe = 0.
	      allwr = 0.
	      allwn = 0.
	      allwc = 0.
	      allo = 0.
c
      do 11 l=lmin,lmax
      if(bol(l).lt.-10.) goto 11
c
c WOLF-RAYET STARS CLASSIFICATION. THIS IS BASED ON SURFACE ABUNDANCES,
c ACCORDING TO SMITH AND HUMMER (MNRAS 230,511) AND SMITH AND MAEDER (1991)
c FOR WC STARS (C+O/HE RATIO).
c FOR WN STARS, THE CLASSIFICATION IS BASED ON CONTI, LEEP
c AND PERRY (APJ 268,228). THE DISTINCTION BETWEEN WNL AND WNE IS BASED
c ON THE H/HE ABUNDANCE RATIO, AND MANY EXCEPTIONS TO THE RULE ARE KNOWN.
c IWR=1--WNL; 2--WNE; 3--WC6-9; 4--WC4-5; 5--WO
c
      if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr) then
        if(xn14s(l).eq.0) xn14s(l)=1.e-6
        cnr=xc12s(l)/xn14s(l)
        coher=((xc12s(l)/12.)+(xo16s(l)/16.))/(ysurf(l)/4.)
        if(xsurf(l).gt.0.1) then
          iwr=1
          goto 17 
        endif
        if(cnr.lt.10.) then
          iwr=2
          goto 17
        endif
        if(coher.lt.0.5) then
          iwr=3
          goto 17
        endif
        if(coher.lt.1.0) then
          iwr=4
          goto 17
        endif
        if(coher.ge.1.0) then
          iwr=5
          goto 17
        endif
17      wrnumb(iwr) = wrnumb(iwr) + dens(l)
        goto 11
      endif
c
c OBAFGKM STARS CLASSIFICATION
c
      call near(l,index)
      anumb(index)=anumb(index)+dens(l)
11    continue
c
c STARS OF ALL SPECTRAL TYPES ARE COUNTED AS A CONSISTENCY CHECK WITH TONUM.
c
      do 300 m=1,445
      allspe = allspe + anumb(m)
300   continue
c
c WOLF-RAYET STARS ARE COUNTED
c
      allwn = allwn + wrnumb(1) + wrnumb(2)
      allwc = allwc + wrnumb(3) + wrnumb(4) +wrnumb(5)
      allwr = allwn + allwc
c
c THE O STARS ARE COUNTED
c
      do 400 n=1,14
      allo = allo + anumb(n)
400   continue
      do 402 n=90,103
      allo = allo + anumb(n)
402   continue
      do 404 n=179,192
      allo = allo + anumb(n)
404   continue
      do 406 n=268,281
      allo = allo + anumb(n)
406   continue
      do 407 n=357,370
      allo = allo + anumb(n)
407   continue
c
c COMPUTATION OF THE WR/O AND WC/WN RATIOS
c
      if(allo.ne.0.) wro=allwr/allo
      if(allo.eq.0.) wro=0.
      if(allwn.eq.0.) wcwn=0.
      if(allwn.ne.0.) wcwn=allwc/allwn
c
      write(94,150)time_in,allspe,allo,allwr,allwn,allwc,wro,wcwn
150   format(1x,1pe11.3,3x,6(1pe9.3,3x),1pe9.3)
c
c      	   write(940,600)
c600 	   format('  <datarow>')
c	   write(940,601) time_in
c601	   format('    <Time>',e10.5,'</Time>')
c	   write(940,603) allspe
c603	   format('    <ALL>',e9.3,'</ALL>')
c	   write(940,604) allo
c604	   format('    <OStar>',e9.3,'</OStar>')
c	   write(940,605) allwr
c605	   format('    <WRStar>',e9.3,'</WRStar>')
c      	   write(940,613) allwn
c613	   format('    <WNStar>',e9.3,'</WNStar>')
c	   write(940,614) allwc
c614	   format('    <WCStar>',e9.3,'</WCStar>')
c	   write(940,615) wro
c615	   format('    <WR_O>',e9.3,'</WR_O>')
c	   write(940,623) wcwn
c623	   format('    <WC_WN>',e9.3,'</WC_WN>')
c      	   write(940,606)
c606 	   format('  </datarow>')     
c
      if(mod(time_in,tdel).lt.tstep) then
        write(90,161) time_in
161     format(/,' TIME = ',1pe11.3)
        write(90,162) 
162     format(/,' LUMINOSITY CLASS V')
        write(90,166) (anumb(i),i=1,89)
166     format(' O:',2x,8(1pe11.3,1x),/,5x,6(1pe11.3,1x),
     *         /,' B:',2x,8(1pe11.3,1x),/,5x,8(1pe11.3,1x),/,5x,
     *                 2(1pe11.3,1x),
     *         /,' A:',2x,8(1pe11.3,1x),/,5x,6(1pe11.3,1x),
     *         /,' F:',2x,8(1pe11.3,1x),
     *         /,' G:',2x,8(1pe11.3,1x),
     *         /,' K:',2x,8(1pe11.3,1x),/,5x,6(1pe11.3,1x),
     *         /,' M:',2x,8(1pe11.3,1x),/,5x,5(1pe11.3,1x))
        write(90,168) 
168     format(/,' LUMINOSITY CLASS IV')
        write(90,166) (anumb(i),i=90,178)
        write(90,170) 
170     format(/,' LUMINOSITY CLASS III')
        write(90,166) (anumb(i),i=179,267)
        write(90,172) 
172     format(/,' LUMINOSITY CLASS II')
        write(90,166) (anumb(i),i=268,356)
        write(90,174) 
174     format(/,' LUMINOSITY CLASS I')
        write(90,166) (anumb(i),i=357,445)
        write(90,178) (wrnumb(i),i=1,5)
178     format(/,' WNL:',1pe11.3,/,' WNE:',1pe11.3,/,
     *         ' WCL:',1pe11.3,/,' WCE:',1pe11.3,/,' WO :',1pe11.3)
       endif

      return
      end
c
c ****************************************************************************
c ****************************************************************************    
c ****************************************************************************
c
      subroutine near(l,index)
c
c SEARCH FOR THE NEAREST NEIGHBOR.
c SCHMIDT-KALER EXTRAPOLATED TO SP=.5 AND 5 LUMINOSITY CLASSES.
c
c ********************************************************************
c
	implicit real*4    (a-h,o-z)      
        common/mgrid/cmass,lmin,lmax,delm
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
     	common/nearinput/tip,bip
        parameter (npgrid = 3000) 
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *    bmdot(npgrid),cmass(npgrid),tip(445),bip(445),tt_star(npgrid)
c
      dimin=1.e20
c
      do 14 i=1,445
      di=(temp(l)-tip(i))**2.+(bol(l)-bip(i))**2.
      if(di.lt.dimin) then
        dimin=di
        index=i
      endif
14    continue
c
      return
      end
c
c *******************************************************************
c ********************************************************************
c ********************************************************************
c
	subroutine windpower(time_in,icount)
c
c COMPUTES THE POWER, ENERGY, AND MOMENTUM FLUX DUE TO STELLAR WINDS.
c THE WIND MODELS ARE INPUT VIA FUNCTIONS WIND1, WIND2, WIND3, WIND4. 
c
c ********************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
	character*80 str_date
       parameter (nmaxint=10,nmaxint1=11)
       common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/stars/dens,tonum
        common/mgrid/cmass,lmin,lmax,delm
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        common/windpower_r/wpow,wpow1,wpow2,wpow3,wpow4,
     *                     wmom,wmom1,wmom2,wmom3,wmom4,wen
        parameter (npgrid = 3000)
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *      bmdot(npgrid),dens(npgrid),cmass(npgrid),tt_star(npgrid)
c
c AT THE FIRST TIME STEP A HEADER FOR THE OUTPUT FILE IS GENERATED.
c
      if(icount.gt.1) goto 98
c      
 	wen=0.
c      
      write(95,196) name
196   format(' MODEL DESIGNATION: ',a20)
         call fdate(str_date)
      write(95,597) str_date
597   format(' MODEL GENERATED: ', a24)
      write(95,195)
195   format(/,'              RESULTS FOR THE',
     *        ' **STELLAR** WIND POWER AND ENERGY')
      write(95,193)
193   format(/,'                             POWER [ERG/SEC]  '
     *        ,'                ENERGY [ERG]            '
     *        ,'   MOMENTUM FLUX [DYN]      ')
      write(95,194)
194   format('    TIME           ALL      OB      RSG      LBV'
     *        ,'       WR          ALL    '
     *        ,'     ALL      OB      RSG      LBV       WR   '
     *        ,'     ')
     
c    
c      write(950,960)
c960   format('<Power>')
c      write(950,961) name
c961    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c         call fdate(str_date)
c      write(950,5971) str_date
c5971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')    
c      write(950,951)
c951    format('  <Title>STELLAR WIND POWER AND ENERGY</Title>')
c      write(950,941)
c941    format('  <Columns>TPow/OBPow/RSGPow/LBVPow/'
c     *      ,'WRPow/TEne/TMom/OBMom/RSGMom/LBVMom/'
c     *      ,'WRMom</Columns>')
c          
     
     
98    continue
c
c THE WIND ACCUMULATORS ARE RESET FOR EACH TIME STEP IF THE STAR
c FORMATION IS NOT CONTINUOUS.
c

       if(isf.gt.0 .and. icount.gt.1) then       
678	      continue
	else       
              
     	wpow=0.
	wpow1=0.
	wpow2=0.
	wpow3=0.
	wpow4=0.
	wmom=0.
	wmom1=0.
	wmom2=0.
	wmom3=0.
	wmom4=0.         
                            
        endif        

c
c CHOICE OF THE STELLAR WIND MODEL
c
	if (iwind .eq.  0) goto 1000
	if (iwind .eq.  1) goto 2000
	if (iwind .eq.  2) goto 3000
	if (iwind .eq.  3) goto 4000

	goto 5000
c
c MASS-LOSS RATES FROM GENEVA.
c
1000	do 100 l=lmin,lmax
	wpow=wpow+wind1(l,ltype,1)*dens(l)
	if(ltype .eq. 1) wpow1=wpow1+wind1(l,ltype,1)*dens(l)
	if(ltype .eq. 2) wpow2=wpow2+wind1(l,ltype,1)*dens(l)
	if(ltype .eq. 3) wpow3=wpow3+wind1(l,ltype,1)*dens(l)
	if(ltype .eq. 4) wpow4=wpow4+wind1(l,ltype,1)*dens(l)
	wmom=wmom+wind1(l,ltype,2)*dens(l)
	if(ltype .eq. 1) wmom1=wmom1+wind1(l,ltype,2)*dens(l)
	if(ltype .eq. 2) wmom2=wmom2+wind1(l,ltype,2)*dens(l)
	if(ltype .eq. 3) wmom3=wmom3+wind1(l,ltype,2)*dens(l)
	if(ltype .eq. 4) wmom4=wmom4+wind1(l,ltype,2)*dens(l)
100	continue
	  if (icount .eq. 1 ) then
           wen=wen+wpow*time_in*3.1558e7
        else
           wen=wen+wpow*tstep*3.1558e7
        endif
	goto 5000
c
c EMPIRICAL MASS-LOSS RATES AND TERMINAL VELOCITIES.
c
2000	do 200 l=lmin,lmax
	wpow=wpow+wind2(l,ltype,1)*dens(l)
	if(ltype .eq. 1) wpow1=wpow1+wind2(l,ltype,1)*dens(l)
	if(ltype .eq. 2) wpow2=wpow2+wind2(l,ltype,1)*dens(l)
	if(ltype .eq. 3) wpow3=wpow3+wind2(l,ltype,1)*dens(l)
	if(ltype .eq. 4) wpow4=wpow4+wind2(l,ltype,1)*dens(l)
	wmom=wmom+wind2(l,ltype,2)*dens(l)
	if(ltype .eq. 1) wmom1=wmom1+wind2(l,ltype,2)*dens(l)
	if(ltype .eq. 2) wmom2=wmom2+wind2(l,ltype,2)*dens(l)
	if(ltype .eq. 3) wmom3=wmom3+wind2(l,ltype,2)*dens(l)
	if(ltype .eq. 4) wmom4=wmom4+wind2(l,ltype,2)*dens(l)
200	continue
	  if (icount .eq. 1 ) then
           wen=wen+wpow*time_in*3.1558e7
        else
           wen=wen+wpow*tstep*3.1558e7
        endif
	goto 5000
c
c THEORETICAL MASS-LOSS RATES AND TERMINAL VELOCITIES.
c
3000	do 300 l=lmin,lmax
	wpow=wpow+wind3(l,ltype,1)*dens(l)
	if(ltype .eq. 1) wpow1=wpow1+wind3(l,ltype,1)*dens(l)
	if(ltype .eq. 2) wpow2=wpow2+wind3(l,ltype,1)*dens(l)
	if(ltype .eq. 3) wpow3=wpow3+wind3(l,ltype,1)*dens(l)
	if(ltype .eq. 4) wpow4=wpow4+wind3(l,ltype,1)*dens(l)
	wmom=wmom+wind3(l,ltype,2)*dens(l)
	if(ltype .eq. 1) wmom1=wmom1+wind3(l,ltype,2)*dens(l)
	if(ltype .eq. 2) wmom2=wmom2+wind3(l,ltype,2)*dens(l)
	if(ltype .eq. 3) wmom3=wmom3+wind3(l,ltype,2)*dens(l)
	if(ltype .eq. 4) wmom4=wmom4+wind3(l,ltype,2)*dens(l)
300	continue
	  if (icount .eq. 1 ) then
           wen=wen+wpow*time_in*3.1558e7
        else
           wen=wen+wpow*tstep*3.1558e7
        endif
	goto 5000
c
c MASS-LOSS RATES AND TERMINAL VELOCITIES VIA ELSON ET AL.
c
4000	do 400 l=lmin,lmax
	wpow=wpow+wind4(l,ltype,1)*dens(l)
	if(ltype .eq. 1) wpow1=wpow1+wind4(l,ltype,1)*dens(l)
	if(ltype .eq. 2) wpow2=wpow2+wind4(l,ltype,1)*dens(l)
	if(ltype .eq. 3) wpow3=wpow3+wind4(l,ltype,1)*dens(l)
	if(ltype .eq. 4) wpow4=wpow4+wind4(l,ltype,1)*dens(l)
	wmom=wmom+wind4(l,ltype,2)*dens(l)
	if(ltype .eq. 1) wmom1=wmom1+wind4(l,ltype,2)*dens(l)
	if(ltype .eq. 2) wmom2=wmom2+wind4(l,ltype,2)*dens(l)
	if(ltype .eq. 3) wmom3=wmom3+wind4(l,ltype,2)*dens(l)
	if(ltype .eq. 4) wmom4=wmom4+wind4(l,ltype,2)*dens(l)
400	continue
	  if (icount .eq. 1 ) then
           wen=wen+wpow*time_in*3.1558e7
        else
           wen=wen+wpow*tstep*3.1558e7
        endif
	goto 5000

c
c CONVERSION TO PHYSICAL UNITS.
c
5000  continue
c
	wpow =alog10(wpow +1.e-30) +35.
	wpow1=alog10(wpow1+1.e-30) +35.
	wpow2=alog10(wpow2+1.e-30) +35.
	wpow3=alog10(wpow3+1.e-30) +35.
	wpow4=alog10(wpow4+1.e-30) +35.
	wen  =alog10(wen  +1.e-30) +35.
	wmom =alog10(wmom +1.e-30) +35.
	wmom1=alog10(wmom1+1.e-30) +35.
	wmom2=alog10(wmom2+1.e-30) +35.
	wmom3=alog10(wmom3+1.e-30) +35.
	wmom4=alog10(wmom4+1.e-30) +35.
	if(wpow .lt. 5.01) wpow =-30.
	if(wpow1.lt. 5.01) wpow1=-30.
	if(wpow2.lt. 5.01) wpow2=-30.
	if(wpow3.lt. 5.01) wpow3=-30.
	if(wpow4.lt. 5.01) wpow4=-30.
	if(wen  .lt. 5.01) wen  =-30.
	if(wmom .lt. 5.01) wmom =-30.
	if(wmom1.lt. 5.01) wmom1=-30.
	if(wmom2.lt. 5.01) wmom2=-30.
	if(wmom3.lt. 5.01) wmom3=-30.
	if(wmom4.lt. 5.01) wmom4=-30.
c
	write(95,500)time_in,
     *               wpow,wpow1,wpow2,wpow3,wpow4,wen,
     *               wmom,wmom1,wmom2,wmom3,wmom4
500     format(1x,e10.5,3x,5f9.3,3x,f9.3,3x,5f9.3)
c
c      	   write(950,600)
c600 	   format('  <datarow>')
c	   write(950,601) time_in
c601	   format('    <Time>',e10.5,'</Time>')
c	   write(950,603) wpow
c603	   format('    <TPow>',f9.3,'</TPow>')
c	   write(950,604) wpow1
c604	   format('    <OBPow>',f9.3,'</OBPow>')
c	   write(950,605) wpow2
c605	   format('    <RSGPow>',f9.3,'</RSGPow>')
c      	   write(950,613) wpow3
c613	   format('    <LBVPow>',f9.3,'</LBVPow>')
c	   write(950,614) wpow4
c614	   format('    <WRPow>',f9.3,'</WRPow>')
c	   write(950,615) wen
c615	   format('    <TEne>',f9.3,'</TEne>')
c	   write(950,623) wmom
c623	   format('    <TMom>',f9.3,'</TMom>')
c	   write(950,624) wmom1
c624	   format('    <OBMom>',f9.3,'</OBMom>')
c	   write(950,625) wmom2
c625	   format('    <RSGMom>',f9.3,'</RSGMom>')
c      	   write(950,633) wmom3
c633	   format('    <LBVMom>',f9.3,'</LBVMom>')
c	   write(950,634) wmom4
c634	   format('    <WRMom>',f9.3,'</WRMom>')
c      	   write(950,606)
c606 	   format('  </datarow>')     
c          

c
	wpow =10.**(wpow -35.)
	wpow1=10.**(wpow1-35.)
	wpow2=10.**(wpow2-35.)
	wpow3=10.**(wpow3-35.)
	wpow4=10.**(wpow4-35.)
	wen  =10.**(wen  -35.)
	wmom =10.**(wmom -35.)
	wmom1=10.**(wmom1-35.)
	wmom2=10.**(wmom2-35.)
	wmom3=10.**(wmom3-35.)
	wmom4=10.**(wmom4-35.)
c
	return
	end
c
c ********************************************************************
c ********************************************************************
c ********************************************************************
c
	subroutine nucleo(time_in,icount)
c
c COMPUTES THE CHEMICAL YIELDS FOR H, HE, C, N, O, MG, SI, S, AND
c FE DUE TO STELLAR WINDS AND THE TOTAL MASS RETURNED BY SUPERNOVAE.
c THE WIND MODELS ARE INPUT VIA FUNCTIONS WIND1, WIND2, WIND3, WIND4. 
c MODIFIED TO INCLUDE THE CHEMICAL YIELDS DUE TO SNEII (A. Aloisi, 10 July 
c 2000). STARS ARE CONSIDERED AS SNEII IF THEIR INITIAL MASS IS IN THE 
c RANGE FROM 8 TO 40 M_sol OR TO THE MASS LIMIT FOR WOLF-RAYET STARS 
c (WHATEVER IT IS THE LOWEST). YIELDS FROM  Woosley & Weaver (1995, ApJS 
c 101, 181), CORRECTED BY Lindner et al. (1999, A&A 341, 709) TO INCLUDE THE 
c RADIOACTIVE DECAY. LINEAR INTERPOLATION OR EXTRAPOLATION FOR METALLICITIES 
c WHICH DIFFER FROM THOSE IN THE ARTICLE. THE FINAL OUTPUT FILE SHOWS THE 
c SUM OF CHEMICAL YIELDS FROM BOTH STELLAR WINDS AND SNEII.
c
c ********************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
	character*80 str_date
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        common/mgrid/cmass,lmin,lmax,delm
        common/stars/dens,tonum
	common/yields/ymass,yh,yhe,yc,yn,yo,ymg,ysi,ys,yfe
	common/nucleo_r/critma1,critma_new1,critup1,critup_new1,
     *		yield,yieh,yiehe,yiec,yien,yieo,yiemg,yiesi,
     *	        yies,yiefe,yield1,yieh1,yiehe1,yiec1,yien1,
     *		yieo1,yiemg1,yiesi1,yies1,yiefe1,tmass
        parameter (npgrid = 3000)
	dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *          ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),cmass(npgrid),dens(npgrid),sn(npgrid),
     *          ymass(5,12),yh(5,12),yhe(5,12),yc(5,12),yn(5,12),
     *          yo(5,12),ymg(5,12),ysi(5,12),ys(5,12),yfe(5,12),
     *          tt_star(npgrid)
	data xmg,xsi,xs,xfe /6.67e-4,6.98e-4,3.64e-4,1.83e-3/
c
c AT THE FIRST TIME STEP A HEADER FOR THE OUTPUT FILE IS GENERATED.
c

  
      if(icount.gt.1) goto 98
      
      write(93,196) name
196   format(' MODEL DESIGNATION: ',a20)
         call fdate(str_date)
      write(93,597) str_date
597   format(' MODEL GENERATED: ', a24)      
      write(93,195)
195   format(/,'                  RESULTS FOR THE',
     *        ' CHEMICAL YIELDS')
      write(93,193)
193   format(/,'                            MASS LOSS VIA'
     *        ,' STELLAR WINDS AND SNeII [Ms/YR]            '
     *        ,' ONLY WINDS  ONLY SNE    BOTH   TOTAL MASS')
      write(93,194)
194   format('    TIME         H       HE      C       N       O'
     *     ,'       MG      SI      S'
     *     ,'      FE         ALL NINE ELEMENTS (H THROUGH FE)  ')
c     
c      write(930,960)
c960   format('<Yields>')
c      write(930,961) name
c961    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c         call fdate(str_date)
c      write(930,5971) str_date
c5971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')    
c      write(930,951)
c951    format('  <Title>CHEMICAL YIELDS</Title>')
c      write(930,941)
c941    format('  <Columns>AllH/AllHe/AllC/AllN/'
c     *      ,'AllO/AllMg/AllSi/AllS/AllFe/WiTot/'
c     *      ,'SNTot/AllTot/AllMas</Columns>')        
c
98    continue
       
c
c THE YIELD ACCUMULATORS ARE RESET FOR EACH TIME STEP IF THE STAR
c FORMATION IS NOT CONTINUOUS. YIELD2 IS ALWAYS RESET SINCE A SN
c EXPLOSION IS A SINGULAR EVENT.
c
	yield2=0.
c
c THE CHEMICAL YIELD ACCUMULATORS FROM SNII ARE RESET 
c
        yieh2=0.
        yiehe2=0.
        yiec2=0.
        yien2=0.
        yieo2=0.
        yiemg2=0.
        yiesi2=0.
        yies2=0.
        yiefe2=0.
c
        
	if(isf.gt.0.and.icount.gt.1) goto 10
	yield=0.
c
c SUM OF CHEMICAL YIELDS ACCUMULATORS FROM STELLAR WINDS AND SNEII
c ARE RESET
c
   
        yieh=0.
        yiehe=0.
        yiec=0.
        yien=0.
        yieo=0.
        yiemg=0.
        yiesi=0.
        yies=0.
        yiefe=0.
c
	yield1=0.
	yieh1=0.
	yiehe1=0.
	yiec1=0.
	yien1=0.
	yieo1=0.
	yiemg1=0.
	yiesi1=0.
	yies1=0.
	yiefe1=0.
10	continue



c
        
      if(jmg.eq.3) then
	 lstart = lmax
	 lend   = lmin
	 lstep  = -1
      else
	 lstart = lmin
	 lend   = lmax
	 lstep  = 1
      endif
c
c DETERMINATION OF THE METALLICITY TO CALCULATE THE YIELDS AND USE OF A 
c METALLICITY INDEX.
c
  
	if (z.eq.0.05) then 
           kz=1
	else if (z.eq.0.20) then 
           kz=2
	else if (z.eq.0.40) then 
           kz=3
	else if (z.eq.1.00) then 
           kz=4
	else if (z.eq.2.00) then
	   kz=5
        endif
              
c
c CHOICE OF THE STELLAR WIND MODEL. FOR EACH WIND MODEL THE OUTPUT
c OF THE MOST IMPORTANT ELEMENTS AND THE TOTAL MASS LOST DURING
c EACH STELLAR GENERATION IS CALCULATED. THE MASS LOST DURING A
c SN EXPLOSION IS CALCULATED FROM THE REMAINING MASS IN THE GENEVA MODELS
c AND THE SN RATE. 
c
	if (iwind .eq.  0) goto 1000
	if (iwind .eq.  1) goto 2000
	if (iwind .eq.  2) goto 3000
	if (iwind .eq.  3) goto 4000

	goto 5000
c
c MASS-LOSS RATES FROM THE GENEVA MODELS.
c
1000	do 100 l=lstart,lend,lstep
        if(bol(l).gt.-10.)then
	yield1=yield1+wind1(l,ltype,3)*dens(l)
	yieh1 =yieh1 +wind1(l,ltype,3)*xsurf(l)*dens(l)
	yiehe1=yiehe1+wind1(l,ltype,3)*ysurf(l)*dens(l)
	yiec1 =yiec1 +wind1(l,ltype,3)*xc12s(l)*dens(l)
	yien1 =yien1 +wind1(l,ltype,3)*xn14s(l)*dens(l)
	yieo1 =yieo1 +wind1(l,ltype,3)*xo16s(l)*dens(l)
	yiemg1=yiemg1+wind1(l,ltype,3)*xmg*z*dens(l)
	yiesi1=yiesi1+wind1(l,ltype,3)*xsi*z*dens(l)
	yies1 =yies1 +wind1(l,ltype,3)*xs*z*dens(l)
	yiefe1=yiefe1+wind1(l,ltype,3)*xfe*z*dens(l)
        endif
c        Skip cases which are NOT SN --> goto 120
        if (bol(l).gt.-10..or.cmass(l).gt.bhcut) goto 120
       if (cmass(l).lt.sncut) then
            if (isf.le.0) critma_new1 = cmass(l)
            goto 120
        endif
c
        sn(l)=dens(l)/tstep
         if (isf.le.0) then
            if (critup_new1.lt.0.) then
               critup_new1=cmass(l)
            else
               if (cmass(l).ge.critup_new1) then
                  if (critma1.gt.sncut.and.l.ne.lstart) then
                     ! regular case
                     critup_new1 = cmass(l)
                  else
                     ! no SN are alive anymore. Do not allow to update
                     ! upper limit...
                     critup_new1 = 1.e+36
                     critup1 = critup_new1
                  endif
               endif
            endif
c
            if (cmass(l).ge.critma1.and.cmass(l).le.critup1) then
               sn(l)  = 0.
            else
               critma_new1 = cmass(l)
            endif
         endif
c
         if (isf.gt.0.and.cmass(l).lt.critma1) then
            critma_new1 = cmass(l)
         endif
c
c THE SN YIELD TABLES DO NOT EXTEND BEYOND 40 SOLAR MASSES. THE
c TRICK BELOW IS DONE TO CIRCUMVENT THIS PROBLEM. WE ASSUME THAT THE YIELDS 
c OF STARS MORE MASSIVE THAN 40 M ARE IDENTICAL TO THOSE OF 30 M. FORTUNATELY,
c THESE STARS ARE RARE ENOUGH TO MAKE ONLY A SMALL CONTRIBUTION TO THE 
c TOTAL SN YIELDS. 
c
	fakemass=cmass(l)
	if (cmass(l).gt.40.) then
	fakemass=30.
	endif
c
c LINEAR INTERPOLATION OF THE YIELDS RELATIVE TO A CERTAIN STELLAR MASS
c
	 do k=2,12
         if (fakemass.gt.ymass(kz,k-1).and.fakemass.le.ymass(kz,k)) then
            rmass=(fakemass-ymass(kz,k-1))/(ymass(kz,k)-ymass(kz,k-1))
	    yhn  =rmass*(yh(kz,k)-yh(kz,k-1))+yh(kz,k-1)
	    yhen =rmass*(yhe(kz,k)-yhe(kz,k-1))+yhe(kz,k-1)
            ycn  =rmass*(yc(kz,k)-yc(kz,k-1))+yc(kz,k-1)
            ynn  =rmass*(yn(kz,k)-yn(kz,k-1))+yn(kz,k-1)
	    yon  =rmass*(yo(kz,k)-yo(kz,k-1))+yo(kz,k-1)
	    ymgn =rmass*(ymg(kz,k)-ymg(kz,k-1))+ymg(kz,k-1)
	    ysin =rmass*(ysi(kz,k)-ysi(kz,k-1))+ysi(kz,k-1)
	    ysn  =rmass*(ys(kz,k)-ys(kz,k-1))+ys(kz,k-1)
	    yfen =rmass*(yfe(kz,k)-yfe(kz,k-1))+yfe(kz,k-1)
       	  endif
          enddo
c
	yield2=yield2 + (zmass(l)-1.4)*sn(l)
c
c CHEMICAL YIELDS FROM SNII ARE UPDATED
c
        yieh2 = yieh2 + yhn * sn(l)
        yiehe2 = yiehe2 + yhen * sn(l)
        yiec2 = yiec2 + ycn * sn(l)
        yien2 = yien2 + ynn * sn(l)
        yieo2 = yieo2 + yon * sn(l)
        yiemg2 = yiemg2 + ymgn * sn(l)
        yiesi2 = yiesi2 + ysin * sn(l)
        yies2 = yies2 + ysn * sn(l)
        yiefe2 = yiefe2 + yfen * sn(l)
c
120	continue
100	continue
	critma1 = critma_new1   
	critup1 = critup_new1   
	goto 5000
c
c EMPIRICAL MASS-LOSS RATES.
c
2000	do 200 l=lstart,lend,lstep
        if(bol(l).gt.-10.)then
	yield1=yield1+wind2(l,ltype,3)*dens(l)
	yieh1 =yieh1 +wind2(l,ltype,3)*xsurf(l)*dens(l)
	yiehe1=yiehe1+wind2(l,ltype,3)*ysurf(l)*dens(l)
	yiec1 =yiec1 +wind2(l,ltype,3)*xc12s(l)*dens(l)
	yien1 =yien1 +wind2(l,ltype,3)*xn14s(l)*dens(l)
	yieo1 =yieo1 +wind2(l,ltype,3)*xo16s(l)*dens(l)
	yiemg1=yiemg1+wind2(l,ltype,3)*xmg*z*dens(l)
	yiesi1=yiesi1+wind2(l,ltype,3)*xsi*z*dens(l)
	yies1 =yies1 +wind2(l,ltype,3)*xs*z*dens(l)
	yiefe1=yiefe1+wind2(l,ltype,3)*xfe*z*dens(l)

        endif 

c        Skip cases which are NOT SN --> goto 220
        if (bol(l).gt.-10..or.cmass(l).gt.bhcut) goto 220
        if (cmass(l).lt.sncut) then
            if (isf.le.0) critma_new1 = cmass(l)
            goto 220
        endif
c
        sn(l)=dens(l)/tstep
         if (isf.le.0) then
            if (critup_new1.lt.0.) then
               critup_new1=cmass(l)
            else
               if (cmass(l).ge.critup_new1) then
                  if (critma1.gt.sncut.and.l.ne.lstart) then
                     ! regular case
                     critup_new1 = cmass(l)
                  else
                     ! no SN are alive anymore. Do not allow to update
                     ! upper limit...
                     critup_new1 = 1.e+36
                     critup1 = critup_new1
                  endif
               endif
            endif
c
            if (cmass(l).ge.critma1.and.cmass(l).le.critup1) then
               sn(l)  = 0.
            else
               critma_new1 = cmass(l)
            endif
         endif
c
         if (isf.gt.0.and.cmass(l).lt.critma1) then
            critma_new1 = cmass(l)
         endif
c
c THE SN YIELD TABLES DO NOT EXTEND BEYOND 40 SOLAR MASSES. THE
c TRICK BELOW IS DONE TO CIRCUMVENT THIS PROBLEM. WE ASSUME THAT THE YIELDS 
c OF STARS MORE MASSIVE THAN 40 M ARE IDENTICAL TO THOSE OF 30 M. FORTUNATELY,
c THESE STARS ARE RARE ENOUGH TO MAKE ONLY A SMALL CONTRIBUTION TO THE 
c TOTAL SN YIELDS. 
c
	fakemass=cmass(l)
	if (cmass(l).gt.40.) then
	fakemass=30.
	endif
c
c LINEAR INTERPOLATION OF THE YIELDS RELATIVE TO A CERTAIN STELLAR MASS
c
	 do k=2,12
         if (fakemass.gt.ymass(kz,k-1).and.fakemass.le.ymass(kz,k)) then
            rmass=(fakemass-ymass(kz,k-1))/(ymass(kz,k)-ymass(kz,k-1))         
	    yhn  =rmass*(yh(kz,k)-yh(kz,k-1))+yh(kz,k-1)
	    yhen =rmass*(yhe(kz,k)-yhe(kz,k-1))+yhe(kz,k-1)
            ycn  =rmass*(yc(kz,k)-yc(kz,k-1))+yc(kz,k-1)
            ynn  =rmass*(yn(kz,k)-yn(kz,k-1))+yn(kz,k-1)
	    yon  =rmass*(yo(kz,k)-yo(kz,k-1))+yo(kz,k-1)
	    ymgn =rmass*(ymg(kz,k)-ymg(kz,k-1))+ymg(kz,k-1)
	    ysin =rmass*(ysi(kz,k)-ysi(kz,k-1))+ysi(kz,k-1)
	    ysn  =rmass*(ys(kz,k)-ys(kz,k-1))+ys(kz,k-1)
	    yfen =rmass*(yfe(kz,k)-yfe(kz,k-1))+yfe(kz,k-1)
       	  endif
          enddo
c
	yield2=yield2 + (zmass(l)-1.4)*sn(l)
c
c CHEMICAL YIELDS FROM SNII ARE UPDATED
c
        yieh2 = yieh2 + yhn * sn(l)
        yiehe2 = yiehe2 + yhen * sn(l)
        yiec2 = yiec2 + ycn * sn(l)
        yien2 = yien2 + ynn * sn(l)
        yieo2 = yieo2 + yon * sn(l)
        yiemg2 = yiemg2 + ymgn * sn(l)
        yiesi2 = yiesi2 + ysin * sn(l)
        yies2 = yies2 + ysn * sn(l)
        yiefe2 = yiefe2 + yfen * sn(l)
c
220	continue
200	continue
	critma1 = critma_new1   
	critup1 = critup_new1   
	goto 5000
c
c THEORETICAL MASS-LOSS RATES.
c
3000	do 300 l=lstart,lend,lstep   
        if(bol(l).gt.-10.)then
	yield1=yield1+wind3(l,ltype,3)*dens(l)
	yieh1 =yieh1 +wind3(l,ltype,3)*xsurf(l)*dens(l)
	yiehe1=yiehe1+wind3(l,ltype,3)*ysurf(l)*dens(l)
	yiec1 =yiec1 +wind3(l,ltype,3)*xc12s(l)*dens(l)
	yien1 =yien1 +wind3(l,ltype,3)*xn14s(l)*dens(l)
	yieo1 =yieo1 +wind3(l,ltype,3)*xo16s(l)*dens(l)
	yiemg1=yiemg1+wind3(l,ltype,3)*xmg*z*dens(l)
	yiesi1=yiesi1+wind3(l,ltype,3)*xsi*z*dens(l)
	yies1 =yies1 +wind3(l,ltype,3)*xs*z*dens(l)
	yiefe1=yiefe1+wind3(l,ltype,3)*xfe*z*dens(l)


        endif 
   

c        Skip cases which are NOT SN --> goto 320
        if (bol(l).gt.-10..or.cmass(l).gt.bhcut) goto 320
        if (cmass(l).lt.sncut) then
            if (isf.le.0) critma_new1 = cmass(l)
            goto 320
        endif
c
        sn(l)=dens(l)/tstep
         if (isf.le.0) then
            if (critup_new1.lt.0.) then
               critup_new1=cmass(l)
            else
               if (cmass(l).ge.critup_new1) then
                  if (critma1.gt.sncut.and.l.ne.lstart) then
                     ! regular case
                     critup_new1 = cmass(l)
                  else
                     ! no SN are alive anymore. Do not allow to update
                     ! upper limit...
                     critup_new1 = 1.e+36
                     critup1 = critup_new1
                  endif
               endif
            endif
c
            if (cmass(l).ge.critma1.and.cmass(l).le.critup1) then
               sn(l)  = 0.
            else
               critma_new1 = cmass(l)
            endif
         endif
c
         if (isf.gt.0.and.cmass(l).lt.critma1) then
            critma_new1 = cmass(l)
         endif
c
c THE SN YIELD TABLES DO NOT EXTEND BEYOND 40 SOLAR MASSES. THE
c TRICK BELOW IS DONE TO CIRCUMVENT THIS PROBLEM. WE ASSUME THAT THE YIELDS 
c OF STARS MORE MASSIVE THAN 40 M ARE IDENTICAL TO THOSE OF 30 M. FORTUNATELY,
c THESE STARS ARE RARE ENOUGH TO MAKE ONLY A SMALL CONTRIBUTION TO THE 
c TOTAL SN YIELDS. 
c
	fakemass=cmass(l)
	if (cmass(l).gt.40.) then
	fakemass=30.
	endif
c
c LINEAR INTERPOLATION OF THE YIELDS RELATIVE TO A CERTAIN STELLAR MASS
c
	 do k=2,12
         if (fakemass.gt.ymass(kz,k-1).and.fakemass.le.ymass(kz,k)) then
            rmass=(fakemass-ymass(kz,k-1))/(ymass(kz,k)-ymass(kz,k-1))         
	    yhn  =rmass*(yh(kz,k)-yh(kz,k-1))+yh(kz,k-1)
	    yhen =rmass*(yhe(kz,k)-yhe(kz,k-1))+yhe(kz,k-1)
            ycn  =rmass*(yc(kz,k)-yc(kz,k-1))+yc(kz,k-1)
            ynn  =rmass*(yn(kz,k)-yn(kz,k-1))+yn(kz,k-1)
	    yon  =rmass*(yo(kz,k)-yo(kz,k-1))+yo(kz,k-1)
	    ymgn =rmass*(ymg(kz,k)-ymg(kz,k-1))+ymg(kz,k-1)
	    ysin =rmass*(ysi(kz,k)-ysi(kz,k-1))+ysi(kz,k-1)
	    ysn  =rmass*(ys(kz,k)-ys(kz,k-1))+ys(kz,k-1)
	    yfen =rmass*(yfe(kz,k)-yfe(kz,k-1))+yfe(kz,k-1)
       	  endif
          enddo
c
	yield2=yield2 + (zmass(l)-1.4)*sn(l)
c
c CHEMICAL YIELDS FROM SNII ARE UPDATED
c
        yieh2 = yieh2 + yhn * sn(l)
        yiehe2 = yiehe2 + yhen * sn(l)
        yiec2 = yiec2 + ycn * sn(l)
        yien2 = yien2 + ynn * sn(l)
        yieo2 = yieo2 + yon * sn(l)
        yiemg2 = yiemg2 + ymgn * sn(l)
        yiesi2 = yiesi2 + ysin * sn(l)
        yies2 = yies2 + ysn * sn(l)
        yiefe2 = yiefe2 + yfen * sn(l)
c
320	continue
300	continue  
	critma1 = critma_new1   
	critup1 = critup_new1   
	goto 5000
c
c MASS-LOSS RATES VIA ELSON ET AL.
c
4000	do 400 l=lstart,lend,lstep
        if(bol(l).gt.-10.)then
	yield1=yield1+wind4(l,ltype,3)*dens(l)
	yieh1 =yieh1 +wind4(l,ltype,3)*xsurf(l)*dens(l)
	yiehe1=yiehe1+wind4(l,ltype,3)*ysurf(l)*dens(l)
	yiec1 =yiec1 +wind4(l,ltype,3)*xc12s(l)*dens(l)
	yien1 =yien1 +wind4(l,ltype,3)*xn14s(l)*dens(l)
	yieo1 =yieo1 +wind4(l,ltype,3)*xo16s(l)*dens(l)
	yiemg1=yiemg1+wind4(l,ltype,3)*xmg*z*dens(l)
	yiesi1=yiesi1+wind4(l,ltype,3)*xsi*z*dens(l)
	yies1 =yies1 +wind4(l,ltype,3)*xs*z*dens(l)
	yiefe1=yiefe1+wind4(l,ltype,3)*xfe*z*dens(l)

        endif

c        Skip cases which are NOT SN --> goto 420
        if (bol(l).gt.-10..or.cmass(l).gt.bhcut) goto 420
        if (cmass(l).lt.sncut) then
            if (isf.le.0) critma_new1 = cmass(l)
            goto 420
        endif
c
        sn(l)=dens(l)/tstep
         if (isf.le.0) then
            if (critup_new1.lt.0.) then
               critup_new1=cmass(l)
            else
               if (cmass(l).ge.critup_new1) then
                  if (critma1.gt.sncut.and.l.ne.lstart) then
                     ! regular case
                     critup_new1 = cmass(l)
                  else
                     ! no SN are alive anymore. Do not allow to update
                     ! upper limit...
                     critup_new1 = 1.e+36
                     critup1 = critup_new1
                  endif
               endif
            endif
c
            if (cmass(l).ge.critma1.and.cmass(l).le.critup1) then
               sn(l)  = 0.
            else
               critma_new1 = cmass(l)
            endif
         endif
c
         if (isf.gt.0.and.cmass(l).lt.critma1) then
            critma_new1 = cmass(l)
         endif
c
c THE SN YIELD TABLES DO NOT EXTEND BEYOND 40 SOLAR MASSES. THE
c TRICK BELOW IS DONE TO CIRCUMVENT THIS PROBLEM. WE ASSUME THAT THE YIELDS 
c OF STARS MORE MASSIVE THAN 40 M ARE IDENTICAL TO THOSE OF 30 M. FORTUNATELY,
c THESE STARS ARE RARE ENOUGH TO MAKE ONLY A SMALL CONTRIBUTION TO THE 
c TOTAL SN YIELDS. 
c
	fakemass=cmass(l)
	if (cmass(l).gt.40.) then
	fakemass=30.
	endif
c
c LINEAR INTERPOLATION OF THE YIELDS RELATIVE TO A CERTAIN STELLAR MASS
c
	 do k=2,12
         if (fakemass.gt.ymass(kz,k-1).and.fakemass.le.ymass(kz,k)) then
            rmass=(fakemass-ymass(kz,k-1))/(ymass(kz,k)-ymass(kz,k-1))         
	    yhn  =rmass*(yh(kz,k)-yh(kz,k-1))+yh(kz,k-1)
	    yhen =rmass*(yhe(kz,k)-yhe(kz,k-1))+yhe(kz,k-1)
            ycn  =rmass*(yc(kz,k)-yc(kz,k-1))+yc(kz,k-1)
            ynn  =rmass*(yn(kz,k)-yn(kz,k-1))+yn(kz,k-1)
	    yon  =rmass*(yo(kz,k)-yo(kz,k-1))+yo(kz,k-1)
	    ymgn =rmass*(ymg(kz,k)-ymg(kz,k-1))+ymg(kz,k-1)
	    ysin =rmass*(ysi(kz,k)-ysi(kz,k-1))+ysi(kz,k-1)
	    ysn  =rmass*(ys(kz,k)-ys(kz,k-1))+ys(kz,k-1)
	    yfen =rmass*(yfe(kz,k)-yfe(kz,k-1))+yfe(kz,k-1)
       	  endif
          enddo
c
	yield2=yield2 + (zmass(l)-1.4)*sn(l)
c
c CHEMICAL YIELDS FROM SNII ARE UPDATED
c
        yieh2 = yieh2 + yhn * sn(l)
        yiehe2 = yiehe2 + yhen * sn(l)
        yiec2 = yiec2 + ycn * sn(l)
        yien2 = yien2 + ynn * sn(l)
        yieo2 = yieo2 + yon * sn(l)
        yiemg2 = yiemg2 + ymgn * sn(l)
        yiesi2 = yiesi2 + ysin * sn(l)
        yies2 = yies2 + ysn * sn(l)
        yiefe2 = yiefe2 + yfen * sn(l)
c
420	continue
400	continue
	critma1 = critma_new1   
	critup1 = critup_new1   
	goto 5000
c
c CALCULATE THE COMBINED YIELD AND THE TOTAL MASS LOSS
c
5000	continue
            
     
	yield=yield1+yield2
c
c
c SUM OF THE CHEMICAL YIELDS FROM STELLAR WINDS AND SNEII
c
   
	yieh=yieh1+yieh2
        yiehe=yiehe1+yiehe2
        yiec=yiec1+yiec2
        yien=yien1+yien2
        yieo=yieo1+yieo2
        yiemg=yiemg1+yiemg2
        yiesi=yiesi1+yiesi2
        yies=yies1+yies2
        yiefe=yiefe1+yiefe2
c
      if (icount .eq. 1 ) then
           tmass = tmass + (yield*time_in)
      else
          tmass = tmass + (yield*tstep)
      endif
c    
       
	write(93,500)time_in,
     *    alog10(yieh+1.e-30),
     *    alog10(yiehe+1.e-30),alog10(yiec+1.e-30),
     *    alog10(yien+1.e-30),alog10(yieo+1.e-30),
     *    alog10(yiemg+1.e-30),alog10(yiesi+1.e-30),
     *    alog10(yies+1.e-30),alog10(yiefe+1.e-30),
     *    alog10(yield1+1.e-30),alog10(yield2+1.e-30),
     *    alog10(yield+1.e-30),alog10(tmass+1.e-30)
500    format(1x,e10.5,2x,9f8.3,2x,f8.3,2x,f8.3,2x,f8.3,2x,f8.3)
c
c      	   write(930,600)
c600 	   format('  <datarow>')
c	   write(930,601) time_in
c601	   format('    <Time>',e10.5,'</Time>')
c	   write(930,603)alog10(yieh+1.e-30)
c603	   format('    <AllH>',f8.3,'</AllH>')
c	   write(930,604)alog10(yiehe+1.e-30)
c604	   format('    <AllHe>',f8.3,'</AllHe>')
c	   write(930,605)alog10(yiec+1.e-30)
c605	   format('    <AllC>',f8.3,'</AllC>')
c      	   write(930,613)alog10(yien+1.e-30)
c613	   format('    <AllN>',f8.3,'</AllN>')
c	   write(930,614)alog10(yieo+1.e-30)
c614	   format('    <AllO>',f8.3,'</AllO>')
c	   write(930,615)alog10(yiemg+1.e-30)
c615	   format('    <AllMg>',f8.3,'</AllMg>')
c	   write(930,623)alog10(yiesi+1.e-30)
c623	   format('    <AllSi>',f8.3,'</AllSi>')
c	   write(930,624)alog10(yies+1.e-30)
c624	   format('    <AllS>',f8.3,'</AllS>')
c	   write(930,625)alog10(yiefe+1.e-30)
c625	   format('    <AllFe>',f8.3,'</AllFe>')
c      	   write(930,633)alog10(yield1+1.e-30)
c633	   format('    <WiTot>',f8.3,'</WiTot>')
c	   write(930,634)alog10(yield2+1.e-30) 
c634	   format('    <SNTot>',f8.3,'</SNTot>')
c      	   write(930,643)alog10(yield+1.e-30)
c643	   format('    <AllTot>',f8.3,'</AllTot>')
c	   write(930,644)alog10(tmass+1.e-30) 
c644	   format('    <AllMas>',f8.3,'</AllMas>')
c      	   write(930,606)
c606 	   format('  </datarow>')            
c
      return
      end
c
c *****************************************************************************
c *****************************************************************************
c *****************************************************************************
c
      subroutine specsyn(time_in,icount)
c
c COMPUTES A SYNTHETIC SPECTRUM FROM A POPULATION OF STARS. UNITS ARE
c LOG (ERG/S/A) VERSUS A. THE WAVELENGTH GRID IS FIXED AND OPTIMIZED
c TO HANDLE DISCONTINUITIES. THE STELLAR ATMOSPHERES CAN BE APPROXIMATED
c EITHER BY A BLACK BODY, A LEJEUNE MODEL ATMOSPHERE, A PAULDRACH O-STAR MODEL,
c A SCHMUTZ UNBLANKETED EXTENDED WR ATMOSPHERE, OR A BLANKETED WR ATMOSPHERE
c FROM HILLIER. THE SAME METALLICITY AS FOR THE EVOLUTIONARY MODELS IS 
c CHOSEN FOR THE ATMOSPHERE MODELS. THE PURPOSE OF THIS SUBROUTINE IS TO 
c CALCULATE THE OVERALL CONTINUUM SHAPE AT A RESOLUTION OF 10 TO 20 A. IF
c LINE PROFILES ARE NEEDED, USE FUSESYN, LINESYN, HIRES, OR IFA_SPECTRUM. 
c THIS SUBROUTINE ALSO CALCULATES IR SPECTRAL FEATURES AND WR EMISSION LINES.
c
c *********************************************************************
c
	implicit real*4    (a-h,o-z)      
        integer     get_wrtype  
        character*20 name
        character*80 str_date
        character*6  wrident  
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        common/stars/dens,tonum
        common/flux/flam
        common/lejeuneinput/tem,glog,nlej,flam1,wave
        common/nebula/xrange,gamma
        parameter (nwrlines  = 9,nwrtypes  = 11 ) 
        common/wrlines/wrfluxes(nwrtypes,nwrlines),
     *         xlam_wrlines(nwrlines),wr_lssp(nwrlines),
     *         wr_wssp(nwrlines),wrident(nwrlines)
     	common/specsyn_r/stflux,toflux,fluneb,co2,ca2,ca4,
     *        	ca5,co,ca,co162,co162b,co229,co229b,si159,
     *	        si159b,xlya,xlya2    	
        parameter (npgrid = 3000)
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *         bmdot(npgrid),grav(npgrid),cmass(npgrid),dens(npgrid),
     *         flam(1221),flux(npgrid,1221), toflux(1221),wave(1221),
     *         fluneb(1221),xrange(26),conti(26),stflux(1221),
     *         co1(npgrid),ca1(npgrid),ca3(npgrid),gamma(26),
     *     co162a(npgrid),co229a(npgrid),si159a(npgrid),tt_star(npgrid),
     *         tem(600),glog(600),flam1(1221,600),xlya1(npgrid)
    
c 
c AT THE FIRST CALL TO THE ROUTINE A HEADER FOR THE OUTPUT FILE IS GENERATED
c AND THE WR EMISSION LINE LUMINOSITIES ARE INITIALIZED.   
c
      if(icount.gt.1) goto 98
c
        call init_wrlinefl(alog10(z)+8.66)
        ico1=0
c
      write(92,96) name
96    format(' MODEL DESIGNATION: ',a20)
         call fdate(str_date)
      write(92,597) str_date
597   format(' MODEL GENERATED: ', a24)    
      write(92,95)
95    format(/,'              COMPUTED SYNTHETIC SPECTRUM')
      write(92,94)
94    format(/,' TIME [YR]    WAVELENGTH [A]   LOG ',
     * 'TOTAL  LOG STELLAR  LOG NEBULAR  [ERG/SEC/A]')
c
c
c      write(920,260)
c260   format('<spectrum>')
c      write(920,861) name
c861    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c         call fdate(str_date)
c      write(920,6971) str_date
c6971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')    
c      write(920,981)
c981    format('  <Title>COMPUTED SYNTHETIC SPECTRUM</Title>')
c      write(920,941)
c941    format('  <Columns>LogTOTAL/LogSTELLA/LogNEBUL</Columns>')
c
98      continue
c
c IF THERE IS NO CONTINUOUS STAR FORMATION, THE FLUX ACCUMULATORS
c ARE RESET FOR EACH TIME STEP, OTHERWISE THEY ARE RECALLED FROM
c THE PREVIOUS ITERATION.
c
       if(isf.gt.0 .and. icount.gt.1) then       
678	      continue
	else       
        	do 50 m=1,1221
        	stflux(m)=0.
        	toflux(m)=0.
        	fluneb(m)=0.
50      	continue
c
        	co2=0.
        	ca2=0.
        	ca4=0.
        	ca5=0.
        	co=0.
        	ca=0.
		co162=0.
		co162b=0.
		co229=0.
		co229b=0.
		si159=0.
		si159b=0.
		xlya=0.
		xlya2=0.
        	do i=1,nwrlines
           	wr_lssp(i)=0.
           	enddo
        endif
c
c
c CALCULATE THE EFFECTIVE TEMPERATURE AND LOG G FOR EACH MASS. THEN GET THE
c NUMBER OF PHOTONS PER UNIT SURFACE FOR EACH STAR. AFTERWARDS MULTIPLICATION
c BY THE STELLAR SURFACE AND THE STELLAR NUMBER DENSITY.
c
        do 10 l=lmin,lmax
        teff=10.**temp(l)
        grav(l)=alog10(zmass(l))+4.*temp(l)-bol(l)-10.6
        blogg=grav(l)
        radius = 10.**(10.8426 + 0.5*bol(l) - 2.*temp(l) + 7.52)
        cotest=5.71*log10(teff)-21.95  
c
        if(bol(l). lt. -19.) goto 4000
        if(iatmos .eq. 1) goto 1000
        if(iatmos .eq. 2) goto 2000
        if(iatmos .eq. 3) goto 3000
        if(iatmos .eq. 4) goto 3100
        if(iatmos .eq. 5) goto 3200

c
1000    call planck(teff)
c
        goto 4000
c
2000    if(teff.gt.60000. .or. teff.lt.2000.)  then
           call planck(teff)
        else
           call kurucz(teff,blogg)
        endif
        goto 4000
c 
3000	if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr) then
           call werner(l,radius,teff)
        else
           if(teff.gt.60000. .or. teff.lt.2000. ) then
                call planck(teff)
           else
                call kurucz(teff,blogg)
           endif
        endif
	  goto 4000
c
3100    if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr)then
c
             call hillier(l,teff,radius)         
         else 
             if(teff.gt.60000. .or. teff.lt.2000. ) then
              call planck(teff)
             else
              call kurucz(teff,blogg)
             endif
         endif
	   goto 4000
c
3200    if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr)then
c
             call hillier(l,teff,radius)
           else 
             if(teff.gt.60000. .or. teff.lt.2000.)  then
               call planck(teff)
             else 
               if(teff.ge.25000.and.blogg.lt.cotest 
     &            .and. blogg.ge.2.2) then
               call pauldrach(teff,blogg,radius)
             else
               call kurucz(teff,blogg)
             endif
           endif
         endif
c
4000    continue
c
        do 20 m=1,1221
           flux(l,m) = 12.566*radius*radius/1.e20*flam(m)*dens(l)
           stflux(m) = stflux(m) + flux(l,m)
20      continue
c
c CALCULATION OF THE CO INDEX. POINT 873 WOULD CORRESPOND TO 2.3 MICRONS.
c WE EXTRAPOLATE OUT TO 2.3 MICRONS FROM POINTS 861 & 870, USING A LINEAR
c EXTRAPOLATION.
c
		if(io11.ge.0) then
         co1(l) = sp_feature(l,1,teff,icount)*(flux(l,861)+
     *            2.0*(flux(l,870)-flux(l,861)))
c
c CALCULATION OF THE CA TRIPLET EQ. WIDTH.  POINT 611 = 8570 A.
c
        ca1(l) = sp_feature(l,2,teff,icount)*flux(l,611)
        ca3(l) = sp_feature(l,3,teff,icount)*flux(l,611)
c
c CALCULATION OF LIVIA ORIGLIA'S CO 1.62 MICRON, CO 2.29 MICRON,
c AND SI 1.59 MICRON FEATURES.  POINT 805 IS FOR 1.62 MU, 801 IS FOR
c 1.59 MU, AND 872 IS FOR 2.29 MU. BECAUSE THE KURUCZ MODELS INCLUDE THE
c CO FEATURES, WE HAVE TO INTERPOLATE A CONTINUUM.  WE USE POINTS 789 & 806
c FOR THE 1.59 AND 1.62 MICRON FEATURES, AND INTERPOLATE LINEARLY
c BETWEEN THE TWO.  FOR THE 2.29 MICRON FEATURE, WE MAKE A LINEAR
c INTERPOLATION ACROSS THE CO BANDS USING POINTS BLUEWARD OF THE BAND HEADS.
c
	co162a(l) = sp_feature(l,4,teff,icount)*(flux(l,789)+
     *0.835*(flux(l,806)-flux(l,789)))
	co229a(l) = sp_feature(l,5,teff,icount)*(flux(l,861)+
     *1.190*(flux(l,870)-flux(l,861)))
	si159a(l) = sp_feature(l,6,teff,icount)*(flux(l,789)+
     *0.544*(flux(l,806)-flux(l,789)))
c     
c CALCULATION OF THE STELLAR LYMAN-ALPHA. WE SIMPLY USE A LOOK-UP TABLE.
c LYMAN-ALPHA IS AT WAVELENGTH POINT 152, WE INTERPOLATE BETWEEN POINTS 
c 149 AND 155 IN ORDER TO AVOID THE INTRINSIC LYMAN-ALPHA OF THE SED.
c
	xlya1(l)=sp_feature(l,7,teff,icount)*(flux(l,149)+flux(l,155))/2.    
c
c SUMMATION OVER ALL MASSES AND GENERATIONS OF STARS FOR THE STELLAR CONTINUUM.
c
        co2=co2+co1(l)
        ca2=ca2+ca1(l)
        ca4=ca4+ca3(l)
	co162b=co162b+co162a(l)
	co229b=co229b+co229a(l)
	si159b=si159b+si159a(l)
	xlya2=xlya2+xlya1(l)
c
	endif
c
c CALCULATION OF THE WR EMISSION LINES.
c
        if(io14.ge.0) then
           iwrtype = get_wrtype(xsurf(l),ysurf(l),xc12s(l),xn14s(l),
     *                          xo16s(l),temp(l),grav(l))
           if(bol(l) .lt. -19.) iwrtype=11
           do i=1,nwrlines
              wr_lssp(i) = wr_lssp(i)+wrfluxes(iwrtype,i)*dens(l)
           enddo
        endif

c
10      continue
c
c COMPUTE THE NUMBER OF IONIZING PHOTONS IF DESIRED.
c
	if(io1.ge.0) call ionize(time_in,icount,stflux)
c
c CALCULATE THE NEBULAR CONTINUUM AND ADD TO THE STELLAR CONTINUUM.
c
        call continuum(time_in,icount,conti)

c
        do 70 m=1,1221
        fluneb(m)=yntra(wave(m),xrange,conti,26)
        toflux(m)=stflux(m)+fluneb(m)
70      continue

c
	if(io11.ge.0) then
        co=-2.5*alog10((1.e-35+co2+
     *     fluneb(861)+2.0*(fluneb(870)-fluneb(861)))/
     *     (toflux(861)+2.0*(toflux(870)-toflux(861))+1.e-35))
c
        ca =ca2/(toflux(611)+1.e-35)
        ca5=ca4/(toflux(611)+1.e-35)
	co162=co162b/(toflux(789)+0.835*(toflux(806)-
     *        toflux(789)) +1.e-35)
	co229=co229b/(toflux(861)+1.190*(toflux(870)-
     *        toflux(861)) +1.e-35)
	si159=si159b/(toflux(789)+0.544*(toflux(806)-
     *        toflux(789)) +1.e-35)
	xlya=xlya2/(toflux(149)+toflux(155)+1.e-35)*2.
	endif
c
c GENERATE THE OUTPUT FILE. UNIT = 92.
c
      if(mod(time_in,tdel).lt.tstep) then
c      
            write(92,500) (time_in,wave(i),
     *     alog10(toflux(i)+1.e-35)+20., 
     *     alog10(stflux(i)+1.e-35)+20., 
     *     alog10(fluneb(i)+1.e-35)
     *     +20., i=1,1221)
500     format(1x,e10.5,2x,f13.2,4x,f10.5,2x,f10.5,2x,f10.5)           
c      
c      	do 6000 i=1,1221
c      	   write(920,600)
c600 	   format('  <datarow>')
c	   write(920,601) time_in
c601	   format('    <Time>',e10.5,'</Time>')
c	   write(920,602) wave(i)
c602	   format('    <Wavelength>',f13.2,'</Wavelength>')
c	   write(920,603) alog10(toflux(i)+1.e-35)+20.
c603	   format('    <LogTOTAL>',f10.5,'</LogTOTAL>')
c	   write(920,604) alog10(stflux(i)+1.e-35)+20.
c604	   format('    <LogSTELLA>',f10.5,'</LogSTELLA>')
c	   write(920,605) alog10(fluneb(i)+1.e-35)+20.
c605	   format('    <LogNEBUL>',f10.5,'</LogNEBUL>')
c      	   write(920,606)
c606 	   format('  </datarow>')
c6000	continue
      endif
c
        if(io9.ge.0) call colors(time_in,icount,toflux,stflux)
        if(io10.ge.0)call width(time_in,icount,toflux,stflux)
c
c WRITE THE RESULTS FOR SELECTED SPECTRAL FEATURES INTO UNIT 87 IF THIS
c OPTION WAS SELECTED.
c
        if(io11.ge.0) then
        if(ico1.gt.0) goto 988


      write(87,96) name
968   format(' MODEL DESIGNATION: ',a20)
         call fdate(str_date)
      write(87,978) str_date
978   format(' MODEL GENERATED: ', a24)    
        write(87,958)
958     format(/,'              COMPUTED SPECTRAL FEATURES')
        write(87,948)
948     format(/,' TIME [YR]    CO INDEX   Ca EQW    CaEQW2    CO1.62',
     * '    CO2.29    Si1.59    Ly-alpha')
	write(87,949)
949	format('                [MAG]     [AA]      [AA]      [AA]      ',
     *'[AA]      [AA]      [AA]')
c     
c      write(870,960)
c960   format('<Features>')
c      write(870,961) name
c961    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c         call fdate(str_date)
c      write(870,5971) str_date
c5971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')    
c      write(870,951)
c951    format('  <Title>SPECTRAL FEATURES</Title>')
c      write(870,9410)
c9410    format('  <Columns>COIND/CaEQ1/CaEQ2/CO162/CO229/Si159/Lya'
c     *               ,'</Columns>')
c          
988     continue
c
        write(87,448) time_in,co,ca,ca5,co162,co229,si159,xlya
448     format(1x,e10.5,2x,f8.3,2x,f8.3,2x,f8.3,2x,f8.3,2x,f8.3,2x,f8.3,
     *         2x,f8.3)
c
c      	   write(870,7000)
c7000 	   format('  <datarow>')
c	   write(870,6010) time_in
c6010	   format('    <Time>',e10.5,'</Time>')
c	   write(870,6030) co
c6030	   format('    <COIND>',f8.3,'</COIND>')
c	   write(870,6040) ca
c6040	   format('    <CaEQ1>',f8.3,'</CaEQ1>')
c	   write(870,6050) ca5
c6050	   format('    <CaEQ2>',f8.3,'</CaEQ2>')
c      	   write(870,6130) co162
c6130	   format('    <CO162>',f8.3,'</CO162>')
c	   write(870,6140) co229
c6140	   format('    <CO229>',f8.3,'</CO229>')
c	   write(870,6150) si159
c6150	   format('    <Si159>',f8.3,'</Si159>')
c	   write(870,6155) xlya
c6155	   format('    <Lya>',f8.3,'</Lya>')
c      	   write(870,6060)
c6060 	   format('  </datarow>')     

c
        endif
c
c WRITE THE RESULTS FOR THE WR EMISSION LINES INTO UNIT 84 IF THIS
c OPTION WAS SELECTED.
c
        if(io14.ge.0) then
           call wrlines_ew(wave,toflux,1221)
c
           if(ico1.le.0) then
           
      write(84,969) name
969   format(' MODEL DESIGNATION: ',a20)
         call fdate(str_date)
      write(84,979) str_date
979   format(' MODEL GENERATED: ', a24)    
	      write(84,989)
 989       format(/,'                 COMPUTED WOLF-RAYET EMISSION',
     *         ' LINES') 
              write (84,221) (wrident(kl), kl=1,nwrlines)
  221 format (/,'     TIME ',5x,9(a6,7x))
	write(84,990)
990	format('      YR      AA LOG E/S',
     *                     '   AA LOG E/S',  
     *                     '   AA LOG E/S' , 
     *                     '   AA LOG E/S',  
     *                     '   AA LOG E/S',  
     *                     '   AA LOG E/S',  
     *                     '   AA LOG E/S',  
     *                     '   AA LOG E/S',  
     *                     '   AA LOG E/S')
c
c      write(840,560)
c560   format('<WRLines>')
c      write(840,561) name
c561    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c         call fdate(str_date)
c      write(840,5951) str_date
c5951   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')    
c      write(840,551)
c551    format('  <Title>WOLF-RAYET EMISSION Lines</Title>')
c      write(840,9420)
c9420    format('  <Columns>WHe1640/LHe1640/WN4640/LN4640'
c     *          ,'/WC4650/LC4650/WHe4686/LHe4686/WHBHe'
c     *          ,'/LHBHe/WC5689/LC5689/WC5808/LC5808'
c     *          ,'/WHAHe/LHAHe/WHe5411/LHe5411'
c     *          ,'</Columns>')
c                     
               endif
c                              
           ico1=ico1+1
           write (84,222) time_in,
     *     (wr_wssp(kl),35.+alog10(wr_lssp(kl)+1.e-35), 
     *     kl=1,nwrlines)
c
c      	   write(840,8000)
c8000 	   format('  <datarow>')
c	   write(840,8010) time_in
c8010	   format('    <Time>',e10.5,'</Time>')
c	   write(840,8030) wr_wssp(1)
c8030	   format('    <WHe1640>',f6.2,'</WHe1640>')
c	   write(840,9030) 35.+alog10(wr_lssp(1)+1.e-35)
c9030	   format('    <LHe1640>',f6.2,'</LHe1640>')
c	   write(840,8040) wr_wssp(2)
c8040	   format('    <WN4640>',f6.2,'</WN4640>')
c	   write(840,9040) 35.+alog10(wr_lssp(2)+1.e-35)
c9040	   format('    <LN4640>',f6.2,'</LN4640>')
c	   write(840,8050) wr_wssp(3)
c8050	   format('    <WC4650>',f6.2,'</WC4650>')
c	   write(840,9050) 35.+alog10(wr_lssp(3)+1.e-35)
c9050	   format('    <LC4650>',f6.2,'</LC4650>')
c      	   write(840,8130) wr_wssp(4)
c8130	   format('    <WHe4686>',f6.2,'</WHe4686>')
c      	   write(840,9130) 35.+alog10(wr_lssp(4)+1.e-35)
c9130	   format('    <LHe4686>',f6.2,'</LHe4686>')
c	   write(840,8140) wr_wssp(5)
c8140	   format('    <WHBHe>',f6.2,'</WHBHe>')
c	   write(840,9140) 35.+alog10(wr_lssp(5)+1.e-35)
c9140	   format('    <LHBHe>',f6.2,'</LHBHe>')
c	   write(840,8150) wr_wssp(6)
c8150	   format('    <WC5689>',f6.2,'</WC5689>')
c	   write(840,9150) 35.+alog10(wr_lssp(6)+1.e-35)
c9150	   format('    <LC5689>',f6.2,'</LC5689>')
c	   write(840,8160) wr_wssp(7)
c8160	   format('    <WC5808>',f6.2,'</WC5808>')
c	   write(840,9160) 35.+alog10(wr_lssp(7)+1.e-35)
c9160	   format('    <LC5808>',f6.2,'</LC5808>')
c	   write(840,8170) wr_wssp(8)
c8170	   format('    <WHAHe>',f6.2,'</WHAHe>')
c	   write(840,9170) 35.+alog10(wr_lssp(8)+1.e-35)
c9170	   format('    <LHAHe>',f6.2,'</LHAHe>')
c	   write(840,8180) wr_wssp(9)
c8180	   format('    <WHe5411>',f6.2,'</WHe5411>')
c	   write(840,9180) 35.+alog10(wr_lssp(9)+1.e-35)
c9180	   format('    <LHe5411>',f6.2,'</LHe5411>')
c      	   write(840,8060)
c8060 	   format('  </datarow>')     
c
        endif
        ico1=ico1+1
c
222     format (1x,e10.5,9(1x,f6.2,f6.2))
c
        return
        end
c
c *****************************************************************************
c *****************************************************************************
c *****************************************************************************
c
      subroutine ifa_spectrum(time_in,icount)
c
c COMPUTES A SYNTHETIC SPECTRUM FROM A POPULATION OF STARS. UNITS ARE
c LOG (ERG/S/A) VERSUS A. THE WAVELENGTH COVERAGE IS FROM 900 A TO
c 3000 A. THE RESOLUTION IS WAVELENGTH DEPENDENT. A TYPICAL VALUE IS 0.5 A
c IN THE SATELLITE UV. THE SPECTRA ARE BASED ON WM-BASIC (PAULDRACH &
c KUDRITZKI) AND ARE OPTIMIZED TO PREDICT HIGHLY RESOLVED SPECTRA IN THE UV.
c THEY SHOULD BE CONSIDERED THEORETICAL COUNTERPARTS OF THE 
c SEMI-EMPIRICAL SPECTRA CALCULATED IN LINESYN AND FUSESYN. 
c
c *********************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
        character*80 str_date
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
        common/match/imatch
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        common/stars/dens,tonum
        common/flux/flam
        common/flux_powr/flam_powr,wave_powr,kmax_powr
        common/flux_ifa/wave_ifa,flam1_ifa_l,flam1_ifa_c,nlej_ifa,
     *                    tem_ifa,glog_ifa,flam_ifa_l,flam_ifa_c
        common/lejeuneinput/tem,glog,nlej,flam1,wave
        common/nebula/xrange,gamma
        common/ifa_spectrum_r/stflux_ifa_l,stflux_ifa_c,
     *               toflux_ifa_l,toflux_ifa_c,fluneb_ifa
        parameter (npgrid = 3000)
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *         bmdot(npgrid),grav(npgrid),cmass(npgrid),dens(npgrid),
     *         flam_ifa_l(4200),flux_ifa_l(npgrid,4200),
     *         toflux_ifa_l(4200),toflux_ifa_c(4200),
     *         flux_ifa_c(npgrid,4200),freelam1(22),
     *         wave_ifa(4200),fluneb_ifa(4200),xrange(26),conti(26),
     *         stflux_ifa_l(4200),gamma(26),wave(1221),flam(1221),
     *         tt_star(npgrid),flam_ifa_c(4200),stflux_ifa_c(4200),
     *         tem(600),glog(600),flam1(1221,600),tem_ifa(86),
     *         glog_ifa(86),flam1_ifa_c(4200,86),flam1_ifa_l(4200,86),
     *         freeflux1(22),flx(4200),wave_powr(15000),flam_powr(15000)
     	data freelam1/899.9,1085.,1150.,1280.,1310.,1360.,1430.,1480.,
     *         1510.,1580.,1630.,1680.,1740.,1785.,1820.,1875.,2035.,
     *         2235.,2565.,2745.,2895.,2999./
c 
c AT THE FIRST CALL TO THE ROUTINE THE IFA WAVELENGTH GRID IS READ IN, 
c AND A HEADER FOR THE OUTPUT FILE IS GENERATED.
c
	if(icount.gt.1) goto 98
c
      write(83,96) name
96    format(' MODEL DESIGNATION: ',a20)
         call fdate(str_date)
      write(83,597) str_date
597   format(' MODEL GENERATED: ', a24)    
      write(83,95)
95    format(/,'        COMPUTED SYNTHETIC LINE SPECTRUM [ERG/SEC/A]')
      write(83,94)
94    format(/,' TIME [YR]      WAVELENGTH  LOG(LUMINOSITY)  ',
     * 'NORMALIZED SPECTRUM')
c         
c      write(830,960)
c960   format('<Ifaspec>')      
c      write(830,961) name
c961    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c      call fdate(str_date)
c      write(830,5971) str_date
c5971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')                           
c      write(830,950)
c950    format('  <Title>COMPUTED SYNTHETIC LINE SPECTRUM [ERG/SEC/A]',
c     *        '</Title>')
c      write(830,940)
c940    format('  <Columns>LogLUMIN/NORMAL</Columns>')    
c                
98      continue
c
c IF THERE IS NO CONTINUOUS STAR FORMATION, THE FLUX ACCUMULATORS
c ARE RESET FOR EACH TIME STEP.
c
      if(isf.gt.0 .and. icount.gt.1) then       
678	      continue
	else 
	
	        do 50 m=1,4200
        	stflux_ifa_l(m)=0.
        	stflux_ifa_c(m)=0.
        	toflux_ifa_l(m)=0.
        	toflux_ifa_c(m)=0.
        	fluneb_ifa(m)=0.
50      	continue	
        endif
c
c CALCULATE THE EFFECTIVE TEMPERATURE AND LOG G FOR EACH MASS. THEN GET THE
c NUMBER OF PHOTONS PER UNIT SURFACE FOR EACH STAR. AFTERWARDS MULTIPLICATION
c BY THE STELLAR SURFACE AND THE STELLAR NUMBER DENSITY.
c
        do 10 l=lmin,lmax
c        
        if(bol(l).lt.-19.) then
        do 100 m=1,4200
        flux_ifa_l(l,m) = 1.e-30
        flux_ifa_c(l,m) = 1.e-30
100     continue
        goto 10
        endif        
c              
        teff=10.**temp(l)
        grav(l)=alog10(zmass(l))+4.*temp(l)-bol(l)-10.6
        blogg=grav(l)
        radius = 10.**(10.8426 + 0.5*bol(l) - 2.*temp(l) + 7.52)
        if(bol(l). lt. -19.) goto 4000
c
          
	if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr) then
           call hamann(l,teff,radius)
c
c PERFORM AN APPROXIMATE NORMALIZATION OF THE CONTINUUM FOR THE POWR
c FLUXES.
c
  		call planck(teff)
 	        do 7021 m=1,4200
                flam_ifa_c(m)=yntra(wave_ifa(m),wave,flam,1221)
7021            continue
c                
 	 do 701 m=1,4200
          flam_ifa_l(m)=yntra(wave_ifa(m),wave_powr,flam_powr,kmax_powr)
   	  flam_ifa_c(m)=flam_ifa_c(m)*flam_ifa_l(4050)/flam_ifa_c(4050)      
701      continue
        else
           if(teff.lt.2000. ) then
                call planck(teff)
 	        do 702 m=1,4200
                flam_ifa_l(m)=yntra(wave_ifa(m),wave,flam,1221)
                flam_ifa_c(m)=flam_ifa_l(m)
702             continue
           else
               if(cmass(l) .gt. 10. .and. teff .lt. 22000.) then
                     call kurucz(teff,blogg)
c                     
c PERFORM AN APPROXIMATE NORMALIZATION OF THE CONTINUUM FOR THE KURUCZ
c FLUXES.
c
	do 456 jj=1,22
	freeflux1(jj)=yntra(freelam1(jj),wave,flam,1221)
	freeflux1(jj)=
     *   alog10((1.e-30+freeflux1(jj)+flam(imatch-1)+flam(imatch+1))/3.)
456	continue        
c                     
 	     do 705 m=1,4200
             flam_ifa_l(m)=yntra(wave_ifa(m),wave,flam,1221)
             call intrpl(22,freelam1,freeflux1,1,wave_ifa(m),flx(m))
             flam_ifa_c(m)=10.**flx(m)
705            continue
			goto 4000
                else
                if(cmass(l) .lt. 5. .or.(cmass(l) .ge. 5. .and. 
     *                     teff .lt. 17000.)) then
                     call kurucz(teff,blogg)
      	do 4561 jj=1,22
	freeflux1(jj)=yntra(freelam1(jj),wave,flam,1221)
	freeflux1(jj)=
     *   alog10((1.e-30+freeflux1(jj)+flam(imatch-1)+flam(imatch+1))/3.)
4561	continue        
c                     
 	     do 706 m=1,4200
             flam_ifa_l(m)=yntra(wave_ifa(m),wave,flam,1221)
            call intrpl(22,freelam1,freeflux1,1,wave_ifa(m),flx(m))
             flam_ifa_c(m)=10.**flx(m)
706                  continue
                else 
                     call fabio(teff,blogg)
		endif
		endif
                endif
           endif
c
4000    continue
c
        do 20 m=1,4200
           flux_ifa_l(l,m)=
     *       12.566*radius*radius/1.e20*flam_ifa_l(m)*dens(l)
           flux_ifa_c(l,m)=
     *       12.566*radius*radius/1.e20*flam_ifa_c(m)*dens(l)
           stflux_ifa_l(m) = stflux_ifa_l(m) + flux_ifa_l(l,m)
           stflux_ifa_c(m) = stflux_ifa_c(m) + flux_ifa_c(l,m)
20      continue
c
10	continue
c
c CALCULATE THE NEBULAR CONTINUUM AND ADD TO THE STELLAR CONTINUUM.
c
        call continuum(time_in,icount,conti)
c
        do 70 m=1,4200
        fluneb_ifa(m)=yntra(wave_ifa(m),xrange,conti,26)
        toflux_ifa_l(m)=stflux_ifa_l(m)+fluneb_ifa(m)
        toflux_ifa_c(m)=stflux_ifa_c(m)+fluneb_ifa(m)
70      continue
c
c GENERATE THE OUTPUT FILE. UNIT = 83.
c
      if(mod(time_in-time1,tdel).lt.tstep) then
           write(83,500) (time_in,wave_ifa(i),
     *     alog10(toflux_ifa_l(i)+1.e-35)+20., 
     *     toflux_ifa_l(i)/(toflux_ifa_c(i)+1.e-35), 
     *     i=1,4200)
500     format(1x,e10.5,4x,f10.2,5x,f10.5,5x,f10.4)
c
c         do 505 i=1,4200
c           write(830,6001)
c6001 	   format('  <datarow>')	   
c	   write(830,601) time_in
c601	   format('    <Time>',e10.5,'</Time>')
c	   write(830,602) wave_ifa(i)
c602	   format('    <Wavelength>',f10.2,'</Wavelength>')
c	   write(830,603) alog10(toflux_ifa_l(i)+1.e-35)+20.
c603	   format('    <LogLUMIN>',f10.5,'</LogLUMIN>')	   
c	   write(830,604) toflux_ifa_l(i)/(toflux_ifa_c(i)+1.e-35)
c604	   format('    <NORMAL>',f10.4,'</NORMAL>')	   
c     	   write(830,606)
c606 	   format('  </datarow>')
c505      continue
c
      endif
c
        return
        end
c
c ********************************************************************
c ********************************************************************
c ********************************************************************
c
      subroutine ionize(time_in,icount,stflux)
c
c CALCULATION OF IONIZING QUANTA FROM ALL STARS AT EACH TIME STEP.
c THE CALCULATIONS ARE DONE FOR H I, HE I, AND HE II. THE NUMBERS
c ARE COMPARED TO THE TOTAL BOLOMETRIC LUMINOSITY.
c
c *********************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
	character*80 str_date
        parameter (nmaxint=10,nmaxint1=11)
        common/equiphot/phot_912
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/lejeuneinput/tem,glog,nlej,flam1,wave
	dimension stflux(1221),f1data(1221),
     *      freq(1221),fnu1(44),fla1(44),xnu1(44),xla1(44),
     *      fnu2(80),fla2(80),xnu2(80),xla2(80),weight(1221),
     *      fnu3(122),fla3(122),xnu3(122),xla3(122),wave(1221),
     *      tem(600),glog(600),flam1(1221,600)
c
c AT THE FIRST TIME STEP A HEADER FOR THE OUTPUT FILE IS GENERATED.
c
      if(icount.gt.1) goto 98
c      
      write(98,96) name
96    format(' MODEL DESIGNATION: ',a20)
         call fdate(str_date)
      write(98,597) str_date
597   format(' MODEL GENERATED: ', a24)          
      write(98,95)
95    format(/,'              RESULTS FOR THE',
     *        ' NUMBER OF IONIZING PHOTONS')
      write(98,94)
94    format(/,'   TIME            H I              HE I      ',
     *        '      HE II         LOG L')
      write(98,93)
93    format('              [s^-1]  % OF L   [s^-1]  % OF L  ',
     *        ' [s^-1]  % OF L   [ERG/S]')
     
c      write(980,960)
c960   format('<quanta>')
c      write(980,961) name
c961    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c         call fdate(str_date)
c      write(980,5971) str_date
c5971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')    
c      write(980,951)
c951    format('  <Title>NUMBER OF IONIZING PHOTONS</Title>')
c      write(980,941)
c941    format('  <Columns>LogHI/LogHeI/LogHeII</Columns>')
c          
98    continue
c
c CONVERSION TO FREQUENCY AND FROM FLAMBDA TO FNU; DIVISION BY 
c PHOTON ENERGY.
c
        do 10 i=1,1221
	freq(i)=2.997925e18/wave(i)
        f1data(i)=3.33564e-19*stflux(i)*wave(i)*wave(i)
        f1data(i)=f1data(i)/freq(i)/6.6262e-27
10      continue
c
c INTEGRATION OF THE SPECTRUM. THE FIRST INTEGRATION IS FOR THE BOLOMETRIC
c LUMINOSITY IN ERG/SEC. THE OTHER INTEGRATIONS ARE FOR THE NUMBER OF PHOTONS
c IN THE H I (I=44), HE I (I=80), AND HE II (I=122) CONTINUUM. 
c
        call fliwgt(wave,stflux,weight,radlum,1221)
        radlum=alog10(-1.e0*radlum+1.e-30) +20.
c
	do 20 i=1,44
	fnu1(i)=f1data(i)
	fla1(i)=stflux(i)
	xnu1(i)=freq(i)
	xla1(i)=wave(i)
20	continue
        call fliwgt(xnu1,fnu1,weight,phot_228,44)
        call fliwgt(xla1,fla1,weight,flu_228,44)
        phot_228=alog10(phot_228+1.e-30)+20.
        flu_228 =alog10(-1.e0*flu_228+1.e-30)+20.
c
	do 30 i=1,80
	fnu2(i)=f1data(i)
	fla2(i)=stflux(i)
	xnu2(i)=freq(i)
	xla2(i)=wave(i)
30	continue
        call fliwgt(xnu2,fnu2,weight,phot_504,80)
        call fliwgt(xla2,fla2,weight,flu_504,80)
        phot_504=alog10(phot_504+1.e-30)+20.
        flu_504 =alog10(-1.e0*flu_504+1.e-30)+20.
c
	do 40 i=1,122
	fnu3(i)=f1data(i)
	fla3(i)=stflux(i)
	xnu3(i)=freq(i)
	xla3(i)=wave(i)
40	continue
        call fliwgt(xnu3,fnu3,weight,phot_912,122)
        call fliwgt(xla3,fla3,weight,flu_912,122)
        phot_912=alog10(phot_912+1.e-30)+20.
        flu_912 =alog10(-1.e0*flu_912+1.e-30)+20.
c
c
c THE OUTPUT IS WRITTEN IN UNIT 98.
c
        write(98,980) time_in,
     *        phot_912,flu_912-radlum,
     *        phot_504,flu_504-radlum,
     *        phot_228,flu_228-radlum,
     *        radlum
980   format(1x,e10.5,2x,f7.3,f8.3,2x,f7.3,f8.3,2x,f7.3,
     *        f8.3,2x,f7.3)
c     
c      	   write(980,600)
c600 	   format('  <datarow>')
c	   write(980,601) time_in
c601	   format('    <Time>',e10.5,'</Time>')
c	   write(980,603) phot_912
c603	   format('    <LogHI>',f7.3,'</LogHI>')
c	   write(980,604) phot_504
c604	   format('    <LogHeI>',f7.3,'</LogHeI>')
c	   write(980,605) phot_228
c605	   format('    <LogHeII>',f7.3,'</LogHeII>')
c      	   write(980,606)
c606 	   format('  </datarow>')     
c
      return
      end
c
c *******************************************************************
c *******************************************************************
c *******************************************************************
c
	subroutine continuum(time,icount,conti)
c
c THIS SUBROUTINE COMPUTES THE EMISSION OF A NEBULAR CONTINUUM. HYDROGEN
c AND HELIUM FREE-FREE AND FREE-BOUND EMISSION AS WELL AS THE 2-PHOTON
c CONTINUUM ARE TAKEN INTO ACCOUNT. UNITS ARE 1.E-20*ERG/SEC/A.
c
c ********************************************************************
c
	implicit real*4    (a-h,o-z)      
	common/nebula/xrange,gamma
        common/equiphot/phot_912
	dimension xrange(26),gamma(26),conti(26)
	data alphab /2.60e-13/
c
	do 10 i=1,26
	conti(i)=2.998e18/xrange(i)/xrange(i)/alphab*1.e-30*gamma(i)
     *           *10.**(phot_912-30.)
10	continue
c
	return
	end	
c
c
c *********************************************************************
c *********************************************************************
c *********************************************************************
c
	subroutine colors(time_in,icount,toflux,stflux)
c
c THIS SUBROUTINE COMPUTES SELECTED SYNTHETIC COLORS FROM THE OUTPUT SPECTRUM
c OF SPECSYN. FILTERS ARE F130M AND F210M FOR THE FOC IN THE F/96 MODE; UBV
c FROM BUSER AND KURUCZ (1978); RI FROM BESSELL (1990); JHKL FROM BRUZUAL 
c (1981). A STAR WITH TEFF= 9400 K AND LOG G = 3.95 HAS ZERO COLORS IN ALL 
c PASSBANDS. THE SYNTHETIC SPECTRUM IS INTEGRATED TO OBTAIN THE TOTAL 
c LUMINOSITY AND ABSOLUTE MAGNITUDES.
c
c *********************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
	character*80 str_date
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
	common/filter/xprof,yprof
	common/lejeuneinput/tem,glog,nlej,flam1,wave
	dimension toflux(1221),profil(1221),xmag(12),
     *   fdata(1221),xgrid(100),prof(100),xprof(12,100),
     *   yprof(12,100),ksize(12),stflux(1221),weight(1221),
     *   tem(600),glog(600),flam1(1221,600),wave(1221)
	data ksize/99,90,26,42,42,56,26,25,33,30,19,16/
c
c
c AT THE FIRST CALL TO THE ROUTINE A HEADER FOR THE OUTPUT FILE IS GENERATED.
c
        if(icount.gt.1) goto 98
        
        write(89,96) name
96      format(' MODEL DESIGNATION: ',a20)
        call fdate(str_date)
        write(89,597) str_date
597     format(' MODEL GENERATED: ', a24)                  
        write(89,95)
95      format(/,'              COMPUTED SYNTHETIC COLORS')
        write(89,94)
94      format(/,' TIME [YR]    (130-V) (210-V)   (U-B)   (B-V)  ',
     *   ' (V-R)   (V-I)   (V-J)   (V-H)  ',
     *   ' (V-K)   (V-L)     M_V      M_B     M_BOL')
c
c      write(890,960)
c960   format('<color>')
c      write(890,961) name
c961    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c         call fdate(str_date)
c      write(890,5971) str_date
c5971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')    
c      write(890,951)
c951    format('  <Title>SYNTHETIC COLORS</Title>')
c      write(890,941)
c941    format('  <Columns>U130-V/U210-V/U-B/B-V/V-R/V-I/V-J/'
c     *        ,'V-H/V-K/V-L/M_V/M_B/M_BOL</Columns>')
c        
98	continue
c
c COMPUTATION OF THE MAGNITUDES IN THE 12 PASSBANDS. AT FIRST THE FILTER
c PROFILES ARE REBINNED TO MATCH THE WAVELENGTHS OF THE MODEL ATMOSPHERES.
c THEN THE ATMOSPHERIC FLUXES ARE MULTIPLIED BY THE PROFILE FUNCTIONS.
c
	do 21 j=1,12
	do 22 k=1,ksize(j)
	xgrid(k)=xprof(j,k)
	prof(k)=yprof(j,k)
22	continue
	do 20 i=1,1221
	profil(i)=yntra(wave(i),xgrid,prof,ksize(j))
	fdata(i)=toflux(i)*profil(i)
20	continue
c
c EVALUATE THE COEFFICIENTS FOR THE SPLINE AND COMPUTE THE INTEGRALS OVER
c THE PROFILE-WEIGHTED FLUXES.
c
        call fliwgt(wave,fdata,weight,value1,1221)
        xmag(j)=-2.5*alog10(-1.e0*value1)
21	continue
c
c CALCULATE THE COLORS. THE NORMALIZATIONS ARE CHOSEN TO GIVE ZERO COLORS FOR
c 9400/3.95 AND Z = Z_SOLAR.
c
	cuv1v= xmag(1) - xmag(6)  - 6.003
	cuv2v= xmag(2) - xmag(6)  - 2.988
	cub  = xmag(3) - xmag(4)  - 1.102
	cbv  = xmag(5) - xmag(6)  + 0.722
	cvr  = xmag(6) - xmag(7)  - 0.093
	cvi  = xmag(6) - xmag(8)  + 0.692
	cvj  = xmag(6) - xmag(9)  + 1.284
        cvh  = xmag(6) - xmag(10) + 1.875
	cvk  = xmag(6) - xmag(11) + 2.746
	cvl  = xmag(6) - xmag(12) + 4.384
c
c CALCULATE M_V, M_B, AND M_BOL OF THE SYNTHETIC SPECTRUM. M_BOL IS OBTAINED
c VIA INTEGRATION OF THE SPECTRUM OVER THE ENTIRE WAVELENGTH RANGE. 
c 38.70 IS DERIVED AS FOLLOWS: M_BOL=-2.5*LOG L + 4.75, CONVERSION INTO SOLAR
c LUMINOSITES, AND A FACTOR OF 10.**20. ===> -2.5*(20.-33.58)+4.75.
c M_V IS OBTAINED FROM M_BOL AND THE BOLOMETRIC CORRECTION. BC = -0.190 FOR
c T_EFF = 5770 K AND LOG G = 4.44 AT SOLAR METALLICITY.
c
        call fliwgt(wave,stflux,weight,absbol,1221)
        absbol=-2.5*alog10(-1.e0*absbol+1.e-30) + 38.70
	absv=xmag(6)+36.552
	absb=absv + cbv
c
c OUTPUT IS WRITTEN IN UNIT 89.
c
	write(89,44) time_in,cuv1v,cuv2v,cub,cbv,cvr,cvi,cvj,cvh,
     *               cvk,cvl,absv,absb,absbol
44	format(1x,e10.5,2x,10f8.3,1x,f8.3,1x,f8.3,1x,f8.3)
c
c      	   write(890,600)
c600 	   format('  <datarow>')
c	   write(890,601) time_in
c601	   format('    <Time>',e10.5,'</Time>')
c	   write(890,603) cuv1v
c603	   format('    <U130-V>',f8.3,'</U130-V>')
c	   write(890,604) cuv2v
c604	   format('    <U210-V>',f8.3,'</U210-V>')
c	   write(890,605) cub
c605	   format('    <U-B>',f8.3,'</U-B>')
c      	   write(890,613) cbv
c613	   format('    <B-V>',f8.3,'</B-V>')
c	   write(890,614) cvr
c614	   format('    <V-R>',f8.3,'</V-R>')
c	   write(890,615) cvi
c615	   format('    <V-I>',f8.3,'</V-I>')
c	   write(890,623) cvj
c623	   format('    <V-J>',f8.3,'</V-J>')
c	   write(890,624) cvh
c624	   format('    <V-H>',f8.3,'</V-H>')
c	   write(890,625) cvk
c625	   format('    <V-K>',f8.3,'</V-K>')
c      	   write(890,633) cvl
c633	   format('    <V-L>',f8.3,'</V-L>')
c	   write(890,634) absv
c634	   format('    <M_V>',f8.3,'</M_V>')
c	   write(890,635) absb
c635	   format('    <M_B>',f8.3,'</M_B>')
c	   write(890,636) absbol
c636	   format('    <M_BOL>',f8.3,'</M_BOL>')
c      	   write(890,606)
c606 	   format('  </datarow>')     
c
	return
        end
c
c
c ***********************************************************************
c ***********************************************************************
c ***********************************************************************
c
	subroutine width(time_in,icount,toflux,stflux)
c
c THIS SUBROUTINE COMPUTES SELECTED EQUIVALENT WIDTHS DUE TO NEBULAR EMISSION
c LINES. CONTINUUM FLUXES ARE TAKEN FROM THE MODEL ATMOSPHERES. THE CONTINUUM
c IS ASSUMED TO BE FEATURELESS. PRESENTLY H_ALPHA, H_BETA, PA_BETA, AND
c BR_GAMMA ARE INCLUDED.
c
c *************************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
	character*80 str_date
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
	common/lejeuneinput/tem,glog,nlej,flam1,wave
        common/equiphot/phot_912
        dimension toflux(1221),wave(1221),tem(600),glog(600),
     *            flam1(1221,600)
c
c AT THE FIRST CALL TO THE ROUTINE A HEADER FOR THE OUTPUT FILE IS GENERATED.
c
        if(icount.gt.1) goto 98
c        
        write(88,96) name
96      format(' MODEL DESIGNATION: ',a20)
        call fdate(str_date)
        write(88,597) str_date
597     format(' MODEL GENERATED: ', a24)                          
        write(88,95)
95      format(/,'                   ',
     *          '      COMPUTED RECOMBINATION LINES')
        write(88,94)
94      format(/,' TIME [YR]     CONT(H_A) LUM(H_A) EQ(H_A)  ',
     *                          'CONT(H_B) LUM(H_B) EQ(H_B)  ',
     *                          'CONT(P_B) LUM(P_B) EQ(P_B)  ',
     *                          'CONT(B_G) LUM(B_G) EQ(B_G)  ')
c
c      write(880,960)
c960   format('<EWidth>')
c      write(880,961) name
c961    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c         call fdate(str_date)
c      write(880,5971) str_date
c5971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')    
c      write(880,951)
c951    format('  <Title>RECOMBINATION LINES</Title>')
c      write(880,941)
c941    format('  <Columns>ContHA/LumHA/EqHA/ContHB/LumHB/EqHB/'
c     *             ,'ContPB/LumPB/EqPB/ContBG/LumBG/EqBG</Columns>')
c      
98	continue
c
c THE CONTINUUM FLUXES AT H_A, H_B, P_B, AND B_G ARE INTERPOLATED.
c TOFLUX IS STILL DIVIDED BY A FACTOR OF 1E20 AT THIS POINT.
c
c
	hacon=yntra(6563., wave,toflux,1221)
	hbcon=yntra(4861., wave,toflux,1221)
	pbcon=yntra(12818.,wave,toflux,1221)
	bgcon=yntra(21655.,wave,toflux,1221)
c
c COMPUTATION OF THE EMISSION-LINE LUMINOSITIES FROM THE NUMBER OF IONIZING
c PHOTONS. THE NUMBER OF IONIZING PHOTONS MUST BE DIVIDED BY A FACTOR OF
c 1E30 TO AVOID OVERFLOW. COMPUTATION OF THE EQUIVALENT WIDTHS.
c
	halum=1.36e-12*10.**(phot_912-30.)
	hawid=halum/hacon*1.e10
	hblum=4.76e-13*10.**(phot_912-30.)
	hbwid=hblum/hbcon*1.e10
	pblum=7.73e-14*10.**(phot_912-30.)
	pbwid=pblum/pbcon*1.e10
	bglum=1.31e-14*10.**(phot_912-30.)
	bgwid=bglum/bgcon*1.e10
c
c OUTPUT IS WRITTEN IN UNIT 88.
c
	write(88,44) time_in,alog10(hacon+1.e-35)+20.,
     *    alog10(halum+1.e-35)+30.,alog10(hawid+1.e-35),
     *    alog10(hbcon+1.e-35)+20.,alog10(hblum+1.e-35)+30.,
     *    alog10(hbwid+1.e-35),alog10(pbcon+1.e-35)+20.,
     *    alog10(pblum+1.e-35)+30.,alog10(pbwid+1.e-35),
     *    alog10(bgcon+1.e-35)+20.,alog10(bglum+1.e-35)+30.,
     *    alog10(bgwid+1.e-35)
44	format(1x,e10.5,2x,3f9.3,1x,3f9.3,1x,3f9.3,1x,3f9.3)
c
c      	   write(880,600)
c600 	   format('  <datarow>')
c	   write(880,601) time_in
c601	   format('    <Time>',e10.5,'</Time>')
c	   write(880,603) alog10(hacon+1.e-35)+20.
c603	   format('    <ContHA>',f9.3,'</ContHA>')
c	   write(880,604) alog10(halum+1.e-35)+30.
c604	   format('    <LumHA>',f9.3,'</LumHA>')
c	   write(880,605) alog10(hawid+1.e-35)
c605	   format('    <EqHA>',f9.3,'</EqHA>')
c      	   write(880,613) alog10(hbcon+1.e-35)+20.
c613	   format('    <ContHB>',f9.3,'</ContHB>')
c	   write(880,614) alog10(hblum+1.e-35)+30.
c614	   format('    <LumHB>',f9.3,'</LumHB>')
c	   write(880,615) alog10(hbwid+1.e-35)
c615	   format('    <EqHB>',f9.3,'</EqHB>')
c	   write(880,623) alog10(pbcon+1.e-35)+20.
c623	   format('    <ContPB>',f9.3,'</ContPB>')
c	   write(880,624) alog10(pblum+1.e-35)+30.
c624	   format('    <LumPB>',f9.3,'</LumPB>')
c	   write(880,625) alog10(pbwid+1.e-35)
c625	   format('    <EqPB>',f9.3,'</EqPB>')
c      	   write(880,633) alog10(bgcon+1.e-35)+20.
c633	   format('    <ContBG>',f9.3,'</ContBG>')
c	   write(880,634) alog10(bglum+1.e-35)+30.
c634	   format('    <LumBG>',f9.3,'</LumBG>')
c	   write(880,635) alog10(bgwid+1.e-35)
c635	   format('    <EqBG>',f9.3,'</EqBG>')
c      	   write(880,606)
c606 	   format('  </datarow>')     
c
c
	return
        end
c
c ***********************************************************************
c ***********************************************************************
c ***********************************************************************
c
	subroutine init_wrlinefl(zmetal)
c
c THIS SUBROUTINE INITIALIZES QUANTITIES RELATED TO WR LINE FLUXES. EMPIRICAL
c LINE FLUXES ARE FROM SCHAERER & VACCA (1997, APJS). NOTE: ALL LINE FLUXES
c ARE GIVEN IN UNITS OF 10^35 ERG S^-1.
c
c *****************************************************************************
c
        implicit real*4    (a-h,o-z)
        parameter (nwrlines  = 9, nwrtypes  = 11 ) 
        character*6  wrident  
        common / wrlines / wrfluxes(nwrtypes,nwrlines),
     *         xlam_wrlines(nwrlines)   ,
     *         wr_lssp(nwrlines)        ,
     *         wr_wssp(nwrlines)        ,
     *         wrident(nwrlines)        
c
c DEFINE IDENTIFIERS AND WAVELENGHTS FOR LINES:
c
      wrident(1)      = 'He1640'	! HeII 1640
      xlam_wrlines(1) = 1640.d+0
      wrident(2)      = 'N_4640'	! NIII 4640
      xlam_wrlines(2) = 4640.d+0
      wrident(3)      = 'C_4650'	! CIII/IV 4650
      xlam_wrlines(3) = 4650.d+0
      wrident(4)      = 'He4686'	! HeII 4686
      xlam_wrlines(4) = 4686.d+0
      wrident(5)      = 'H_4861'	! H beta + HeII 4861
      xlam_wrlines(5) = 4861.d+0
      wrident(6)      = 'C_5696'	! CIII 5689
      xlam_wrlines(6) = 5696.d+0
      wrident(7)      = 'C_5808'	! CIV 5808
      xlam_wrlines(7) = 5808.d+0
      wrident(8)      = 'H_6560'	! H alpha + HeII 6560
      xlam_wrlines(8) = 6540.d+0
      wrident(9)      = 'He5411'	! HeII 5411
      xlam_wrlines(9) = 5411.d+0
c
c SET LINE FLUXES TO ZERO:
c
      do i=1,nwrtypes
         do j=1,nwrlines
            wrfluxes(i,j) = 0.d+0
         enddo
      enddo
c
c DEFINE THE SCALING FACTOR TO ACCOUNT FOR THE METALLICITY DEPENDENCE
c OF THE 4686 AND THE 5808 LINES. ADOPTED FROM LOPEZ-SANCHEZ ET AL.
c (2010).
c
	zscale1=-3.394+0.508*zmetal
	zscale2=-3.279+0.494*zmetal
c
c INITIALIZE LINE FLUXES FOR ALL WR SUBTYPES:
c
c OIf STARS:
      wrfluxes(10,4) = 10.**0.4
      wrfluxes(10,2) = 10.**(-1.0) * wrfluxes(10,4)
c
c WNE STARS (HEII4686 IS REFERENCE):
      wrfluxes(1,4) = zscale1*5.2e+0		
      wrfluxes(1,1) = 7.952    * wrfluxes(1,4)	
      wrfluxes(1,5) = 0.129    * wrfluxes(1,4)	
      wrfluxes(1,7) = 0.074    * wrfluxes(1,4)	
      wrfluxes(1,8) = 0.202    * wrfluxes(1,4)	
      wrfluxes(1,9) = 0.137    * wrfluxes(1,4)	
c
c WNL STARS (HEII4686 IS REFERENCE):
      wrfluxes(2,4) = zscale1*1.6e+1		 
      wrfluxes(2,1) = 7.55     * wrfluxes(2,4)	
c      if (zmetal.ge.0.018) then
         wrfluxes(2,2) = 0.616 * wrfluxes(2,4)	
c      else
c         wrfluxes(2,2) = 0.244 * wrfluxes(2,4)	
c      endif
      wrfluxes(2,5) = 0.309    * wrfluxes(2,4)	
      wrfluxes(2,7) = 0.062    * wrfluxes(2,4)	 
      wrfluxes(2,8) = 1.596    * wrfluxes(2,4)	 
      wrfluxes(2,9) = 0.107    * wrfluxes(2,4)	 
c
c WO3-4 STARS (CIV5808 IS REFERENCE):
      wrfluxes(3,7) = zscale2*1.1e+1		
      wrfluxes(3,1) = 2.65    * wrfluxes(3,7)
ctest 	test OVI 3811-34 contribution
c      wrfluxes(3,2) = 1.5     * wrfluxes(3,7)
ctest 	test OIV 3400    contribution
c      wrfluxes(3,2) = 1.9     * wrfluxes(3,7)
ctest 	test OV 5590     contribution
c      wrfluxes(3,2) = 1.5     * wrfluxes(3,7)
      wrfluxes(3,3) = 0.51    * wrfluxes(3,7)
      wrfluxes(3,4) = 0.386    * wrfluxes(3,7)
      wrfluxes(3,8) = 0.078   * wrfluxes(3,7)
      wrfluxes(3,9) = 0.026   * wrfluxes(3,7)
c 
c WC4 STARS (CIV5808 IS REFERENCE):
      wrfluxes(4,7) = zscale2*3.0e+1		
      wrfluxes(4,1) = 2.14    * wrfluxes(4,7)
      wrfluxes(4,3) = 1.71    * wrfluxes(4,7)
      wrfluxes(4,5) = 0.019   * wrfluxes(4,7)
      wrfluxes(4,6) = 0.021   * wrfluxes(4,7)
      wrfluxes(4,8) = 0.045   * wrfluxes(4,7)
      wrfluxes(4,9) = 0.023   * wrfluxes(4,7)
c
c WC5 STARS (CIV5808 IS REFERENCE):
      wrfluxes(5,7) = zscale2*9.8e+0		
      wrfluxes(5,1) = 5.14    * wrfluxes(5,7)
      wrfluxes(5,3) = 2.53    * wrfluxes(5,7)
      wrfluxes(5,5) = 0.022   * wrfluxes(5,7)
      wrfluxes(5,6) = 0.077   * wrfluxes(5,7)
      wrfluxes(5,8) = 0.074   * wrfluxes(5,7)
      wrfluxes(5,9) = 0.036   * wrfluxes(5,7)
c
c WC6 STARS (CIV5808 IS REFERENCE):
      wrfluxes(6,7) = zscale2*8.9e+0		
      wrfluxes(6,1) = 7.60    * wrfluxes(6,7)
      wrfluxes(6,3) = 2.98    * wrfluxes(6,7)
      wrfluxes(6,5) = 0.047   * wrfluxes(6,7)
      wrfluxes(6,6) = 0.184   * wrfluxes(6,7)
      wrfluxes(6,8) = 0.112   * wrfluxes(6,7)
      wrfluxes(6,9) = 0.054   * wrfluxes(6,7)
c
c WC7 STARS (CIV5808 IS REFERENCE):
      wrfluxes(7,7) = zscale2*1.4e+1		
      wrfluxes(7,1) = 10.22   * wrfluxes(7,7)
      wrfluxes(7,3) = 3.21    * wrfluxes(7,7)
      wrfluxes(7,5) = 0.069   * wrfluxes(7,7)
      wrfluxes(7,6) = 0.579   * wrfluxes(7,7)
      wrfluxes(7,8) = 0.177   * wrfluxes(7,7)
      wrfluxes(7,9) = 0.076   * wrfluxes(7,7)
c 
c WC8 STARS (CIV5808 IS REFERENCE):
      wrfluxes(8,7) = zscale2*3.5e+0		 
      wrfluxes(8,1) = 13.69   * wrfluxes(8,7)
      wrfluxes(8,3) = 3.30    * wrfluxes(8,7)
      wrfluxes(8,5) = 0.096   * wrfluxes(8,7)
      wrfluxes(8,6) = 1.968   * wrfluxes(8,7)
      wrfluxes(8,8) = 0.580   * wrfluxes(8,7)
      wrfluxes(8,9) = 0.091   * wrfluxes(8,7)
c
c WC9 STARS (CIV5808 IS REFERENCE):
      wrfluxes(9,7) = zscale2*2.0e+0		
      wrfluxes(9,1) = 4.47   * wrfluxes(8,7)	
      wrfluxes(9,3) = 4.46   * wrfluxes(9,7)	
      wrfluxes(9,5) = 0.294  * wrfluxes(9,7)	
      wrfluxes(9,6) = 3.705  * wrfluxes(9,7)	
      wrfluxes(9,8) = 1.243  * wrfluxes(9,7)	
      wrfluxes(9,9) = 0.135  * wrfluxes(9,7)	
c
      return
      end
c
c *****************************************************************************
c *****************************************************************************
c *****************************************************************************
c
	integer function get_wrtype(xh,xhe,xc,xn,xo,tstar,xlogg)
c
c THIS FUNCTION RETURNS THE TYPE NUMBER OF WR STARS FOR USE WITH LINE FLUXES.
c THE FOLLOWING VALUES ARE RETURNED:
c 1 = WNE, 2 = WNL, 3 = WO, 4 = WC4, 5 = WC5, ..., 9 = WC9        
c 10 = OIF, 11 = OTHERWISE.
c
c *****************************************************************************
c
	implicit real*4    (a-h,o-z)
c
c SET DEFAULT VALUE, WHICH CORRESPONDS TO NO LINE EMISSION.
c
      get_wrtype = 11
c 
      if (xh.lt.0.4.and.tstar.gt.4.4d0) then
         if (xh.le.0.001) then
            if (xc.gt.xn) then
c WC STARS    
               cohe = (xc/12.d+0 + xo/16.d+0) / (xhe/4.d+0)
               if (cohe.gt.1.) then
                  get_wrtype = 3	! WO
               elseif (cohe.gt.0.43) then
                  get_wrtype = 4	! WC4
               elseif (cohe.gt.0.35) then
                  get_wrtype = 5	! WC5
               elseif (cohe.gt.0.25) then
                  get_wrtype = 6	! WC6
               elseif (cohe.gt.0.15) then
                  get_wrtype = 7	! WC7
               elseif (cohe.gt.0.08) then
                  get_wrtype = 8	! WC8
               else
                 get_wrtype = 9	! WC9
               endif
            else
c              case of WNE stars
               get_wrtype = 1
            endif           
         else
c WNL STARS
            get_wrtype = 2
         endif   
      else 
c
c CHECK IF OIf 
c
         xglim = 3.676d+0 * tstar - 13.253d+0	! using g_evol 
         if (xlogg.lt.xglim.and.tstar.ge.4.519d+0) then		! Teff>33000K
            get_wrtype = 10
         endif
      endif
c
      return
      end
c
c *****************************************************************************
c *****************************************************************************
c *****************************************************************************
c
	subroutine wrlines_ew(wave,toflux,nw)
c
c THIS SUBROUTINE CALCULATES THE EQUIVALENT WIDTH [A] OF ALL WR EMISSION LINES.
c
c *****************************************************************************
c
        implicit real*4    (a-h,o-z)
        character*6  wrident   
        parameter (nwrlines  = 9, nwrtypes  = 11 )
        common / wrlines / wrfluxes(nwrtypes,nwrlines),
     *         xlam_wrlines(nwrlines)   ,
     *         wr_lssp(nwrlines)        ,
     *         wr_wssp(nwrlines)        ,
     *         wrident(nwrlines)  
        dimension wave(nw),toflux(nw),xl(2),yf(2)
c
      do i=1,nwrlines
         xl(1) = xlam_wrlines(i)-20.d+0
         xl(2) = xlam_wrlines(i)+20.d+0
         call linterp(wave,toflux,nw,xl,yf,2)
         f_cont = yf(1) + (yf(2)-yf(1)) * 
     *            (xlam_wrlines(i)-xl(1)) / (xl(2)-xl(1))
         wr_wssp(i) = (wr_lssp(i)*1.e+15) / f_cont
      enddo
c     
      return
      end
c

c *****************************************************************************
c *****************************************************************************
c *****************************************************************************
c
	subroutine planck(teff)
c
c THIS PROGRAM COMPUTES THE EMERGENT FLUX FROM A BLACK BODY.
c UNITS: ERG/SEC/CM/CM/A. INCLUDES PI (I.E. PHYSICAL FLUX).
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
	common/lejeuneinput/tem,glog,nlej,flam1,wave
	common/flux/flam
	dimension wave(1221),flam1(1221,600),tem(600),glog(600),
     *            flam(1221)
        data pi,h,c,boltz/3.1415927,6.626196e-27,2.997925e10,
     *                    1.380622e-16/

c
c COMPUTE THE PLANCK FUNCTION. PROVISION IS MADE TO INCLUDE AS MANY
c HIGH-ENERGY POINTS AT LOW TEMPERATURES AS POSSIBLE.
c
        do 1 i=1,1221
	cgswave=1.e-8*wave(i)
        c1=h*c/boltz/teff/cgswave
        if(c1.ge.80.) then
		flam(i)=1.e-30
	else
        	flam(i)=2.*pi*h*c*c/cgswave**5./
     *          (exp(c1)-1.)*1.e-8
	endif
1       continue
c
        return 
        end
c
c ***********************************************************************
c ***********************************************************************
c ***********************************************************************
c
	subroutine kurucz(teff,blogg)
c
c ***********************************************************************
c
c THIS SUBROUTINE COMPUTES THE EMERGENT FLUX FROM A KURUCZ MODEL ATMOSPHERE
c AS COMPILED BY LEJEUNE ET AL. THE FLUXES ARE OBTAINED BY SELECTING THE
c CLOSEST ENTRY IN LEJEUNE'S ATMOSPHERE GRID.
c UNITS: ERG/S/CM/CM/A. INCLUDES PI (I.E. PHYSICAL FLUX).
c THE METALLICITY IS THE SAME AS THE ONE FOR THE EVOLUTIONARY TRACKS.
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z) 
	character*20 name     
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
	common/flux/flam
	common/lejeuneinput/tem,glog,nlej,flam1,wave	
	dimension wave(1221),flam1(1221,600),flam(1221),tem(600),
     *            glog(600)
c
c PICK CLOSEST MODEL ATMOSPHERE
c
	  call choose_atm(tem,glog,nlej,teff,blogg,imodel)	  
c
c WE ARE REFINING THE PROCESS BY SEARCHING FOR THE NEXT BEST MATCH TO
c TEFF. WHILE THIS IGNORES THE GRAVITY DEPENDENCE, IT IS A RESONABLE
c COMPROMISE BETWEEN DOING A TIME CONSUMING FULL-BLOWN INTERPOLATION
c AND SIMPLY SELECTING THE NEAREST NEIGHBOR IN TEFF.
c
        teff_iter = teff/(tem(imodel)/teff)**2.
        call choose_atm(tem,glog,nlej,teff_iter,blogg,imodel_iter)
c
	if (imodel_iter.eq.imodel) then
        teff_iter = teff/(tem(imodel)/teff)**3.
        call choose_atm(tem,glog,nlej,teff_iter,blogg,imodel_iter)
	else
	  goto 888
      endif
c
	if (imodel_iter.eq.imodel) then
        teff_iter = teff/(tem(imodel)/teff)**4.
        call choose_atm(tem,glog,nlej,teff_iter,blogg,imodel_iter)
      else
        goto 888
      endif
c
	if (imodel_iter.eq.imodel) then
        teff_iter = teff/(tem(imodel)/teff)**5.
        call choose_atm(tem,glog,nlej,teff_iter,blogg,imodel_iter)
      else
        goto 888
      endif
c
888	continue
c
c THE FINAL MODEL WILL BE INTERPOLATED BETWEEN THE NEAREST NEIGHBOR AND 
c THE NEXT BEST TEFF, UNLESS THE NEAREST NEIGHBOR IS VERY CLOSE TO THE 
c ACTUAL TEFF.
c
	if(imodel_iter.eq.imodel) then
		factor=0.
		goto 777
	endif
	factor=(teff-tem(imodel))/(tem(imodel_iter)-tem(imodel))
777	continue
        do i=1,1221
         flam(i) =
     *   flam1(i,imodel)+factor*(flam1(i,imodel_iter)-flam1(i,imodel))
        enddo
c
        return
        end
c
c
c *****************************************************************************
c *****************************************************************************
c *****************************************************************************
c 
      subroutine choose_atm(tem,glog,nlej,xt,xg,imodel)
c
c THIS SUBROUTINE CHOOSES THE "CLOSEST" LEJEUNE OR OTHER MODEL AVAILABLE IN 
c (TEFF-LOG G) SPACE. IT RETURNS THE MODEL NUMBER.
c
c *****************************************************************************
c
        implicit real*4    (a-h,o-z)
        dimension tem(600),glog(600)
c
c DERIVE ONE MODEL WITH CLOSEST TEFF. NOTE: SEVERAL MODELS WITH SAME TEFF 
c ARE AVAILABLE. DISTT,G ARE JUST BIG NUMBERS TO GET STARTED.
c
      distt = 9.e+34
      distg = 9.e+34
c
      do i=1,nlej
	 dt = abs(xt-tem(i))
         if (dt.lt.distt) then
            iteff  = i		! index of closest model (last on list)
            distt  = dt		! distance to closest model	
         endif
      enddo

c 
c NOW GET THE MODEL CLOSEST IN GRAVITY. CHECK ALL MODELS WITH FIXED TEFF.
c
      i = iteff
c
      do while (abs(tem(i)-tem(iteff)).lt.1.)
         dg = abs(1000.*10.**xg-1000.*10.**glog(i))
         if (dg.lt.distg) then
            imodel  = i		! index of closest model
            distg  = dg		! distance to closest model	
         endif
         i = i + 1
         if (i.eq.nlej) goto 10    ! stop for special case
      enddo
 10   continue
c
      return
      end
c
c *****************************************************************************
c *****************************************************************************
c *****************************************************************************
c
	subroutine pauldrach(teff,blogg,radius)
c
c ***********************************************************************
c
c THE WM-BASIC MODEL ATMOSHPERE GRID. SOLAR PARAMETERS WERE DETERMINED 
c AND SCALED FOR OTHER METALLICITIES. MASS LOSS WAS DETERMINED USING
c THE WIND MOMENTUM - LUMINOSITY RELATIONSHIP OF KUDRITZKI & PULS
c (2000) AND TERMINAL VELOCITIES WERE TAKEN FROM PRINJA, BARLOW AND 
c HOWARTH (1990). MASS LOSS SCALING PROPORTIONAL TO Z^0.8, WHILE TERMINAL 
c VELOCITY SCALING WAS PROPORTIONAL TO Z^0.13.
c FIVE METALLICITIES WERE CALCULATED AT DWARF AND SUPERGIANT GRAVITIES
c GIANTS WHERE INTERPOLATED FROM THE TWO TRACKS
c UNITS: ERG/S/CM/CM/A. INCLUDES PI (I.E. PHYSICAL FLUX).
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
	character*20 name
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/flux/flam
        common/wmbasicinput/tem_p,alum_p,glog_p,flampaul,wave_wm
	dimension wave_wm(1221),flam(1221),
     *  flampaul(1221,33),tem_p(33),glog_p(33),alum_p(33),f_t_g(33)

c
c     
      call renorm_pauldrach(tem_p,flampaul,wave_wm) 
c
        
      do i=1,1221
        do j=1,33
          f_t_g(j)=flampaul(i,j)
        enddo
        call mk_atmo(tem_p,glog_p,f_t_g,33,teff,blogg,flam(i),mmodel)
      enddo

c
c PICK CLOSEST MODEL ATMOSPHERE
c
      call renorm_at(teff,flam,33)
c
c
        return 
        end
c
c ************************************************************************
c ************************************************************************
c ************************************************************************
        
        subroutine renorm_pauldrach(tem_p,flampaul,wave_wm)
c
c ROUTINE CALLED FROM "PAULDRACH". CHECKS AND RENORMALIZES ALL WR 
c ATMOSPHERE MODELS SUCH THAT THE TOTAL EMERGENT FLUX CORRESPONDS TO SIGMA
c *TEFF^4.THIS IS NECESSARY SINCE THE ATMOSPHERE MODELS RESULT FROM 
c PREVIOUS INTERPOLATIONS, WHICH DO NOT a priori GUARANTEE A PROPER 
c NORMALIZATION.
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
	common/flux/flam
	dimension wave_wm(1221),flampaul(1221,33),flam(1221),
     *            tem_p(33),fla_temp(1221)

        kmax = 1221
c
c RENORMALIZE ATMOSPHERES FROM GIANT GRID
c
 
        do i=12,22
          do k=1,1221
            fla_temp(k)=flampaul(k,i)
          enddo
          call total_flux(wave_wm,fla_temp,kmax,tem_p(i),xinte)
          do k=1,1221
            flampaul(k,i)=fla_temp(k)/xinte
          enddo

       
        enddo
        return
        end
c
c
c
c
c************************************************************
c************************************************************
c************************************************************
c

      subroutine mk_atmo(tem,xlogg,flp,m,teff,blogg,flux,mmodel)
c
c 2-DIMENSIONAL INTERPOLATION ROUTINE FROM NUMERICAL RECIPIES.
c
c ***********************************************************************
c
      implicit real (a-h,p-z) 
      dimension tem(m),xlogg(m),flp(m),dtem_abs(m),dtem(m),
     &  dlogg_abs(m)
      
      flux=0.0
      dt=1.0e20
      dg=1.0e20
      do i=1,11 

        dtem(i)=teff-tem(i)
        dtem_abs(i)=abs(teff-tem(i))
        if(dtem_abs(i).lt.dt)then 
          dt=dtem_abs(i)
          model=i
        endif
      enddo

        if(model.gt.11)then
          model=11
        endif
        if(model.le.0)then
          model=1
        endif


      do i=1,3
        dlogg_abs(i)=abs(blogg-xlogg((i-1)*11+model))       
        if(dlogg_abs(i).lt.dg)then 
          dg=dlogg_abs(i)
          modelg=i

        endif
      enddo

      flux=flp((modelg-1)*11+model)
  
      mmodel=(modelg-1)*11+model
  

      return
      end
c
c ************************************************************************
c ************************************************************************
c ************************************************************************
c
        subroutine renorm_at(teff,flux,nmod)
c
c  ROUTINE TO RESCALE ATMOSPHERES TO TEFF WHEN THE NEAREST
c  ATMOSPHERE IS PICKED.
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
	common/flux/flam
	dimension flam(1221),flux(1221)
	common/wmbasicinput/tem_p,alum_p,glog_p,flampaul,wave_wm
	dimension wave_wm(1221),flampaul(1221,33),tem_p(33),
     *            glog_p(33),alum_p(33)
        dimension fla_temp(1221)

        kmax = 1221
c
c RENORMALIZE ATMOSPHERES FROM GIANT GRID
c
 
          do k=1,1221
            fla_temp(k)=flux(k)
          enddo
          call total_flux(wave_wm,fla_temp,kmax,teff,xinte)
          do k=1,1221
            flux(k)=fla_temp(k)/xinte
          enddo
        return
        end
c
c ************************************************************************
c ************************************************************************
c ************************************************************************
c
        subroutine grid_pown(teff,model)
c
c  ROUTINE TO RESCALE THE HAMANN WN ATMOSPHERES TO TEFF WHEN THE NEAREST
c  ATMOSPHERE IS PICKED.
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)     
     	common/powrinput/i_pot,t_pot_wn,t_pot_wc,r_pot_wn,r_pot_wc,
     *                 wave_pot_wn,wave_pot_wc,fl_pot_wn,fl_pot_wc,
     *		       i_wn,i_wc
     	common/flux_powr/flam_powr,wave_powr,kmax_powr
	dimension i_pot(12),t_pot_wn(12),t_pot_wc(12),r_pot_wn(12),
     *		  r_pot_wc(12),wave_pot_wn(15000,12),
     *            wave_pot_wc(15000,12),fl_pot_wn(15000,12),
     *		  fl_pot_wc(15000,12),
     *		  flam_powr(15000),wave_powr(15000),
     *            i_wn(12),i_wc(12)                	
c
c RENORMALIZE ATMOSPHERES OF THE HAMANN WN GRID
c 
          do k=1,i_wn(model) 
            wave_powr(k)=wave_pot_wn(k,model)
	    flam_powr(k)=flam_powr(k)*teff/t_pot_wn(model)
            kmax_powr=k
          enddo
c 	   

        return
        end
c
c ************************************************************************
c ************************************************************************
c ************************************************************************
c
        subroutine grid_powc(teff,model)
c
c  ROUTINE TO RESCALE THE HAMANN WC ATMOSPHERES TO TEFF WHEN THE NEAREST
c  ATMOSPHERE IS PICKED.
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)     
     	common/powrinput/i_pot,t_pot_wn,t_pot_wc,r_pot_wn,r_pot_wc,
     *                 wave_pot_wn,wave_pot_wc,fl_pot_wn,fl_pot_wc,
     *		       i_wn,i_wc
     	common/flux_powr/flam_powr,wave_powr,kmax_powr
	dimension i_pot(12),t_pot_wn(12),t_pot_wc(12),r_pot_wn(12),
     *		  r_pot_wc(12),wave_pot_wn(15000,12),
     *            wave_pot_wc(15000,12),fl_pot_wn(15000,12),
     *		  fl_pot_wc(15000,12),
     *		  flam_powr(15000),wave_powr(15000),
     *            i_wn(12),i_wc(12)
c
c RENORMALIZE ATMOSPHERES OF THE HAMANN WC GRID
c 
          do k=1,i_wc(model)
            wave_powr(k)=wave_pot_wc(k,model)
            flam_powr(k)=flam_powr(k)*teff/t_pot_wc(model)
            kmax_powr=k                        
          enddo
c
        return
        end
c
c ***********************************************************************
c ***********************************************************************
c ***********************************************************************
c
	subroutine fabio(teff,blogg)
c
c THIS SUBROUTINE COMPUTES THE EMERGENT FLUX FROM AN IFA MODEL ATMOSPHERE.
c THE FLUXES ARE OBTAINED BY SELECTING THE CLOSEST ENTRY IN THE ATMOSPHERE 
c GRID. UNITS: ERG/S/CM/CM/A. INCLUDES PI (I.E. PHYSICAL FLUX).
c THE METALLICITY IS THE SAME AS THE ONE FOR THE EVOLUTIONARY TRACKS.
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)
	character*20 name      
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/flux_ifa/wave_ifa,flam1_ifa_l,flam1_ifa_c,nlej_ifa,
     *                    tem_ifa,glog_ifa,flam_ifa_l,flam_ifa_c
	dimension wave_ifa(4200),flam1_ifa_l(4200,86),
     *             flam_ifa_l(4200),tem_ifa(86),glog_ifa(86),
     *         flam1_ifa_c(4200,86),flam_ifa_c(4200)
c
c
c PICK CLOSEST MODEL ATMOSPHERE
c
      dimin=1.e20
      do 14 i=1,86
      di=1.*(alog10(teff)-alog10(tem_ifa(i)))**2.
     *    +5.0*(blogg-glog_ifa(i))**2.
      if(di.lt.dimin) then
        dimin=di
        imodel=i
      endif
14    continue
c	
       do i=1,4200
           flam_ifa_l(i) = flam1_ifa_l(i,imodel)
           flam_ifa_c(i) = flam1_ifa_c(i,imodel)
       enddo
c	
        return 
        end
c
c
c ***********************************************************************
c ***********************************************************************
c ***********************************************************************
c
	subroutine lucimara(teff,blogg)
c
c ***********************************************************************
c
c THIS SUBROUTINE COMPUTES THE EMERGENT FLUX FROM HIGH-RES ATMOSPHERES.
c THE FLUXES ARE OBTAINED BY SELECTING THE CLOSEST ENTRY IN THE ATMOSPHERE 
c GRID. UNITS: ERG/S/CM/CM/A. INCLUDES PI (I.E. PHYSICAL FLUX).
c THE METALLICITY IS THE SAME AS THE ONE FOR THE EVOLUTIONARY TRACKS.
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
	character*20 name
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/flux_hires/wave_hires,flam_hires_l,flam_hires_c,
     *                    flam1_hires_l,flam1_hires_c,nlej_lu,
     *                    tem_luci,glog_luci
	dimension wave_hires(13323),flam1_hires_l(13323,416),
     *       flam_hires_l(13323),tem_luci(416),glog_luci(416),
     *       flam1_hires_c(13323,416),flam_hires_c(13323)

c
c PICK CLOSEST MODEL ATMOSPHERE
c
        call choose_atm
     *  (tem_luci,glog_luci,nlej_lu,teff,blogg,imodel)
        do i=1,13323
           flam_hires_l(i) = flam1_hires_l(i,imodel)
           flam_hires_c(i) = flam1_hires_c(i,imodel)
        enddo
c
        return 
        end
c
c
c ***********************************************************************
c ***********************************************************************
c ***********************************************************************
c
	subroutine werner(l,radius,teff)
c
c COMPUTES THE EMERGENT FLUXES FROM WERNER SCHMUTZ'S WR MODEL ATMOSPHERES.
c A GRID OF MODELS IS READ IN FROM TWO INPUT FILES, AND A 2-DIMENSIONAL
c INTERPOLATION IN TEFF AND WIND DENSITY IS PERFORMED. THE DENSITY IS 
c EXPRESSED IN TERMS OF RADIUS, MASS-LOSS RATE, AND WIND VELOCITY (SCHMUTZ
c ET AL., A&A 210, 236 [1989]).
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
	character*20 name
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
	common/flux/flam
	common/wernerinput/wave1,flam2,flam4,tgrid1,tgrid2,
     *                     rgrid1,rgrid2
	dimension wave1(1221),flam2(1221,12,10),tgrid1(12),
     *            rgrid1(10),flam(1221),tgrid2(11),rgrid2(8),
     *            flam4(1221,11,8)
c
c ASSURE RENORMALIZATION OF WR ATMOSPHERES
c
        call renorm_werner(flam2,tgrid1,flam4,tgrid2,wave1) 
c
c CHOICE OF THE STELLAR WIND MODEL AND CALCULATION OF THE CORRESPONDING RT.
c
	if (iwind .eq.  0) goto 1000
	if (iwind .eq.  1) goto 2000
	if (iwind .eq.  2) goto 3000
	if (iwind .eq.  3) goto 4000

	goto 5000

1000	rt=radius/6.96e10*(1.e-4/wind1(l,ltype,3))**0.66667
     *                 *(wind1(l,ltype,4)/2500.)**0.66667
	goto 5000
2000	rt=radius/6.96e10*(1.e-4/wind2(l,ltype,3))**0.66667
     *                 *(wind2(l,ltype,4)/2500.)**0.66667
	goto 5000
3000	rt=radius/6.96e10*(1.e-4/wind3(l,ltype,3))**0.66667
     *                 *(wind3(l,ltype,4)/2500.)**0.66667
	goto 5000
4000	rt=radius/6.96e10*(1.e-4/wind4(l,ltype,3))**0.66667
     *                 *(wind4(l,ltype,4)/2500.)**0.66667
	goto 5000

5000	continue
c
c CHOOSE "CLOSEST" WR ATMOSPHERE MODEL IN log(T_star)--log(R_trans) PLANE: 
c
      bchoose = 0
      ichoose = 0
      jchoose = 0
      distmin = 9.e+33
c
c IF TEFF < 90000, THE BETA = 1 GRID IS USED. OTHERWISE WE USE BETA = 2.
c
      if(teff.lt.90000.) then
         do i=1,12
            do j=1,10
               dist = (log10(teff) - log10(tgrid1(i)))**2 +
     &              (log10(rt)- log10(rgrid1(j)))**2
               if (dist.lt.distmin) then
                  bchoose = 1   ! beta=1 grid
                  ichoose = i 
                  jchoose = j 
                  distmin = dist
               endif
            enddo
         enddo
      else
         do i=1,11
            do j=1,8
               dist = (log10(teff) - log10(tgrid2(i)))**2 +
     &              (log10(rt)- log10(rgrid2(j)))**2
               if (dist.lt.distmin) then
                  bchoose = 2   ! beta=1 grid
                  ichoose = i 
                  jchoose = j 
                  distmin = dist
               endif
            enddo
         enddo
      endif
      if (bchoose.eq.0) call errpri('werner: No closest WR model !')

      do k=1,1221
         if (bchoose.eq.1) then
            flam(k)=flam2(k,ichoose,jchoose)
         elseif (bchoose.eq.2) then
            flam(k)=flam4(k,ichoose,jchoose)
         endif
      enddo
c      
      return
c
	end
c
c
c ************************************************************************
c ************************************************************************
c ************************************************************************
c
        subroutine renorm_werner(flam2,tgrid1,flam4,tgrid2,wave1)
c
c  ROUTINE CALLED FROM "WERNER". CHECKS AND RENORMALIZES ALL WR ATMOSPHERE
c  MODELS SUCH THAT THE TOTAL EMERGENT FLUX CORRESPONDS TO SIGMA*TEFF^4.
c  THIS IS NECESSARY SINCE THE ATMOSPHERE MODELS RESULT FROM PREVIOUS
c  INTERPOLATIONS, WHICH DO NOT a priori GUARANTEE A PROPER NORMALIZATION.
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
	common/flux/flam
	dimension wave1(1221),flam(1221),flam2(1221,12,10),tgrid1(12),
     *            flam4(1221,11,8),tgrid2(11),fla_temp(1221)

        kmax = 1221
c
c RENORMALIZE ATMOSPHERES FROM BETA=1 GRID:
c
        do i=1,11
           do j=1,8
              do k=1,1221
                 fla_temp(k)=flam2(k,i,j)
              enddo
              call total_flux(wave1,fla_temp,kmax,tgrid1(i),xinte)
              do k=1,1221
                 flam2(k,i,j)=fla_temp(k)/xinte
              enddo
           enddo
        enddo
c
c RENORMALIZE ATMOSPHERES FROM BETA=2 GRID:
c
        do i=1,11
           do j=1,8
              do k=1,1221
                 fla_temp(k)=flam4(k,i,j)
              enddo
              call total_flux(wave1,fla_temp,kmax,tgrid2(i),xinte)
              do k=1,1221
                 flam4(k,i,j)=fla_temp(k)/xinte
              enddo
           enddo
        enddo
c
 100    format ('renorm_werner: ',f10.1,f8.2,f8.3)
        return
        end
c
c
c ************************************************************************
c ************************************************************************
c ************************************************************************
c
      subroutine total_flux(wave,flux,nw,teff,xinte)
c
c INTEGRATES THE FLUX DISTRIBUTION TO DETERMINE THE CORRECT TOTAL
c EMISSION. DETERMINES THE NORMALIZATION FACTOR WITH RESPECT TO A
c BLACK BODY OF TEMPERATURE TEFF.
c INPUT:  wave    WAVELENGTH GRID [A]
c         flux    FLUX DISTRIBUTION [erg cm^-2 s^-1 A^-1]
c         nw      NUMBER OF WAVELENGTH POINTS
c         teff    EFFECTIVE TEMPERATURE [K]
c OUTPUT: xinte   NORMALIZATION FACTOR SUCH THAT 
c                 flux/xinte = INTEGRATED BLACK-BODY FLUX
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
        PARAMETER (STEBO  =     5.6696196D-05) ! Stefan-Boltzmann const.
        integer nw
        real*4  wave(nw),flux(nw)
        real*4  weight(15000),bbflux
c	
c CALCULATE INTEGRAL OVER F_LAMBDA*DLAMBDA (LAMBDA IS INCREASING
c CONTRARY TO ASSUMPTION IN FLIWGT. THEREFORE MULTIPLICATION BY -1.)
c
      call fliwgt(wave,flux,weight,xinte,nw)
c	
      bbflux = stebo * teff**4
      xinte  = - 1.* xinte / bbflux
c
      return
      end       
c
c
c ************************************************************************
c ************************************************************************
c ************************************************************************
c
	subroutine hillier(l,teff,radius)
c
c COMPUTES THE EMERGENT FLUX FROM THE WR STARS USING THE HILLIER & MILLER
c CMFGEN N-LTE ATMOSPHERE CODE.  THERE ARE FIVE METALLICITY GRIDS OF WC AND
c WN, WITH SCALED MASS LOSS AND VELOCITY TAKEN INTO ACCOUNT.  A NON SCALED
c SET FOR ANY METALLICITY CAN ALSO BE USED (WHERE THE SOLAR MODELS ARE 
c USED)  THE FLUXES ARE NORMALIZED TO 1 KPC AND ARE CHANGED TO STELLAR 
c SURFACE IN THIS SUBROUTINE.
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
	character*20 name
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/flux/flam
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
     	common/cmfgeninput/count,tem_hi,tem2_hi,wave_hi,fl,fl2
      parameter (npgrid = 3000) 
	dimension flam(1221),wave_hi(1221),fl(1221,12),fl2(1221,12)
     *  ,tem_hi(12),tem2_hi(12),temp(npgrid),
     *     bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),count(12),radc(12),radn(12),
     *         tt_star(npgrid)
        data radc  /9.31,8.04,7.04,5.95,4.94,4.14,3.05,2.33
     &     ,1.84,1.50,1.03,0.76/
        data radn  /20.30,17.24,14.90,11.40,9.00,7.30,5.07,3.72
     &      ,2.84,2.26,1.82,1.27/
c 
	nmod=12
      	nmod2=12
C
      if(xn14s(l).eq.0.) xn14s(l)=1.e-6
      cnr=xc12s(l)/xn14s(l)
      coher=((xc12s(l)/12.)+(xo16s(l)/16.))/(ysurf(l)/4.)
      if(xsurf(l).gt.0.1) then
       call choosewr(teff,tem_hi,nmod,model)
        do i=1,1221 
          flam(i)=fl(i,model)
          radius2=radn(model)
          flam(i)=flam(i)*(((3.0856e11)**2.0)/((radius2*6.96e10)**2.0))
          flam(i)=flam(i)*1.e20
        enddo 
        call renorm_at(teff,flam,nmod)
        goto 777
      endif
      if(cnr.lt.10.) then
       call choosewr(teff,tem_hi,nmod,model)
        do i=1,1221 
          flam(i)=fl(i,model)
          radius2=radn(model)
          flam(i)=flam(i)*(((3.0856e11)**2.0)/((radius2*6.96e10)**2.0))
          flam(i)=flam(i)*1.e20
        enddo 
        call renorm_at(teff,flam,nmod)
        goto 777
      endif
      if(coher.lt.0.5) then
        call choosewr(teff,tem2_hi,nmod2,model)
        do i=1,1221
          flam(i)=fl2(i,model)
          radius2=radc(model)
          flam(i)=flam(i)*(((3.0856e11)**2.0)/((radius2*6.96e10)**2.0))
          flam(i)=flam(i)*1.e20
        enddo
        call renorm_at(teff,flam,nmod2)  
        goto 777
      endif
      if(coher.lt.1.0) then
        call choosewr(teff,tem2_hi,nmod2,model)
        do i=1,1221
          flam(i)=fl2(i,model)
          radius2=radc(model)
          flam(i)=flam(i)*(((3.0856e11)**2.0)/((radius2*6.96e10)**2.0))
          flam(i)=flam(i)*1.e20
        enddo
        call renorm_at(teff,flam,nmod2)  
        goto 777
      endif
      if(coher.ge.1.0) then
        call choosewr(teff,tem2_hi,nmod2,model)
        do i=1,1221  
          flam(i)=fl2(i,model)
          radius2=radc(model)
          flam(i)=flam(i)*(((3.0856e11)**2.0)/((radius2*6.96e10)**2.0))
          flam(i)=flam(i)*1e20
        enddo
        call renorm_at(teff,flam,nmod2)  
        goto 777
      endif
c

777   continue
      


      return
      end
c
c ***********************************************************************
c ***********************************************************************
c ***********************************************************************
c
      subroutine choosewr(xt,temp,nmod,model)
c
c SELECTS THE CORRECT HILLIER OR HAMANN WR MODEL. WRITTEN BY RICHARD NORRIS (UCL).
c
c *****************************************************************************
c
        implicit real*4    (a-h,o-z)
        dimension temp(nmod)
        
c
c DERIVE ONE MODEL WITH CLOSEST TEFF. NOTE: SEVERAL MODELS WITH SAME TEFF 
c ARE AVAILABLE. DISTT,G ARE JUST BIG NUMBERS TO GET STARTED.
c   

      distt = 9.e+33
      do i=1,nmod
       	 dt_abs = abs((xt)-temp(i))
         if (dt_abs.lt.distt)then
           model=i
           distt=dt_abs
         endif
      enddo
        if (model.gt.nmod)then
          model=nmod
        endif      
        if (model.le.0)then
          model=1
        endif
      return
      end
c
c ***********************************************************************
c ***********************************************************************
c ***********************************************************************
c
        subroutine radint(tem,rad,nmod,teff,rad2)
c
c CALCULATES THE WOLF-RAYET RADIUS OF THE HILLIER MODEL.
c
c ***********************************************************************
c
	implicit real*4    (a-h,o-z)       
        dimension tem(nmod),rad(nmod)
      
        distt = 9.e+34
        do i=1,nmod
           dt=teff-tem(i)
       	   dt_abs = abs(teff-tem(i))
          if (dt_abs.lt.distt)then
            model=i
            distt=dt_abs
          endif
          if (dt.gt.0.0)then 
            model=model+1
          endif
        enddo
        if (model.eq.1)then
          rad2=rad(1) 
        else if (model.ge.nmod+1)then
          rad2=rad(nmod)
        else        
        rad2=rad(model)+(teff-tem(model))*(rad(model)-rad(model-1))
     & /(tem(model)-tem(model-1))
      endif
      return
      end
c
c ************************************************************************
c ************************************************************************
c ************************************************************************
c
	subroutine hamann(l,teff,radius)
c
c COMPUTES THE EMERGENT FLUX FROM THE WR STARS USING THE HAMANN & GRAEFENER
c (POTSDAM) MODELS. THERE ARE FIVE METALLICITY GRIDS OF WN AND WC STARS.
c CURRENTLY ONLY SOLAR MODELS ARE AVAILABLE. THE FLUXES ARE NORMALIZED TO 
c 10 PC AND ARE CHANGED TO STELLAR SURFACE IN THIS SUBROUTINE.
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
	character*20 name
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/flux_powr/flam_powr,wave_powr,kmax_powr
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
     	common/powrinput/i_pot,t_pot_wn,t_pot_wc,r_pot_wn,r_pot_wc,
     *                 wave_pot_wn,wave_pot_wc,fl_pot_wn,fl_pot_wc,
     *		       i_wn,i_wc
        parameter (npgrid = 3000) 
	dimension flam_powr(15000),temp(npgrid),
     *     bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),tt_star(npgrid),
     *		  i_pot(12),t_pot_wn(12),t_pot_wc(12),r_pot_wn(12),
     *		  r_pot_wc(12),wave_pot_wn(15000,12),
     *            wave_pot_wc(15000,12),fl_pot_wn(15000,12),
     *		  fl_pot_wc(15000,12),i_wn(12),i_wc(12),wave_powr(15000)               	
c 
	nmod=12
      	nmod2=12
c
      if(xn14s(l).eq.0.) xn14s(l)=1.e-6
      cnr=xc12s(l)/xn14s(l)
      coher=((xc12s(l)/12.)+(xo16s(l)/16.))/(ysurf(l)/4.)
      if(xsurf(l).gt.0.1) then
       call choosewr(teff,t_pot_wn,nmod,model)
        do i=1,i_wn(model) 
          flam_powr(i)=fl_pot_wn(i,model)
          radius2=r_pot_wn(model)
          flam_powr(i)=
     *         flam_powr(i)*(((3.0856e9)**2.0)/((radius2*6.96e10)**2.0))
          flam_powr(i)=flam_powr(i)*1.e20
        enddo 
        call grid_pown(teff,model)
        goto 777
      endif
c
      if(cnr.lt.10.) then
       call choosewr(teff,t_pot_wn,nmod,model)
        do i=1,i_wn(model) 
          flam_powr(i)=fl_pot_wn(i,model)
          radius2=r_pot_wn(model)
          flam_powr(i)=
     *         flam_powr(i)*(((3.0856e9)**2.0)/((radius2*6.96e10)**2.0))
          flam_powr(i)=flam_powr(i)*1.e20
        enddo 
        call grid_pown(teff,model)
        goto 777
      endif
      
      if(coher.lt.0.5) then
       call choosewr(teff,t_pot_wc,nmod2,model)
        do i=1,i_wc(model)
          flam_powr(i)=fl_pot_wc(i,model)
          radius2=r_pot_wc(model)
          flam_powr(i)=
     *         flam_powr(i)*(((3.0856e9)**2.0)/((radius2*6.96e10)**2.0))
          flam_powr(i)=flam_powr(i)*1.e20
        enddo 
        call grid_powc(teff,model)
        goto 777
      endif
c
      if(coher.lt.1.0) then
        call choosewr(teff,t_pot_wc,nmod2,model)
         do i=1,i_wc(model)
          flam_powr(i)=fl_pot_wc(i,model)
          radius2=r_pot_wc(model)
          flam_powr(i)=
     *         flam_powr(i)*(((3.0856e9)**2.0)/((radius2*6.96e10)**2.0))
          flam_powr(i)=flam_powr(i)*1.e20
        enddo
        call grid_powc(teff,model) 
        goto 777
      endif
c
      if(coher.ge.1.0) then
        call choosewr(teff,t_pot_wc,nmod2,model)
         do i=1,i_wc(model)
          flam_powr(i)=fl_pot_wc(i,model)
          radius2=r_pot_wc(model)
          flam_powr(i)=
     *         flam_powr(i)*(((3.0856e9)**2.0)/((radius2*6.96e10)**2.0))
          flam_powr(i)=flam_powr(i)*1.e20
        enddo
        call grid_powc(teff,model) 
        goto 777
      endif
c
c
777   continue
c      
      return
      end
c
c ***********************************************************************
c ***********************************************************************
c ***********************************************************************
c
        subroutine linesyn(time_in,icount)
c
c COMPUTES THE SYNTHETIC LINES FROM A POPULATION OF STARS FROM 1205.5 TO 
c 1849.75 A (SP. RES. = 0.75 A, NB OF PIX = 860). IT USES NORMALIZED SPECTRA 
c (450 SP. TYPE) FROM THE LIBRARIES "SP.DAT" AND "SP_LOW.DAT". THE FORMER IS
c FOR SOLAR METALLICITY (DE MELLO ET AL. 2000) AND THE LATTER FOR LMC/SMC
c METALLICITY (LEITHERER ET AL. 2001). THE SCALING OF THE FLUX IS DONE 
c WITH MODEL ATMOSPHERES. UNITS ARE LOG(ERG/SEC/A).
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
	character*80 str_date
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
	common/flux/flam
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        common/stars/dens,tonum
        common/nebula/xrange,gamma	
        common/fluxline/np,wavel,ffac
        common/match/imatch
        common/uvtemplate/fli
        common/lejeuneinput/tem,glog,nlej,flam1,wave
        common/linesyn_r/tofluxl,tofluxc,tfluxl,tfluxc,fluneb2
        parameter (npgrid = 3000)
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),cmass(npgrid),dens(npgrid),freeflux(14),
     *        fli(450,860),wavel(860),fluxl(npgrid,860),freelam(14),
     *        fluxc(npgrid,860),ffac(860),tofluxl(860),tofluxc(860),
     *        conti(26),xrange(26),fluneb2(860),gamma(26),tfluxl(860),
     *        tfluxc(860),wave(1221),flam(1221),tt_star(npgrid),
     *	      tem(600),glog(600),flam1(1221,600)
        data rlam0,dell,np/1205.5,0.75,860/
	data freelam/1150.,1280.,1310.,1360.,1430.,1480.,1510.,1580.,
     *               1630.,1680.,1740.,1785.,1820.,1875./
c
c AT THE FIRST CALL TO THE ROUTINE A HEADER FOR THE OUTPUT FILE IS GENERATED.
c
      if(icount.gt.1) goto 98
c      
      write(91,96) name
96    format(' MODEL DESIGNATION: ',a20)
      call fdate(str_date)
      write(91,597) str_date
597   format(' MODEL GENERATED: ', a24)                        
      write(91,95)
95    format(/,'        COMPUTED SYNTHETIC LINE SPECTRUM [ERG/SEC/A]')
      write(91,94)
94    format(/,' TIME [YR]      WAVELENGTH  LOG(LUMINOSITY)  ',
     * 'NORMALIZED SPECTRUM')
c
c      write(910,960)
c960   format('<line>')      
c      write(910,961) name
c961    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c      call fdate(str_date)
c      write(910,5971) str_date
c5971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')                           
c      write(910,950)
c950    format('  <Title>COMPUTED SYNTHETIC LINE SPECTRUM [ERG/SEC/A]',
c     *        '</Title>')
c      write(910,940)
c940    format('  <Columns>LogLUMIN/NORMAL</Columns>')    
c
c DEFINITION OF THE WAVELENGTH GRID.
c
      do 85 k=1,np
      wavel(k)=rlam0+(float(k-1)*dell)
85    continue
c
98    continue
c
c
c IF THERE IS NO CONTINUOUS STAR FORMATION, THE FLUX ACCUMULATORS
c ARE RESET FOR EACH TIME STEP.
c
       if(isf.gt.0 .and. icount.gt.1) then       
678	      continue
	else       
      		do 50 k=1,np
      		tofluxl(k)=0.
      		tofluxc(k)=0.
      		tfluxl(k)=0.
      		tfluxc(k)=0.
      		fluneb2(k)=0.
50    		continue
c
        endif
c
c CALCULATE THE EFFECTIVE TEMPERATURE AND LOG G FOR EACH MASS. THEN GET THE
c SPECTRAL TYPE INDEX FROM SCHMIDT-KALER (IF NOT WR) AND NORMALIZED LINE 
c AND RESCALED ACCORDING TO MODEL ATMOSPHERES (IN ERG PER UNIT SURFACE FOR 
c EACH STAR). AFTERWARDS MULTIPLICATION BY THE STELLAR SURFACE AND THE 
c STELLAR NUMBER DENSITY.
c
      do 10 l=lmin,lmax
c
      if(bol(l).lt.-19.) then
        do 100 k=1,np
        fluxl(l,k) = 1.e-30
        fluxc(l,k) = 1.e-30
100     continue
        goto 10
      endif
c
      teff=10.**temp(l)
      blogg=alog10(zmass(l))+4.*temp(l)-bol(l)-10.6
      radius=10.**(10.8426+0.5*bol(l)-2.*temp(l)+7.52)
      cotest=5.71*log10(teff)-21.95
      if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr) then
        if(xn14s(l).eq.0) xn14s(l)=1.e-6
        cnr=xc12s(l)/xn14s(l)
        coher=((xc12s(l)/12.)+(xo16s(l)/16.))/(ysurf(l)/4.)
        if(xsurf(l).gt.0.1) then
          index=446
          goto 17 
        endif
        if(cnr.lt.10.) then
          index=447
          goto 17
        endif
        if(coher.lt.0.5) then
          index=448
          goto 17
        endif
        if(coher.lt.1.0) then
          index=449
          goto 17
        endif
        if(coher.ge.1.0) then
          index=450
          goto 17
        endif
17      call hillier(l,teff,radius)
      else
        call near(l,index)
        if(teff.lt.2000..or.teff.gt.60000.) then
           call planck(teff)
        else
          call kurucz(teff,blogg)
        endif
      endif
c
c PREPARE THE CONTINUUM GRID. FIRST THE FLUXES CORRESPONDING TO THE PRESELECTED
c LINE FREE WAVELENGTH GRID ARE COMPUTED. THEN AN AVERAGE OVER THREE POINTS IS
c DONE. A SPLINE FIT TO THE FLUXES AT THE 14 WAVELENGTH POINTS IS DONE TO 
c MATCH THE GRID OF THE 860 POINTS OF THE LINE SPECTRUM. THE LMC/SMC LIBRARY
c CUTS OFF AT 1600 A. POINTS LONGWARD OF 1600 A ARE MEANINGLESS. THEREFORE
c WE SET THEM TO ZERO.
c
	do 456 jj=1,14
	freeflux(jj)=yntra(freelam(jj),wave,flam,1221)
	freeflux(jj)=
     *   alog10((freeflux(jj)+flam(imatch-1)+flam(imatch+1))/3.)
456	continue
c
	do 200 k=1,np
	call intrpl(14,freelam,freeflux,1,wavel(k),ffac(k))
        fluxc(l,k)=
     *       12.566*radius*radius/1.e20*10.**ffac(k)*dens(l)
        fluxl(l,k)=fli(index,k)*fluxc(l,k)
        if(iline.eq.2 .and. k.ge.529) fluxl(l,k)=1.e-30
200     continue
10    continue
c
c SUMMATION OVER ALL MASSES AND GENERATIONS OF STARS.
c
      do 35 k=1,np
      do 30 l=lmin,lmax
      tofluxl(k)=tofluxl(k)+fluxl(l,k)
      tofluxc(k)=tofluxc(k)+fluxc(l,k)
30    continue
35    continue
c
c CALCULATE THE NEBULAR CONTINUUM AND ADD TO THE STELLAR CONTINUUM.
c
	call continuum(time_in,icount,conti)
c
	do 70 m=1,np
	fluneb2(m)=yntra(wavel(m),xrange,conti,26)
	tfluxl(m)=tofluxl(m)+fluneb2(m)
	tfluxc(m)=tofluxc(m)+fluneb2(m)
70	continue
c
c GENERATE THE OUTPUT FILE. UNIT = 91.
c
      if(mod(time_in,tdel).lt.tstep) then
c      
        do 505 k=1,np
           write(91,500) time_in,wavel(k),
     *     alog10(tfluxl(k)+1.e-35)+20., 
     *     tfluxl(k)/(tfluxc(k)+1.e-35)
500	format(1x,e10.5,4x,f10.2,5x,f10.5,5x,f10.4)

c           write(910,6001)
c6001 	   format('  <datarow>')	   
c	   write(910,601) time_in
c601	   format('    <Time>',e10.5,'</Time>')
c	   write(910,602) wavel(k)
c602	   format('    <Wavelength>',f10.2,'</Wavelength>')
c	   write(910,603) alog10(tfluxl(k)+1.e-35)+20.
c603	   format('    <LogLUMIN>',f10.5,'</LogLUMIN>')	   
c	   write(910,604) tfluxl(k)/(tfluxc(k)+1.e-35)
c604	   format('    <NORMAL>',f10.4,'</NORMAL>')	   
c     	   write(910,606)
c606 	   format('  </datarow>')
505      continue
      endif
c

      return
      end
c
c ************************************************************************
c ************************************************************************
c ************************************************************************
c
        subroutine fusesyn(time_in,icount)
c
c COMPUTES THE SYNTHETIC LINES FROM A POPULATION OF STARS FROM 1003 TO 
c 1183 A (SP. RES. = 0.127 A, NB OF PIX = 1415). IT USES NORMALIZED SPECTRA 
c (450 SP. TYPE) FROM THE LIBRARIES "FUSE_HIGH.DAT" AND "FUSE_LOW.DAT". THE 
c FORMER IS FOR SOLAR METALLICITY AND THE LATTER FOR LMC/SMC METALLICITY 
c (PELLERIN ET AL. 2002). THE SCALING OF THE FLUX IS DONE WITH MODEL 
c ATMOSPHERES. UNITS ARE LOG(ERG/SEC/A).
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
	character*80 str_date
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
	common/flux/flam
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        common/stars/dens,tonum
        common/nebula/xrange,gamma
        common/match/imatch
        common/lejeuneinput/tem,glog,nlej,flam1,wave
        common/fusetemplate/fli1
        common/fusesyn_r/tofluxl_fu,tofluxc_fu,tfluxl_fu,tfluxc_fu,
     *                   fluneb2_fu
        common/fluxfuse/np1,wave_f,ffac
        parameter (npgrid = 3000)
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),cmass(npgrid),dens(npgrid),freeflux(8),
     *        fli1(450,1415),wave_f(1415),fluxl(npgrid,1415),freelam(8),
     *        fluxc(npgrid,1415),ffac(1415),tofluxl_fu(1415),
     *        tofluxc_fu(1415),conti(26),xrange(26),fluneb2_fu(1415),
     *        gamma(26),tfluxl_fu(1415),tem(600),glog(600),
     *        tfluxc_fu(1415),wave(1221),flam(1221),tt_star(npgrid),
     *        flam1(1221,600)
        data rlam0,dell,np1/1003.1,0.127,1415/
	data freelam/995.,1005.,1055.,1085.,1105.,1125.,1155.,1195./
c
c AT THE FIRST CALL TO THE ROUTINE A HEADER FOR THE OUTPUT FILE IS GENERATED.
c
      if(icount.gt.1) goto 98
c      
      write(86,96) name
96    format(' MODEL DESIGNATION: ',a20)
      call fdate(str_date)
      write(86,597) str_date
597   format(' MODEL GENERATED: ', a24)             
      write(86,95)
95    format(/,'        COMPUTED SYNTHETIC LINE SPECTRUM [ERG/SEC/A]')
      write(86,94)
94    format(/,' TIME [YR]      WAVELENGTH  LOG(LUMINOSITY)  ',
     * 'NORMALIZED SPECTRUM')           
c
c      write(860,960)
c960   format('<OVI>')      
c      write(860,961) name
c961    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c      call fdate(str_date)
c      write(860,5971) str_date
c5971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')                           
c      write(860,950)
c950    format('  <Title>COMPUTED SYNTHETIC LINE SPECTRUM [ERG/SEC/A]',
c     *        '</Title>')
c      write(860,940)
c940    format('  <Columns>LogLUMIN/NORMAL</Columns>')    
c
c DEFINITION OF THE WAVELENGTH GRID.
c
      do 85 k=1,np1
      wave_f(k)=rlam0+(float(k-1)*dell)
85    continue
c 
98	continue
c
c IF THERE IS NO CONTINUOUS STAR FORMATION, THE FLUX ACCUMULATORS
c ARE RESET FOR EACH TIME STEP.
c
       if(isf.gt.0 .and. icount.gt.1) then       
678	      continue
	else       
	      do 50 k=1,np1
	      tofluxl_fu(k)=0.
	      tofluxc_fu(k)=0.
	      tfluxl_fu(k)=0.
	      tfluxc_fu(k)=0.
	      fluneb2_fu(k)=0.
50    	      continue
c
        endif
c
c CALCULATE THE EFFECTIVE TEMPERATURE AND LOG G FOR EACH MASS. THEN GET THE
c SPECTRAL TYPE INDEX FROM SCHMIDT-KALER (IF NOT WR) AND NORMALIZED LINE 
c AND RESCALED ACCORDING TO MODEL ATMOSPHERES (IN ERG PER UNIT SURFACE FOR 
c EACH STAR). AFTERWARDS MULTIPLICATION BY THE STELLAR SURFACE AND THE 
c STELLAR NUMBER DENSITY.
c
99    do 10 l=lmin,lmax
      if(bol(l).lt.-19.) then
        do 100 k=1,np1
        fluxl(l,k) = 1.e-30
        fluxc(l,k) = 1.e-30
100     continue
        goto 10
      endif
c
      teff=10.**temp(l)
      blogg=alog10(zmass(l))+4.*temp(l)-bol(l)-10.6
      radius=10.**(10.8426+0.5*bol(l)-2.*temp(l)+7.52)
      cotest=5.71*log10(teff)-21.95  
      if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr) then
        if(xn14s(l).eq.0) xn14s(l)=1.e-6
        cnr=xc12s(l)/xn14s(l)
        coher=((xc12s(l)/12.)+(xo16s(l)/16.))/(ysurf(l)/4.)
        if(xsurf(l).gt.0.1) then
          index=446
          goto 17 
        endif
        if(cnr.lt.10.) then
          index=447
          goto 17
        endif
        if(coher.lt.0.5) then
          index=448
          goto 17
        endif
        if(coher.lt.1.0) then
          index=449
          goto 17
        endif
        if(coher.ge.1.0) then
          index=450
          goto 17
        endif
17      call hillier(l,teff,radius)
      else
        call near(l,index)
        if(teff.lt.2000..or.teff.gt.60000.) then
           call planck(teff)
        else
          call kurucz(teff,blogg)
        endif
      endif
c
c PREPARE THE CONTINUUM GRID. FIRST THE FLUXES CORRESPONDING TO THE PRESELECTED
c LINE FREE WAVELENGTH GRID ARE COMPUTED. THEN AN AVERAGE OVER THREE POINTS IS
c DONE. A SPLINE FIT TO THE FLUXES AT THE 8 WAVELENGTH POINTS IS DONE TO 
c MATCH THE GRID OF THE 1415 POINTS OF THE LINE SPECTRUM. 
c
	do 456 jj=1,8
	freeflux(jj)=yntra(freelam(jj),wave,flam,1221)
	freeflux(jj)=
     *   alog10((freeflux(jj)+flam(imatch-1)+flam(imatch+1))/3.)
456	continue
c
	do 200 k=1,np1
	call intrpl(8,freelam,freeflux,1,wave_f(k),ffac(k))
        fluxc(l,k)=
     *       12.566*radius*radius/1.e20*10.**ffac(k)*dens(l)
        fluxl(l,k)=fli1(index,k)*fluxc(l,k) 
200     continue
10    continue
c
c SUMMATION OVER ALL MASSES AND GENERATIONS OF STARS.
c
      do 35 k=1,np1
      do 30 l=lmin,lmax
      tofluxl_fu(k)=tofluxl_fu(k)+fluxl(l,k)
      tofluxc_fu(k)=tofluxc_fu(k)+fluxc(l,k)
30    continue
35    continue
c
c CALCULATE THE NEBULAR CONTINUUM AND ADD TO THE STELLAR CONTINUUM.
c
	call continuum(time_in,icount,conti)
c
	do 70 m=1,np1
	fluneb2_fu(m)=yntra(wave_f(m),xrange,conti,26)
	tfluxl_fu(m)=tofluxl_fu(m)+fluneb2_fu(m)
	tfluxc_fu(m)=tofluxc_fu(m)+fluneb2_fu(m)
70	continue
c
c GENERATE THE OUTPUT FILE. UNIT = 86.
c
      if(mod(time_in,tdel).lt.tstep) then
c      
         do 505 k=1,np1
           write(86,500) time_in,wave_f(k),
     *     alog10(tfluxl_fu(k)+1.e-35)+20., 
     *     tfluxl_fu(k)/(tfluxc_fu(k)+1.e-35)
500	format(1x,e10.5,4x,f10.2,5x,f10.5,5x,f10.4)     
c      
c           write(860,6001)
c6001 	   format('  <datarow>')	   
c	   write(860,601) time_in
c601	   format('    <Time>',e10.5,'</Time>')
c	   write(860,602) wave_f(k)
c602	   format('    <Wavelength>',f10.2,'</Wavelength>')
c	   write(860,603) alog10(tfluxl_fu(k)+1.e-35)+20.
c603	   format('    <LogLUMIN>',f10.5,'</LogLUMIN>')	   
c	   write(860,604) tfluxl_fu(k)/(tfluxc_fu(k)+1.e-35)
c604	   format('    <NORMAL>',f10.4,'</NORMAL>')	   
c     	   write(860,606)
c606 	   format('  </datarow>')
505      continue
      endif
c
      return
      end
c
c
c ************************************************************************
c ************************************************************************
c ************************************************************************
c
        subroutine hires(time_in,icount)
c
c THIS SUBROUTINE COMPUTES A HIGH-RESOLUTION OPTICAL SPECTRUM FOR A 
c POPULATION OF STARS. THE LIBRARY IS BASED ON A SET OF MODEL ATMOSPHERES
c AND WAS DESCRIBED BY MARTINS ET AL. (2005).
c
c ************************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
        character*80 str_date
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        common/stars/dens,tonum
        common/flux/flam
        common/flux_hires/wave_hires,flam_hires_l,flam_hires_c,
     *                    flam1_hires_l,flam1_hires_c,nlej_lu,
     *                    tem_luci,glog_luci                
        common/hires_r/stflux_hires_l,stflux_hires_c,toflux_hires_l,
     *         toflux_hires_c,fluneb_hires
        common/nebula/xrange,gamma
        common/lejeuneinput/tem,glog,nlej,flam1,wave
        parameter (npgrid = 3000)
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *         bmdot(npgrid),grav(npgrid),cmass(npgrid),dens(npgrid),
     *         flam_hires_l(13323),flux_hires_l(npgrid,13323),
     *         toflux_hires_l(13323),toflux_hires_c(13323),
     *         flux_hires_c(npgrid,13323),wave_hires(13323),
     *         fluneb_hires(13323),xrange(26),conti(26),
     *         stflux_hires_l(13323),gamma(26),wave(1221),flam(1221),
     *         tt_star(npgrid),flam_hires_c(13323),flam1(1221,600),
     *         stflux_hires_c(13323),flam1_hires_l(13323,416),
     *         flam1_hires_c(13323,416),tem_luci(416),glog_luci(416),
     *         tem(600),glog(600)     
c 
c AT THE FIRST CALL TO THE ROUTINE THE LIBRARY WAVELENGTH GRID IS READ IN, 
c AND A HEADER FOR THE OUTPUT FILE IS GENERATED.
c
      if(icount.gt.1) goto 98      
c     
        write(82,96) name
96      format(' MODEL DESIGNATION: ',a20)
        call fdate(str_date)
        write(82,597) str_date
597     format(' MODEL GENERATED: ', a24)                        
        write(82,95)
95      format(/,'        COMPUTED SYNTHETIC LINE SPECTRUM [ERG/SEC/A]')
        write(82,94)
94      format(/,' TIME [YR]      WAVELENGTH  LOG(LUMINOSITY)  ',
     * 'NORMALIZED SPECTRUM')
c
c      write(820,960)
c960   format('<Hires>')      
c      write(820,961) name
c961    format('  <ModelDesignation>',a20,'</ModelDesignation>')
c      call fdate(str_date)
c      write(820,5971) str_date
c5971   format('  <ModelGeneratedOn>', a24,'</ModelGeneratedOn>')                           
c      write(820,950)
c950    format('  <Title>COMPUTED SYNTHETIC LINE SPECTRUM [ERG/SEC/A]',
c     *        '</Title>')
c      write(820,940)
c940    format('  <Columns>LogLUMIN/NORMAL</Columns>')    
c      
98      continue
c
c IF THERE IS NO CONTINUOUS STAR FORMATION, THE FLUX ACCUMULATORS
c ARE RESET FOR EACH TIME STEP, OTHERWISE THEY ARE RECALLED FROM
c THE PREVIOUS ITERATION.
c
       if(isf.gt.0 .and. icount.gt.1) then       
678	      continue
	else       
        do 50 m=1,13323
        stflux_hires_l(m)=0.
        stflux_hires_c(m)=0.
        toflux_hires_l(m)=0.
        toflux_hires_c(m)=0.
        fluneb_hires(m)=0.
50      continue
c
        endif
c
c CALCULATE THE EFFECTIVE TEMPERATURE AND LOG G FOR EACH MASS. THEN GET THE
c NUMBER OF PHOTONS PER UNIT SURFACE FOR EACH STAR. AFTERWARDS MULTIPLICATION
c BY THE STELLAR SURFACE AND THE STELLAR NUMBER DENSITY.
c
        do 10 l=lmin,lmax
c        
        if(bol(l).lt.-19.) then
        do 199 m=1,13323
        flux_hires_l(l,m) = 1.e-30
        flux_hires_c(l,m) = 1.e-30
199     continue
        goto 10
        endif        
        
        teff=10.**temp(l)
        grav(l)=alog10(zmass(l))+4.*temp(l)-bol(l)-10.6
        blogg=grav(l)
        radius = 10.**(10.8426 + 0.5*bol(l) - 2.*temp(l) + 7.52)
                if(bol(l). lt. -19.) goto 4000 
c
3200	if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr) then
c
           call hillier(l,teff,radius)
 	   do 701 m=1,13323
           flam_hires_l(m)=yntra(wave_hires(m),wave,flam,1221)
           flam_hires_c(m)=flam_hires_l(m)
701        continue
        else
           if(teff.lt.2000. ) then
 	        do 702 m=1,13323
                flam_hires_l(m)=yntra(wave_hires(m),wave,flam,1221)
                flam_hires_c(m)=flam_hires_l(m)                
702             continue
            else
                if(teff .lt. 3000.) then
                     call kurucz(teff,blogg)
 	             do 703 m=1,13323
                     flam_hires_l(m)=yntra(wave_hires(m),wave,flam,1221)
                     flam_hires_c(m)=flam_hires_l(m)
703                  continue                       
                else
                     call lucimara(teff,blogg)
                endif
           endif
        endif
c
4000	continue
c
        do 20 m=1,13323
           flux_hires_l(l,m)=
     *       12.566*radius*radius/1.e20*flam_hires_l(m)*dens(l)
           flux_hires_c(l,m)=
     *       12.566*radius*radius/1.e20*flam_hires_c(m)*dens(l)
           stflux_hires_l(m) = stflux_hires_l(m) + flux_hires_l(l,m)
           stflux_hires_c(m) = stflux_hires_c(m) + flux_hires_c(l,m)
20      continue
c
10	continue
c      
c CALCULATE THE NEBULAR CONTINUUM AND ADD TO THE STELLAR CONTINUUM.
c
        call continuum(time_in,icount,conti)
c
        do 70 m=1,13323
        fluneb_hires(m)=yntra(wave_hires(m),xrange,conti,26)
        toflux_hires_l(m)=stflux_hires_l(m)+fluneb_hires(m)
        toflux_hires_c(m)=stflux_hires_c(m)+fluneb_hires(m)
70      continue
c
c GENERATE THE OUTPUT FILE. UNIT = 82.
c
      if(mod(time_in,tdel).lt.tstep) then
c      
           write(82,500) (time_in,wave_hires(i),
     *     alog10(toflux_hires_l(i)+1.e-35)+20., 
     *     toflux_hires_l(i)/(toflux_hires_c(i)+1.e-35), 
     *     i=1,13323)
500     format(1x,e10.5,4x,f10.2,5x,f10.5,5x,f10.4)      
c      
c         do 505 i=1,13323
c           write(820,6001)
c6001 	   format('  <datarow>')	   
c	   write(820,601) time_in
c601	   format('    <Time>',e10.5,'</Time>')
c	   write(820,602) wave_hires(i)
c602	   format('    <Wavelength>',f10.2,'</Wavelength>')
c	   write(820,603) alog10(toflux_hires_l(i)+1.e-35)+20.
c603	   format('    <LogLUMIN>',f10.5,'</LogLUMIN>')	   
c	   write(820,604) toflux_hires_l(i)/(toflux_hires_c(i)+1.e-35)
c604	   format('    <NORMAL>',f10.4,'</NORMAL>')	   
c     	   write(820,606)
c606 	   format('  </datarow>')
c505      continue
      endif
c
        return
        end
       
c
c ***********************************************************************
c ***********************************************************************
c ***********************************************************************
c
	subroutine output
c
c	WRITES THE INPUT PARAMETERS TO A FILE.
c
c ***********************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
        character*9 str_date
        character*8 str_time
	character*10 zone
        integer*4 date_time(8)
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
        parameter (npgrid = 3000) 
        dimension cmass(npgrid)
c
	write(99,10001) name
10001	format(//,' MODEL DESIGNATION: ',a20)
        call date_and_time(str_date,str_time,zone,date_time)
        write(99,597) str_date,str_time
597     format(' MODEL GENERATED ON ',a9,' AT ',a8)
c
	write(99,10005) isf
10005   format(//,' CONTINUOUS STAR FORMATION (>0) OR FIXED MASS',
     *        ' (<=): ',/,i3)
	write(99,10006) toma
10006	format(' TOTAL STELLAR MASS (IF "FIXED MASS" IS CHOSEN): ',
     *         /,e10.3)
	write(99,10007) sfr
10007   format(' SFR(T=0) IF "CONT SF" IS CHOSEN: ',/,f12.2)
      write(99,10008) Ninterv
10008   format(' NUMBER OF INTERVALS FOR THE IMF: ',/,i3)
	write(99,10009) (xponent(i), i=1,Ninterv)
10009	format(' IMF EXPONENTS : ',/,10(f12.2))
	write(99,10011) (xmaslim(i), i=1,Ninterv+1)
10011 format(' MASS LIMITS FOR IMF [SOLAR MASSES]: ',/,11(f12.2))
	write(99,1011) sncut
1011	format(' SUPERNOVA CUT-OFF MASS: ',/,f12.2)
	write(99,1010) bhcut
1010    format(' BLACK HOLE CUT-OFF MASS: ',/,f12.2)
	write(99,10012) iz
10012   format(' METALLICITY + TRACKS: ',/,
     *  ' GENEVA STD:  11=0.001; 12=0.004; 13=0.008;',
     *  ' 14=0.020; 15=0.040',/,            
     *  ' GENEVA HIGH: 21=0.001; 22=0.004; 23=0.008;',
     *  ' 24=0.020; 25=0.040',/,
     *  ' PADOVA STD: 31=0.0004; 32=0.004; 33=0.008;',
     *  ' 34=0.020; 35=0.050',/,
     *  ' PADOVA AGB: 41=0.0004; 42=0.004; 43=0.008;',
     *  ' 44=0.020; 45=0.050',/,     
     *  ' GENEVA v00:  51=0.001; 52=0.002; 53=0.008;',
     *  ' 54=0.014; 55=0.040',/,                 
     *  ' GENEVA v40:  61=0.001; 62=0.002; 63=0.008;',
     *  ' 64=0.014; 65=0.040',/,i3)                      
	write(99,1012) iwind
1012	format(' WIND MODEL (0=MAEDER; 1=EMPIRICAL;',
     *         ' 2=THEOR.; 3=ELSON): ',/,I3)
	write(99,10013) time1
10013   format(' INITIAL TIME: ',/, e10.3)
	write(99,10014) jtime
10014	format(' TIME SCALE: LINEAR (=0) OR LOGARITHMIC (=1)',/,I3)
        if(jtime.eq.0) then
	 write(99,1014) tvar/1.e6
1014	 format(' TIME STEP [1.e6 YEARS] (IF JTIME=0) OR',/,
     *   ' NUMBER OF STEPS        (IF JTIME=1): ',/,f12.2)
        else
	 write(99,1015) ifix(tinter)
 1015    format(' TIME STEP [1.e6 YEARS] (IF JTIME=0) OR',/,
     *   ' NUMBER OF STEPS        (IF JTIME=1): ',/,i8)
        endif
	write(99,10015) tmax
10015	format(' LAST GRID POINT: ',/,e10.3)
	write(99,10016) jmg
10016   format(' SMALL (=0) OR LARGE (=1) MASS GRID;',/,
     *  ' ISOCHRONE ON  LARGE GRID (=2) OR FULL ISOCHRONE (=3): ',/,i3)
	write(99,10017) lmin,lmax
10017	format(' LMIN, LMAX (ALL = 0): ',/,2i6)
	write(99,1017) tdel
1017	format(' TIME STEP FOR PRINTING OUT THE SYNTHETIC SPECTRA',
     *           ': ',/,e10.3)
	write(99,1018) iatmos
1018	format(' MODEL ATMOSPHERE: 1=PLA, 2=LEJ,',
     *  ' 3=LEJ+SCH, 4=LEJ+SMI, 5=PAU+SMI',/,i3)
      write(99,10021) ilib
10021 format(' METALLICITY OF THE HIGH RESOLUTION MODELS',/,
     *  ' (1=0.001, 2=0.008, 3=0.020, 4=0.040):',/,i3)
        write(99,10020) iline
10020   format(' METALLICITY OF THE UV LINE SPECTRUM: (1=SOLAR,',
     *  ' 2=LMC/SMC)',/,i3)
        write(99,10018) ivt,irsg
10018   format(' RSG FEATURE: MICROTURB. VELOCITY (1-6),' ,
     *  ' SOLAR/NON-SOLAR ABUNDANCE (0,1)',/,i3,',',i1)
	write(99,10019) io1,io2,io3,io4,io5,io6,io7,io8,io9,io10,
     *                  io11,io12,io13,io14,io15
10019	format(' OUTPUT FILES (NO<0, YES >=0): ',/,15i3)
        close(1)
c
	return
	end
c
c **************************************************************************
c **************************************************************************
c ****************************************************************************
c
      function sp_feature(l,isel,teff,icount)
c
c CALCULATION OF SELECTED EMISSION AND ABSORPTION FEATURES IN THE SPECTRUM.
c CURRENTLY THE FOLLOWING FEATURES ARE SUPPORTED: CO INDEX IN THE DEFINITION 
c OF DOYON ET AL. (APJ, 421, 101 [1994]); CA IR TRIPLET EQUIVALENT WIDTH
c USING CALIBRATION OF DIAZ ET AL. (MNRAS, 239, 325 [1989]), STELLAR 
c LYMAN-ALPHA OF PENA-GUERRERO & LEITHERER (2013).
c 
c ****************************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
    	common/sp_feature_r/co162data,co229data,si159data,
     *                      co162nsdata,co229nsdata,si159nsdata,
     *                      origg,origt,xlyman_t,xlyman_g,xlyman   
        parameter (npgrid = 3000) 
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),grav(npgrid),feature(npgrid),
     *          origt(8),origg(5),co162data(8,5,6,5),
     *          co229data(8,5,6,5),si159data(8,5,6,5),
     *          co162nsdata(8,5,6,5),co229nsdata(8,5,6,5),
     *          si159nsdata(8,5,6,5),tt_star(npgrid),
     *		xlyman_t(23),xlyman_g(12),xlyman(12,23)
c
c FIRST: SET THE MICROTURBULENT VELOCITY (IMUTURB), AN INTEGER VARIABLE
c WITH PERMITTED VALUES 1,2,3,4,5,6 (UNITS KM/S).
c
	imuturb=ivt
c
c SECOND: SET THE INDICES TO SOLAR OR NONSOLAR ABUNDANCE RATIOS;
c USE INTEGER VARIABLE INSABUND; IF =0, THEN USE SOLAR ABUNDANCES; IF
c 1, USE NON-SOLAR ABUNDANCES
c
	insabund=irsg
c
c THIRD: RESET A TEMPORARY VARIABLE TTEMP AS TEFF AND GTEMP AS LOG G.  
c WE MUST NOT CHANGE TEFF AND LOG G BUT WE CAN CHANGE TTEMP AND GTMP!
c 
	ttemp=teff
	gtemp=alog10(zmass(l))+4.*temp(l)-bol(l)-10.6
c
c IF THIS IS THE FIRST TIME THE SUBROUTINE WAS CALLED, AND
c WE MUST INITIALIZE THE BIG ARRAYS IN LIVIA'S FEATURE DATA.
c
	if(icount.gt.1) goto 98
c
        do 4 ii=1,6
         do 3 jj=1,8
          do 2 kk=1,5
           do 1 ll=1,5
            if(co162data(jj,ll,ii,kk).le.0.)
     *co162data(jj,ll,ii,kk)=1.E-30
            if(co162nsdata(jj,ll,ii,kk).le.0.)
     *co162nsdata(jj,ll,ii,kk)=1.E-30
            if(co229data(jj,ll,ii,kk).le.0.)
     *co229data(jj,ll,ii,kk)=1.E-30
            if(co229nsdata(jj,ll,ii,kk).le.0.)
     *co229nsdata(jj,ll,ii,kk)=1.E-30
            if(si159data(jj,ll,ii,kk).le.0.)
     *si159data(jj,ll,ii,kk)=1.E-30
            if(si159nsdata(jj,ll,ii,kk).le.0.)
     *si159nsdata(jj,ll,ii,kk)=1.E-30
 1         continue
 2        continue
 3       continue
 4      continue
c
98	continue
c
c CHOOSE A FEATURE
c
c 1 = CO INDEX (DOYON)
c 2 = CA II IRT, ALL TEMPERATURES
c 3 = CA II IRT, ONLY FOR STARS WITH T<7200K
c 4 = CO 1.62 MICRON EQUIVALENT WIDTH, AFTER ORIGLIA
c 5 = CO 2.29 MICRON EQUIVALENT WIDTH, AFTER ORIGLIA
c 6 = SI 1.59 MICRON EQUIVALENT WIDTH, AFTER ORIGLIA
c 7 = LYMAN-ALPHA EQUIVALENT WIDTH, AFTER PENA-GUERRERO & LEITHERER
c
        if(isel.eq.1) goto 100
        if(isel.eq.2) goto 200
        if(isel.eq.3) goto 230
        if(isel.eq.4) goto 300
        if(isel.eq.5) goto 400
        if(isel.eq.6) goto 500
        if(isel.eq.7) goto 600
c
        goto 999
c
c THE CO INDEX IS CALCULATED FOLLOWING DOYON ET EL.
c       
100     if(teff.gt.6000.) then
        feature(l)=0.00
        else
        t4=teff/10000.
        if(bol(l).lt.0.3) feature(l)=0.866-2.95*t4+2.55*t4*t4
        if(bol(l).gt.3.)  feature(l)=1.353-2.80*t4
        if(bol(l).ge.0.3 .and. bol(l).le.3.) 
     *     feature(l)=1.530-5.01*t4+4.10*t4*t4
        if(feature(l).lt.0.0) feature(l)=0.0
        endif
c
        sp_feature=10.**(-0.4*feature(l))
c
        goto 999
c
c THE CA TRIPLET EQUIVALENT WIDTH IS CALCULATED FOLLOWING DIAZ ET AL.
c
200     grav(l)=alog10(zmass(l))+4.*temp(l)-bol(l)-10.6
        sp_feature=10.21-0.95*grav(l)+2.18*alog10(z)
c
        goto 999
c
c AS ABOVE, BUT WITH FEATURE SET TO 0 FOR T>7200
c
230     grav(l)=alog10(zmass(l))+4.*temp(l)-bol(l)-10.6
        if(teff.le.7200) then
        sp_feature=10.21-0.95*grav(l)+2.18*alog10(z)
        else 
        sp_feature=0
        endif
        goto 999
c
c THE 1.62 MICRON CO FEATURE EQ. WIDTH IS CALCULATED FOLLOWING
c ORIGLIA ET AL.  MICROTURBULENT VELOCITY == imuturb
c BE CAREFUL NOT TO GO PAST BOUNDARIES OF ORIGLIA'S MODELS.
c 
300	grav(l)=alog10(zmass(l))+4.*temp(l)-bol(l)-10.6
        if(z.eq.0.05)ind4=1
        if(z.eq.0.2)ind4=2
        if(z.eq.0.4)ind4=3
        if(z.eq.1.)ind4=4
        if(z.eq.2.)ind4=5
	if(teff.gt.5000.) go to 301
	if(bol(l).le.-10.) go to 301
	if(ttemp.lt.3000.)ttemp=3000.
	if(grav(l).gt.2.0)go to 301
	if(grav(l).le.0.) go to 302
	go to 303
 301 	sp_feature=0.
	go to 999
 302	if(insabund.eq.0)sp_feature=ynter2x(ttemp,0.01,origt,origg,
     *co162data,8,5,6,5,imuturb,ind4)
 	if(insabund.eq.1)sp_feature=ynter2x(ttemp,0.01,origt,origg,
     *co162nsdata,8,5,6,5,imuturb,ind4)
	go to 999
 303	if(insabund.eq.0)sp_feature=ynter2x(ttemp,grav(l),origt,origg,
     *co162data,8,5,6,5,imuturb,ind4)
 	if(insabund.eq.1)sp_feature=ynter2x(ttemp,grav(l),origt,origg,
     *co162nsdata,8,5,6,5,imuturb,ind4)
	goto 999
c
c THE 2.29 MICRON CO FEATURE EQ. WIDTH IS CALCULATED FOLLOWING
c ORIGLIA ET AL.  MICROTURBULENT VELOCITY == imuturb
c
400     grav(l)=alog10(zmass(l))+4.*temp(l)-bol(l)-10.6
        if(z.eq.0.05)ind4=1
        if(z.eq.0.2)ind4=2
        if(z.eq.0.4)ind4=3
        if(z.eq.1.)ind4=4
        if(z.eq.2.)ind4=5
        if(teff.gt.5000.) go to 401
	if(bol(l).le.-10.) go to 401
	if(ttemp.lt.3000.)ttemp=3000.
	if(grav(l).gt.2.0)go to 401
        if(grav(l).le.0.) go to 402
        go to 403
 401    sp_feature=0.
        go to 999
 402    if(insabund.eq.0)sp_feature=ynter2x(ttemp,0.01,origt,origg,
     *co229data,8,5,6,5,imuturb,ind4)
        if(insabund.eq.1)sp_feature=ynter2x(ttemp,0.01,origt,origg,
     *co229nsdata,8,5,6,5,imuturb,ind4)
        go to 999
 403    if(insabund.eq.0)sp_feature=ynter2x(ttemp,grav(l),origt,origg,
     *co229data,8,5,6,5,imuturb,ind4)
        if(insabund.eq.1)sp_feature=ynter2x(ttemp,grav(l),origt,origg,
     *co229nsdata,8,5,6,5,imuturb,ind4)
        goto 999
c
c THE 1.59 MICRON Si FEATURE EQ. WIDTH IS CALCULATED FOLLOWING
c ORIGLIA ET AL.  MICROTURBULENT VELOCITY == imuturb
c
500     grav(l)=alog10(zmass(l))+4.*temp(l)-bol(l)-10.6
	if(z.eq.0.05)ind4=1
	if(z.eq.0.2)ind4=2
	if(z.eq.0.4)ind4=3
	if(z.eq.1.)ind4=4
	if(z.eq.2.)ind4=5
        if(teff.gt.5000.) go to 501
	if(bol(l).le.-10.) go to 501
	if(ttemp.lt.3000.)ttemp=3000.
	if(grav(l).gt.2.0)go to 501
        if(grav(l).le.0.) go to 502
        go to 503
 501    sp_feature=0.
        go to 999
 502    if(insabund.eq.0)sp_feature=ynter2x(ttemp,0.01,origt,origg,
     *si159data,8,5,6,5,imuturb,ind4)
        if(insabund.eq.1)sp_feature=ynter2x(ttemp,0.01,origt,origg,
     *si159nsdata,8,5,6,5,imuturb,ind4)
        go to 999
 503    if(insabund.eq.0)sp_feature=ynter2x(ttemp,grav(l),origt,origg,
     *si159data,8,5,6,5,imuturb,ind4)
        if(insabund.eq.1)sp_feature=ynter2x(ttemp,grav(l),origt,origg,
     *si159nsdata,8,5,6,5,imuturb,ind4)
        goto 999
c
c CALCULATION OF LYMAN-ALPHA. 2-DIM INTERPOLATION IN TEFF AND LOG G. 
c VALID FOR TEFF > 10,000 K .BASED IN CMFGEN FOR O STARS AND TLUSTY FOR
c B STARS.
c
600     if(bol(l).le.-10.) go to 511
	if(ttemp.lt.10000.)go to 511
	if(ttemp.lt.15000.) then
	sp_feature=-420.*exp(-ttemp/6100.)
	goto 999
	endif
	if(ttemp.gt.50000.)ttemp=49999.
	if(gtemp.gt.4.5)gtemp=4.49
	if(gtemp.lt.1.75)gtemp=1.76
	go to 521
511     sp_feature=0.
        go to 999
521	sp_feature=ynter2(gtemp,ttemp,xlyman_g,xlyman_t,xlyman,12,23)	
c
999     return
        end
c
c ********************************************************************
c ********************************************************************
c ********************************************************************
c
	function wind1(l,ltype,ichoic)
c
c RETURNS THE WIND POWER AND MOMENTUM CALCULATED FROM THE MASS-LOSS 
c RATES AND TERMINAL VELOCITIES. THE MASS-LOSS RATES ARE TAKEN FROM 
c THE GENEVA TABULATION. TERMINAL VELOCITIES ARE BASED ON OBSERVATIONS.
c
c *************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        parameter (npgrid = 3000) 
        dimension cmass(npgrid)
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),tt_star(npgrid)
c
c MASS-LOSS RATES FROM GENEVA.
c
	if(bol(l).lt.-10. .or. bmdot(l).gt.-0.1) bmdot(l)=-30.
c
c OBSERVED TERMINAL VELOCITIES. FOUR GROUPS OF STARS ARE CONSIDERED:
c 1) FOR NORMAL HOT STARS (LOG TEFF > 3.9) WE USE EQ.(11) OF HOWARTH 
c    AND PRINJA (1989). 
c 2) FOR COOL STARS (LOG TEFF < 3.9) WE USE A GENERIC VALUE OF 
c    30 KM/SEC (DRAKE 1986).
c 3) FOR LBV'S (DEFINED VIA: 4.4 > LOG TEFF > 3.75 AND LOG MDOT > -3.5)
c    WE USE VINF = 200 KM/SEC.
c 4) FOR WR STARS (DEFINED VIA: LOG TEFF > 4.4 AND XSURF < 0.4 AND
C    M_INITIAL >= M_WR, WHERE M_WR=MASS LIMIT FOR WR FORMATION) WE
c    ADOPT THE AVERAGE VELOCITIES FROM PRINJA, BARLOW AND HOWARTH (1990).
c    SUBTYPE CLASSIFICATION IS DONE AS IN THE SPECTYPE SUBROUTINE
c ALL TERMINAL VELOCITIES EXCEPT THOSE  OF WR'S ARE SCALED WITH Z**0.13
c FOR DIFFERENT METALLICITIES.
c
	if(temp(l) .gt. 3.9 ) then
	gamma0=1.-2.7e-5*10.**bol(l)/zmass(l)
	if(gamma0 .le. 0.) gamma0= 1.e-10
        vinf=618.*sqrt(zmass(l)/
     *          (10.**(0.5*bol(l) - 2.*temp(l) + 7.52))*gamma0)*
     *          (0.58 + 2.04*(0.5*bol(l) - 2.*temp(l) + 7.52))
	ltype=1
	endif
c
	if(temp(l) .le. 3.9) then
	vinf=30.
	ltype=2
	endif
c
	if(temp(l) .lt. 4.4 .and. temp(l) .gt. 3.75 .and. bmdot(l)
     *     .gt. -3.5) then
	vinf=200.
	ltype=3
	endif
c
	if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr) then
	ltype=4
        if(xn14s(l).eq.0.) xn14s(l)=1.e-6
        cnr=xc12s(l)/xn14s(l)
        coher=((xc12s(l)/12.)+(xo16s(l)/16.))/(ysurf(l)/4.)
        if(xsurf(l).gt.0.1) then
         vinf=1650.
         goto 777
        endif
        if(cnr.lt.10.) then
         vinf=1900.
         goto 777
        endif
        if(coher.lt.0.5) then
         vinf=1800.
         goto 777
        endif
        if(coher.lt.1.0) then
         vinf=2800.
         goto 777
        endif
	if(coher.ge.1.0) then
         vinf=3500.
         goto 777
 	endif

	endif
c
	vinf=vinf*z**0.13
777	if(bol(l).lt.-10.) then
	vinf=1.e-10
	ltype=0
	endif
c
c
c CALCULATION OF THE WIND POWER AND THE WIND MOMENTUM. 3.155 COMES 
c FROM THE CONVERSION TO CGS. WIND1 WAS DIVIDED BY 10**35 TO AVOID 
c OVERFLOW.
c
	if (ichoic .eq. 1) wind1=10.**bmdot(l)*vinf*vinf*3.155
	if (ichoic .eq. 2) wind1=2.*10.**bmdot(l)*vinf*3.155e-5
	if (ichoic .eq. 3) wind1=10.**bmdot(l)
	if (ichoic .eq. 4) wind1=vinf
c
	return
	end
c
c *************************************************************
c *************************************************************
c *************************************************************
c
	function wind2(l,ltype,ichoic)
c
c RETURNS THE WIND POWER AND MOMENTUM CALCULATED FROM THE MASS-LOSS
c RATES AND TERMINAL VELOCITIES. THE MASS-LOSS RATES AND THE TERMINAL
c VELOCITIES ARE TAKEN FROM OBSERVATIONS.
c
c *************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        parameter (npgrid = 3000) 
        dimension cmass(npgrid)
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),tt_star(npgrid)
c
c OBSERVED MASS-LOSS RATES. FOUR GROUPS OF STARS ARE CONSIDERED:
c 1) FOR NORMAL HOT STARS (LOG TEFF > 3.9) WE USE EQ.(18) OF HOWARTH 
c    AND PRINJA (1989). 
c 2) FOR COOL STARS (LOG TEFF < 3.9) WE USE THE REIMERS (1975) RELATION. 
c 3) FOR LBV'S (DEFINED VIA: 4.4 > LOG TEFF > 3.75 AND LOG MDOT > -3.5)
c    WE USE MDOT = -3.9 (LAMERS 1989).
c 4) FOR WR STARS (DEFINED VIA: LOG TEFF > 4.4 AND XSURF < 0.4 AND
C    M_INITIAL >= M_WR, WHERE M_WR=MASS LIMIT FOR WR FORMATION) WE
c    ADOPT THE AVERAGE VALUES GIVEN BY VAN DER HUCHT, CASSINELLI
c    AND WILLIAMS (1986), MULTIPLIED BY 0.76 TO TAKE INTO ACOUNT THE
c    NEW VALUES OF Vinf BY PRINJA ET AL.
c
c ALL MASS-LOSS RATES EXCEPT THOSE  OF WR'S ARE SCALED WITH Z**0.80
c FOR DIFFERENT METALLICITIES.
c
c OBSERVED TERMINAL VELOCITIES. FOUR GROUPS OF STARS ARE CONSIDERED:
c 1) FOR NORMAL HOT STARS (LOG TEFF > 3.9) WE USE EQ.(11) OF HOWARTH 
c    AND PRINJA (1989). 
c 2) FOR COOL STARS (LOG TEFF < 3.9) WE USE A GENERIC VALUE OF 
c    30 KM/SEC (DRAKE 1986).
c 3) FOR LBV'S (DEFINED VIA: 4.4 > LOG TEFF > 3.75 AND LOG MDOT > -3.5)
c    WE USE VINF = 200 KM/SEC.
c 4) FOR WR STARS (DEFINED VIA: LOG TEFF > 4.4 AND XSURF < 0.4 AND 
C    M_INITIAL >= M_WR, WHERE M_WR=MASS LIMIT FOR WR FORMATION) WE
c    ADOPT THE AVERAGE VALUES GIVEN BY PRINJA, BARLOW AND WILLIS (1990)
c ALL TERMINAL VELOCITIES EXCEPT THOSE  OF WR'S ARE SCALED WITH Z**0.13
c FOR DIFFERENT METALLICITIES.
c
	if(temp(l) .gt. 3.9 ) then
	xloss=1.69*bol(l)-15.41
	gamma0=1.-2.7e-5*10.**bol(l)/zmass(l)
	if(gamma0 .le. 0.) gamma0= 1.e-10
        vinf=618.*sqrt(zmass(l)/
     *          (10.**(0.5*bol(l) - 2.*temp(l) + 7.52))*gamma0)*
     *          (0.58 + 2.04*(0.5*bol(l) - 2.*temp(l) + 7.52))
	ltype=1
	endif
c
	if(temp(l) .le. 3.9) then
	xloss=-12.26+1.5*bol(l)-2.*temp(l)+7.52-
     *           alog10(zmass(l)+1.e-20)
	vinf=30.
	ltype=2
	endif
c
	if(temp(l) .lt. 4.4 .and. temp(l) .gt. 3.75 .and. bmdot(l)
     *     .gt. -3.5) then
	xloss=-3.9
	vinf=200.
	ltype=3
	endif
c
	if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr) then
	ltype=4
        if(xn14s(l).eq.0.) xn14s(l)=1.e-6
        cnr=xc12s(l)/xn14s(l)
        coher=((xc12s(l)/12.)+(xo16s(l)/16.))/(ysurf(l)/4.)
        if(xsurf(l).gt.0.1) then
         vinf=1650.
	 xloss=-4.2
         goto 777
        endif
        if(cnr.lt.10.) then
         vinf=1900.
	 xloss=-4.5
         goto 777
        endif
        if(coher.lt.0.5) then
         vinf=1800.
	 xloss=-4.4
         goto 777
        endif
        if(coher.lt.1.0) then
         vinf=2800.
	 xloss=-4.7
         goto 777
        endif
	if(coher.ge.1.0) then
         vinf=3500.
	 xloss=-5.0
         goto 777
 	endif
c
	endif
c
	xloss=xloss+0.80*alog10(z)
	vinf=vinf*z**0.13	
777	if(bol(l).lt.-10. .or. bmdot(l).gt.-0.1) then
	xloss=-30.
	vinf=1.e-10
	ltype=0
	endif
c
c
c CALCULATION OF THE WIND POWER AND THE WIND MOMENTUM. 3.155 COMES 
c FROM THE CONVERSION TO CGS. WIND2 WAS DIVIDED BY 10**35 TO AVOID 
c OVERFLOW.
c
	if (ichoic .eq. 1) wind2=10.**xloss*vinf*vinf*3.155
	if (ichoic .eq. 2) wind2=2.*10.**xloss*vinf*3.155e-5
	if (ichoic .eq. 3) wind2=10.**xloss
	if (ichoic .eq. 4) wind2=vinf
c
	return
	end
c
c *************************************************************
c *************************************************************
c *************************************************************
c
	function wind3(l,ltype,ichoic)
c
c RETURNS THE WIND POWER AND MOMENTUM CALCULATED FROM THE MASS-LOSS
c RATES AND TERMINAL VELOCITIES. THE MASS-LOSS RATES AND THE TERMINAL
c VELOCITIES OF OB STARS ARE FROM THE CAK THEORY. MASS-LOSS RATES 
c AND TERMINAL VELOCITIES OF ALL OTHER STARS ARE TAKEN FROM OBSERVATIONS.
c
c *************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        parameter (npgrid = 3000) 
        dimension cmass(npgrid)
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),tt_star(npgrid)
c
c MASS-LOSS RATES. FOUR GROUPS OF STARS ARE CONSIDERED:
c 1) FOR NORMAL HOT STARS (LOG TEFF > 3.9) WE USE MDOT PREDICTED BY
c    THE CAK THEORY. 
c 2) FOR COOL STARS (LOG TEFF < 3.9) WE USE THE REIMERS (1975) RELATION. 
c 3) FOR LBV'S (DEFINED VIA: 4.4 > LOG TEFF > 3.75 AND LOG MDOT > -3.5)
c    WE USE MDOT = -3.9 (LAMERS 1989).
c 4) FOR WR STARS (DEFINED VIA: LOG TEFF > 4.4 AND XSURF < 0.4 AND
C    M_INITIAL >= M_WR, WHERE M_WR=MASS LIMIT FOR WR FORMATION) WE
c    ADOPT THE AVERAGE VALUES GIVEN BY VAN DER HUCHT ET AL (1986),
c    MULTIPLIED BY 0.76.
c
c ALL MASS-LOSS RATES EXCEPT THOSE  OF WR'S ARE SCALED WITH Z**0.80
c FOR DIFFERENT METALLICITIES.
c
c TERMINAL VELOCITIES. FOUR GROUPS OF STARS ARE CONSIDERED:
c 1) FOR NORMAL HOT STARS (LOG TEFF > 3.9) WE USE VINF PREDICTED BY
c    THE CAK THEORY. 
c 2) FOR COOL STARS (LOG TEFF < 3.9) WE USE A GENERIC VALUE OF 
c    30 KM/SEC (DRAKE 1986).
c 3) FOR LBV'S (DEFINED VIA: 4.4 > LOG TEFF > 3.75 AND LOG MDOT > -3.5)
c    WE USE VINF = 200 KM/SEC.
c 4) FOR WR STARS (DEFINED VIA: LOG TEFF > 4.4 AND XSURF < 0.4 AND
C    M_INITIAL >= M_WR, WHERE M_WR=MASS LIMIT FOR WR FORMATION)) WE
c    ADOPT THE VALUES GIVEN BY PRINJA, BARLOW AND HOWARTH (1990).
c
c ALL TERMINAL VELOCITIES EXCEPT THOSE  OF WR'S ARE SCALED WITH Z**0.13
c FOR DIFFERENT METALLICITIES.
c
	if(temp(l) .gt. 3.9 ) then
	xloss=2.45*bol(l)-1.10*alog10(1.e-20+zmass(l))+
     *           1.31*temp(l)-24.06
	vinf=10.**(-0.30*bol(l)+0.55*alog10(1.e-20+zmass(l))+
     *        0.64*temp(l)+1.23)
	ltype=1
	endif
c
	if(temp(l) .le. 3.9) then
	xloss=-12.26+1.5*bol(l)-2.*temp(l)+7.52-
     *           alog10(zmass(l)+1.e-20)
	vinf=30.
	ltype=2
	endif
c
	if(temp(l) .lt. 4.4 .and. temp(l) .gt. 3.75 .and. bmdot(l)
     *     .gt. -3.5) then
	xloss=-3.9
	vinf=200.
	ltype=3
	endif
c
	if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr) then
	ltype=4
        if(xn14s(l).eq.0.) xn14s(l)=1.e-6
        cnr=xc12s(l)/xn14s(l)
        coher=((xc12s(l)/12.)+(xo16s(l)/16.))/(ysurf(l)/4.)
        if(xsurf(l).gt.0.1) then
         vinf=1650.
	 xloss=-4.2
         goto 777
        endif
        if(cnr.lt.10.) then
         vinf=1900.
	 xloss=-4.5
         goto 777
        endif
        if(coher.lt.0.5) then
         vinf=1800.
	 xloss=-4.4
         goto 777
        endif
        if(coher.lt.1.0) then
         vinf=2800.
	 xloss=-4.7
         goto 777
        endif
	if(coher.ge.1.0) then
         vinf=3500.
	 xloss=-5.0
         goto 777
 	endif
c
	endif
c
	xloss=xloss+0.80*alog10(z)
	vinf=vinf*z**0.13	
777	if(bol(l).lt.-10. .or. bmdot(l).gt.-0.1) then
	xloss=-30.
	vinf=1.e-10
	ltype=0
	endif
c
c
c CALCULATION OF THE WIND POWER AND THE WIND MOMENTUM. 3.155 COMES 
c FROM THE CONVERSION TO CGS. WIND3 WAS DIVIDED BY 10**35 TO AVOID 
c OVERFLOW.
c
	if (ichoic .eq. 1) wind3=10.**xloss*vinf*vinf*3.155
	if (ichoic .eq. 2) wind3=2.*10.**xloss*vinf*3.155e-5
	if (ichoic .eq. 3) wind3=10.**xloss
	if (ichoic .eq. 4) wind3=vinf
c
	return
	end
c
c *************************************************************
c *************************************************************
c *************************************************************
c
	function wind4(l,ltype,ichoic)
c
c RETURNS THE WIND POWER AND MOMENTUM CALCULATED FROM THE MASS-LOSS
c RATES AND TERMINAL VELOCITIES. THE MASS-LOSS RATES AND THE TERMINAL
c VELOCITIES ARE TAKEN FROM OBSERVATIONS A LA ELSON ET AL. (1989).
c
c *************************************************************
c
	implicit real*4    (a-h,o-z)      
        character*20 name
        parameter (nmaxint=10,nmaxint1=11)
        common/parameters/time1,tstep,tmax,iz,toma,sfr,ninterv,
     *           xponent(nmaxint),upma,xmaslim(nmaxint1),doma,
     *           io1,io2,io3,io4,io5,io6,io7,io8,isf,name,jmg,z,
     *           iwind,sncut,bhcut,tdel,iatmos,ilib,iline,ivt,irsg,
     *           io9,io10,io11,io12,io13,io14,io15,xmwr,   
     *           iwrscale,iwrt,jtime,tvar,tiempo1,tinter
        common/mgrid/cmass,lmin,lmax,delm
        common/position/temp,bol,xsurf,zmass,ysurf,xc12s,xn14s,xo16s,
     *                bmdot,tt_star
        parameter (npgrid = 3000) 
        dimension cmass(npgrid)
        dimension temp(npgrid),bol(npgrid),xsurf(npgrid),zmass(npgrid),
     *         ysurf(npgrid),xc12s(npgrid),xn14s(npgrid),xo16s(npgrid),
     *          bmdot(npgrid),tt_star(npgrid)
c
c OBSERVED MASS-LOSS RATES. FOUR GROUPS OF STARS ARE CONSIDERED:
c 1) FOR NORMAL HOT STARS (LOG TEFF > 3.9) WE USE THE RELATION
c    OF ELSON ET AL. (1989)
c 2) FOR COOL STARS (LOG TEFF < 3.9) WE USE THE REIMERS (1975) RELATION. 
c 3) FOR LBV'S (DEFINED VIA: 4.4 > LOG TEFF > 3.75 AND LOG MDOT > -3.5)
c    WE USE MDOT = -3.9 (LAMERS 1989).
c 4) FOR WR STARS (DEFINED VIA: LOG TEFF > 4.4 AND XSURF < 0.4 AND
c    M_INITIAL >= M_WR, WHERE M_WR=MASS LIMIT FOR WR FORMATION) WE
c    ADOPT THE AVERAGE VALUES GIVEN BY VAN DER HUCHT, CASSINELLI
c    AND WILLIAMS (1986), MULTIPLIED BY 0.76 TO TAKE INTO ACOUNT THE
c    NEW VALUES OF Vinf BY PRINJA ET AL.
c
c ALL MASS-LOSS RATES EXCEPT THOSE  OF WR'S ARE SCALED WITH Z**0.80
c FOR DIFFERENT METALLICITIES.
c
c OBSERVED TERMINAL VELOCITIES. FOUR GROUPS OF STARS ARE CONSIDERED:
c 1) FOR NORMAL HOT STARS (LOG TEFF > 3.9) WE USE THE RELATION
c    OF ELSON ET AL. (1989)
c 2) FOR COOL STARS (LOG TEFF < 3.9) WE USE A GENERIC VALUE OF 
c    30 KM/SEC (DRAKE 1986).
c 3) FOR LBV'S (DEFINED VIA: 4.4 > LOG TEFF > 3.75 AND LOG MDOT > -3.5)
c    WE USE VINF = 200 KM/SEC.
c 4) FOR WR STARS (DEFINED VIA: LOG TEFF > 4.4 AND XSURF < 0.4 AND
C    M_INITIAL >= M_WR, WHERE M_WR=MASS LIMIT FOR WR FORMATION) WE
c    ADOPT THE AVERAGE VALUES GIVEN BY PRINJA, BARLOW AND WILLIS (1990)
c ALL TERMINAL VELOCITIES EXCEPT THOSE  OF WR'S ARE SCALED WITH Z**0.13
c FOR DIFFERENT METALLICITIES.
c
	if(temp(l) .gt. 3.9 ) then
	xloss=5.*alog10(cmass(l)+1.e-30) - 14.24
	vinf=1863.*cmass(l)**0.14
	ltype=1
	endif
c
	if(temp(l) .le. 3.9) then
	xloss=-12.26+1.5*bol(l)-2.*temp(l)+7.52-
     *           alog10(zmass(l)+1.e-20)
	vinf=30.
	ltype=2
	endif
c
	if(temp(l) .lt. 4.4 .and. temp(l) .gt. 3.75 .and. bmdot(l)
     *     .gt. -3.5) then
	xloss=-3.9
	vinf=200.
	ltype=3
	endif
c
	if(temp(l).gt.4.4.and.xsurf(l).lt.0.4.and.cmass(l).ge.xmwr) then
	ltype=4
        if(xn14s(l).eq.0.) xn14s(l)=1.e-6
        cnr=xc12s(l)/xn14s(l)
        coher=((xc12s(l)/12.)+(xo16s(l)/16.))/(ysurf(l)/4.)
        if(xsurf(l).gt.0.1) then
         vinf=1650.
	 xloss=-4.2
         goto 777
        endif
        if(cnr.lt.10.) then
         vinf=1900.
	 xloss=-4.5
         goto 777
        endif
        if(coher.lt.0.5) then
         vinf=1800.
	 xloss=-4.4
         goto 777
        endif
        if(coher.lt.1.0) then
         vinf=2800.
	 xloss=-4.7
         goto 777
        endif
	if(coher.ge.1.0) then
         vinf=3500.
	 xloss=-5.0
         goto 777
 	endif
c
	endif
c
	xloss=xloss+0.80*alog10(z)
	vinf=vinf*z**0.13	
777	if(bol(l).lt.-10. .or. bmdot(l).gt.-0.1) then
	xloss=-30.
	vinf=1.e-10
	ltype=0
	endif
c
c
c CALCULATION OF THE WIND POWER AND THE WIND MOMENTUM. 3.155 COMES 
c FROM THE CONVERSION TO CGS. WIND4 WAS DIVIDED BY 10**35 TO AVOID 
c OVERFLOW.
c
	if (ichoic .eq. 1) wind4=10.**xloss*vinf*vinf*3.155
	if (ichoic .eq. 2) wind4=2.*10.**xloss*vinf*3.155e-5
	if (ichoic .eq. 3) wind4=10.**xloss
	if (ichoic .eq. 4) wind4=vinf
c
	return
	end
c
c 
c ************************************************************
c ************************************************************
c ************************************************************
c
      subroutine polin2(x1a,x2a,ya,m,n,x1,x2,y,dy)
c
c 2-DIMENSIONAL INTERPOLATION ROUTINE FROM NUMERICAL RECIPIES.
c
c ***********************************************************************
c
      parameter (nmax=14,mmax=48)
      dimension x1a(m),x2a(n),ya(m,n),yntmp(nmax),ymtmp(mmax)
      dimension xx(100)
c
      do 10 j=1,m
      kk=0
      do 20 k=1,n
      kk=kk+1
      if(ya(j,k).lt.1.e-30) then
        kk=kk-1
        go to 100
      endif
      xx(kk)=x2a(k)
      yntmp(kk)=ya(j,k)
100   continue
20    continue
      minx=ismin(kk,xx,1)
      maxx=ismax(kk,xx,1)
      x3=x2
      if(x2.lt.xx(minx)) x3=xx(minx)
      if(x2.gt.xx(maxx)) x3=xx(maxx)
      ymtmp(j)=yntra(x3,xx,yntmp,kk)
10    continue
      y=yntra(x1,x1a,ymtmp,m)
c   
      return
      end
c
c *********************************************************************
c *********************************************************************
c *********************************************************************
c
        function ynter2(x,y,xd,yd,f,imax,jmax)
c
c GENERAL 2-D INTERPOLATION ROUTINE. (X,Y) IS THE POINT AT
c WHICH THE INTERPOLATION IS PERFORMED, XD AND YD ARE THE
c COORDINATE VECTORS, WHICH HAVE DIMENSIONS IMAX AND JMAX,
c AND F IS THE FUNCTION TO BE INTERPOLATED. BOTH XD AND YD
c MUST BE ENTERED IN ASCENDING ORDER.
c
c **********************************************************************
c
        implicit real*4 (a-h,o-z)
        dimension xd(imax),yd(jmax),f(imax,jmax)
        data i,j/1,1/
        if(x-xd(1)) 15,16,16
16      continue
        if(x-xd(imax)) 17,17,15
17      continue
        if(i.ge.imax) i=1
        if(i.lt.1) i=1
c
        if(y-yd(1)) 15,18,18
18      continue
        if(y-yd(jmax)) 19,19,15
19      continue
        if(j.ge.jmax) j=1
        if(j.lt.1) j=1
c
        if(xd(i)-x) 10,11,12
10      continue
        i=i+1
        if(xd(i)-x) 10,11,13
13      continue
        i=i-1
        goto 14
12      continue
        i=i-1
        if(xd(i)-x) 14,11,12
11      continue
        i1=i
        fax=0.
        goto 30
14      continue
        i1=i+1
        fax=(x-xd(i))/(xd(i1)-xd(i))
30      continue
        if(yd(j)-y) 20,21,22
20      continue
        j=j+1
        if(yd(j)-y) 20,21,23
23      continue
        j=j-1
        goto 24
22      continue
        j=j-1
        if(yd(j)-y) 24,21,22
21      continue
        j1=j
        fay=0.
        goto 31
24      continue
        j1=j+1
        fay=(y-yd(j))/(yd(j1)-yd(j))
31      continue
        t1=(1.-fax)*(1.-fay)*f(i,j)
        t2=fax*(1.-fay)*f(i1,j)
        t3=fay*(1.-fax)*f(i,j1)
        t4=fax*fay*f(i1,j1)
        ynter2=t1+t2+t3+t4
        return
15      continue
        write(6,900) x,y
900     format(' ***** ERROR IN YNTER2 ***** X,Y:',1p2d12.4)
        stop
        end
c
c *********************************************************************
c *********************************************************************
c *********************************************************************
c
        function ynter2x(x,y,xd,yd,f,imax,jmax,ind3max,ind4max,
     *                   ind3,ind4)
c
c GENERAL 2-D INTERPOLATION ROUTINE. (X,Y) IS THE POINT AT
c WHICH THE INTERPOLATION IS PERFORMED, XD AND YD ARE THE
c COORDINATE VECTORS, WHICH HAVE DIMENSIONS IMAX AND JMAX,
c AND F IS THE FUNCTION TO BE INTERPOLATED. BOTH XD AND YD
c MUST BE ENTERED IN ASCENDING ORDER.
c THIS ROUTINE HAS BEEN MODIFIED FROM THE ORIGINAL YNTER2 TO
c HANDLE FUNCTIONS WITH MORE THAN 2 DIMENSIONS, ALTHOUGH IT
c STILL INTERPOLATES IN ONLY TWO DIMENSIONS.  THESE TWO NEW
c DIMENSIONS ARE KNOWN AS ind3 (INDEX 3) AND ind4 (INDEX4)
c
c ****************************************************************************
c
        implicit real*4 (a-h,o-z)
        dimension xd(imax),yd(jmax),f(imax,jmax,ind3max,ind4max)
        data i,j/1,1/
        if(x-xd(1)) 15,16,16
16      continue
        if(x-xd(imax)) 17,17,15
17      continue
        if(i.ge.imax) i=1
        if(i.lt.1) i=1
c
        if(y-yd(1)) 15,18,18
18      continue
        if(y-yd(jmax)) 19,19,15
19      continue
        if(j.ge.jmax) j=1
        if(j.lt.1) j=1
c
        if(xd(i)-x) 10,11,12
10      continue
        i=i+1
        if(xd(i)-x) 10,11,13
13      continue
        i=i-1
        goto 14
12      continue
        i=i-1
        if(xd(i)-x) 14,11,12
11      continue
        i1=i
        fax=0.
        goto 30
14      continue
        i1=i+1
        fax=(x-xd(i))/(xd(i1)-xd(i))
30      continue
        if(yd(j)-y) 20,21,22
20      continue
        j=j+1
        if(yd(j)-y) 20,21,23
23      continue
        j=j-1
        goto 24
22      continue
        j=j-1
        if(yd(j)-y) 24,21,22
21      continue
        j1=j
        fay=0.
        goto 31
24      continue
        j1=j+1
        fay=(y-yd(j))/(yd(j1)-yd(j))
31      continue
        t1=(1.-fax)*(1.-fay)*f(i,j,ind3,ind4)
        t2=fax*(1.-fay)*f(i1,j,ind3,ind4)
        t3=fay*(1.-fax)*f(i,j1,ind3,ind4)
        t4=fax*fay*f(i1,j1,ind3,ind4)
        ynter2x=t1+t2+t3+t4
        return
15      continue
        write(6,900) x,y
900     format(' ***** ERROR IN YNTER2X ***** X,Y:',1p2d12.4)
        stop
        end
c
c ************************************************************
c *************************************************************
c *************************************************************
c
      function yntra(r,rw,fu,imax)
c
c 1-DIMENSIONAL LINEAR INTERPOLATION ROUTINE. R IS THE POINT WHERE THE
c INTERPOLATION IS PERFORMED. RW IS THE VECTOR CONTAINING THE X VALUES
c OF THE FUNCTION TO BE INTERPOLATED. RW MUST BE INCREASING. FU IS THE
c VECTOR CONTAINING THE FUNCTION FOR INTERPOLATION. IMAX IS THE NUMBER
c OF ELEMENTS IN RW AND FU.
c
c **********************************************************************
c
      implicit real*4(a-h,o-z)
      common/match/imatch
      dimension rw(imax),fu(imax)
      data i/1/
      if(r-rw(1)) 15,16,16
16    continue
      if(r-rw(imax)) 17,17,15
17    continue
      if(i.ge.imax) i=1
      if(i.lt.1) i=1
      if(rw(i)-r) 10,11,12
10    continue
      i=i+1
      if(rw(i)-r) 10,11,13
13    continue
      i=i-1
      goto 14
12    continue
      i=i-1
      if(rw(i)-r) 14,11,12
14    continue
      i1=i+1
      fak=(r-rw(i))/(rw(i1)-rw(i))
      yntra=fu(i)+(fu(i1)-fu(i))*fak
      imatch=i
      return
11    continue
      yntra=fu(i)
      imatch=i
101   continue
      return
15    continue
      write(6,900) r
900   format(' ***** ERROR IN YNTRA ***** R:',e12.4)
	write(6,*)rw,fu
      stop
      end
c
c ******************************************************************************
c ******************************************************************************
c ******************************************************************************
c
	function reci_polint(x,ndata,xdata,fdata)
c
c PERFORMS A QUADRATIC INTERPOLATION. CALLS ROUTINE POLINT FROM NUMERICAL
c RECIPES.
c
c *****************************************************************************
c
        implicit real*4(a-h,o-z)
	dimension xdata(ndata),fdata(ndata)
c
	idegree=2
	call locate(xdata,ndata,x,j)
	if(j.eq.0 .or. j.eq.ndata) then
		write(6,99)
99		format(' ERROR IN RECI_POLINT')
		stop 
	endif
	if(abs(x-xdata(j)).lt.abs(x-xdata(j+1))) then
		if(j.ne.1) j=j-1
	endif
c
	if(j.gt.ndata-idegree) then
		j=ndata-idegree
	endif
	call polint(xdata(j),fdata(j),idegree+1,x,y,dy)
	reci_polint=y
	return
	end 
c
c ******************************************************************************
c ******************************************************************************
c ******************************************************************************
c
	subroutine polint(xa,ya,n,x,y,dy)
c
c LINEAR INTERPOLATION ROUTINE FROM NUMERICAL RECIPES.
c
c *****************************************************************************
c
	integer n,nmax
	real dy,x,y,xa(n),ya(n)
	parameter (nmax=100) 
	integer i,m,ns
	real den,dif,dift,ho,hp,w,c(nmax),d(nmax)
c
	ns=1
	dif=abs(x-xa(1))
	do i=1,n 
		dift=abs(x-xa(i))
		if (dift.lt.dif) then
			ns=i
			dif=dift
		endif
		c(i)=ya(i)
		d(i)=ya(i)
	enddo
	y=ya(ns)
	ns=ns-1
	do m=1,n-1
		do i=1,n-m
			ho=xa(i)-x
			hp=xa(i+m)-x
			w=c(i+1)-d(i)
			den=ho-hp
			if(den.eq.0.)pause
			den=w/den
			d(i)=hp*den
			c(i)=ho*den
		enddo
		if (2*ns.lt.n-m)then
			dy=c(ns+1)
		else
			dy=d(ns)
			ns=ns-1
		endif
		y=y+dy
	enddo
c
	return
	end
c
c ******************************************************************************
c ******************************************************************************
c ******************************************************************************
c
	subroutine locate(xx,n,x,j)
c
c SEARCHES IN AN ORDERED TABLE. FROM NUMERICAL RECIPES (MODIFIED).
c
c *****************************************************************************
c
	integer j,n,jl,jm,ju
	real x,xx(n)
c
	jl=0
	ju=n+1
10	if(ju-jl.gt.1)then
		jm=(ju+jl)/2
		if((xx(n).gt.xx(1)).eqv.(x.gt.xx(jm)))then
			jl=jm
		else
			ju=jm
		endif
	go to 10
	endif
c
c TREAT BOUNDARY CASE SEPARATELY. ADDED TO NUM REC ROUTINE
c
	j=min(n,jl)
	j=max(jl,1)
c
	return
	end
c
c *****************************************************************************
c *****************************************************************************
c *****************************************************************************
c
      subroutine intrpl(l,x,y,n,u,v)
c
c ALGORITHM 433 FROM COLLECTED ALGORITHMS FROM CACM.
c     "INTERPOLATION AND SMOOTH CURVE FITTING BASED ON LOCAL PROCEDURES"
c     [E2], H. AKIMA
c
c     INTERPOLATION OF A SINGLE-VALUED FUNCTION
c
c     THE INPUT PARAMETERS ARE
c         L  = NUMBER OF INPUT DATA POINTS
c              (MUST BE 2 OR GREATER)
c         X  = ARRAY OF DIMENSION L STORING THE X VALUES
c              (ABSCISSAS) OF INPUT DATA POINTS  
c              (IN ASCENDING ORDER)
c         Y  = ARRAY OF DIMENSION L STORING THE Y VALUES
c              (ORDINATES) OF INPUT DATA POINTS  
c         N  = NUMBER OF POINTS AT WHICH INTERPOLATION OF THE
c              Y VALUE (ORDINATE) IS DESIRED
c              (MUST BE 1 OR GREATER)
c         U  = ARRAY OF DIMENSION N STORING THE X VALUES
c              (ABSCISSAS) OF DESIRED POINTS  
c
c     THE OUTPUT PARAMETER IS
c         V  = ARRAY OF DIMENSION N WHERE THE INTERPOLATED Y
c              VALUES (ORDINATES) ARE TO BE DISPLAYED
c
c *****************************************************************************
c
      implicit real*4(a-h,o-z)
      dimension    x(l),y(l),u(n),v(n)
      equivalence  (p0,x3),(q0,y3),(q1,t3)
      real         m1,m2,m3,m4,m5
      equivalence  (uk,dx),(imn,x2,a1,m1),(imx,x5,a5,m5),
     *             (j,sw,sa),(y2,w2,w4,q2),(y5,w3,q3)
c
c PRELIMINARY PROCESSING
c
 10   l0  = l
      lm1 = l0  - 1
      lm2 = lm1 - 1
      lp1 = l0  + 1
      n0  = n
      if (lm2.lt.0)       goto 90
      if (n0.le.0)        goto 91
      do 11   i=2,l0
        if (x(i-1)-x(i))  11,95,96
 11   continue
      ipv = 0
c
c MAIN DO-LOOP
c
      do 80  k=1,n0
        uk=u(k)
c
c ROUTINE TO LOCATE THE DESIRED POINT
c
 20     if (lm2.eq.0)     goto 27
        if (uk.ge.x(l0))  goto 26
        if (uk.lt.x(1))   goto 25
        imn = 2
        imx = l0
 21     i = (imn+imx)/2
        if (uk.ge.x(i))   goto 23
 22     imx = i
        goto 24
 23     imn = i + 1
 24     if (imx.gt.imn)   goto 21
        i = imx
        goto 30
 25     i = 1
        goto 30
 26     i = lp1
        goto 30
 27     i = 2
c
c CHECK IF I = IPV
c
 30     if (i.eq.ipv)    goto 70
        ipv = i 
c
c ROUTINES TO PICK UP NECESSARY X AND Y VALUES AND 
c          TO ESTIMATE THEM IF NECESSARY
c
 40     j = i
        if (j.eq.1)      j=2
        if (j.eq.lp1)    j=l0
        x3 = x(j-1)
        y3 = y(j-1)
        x4 = x(j)
        y4 = y(j)
        a3 = x4 - x3
        m3 = (y4-y3)/a3
        if (lm2.eq.0)    goto 43
        if (j.eq.2.)     goto 41
        x2 = x(j-2)
        y2 = y(j-2)
        a2 = x3 - x2
        m2 = (y3-y2)/a2
        if (j.eq.l0)     goto 42
c
 41     x5 = x(j+1)
        y5 = y(j+1)
        a4 = x5 - x4
        m4 = (y5-y4)/a4
        if (j.eq.2)      m2 = m3 + m3 - m4
        goto 45
 42     m4 = m3 + m3 - m2
        goto 45
 43     m2 = m3
        m4 = m3
 45     if (j.le.3)      goto 46
        a1 = x2 - x(j-3)
        m1 = (y2 - y(j-3))/a1
        goto 47
 46     m1 = m2 + m2 -m3
 47     if (j.ge.lm1)    goto 48
        a5 = x(j+2) - x5
        m5 = (y(j+2) - y5)/a5
        goto 50
 48     m5 = m4 + m4 -m3
c
c NUMERICAL DIFFERENTIATION
c
 50     if (i.eq.lp1)    goto 52
        w2 = abs(m4-m3)
        w3 = abs(m2-m1)
        sw = w2 + w3
        if (sw.ne.0.0)   goto 51
        w2 = 0.5
        w3 = 0.5
        sw = 1.0
 51     t3 = (w2*m2 + w3*m3) / sw
        if (i.eq.1)      goto 54
 52     w3 = abs(m5-m4)
        w4 = abs(m3-m2)
        sw = w3 + w4
        if (sw.ne.0.0)   goto 53
        w3 = 0.5
        w4 = 0.5
        sw = 1.0
 53     t4 = (w3*m3 + w4*m4) / sw
        if (i.ne.lp1)    goto 60
        t3 = t4
        sa = a2 + a3
        t4 = 0.5*(m4+m5-a2*(a2-a3)*(m2-m3)/(sa*sa))
        x3 = x4
        y3 = y4
        a3 = a2
        m3 = m4
        goto 60
 54     t4 = t3
        sa = a3 + a4
        t3 = 0.5*(m1+m2-a4*(a3-a4)*(m3-m4)/(sa*sa))
        x3 = x3 - a4
        y3 = y3 - m2*a4
        a3 = a4
        m3 = m2
c
c DETERMINATION OF THE COEFFICIENTS
c
 60     q2 = (2.0*(m3-t3)+m3-t4)/a3
        q3 = (-m3-m3+t3+t4)/(a3*a3)
c
c COMPUTATION OF THE POLYNOMIAL
c
 70     dx = uk - p0
 80     v(k) = q0 + dx*(q1+dx*(q2+dx*q3))
      return
c
c ERROR EXIT
c
 90   write (6,2090)
      goto 99
 91   write (6,2091)
      goto 99
 95   write (6,2095)
      goto 97
 96   write (6,2096)
 97   write (6,2097)  i,x(i)
 99   write (6,2099)  l0,n0
      return
c
c FORMAT STATEMENTS
c      
 2090 format (1x/22h  ***   L = 1 OR LESS./)
 2091 format (1x/22h  ***   N = 1 OR LESS./)
 2095 format (1x/27h  ***   IDENTICAL X VALUES./)
 2096 format (1x/33h  ***   X VALUES OUT OF SEQUENCE./)
 2097 format (6h   i =,i7,10x,6hx(i) =,e12.3)
ctls(linux)  "," at the end of the lines of format
 2099 format (6h   l =,i7,10x,3hn =,i7/,
     1        36h ERROR DETECTED IN ROUTINE    INTRPL)
      end
c
c
c *****************************************************************************
c *****************************************************************************
c *****************************************************************************
c
      subroutine fliwgt (x,y,weight,sum,ndim)
c
c LINEAR INTEGRATION OF FUNCTION Y(X), WHERE X(NDIM) AND Y(NDIM)
c USING THE TRAPEZIUM RULE. WEIGHT(X) CONTAINS THE INTEGRATION
c WEIGHT CONTRIBUTION AT X.
c NOTE: X(NDIM) CONTAIN DECREASING VALUES, THUS: X(1) > X(2) > ..
c                                                    .. X(NDIM)
c *****************************************************************************
c
      implicit real*4    (a-h,o-z)
      real*4 x(ndim),y(ndim),weight(ndim)
c
      weight(1)    = (x(1)-x(2))/2.
      sum          = weight(1)*y(1)
      do i = 2,ndim-1
         weight(i) = (x(i-1)-x(i+1))/2.
         sum       = sum + weight(i)*y(i)
      end do
      weight(ndim) = (x(ndim-1)-x(ndim))/2.
      sum          = sum + weight(ndim)*y(ndim)
c
      return
      end
c
c *********************************************************************
c *********************************************************************
c *********************************************************************
c
      function ismin(n,x,idummy)
c
c RETURNS THE SMALLEST INDEX I SUCH THAT X_I=MIN_{1<=J<=N}(X_J)
c IF N<=0 THE FUNCTION RETURNS ZERO.
c
c *********************************************************************
c
      implicit real*4(a-h,o-z)
      real x(n),xmin
      integer n,i,idummy,ismin
c
      if (n.le.0) then
         ismin = 0
         return
      endif
c
      xmin = 1.e+34
      do i = n,1,-1
         if (x(i).le.xmin) then
            ismin = i
            xmin  = x(i)
         endif
      enddo
c
      return
      end
c
c *********************************************************************
c *********************************************************************
c *********************************************************************
c
      function ismax(n,x,idummy)
c
c RETURNS THE SMALLEST INDEX I SUCH THAT X_I=MAX_{1<=J<=N}(X_J)
c IF N<=0 THE FUNCTION RETURNS ZERO.
c
c *********************************************************************
c
      implicit real*4(a-h,o-z)
      real x(n),xmax
      integer n,i,idummy,ismax
c
      if (n.le.0) then
         ismax = 0
         return
      endif
c
      xmax = -1.e+38
      do i = n,1,-1
         if (x(i).ge.xmax) then
            ismax = i
            xmax  = x(i)
         endif
      enddo
c
      return
      end
c
c **********************************************************************
c **********************************************************************
c **********************************************************************
c
      subroutine errpri(name)
c
c PRINTS NAME OF SUBROUTINE WHERE ERROR OCCURRED.
c
c **********************************************************************
c
	character name*(*)
	write (6,*) name
c      
	return
	end
c
c ****************************************************************************
c ****************************************************************************
c ****************************************************************************
c
	subroutine linterp(x1,y1,n1,x2,y2,n2)
c
c LINEAR INTERPOLATION OF THE VECTOR X2 IN (X1,Y1) YIELDING Y2.
c X1 HAS TO BE MONOTONOUSLY INCREASING OR DECREASING.
c THE DIMENSION OF THE VECTORS X1,Y1 IS N1; THAT OF X2,Y2 IS N2.
c
c *****************************************************************************
c
      implicit real*4(a-h,o-z)
      dimension x1(n1),y1(n1),x2(n2),y2(n2)
      integer i,k,pos
c      
      do i=1,n2
         k=pos(x2(i),x1,n1)
         y2(i)=flin(x1(k),x1(k+1),y1(k),y1(k+1),x2(i))
      enddo
c
      return
      end
c  
c ****************************************************************************
c ****************************************************************************
c ****************************************************************************
c
	integer function pos(x0,x,m)
c
c DETERMINES THE POSITION OF THE POINT X0 IN A MONOTONOUSLY INCREASING
c OR DECREASING VECTOR X OF DIMENSION M.
c RETURNS K = POS(X0,X,M) SUCH THAT X(K) <= X0 < X(K+1)
c IF X0 IS OUTSIDE THE RANGE GIVEN BY X ONE HAS AT EXIT:
c   POS = 1   IF X0 IS ON THE SIDE OF X(1) AND
c   POS = M-1 IF X0 IS ON THE SIDE OF X(M)
c
c **************************************************************************** 
c
      implicit real*4(a-h,o-z)
      dimension x(m)
c
      n=0
      k=m+1
    1 if(k-n.gt.1) then
        i = (k+n)/2
        if((x(m).gt.x(1)).eqv.(x0.gt.x(i))) then
           n=i
        else
           k=i
        endif
        goto 1
      endif
      n=max(1,n)
      n=min(m-1,n)
      pos = n
c
      return
      end
c     
c ****************************************************************************
c ****************************************************************************
c ****************************************************************************
c      
	function flin(x1,x2,y1,y2,x0)
c
c PERFORMS A LINEAR INTERPOLATION OR EXTRAPOLATION BETWEEN TWO POINTS
c (X1,Y1) AND (X2,Y2). X0 IS THE CORDINATE OF THE DESIRED INTERPOLATION
c POINT, THE RETURNED VALUE IS FLIN.
c
c ****************************************************************************
c
      implicit real*4(a-h,o-z)
c
      a12  = x1 - x2
      a01  = x0 - x1
      a02  = x0 - x2
c
      flin =  (a02 * y1 - a01 * y2)/a12
c
      return
      end
c
c ****************************************************************************
c ****************************************************************************
c ****************************************************************************
c
      function yparinterp(xint,x,y,n,ntot,lup,iii,ntot2)
c
c MIGUEL CERVINO, TOULOUSE, 1999. PARABOLIC INTERPOLATION ROUTINE. DETERMINES
c YINT = Y(XINT) FROM A GRID Y(X) USING THE FIRST N POINTS WITH DIMENSION NTOT.
c NOTES:
c  i)   xINT is always in the interval k,k+1 
c       lup=false: use k-1, k and k+1 for the interpolation 
c       lup=true:  use k, k+1 and k+2 for the interpolation 
c  ii)  Parabolic interpolation if:
c       MAX(Y(x1),Y(x2),Y(x3))  >=  Y(XINT) >= MIN(Y(x1),Y(x2),y(x3)) 
c       Linear otherwise or if there are only two points
c  iii) If XINT = X(1) or XINT = X(N) the routine will not work!!!
c       This is supposed to be checked prior to calling YPARINTERP
c
c ****************************************************************************
c
      implicit real*4(a-h,o-z)
      dimension x(ntot),y(ntot,ntot2)
      logical lup
c
c BISECTION (SEE NUMERICAL RECIPES SECTION 3.4, PAGE 90). OBTAIN K,
c WHERE X IS IN THE INTERVAL X(N) AND X(N+1).
c
	JL = 0
	JU = N+1
 10	IF (JU-JL.GT.1) THEN
	  JM = (JU+JL)/2
	  IF ((X(N).GT.X(1)).EQV.(XINT.GT.X(JM))) THEN
            JL = JM
	  ELSE
            JU = JM
	  END IF
	  GO TO 10
	END IF
	J = JL
c	IF (J.EQ.0.OR.J.EQ.N) CALL ERRPRI 
c	1    ('YPARINTERP: EXTRAPOLATION')
c
        if(j.eq.0) then
           yparinterp=y(1,iii)
           return
        endif
        if(j.eq.n) then
           yparinterp=y(n,iii)
           return
        endif

        if(xint.eq.x(1)) then
          yparinterp=y(1,iii)
          return
        endif
        if(xint.eq.x(n)) then
          yparinterp=y(n,iii)
          return
        endif
c
c LINEAR INTERPOLATION IF WITHIN THE BOUNDARIES
c
	k=j
	if(j.eq.1) then
	  if(x(j).eq.x(j+1)) then
	    YPARINTERP = y(j,iii)
	    return
	  else
	    if(x(j+1).eq.x(j+2)) then
	      YPARINTERP = y(j,iii)+((y(j+1,iii)-y(j,iii))
     $              *(XINT-x(j))/(x(j+1)-x(j)))
	      return
	    else
	      k=2
	      lup=.false.
	    endif
	  endif
	endif
c	
c PARABOLIC INTERPOLATION CASE
c
	if(j.eq.n-1) then
	  if(x(j).eq.x(j+1)) then
	    YPARINTERP = y(j,iii)
	    return
	  else
	    if(x(j-1).eq.x(j+1)) then
	      YPARINTERP = y(j,iii)+((y(j+1,iii)-y(j,iii))
     $              *(XINT-x(j))/(x(j+1)-x(j)))
	      return
	    else
	      k=j
	      lup=.false.
	    endif
	  endif
	endif

	if(x(k).eq.x(k+1)) then
	  YPARINTERP = y(k,iii)
	  return
	else
	  if(lup) then
	    if(x(k+1).eq.x(k+2).or.x(k).eq.x(k+2)) then
	      YPARINTERP = y(k,iii)+((y(k+1,iii)-y(k,iii))
     $              *(XINT-x(k))/(x(k+1)-x(k)))
	      return
	    else
	      help1=(y(k,iii)-y(k+1,iii))/
     $              ((x(k)-x(k+1))*(x(k)-x(k+2)))
	      help2=(y(k+1,iii)-y(k+2,iii))
     $             /((x(k+1)-x(k+2))*(x(k)-x(k+2)))
	      A=help1-help2
	      B=(help2*(x(k)+x(k+1)))-(help1*(x(k+1)+x(k+2)))
	      C=y(k+1,iii)-(A*(x(k+1)**2.))-(b*x(k+1))
	      YPARINTERP = (A*(XINT**2.))+(B*XINT)+C

	      ylintest = y(k,iii)+((y(k+1,iii)-y(k,iii))
     $             *(XINT-x(k))/(x(k+1)-x(k)))
              ymax=max(y(k,iii),y(k+1,iii),y(k+2,iii))
              ymin=min(y(k,iii),y(k+1,iii),y(k+2,iii))
c              if(yparinterp.gt.ymax.or.yparinterp.lt.ymin) 
c     $             YPARINTERP=ylintest
	      return
	    endif
	  else
	    if(x(k-1).eq.x(k).or.x(k-1).eq.x(k+1)) then
	      YPARINTERP = y(k,iii)+((y(k+1,iii)-y(k,iii))
     $              *(XINT-x(k))/(x(k+1)-x(k)))
	      return
	    else
	      help1=(y(k-1,iii)-y(k,iii))
     $              /((x(k-1)-x(k))*(x(k-1)-x(k+1)))
	      help2=(y(k,iii)-y(k+1,iii))
     $             /((x(k)-x(k+1))*(x(k-1)-x(k+1)))
	      A=help1-help2
	      B=(help2*(x(k-1)+x(k)))-(help1*(x(k)+x(k+1)))
	      C=y(k,iii)-(A*(x(k)**2.))-(b*x(k))
	      YPARINTERP = (A*(XINT**2.))+(B*XINT)+C
	      ylintest = y(k,iii)+((y(k+1,iii)-y(k,iii))
     $             *(XINT-x(k))/(x(k+1)-x(k)))
              ymax=max(y(k-1,iii),y(k,iii),y(k+1,iii))
              ymin=min(y(k-1,iii),y(k,iii),y(k+1,iii))
c              if(yparinterp.gt.ymax.or.yparinterp.lt.ymin) 
c     $             YPARINTERP=ylintest
	      return
	    endif
	  endif
	endif
c
	end
c
c
c ****************************************************************************
c ****************************************************************************
c ****************************************************************************
c
        block data
c
c "FILTER" CONTAINS THE FILTER PROFILES FOR THE SYNTHETIC COLORS.
c "NEBULA" CONTAINS THE FF, FB, AND 2-PHOT EMISSION COEFFICIENTS FOR H AND HE.
c "YIELDS" CONTAINS THE CHEMICAL YIELDS FOR TYPE II SUPERNOVAE.
c
c *****************************************************************
c
      implicit real*4(a-h,o-z)
      common/nebula/xrange,gamma	
      common/filter/xprof,yprof
      common/yields/ymass,yh,yhe,yc,yn,yo,ymg,ysi,ys,yfe
      dimension xprof(12,100),yprof(12,100),xrange(26),
     *          gamma(26),
     *          ymass(5,12),yh(5,12),yhe(5,12),yc(5,12),yn(5,12),
     *          yo(5,12),ymg(5,12),ysi(5,12),ys(5,12),yfe(5,12)
c
c
c FILTER PROFILE FOR UIT_B1
c
	data xprof(1,1),xprof(1,2),xprof(1,3),xprof(1,4),
     *       xprof(1,5),xprof(1,6),xprof(1,7),xprof(1,8),
     *       xprof(1,9),xprof(1,10),xprof(1,11),xprof(1,12),
     *       xprof(1,13),xprof(1,14),xprof(1,15),xprof(1,16),
     *       xprof(1,17),xprof(1,18),xprof(1,19),xprof(1,20),
     *       xprof(1,21),xprof(1,22),xprof(1,23),xprof(1,24),
     *       xprof(1,25),xprof(1,26),xprof(1,27),xprof(1,28),
     *       xprof(1,29),xprof(1,30),xprof(1,31),xprof(1,32),
     *       xprof(1,33),xprof(1,34),xprof(1,35),xprof(1,36),
     *       xprof(1,37),xprof(1,38),xprof(1,39),xprof(1,40),
     *       xprof(1,41),xprof(1,42),xprof(1,43),xprof(1,44),
     *       xprof(1,45),xprof(1,46),xprof(1,47),xprof(1,48),
     *       xprof(1,49),xprof(1,50),xprof(1,51),xprof(1,52),
     *       xprof(1,53),xprof(1,54),xprof(1,55),xprof(1,56),
     *       xprof(1,57),xprof(1,58),xprof(1,59),xprof(1,60),
     *       xprof(1,61),xprof(1,62),xprof(1,63),xprof(1,64),
     *       xprof(1,65),xprof(1,66),xprof(1,67),xprof(1,68),
     *       xprof(1,69),xprof(1,70),xprof(1,71),xprof(1,72),
     *       xprof(1,73),xprof(1,74),xprof(1,75),xprof(1,76),
     *       xprof(1,77),xprof(1,78),xprof(1,79),xprof(1,80),
     *       xprof(1,81),xprof(1,82),xprof(1,83),xprof(1,84),
     *       xprof(1,85),xprof(1,86),xprof(1,87),xprof(1,88),
     *       xprof(1,89),xprof(1,90),xprof(1,91),xprof(1,92),
     *       xprof(1,93),xprof(1,94),xprof(1,95),xprof(1,96),
     *       xprof(1,97),xprof(1,98),xprof(1,99)/
     *       50.,100.,200.,400.,600.,700.,800.,900.,
     *	     1000.,1020.75,1059.03,1118.07,1181.76,1223.62,1256.56,
     *       1273.4,
     *       1279.54,1286.78,1287.59,1294.19,1297.58,1303.93,1309.54,
     *       1319.91,
     *       1339.78,1360.53,1383.31,1415.32,1433.99,1475.48,1505.79,
     *       1526.79,
     *       1540.22,1555.82,1577.71,1603.53,1617.76,1632.4,1645.99,
     *       1662.1,
     *       1674.22,1701.23,1723.18,1748.62,1776.94,1804.67,1843.5,
     *       1874.54,
     *       1917.08,1974.99,2031.15,2080.52,2116.29,2156.72,2200.,
     *       2300.,
     *       2400.,2500.,2750.,3000.,3250.,3500.,3750.,3800.,
     *       3850.,3900.,3950.,4000.,4050.,4100.,4150.,4200.,
     *       4250.,4300.,4350.,4400.,4450.,4500.,4550.,4600.,
     *       4650.,4700.,4750.,4800.,4850.,4900.,4950.,5000.,
     *       5050.,5100.,5150.,5200.,5250.,5300.,5350.,5400.,
     *       5450.,5500.,2000000./
	data yprof(1,1),yprof(1,2),yprof(1,3),yprof(1,4),
     *       yprof(1,5),yprof(1,6),yprof(1,7),yprof(1,8),
     *       yprof(1,9),yprof(1,10),yprof(1,11),yprof(1,12),
     *       yprof(1,13),yprof(1,14),yprof(1,15),yprof(1,16),
     *       yprof(1,17),yprof(1,18),yprof(1,19),yprof(1,20),
     *       yprof(1,21),yprof(1,22),yprof(1,23),yprof(1,24),
     *       yprof(1,25),yprof(1,26),yprof(1,27),yprof(1,28),
     *       yprof(1,29),yprof(1,30),yprof(1,31),yprof(1,32),
     *       yprof(1,33),yprof(1,34),yprof(1,35),yprof(1,36),
     *       yprof(1,37),yprof(1,38),yprof(1,39),yprof(1,40),
     *       yprof(1,41),yprof(1,42),yprof(1,43),yprof(1,44),
     *       yprof(1,45),yprof(1,46),yprof(1,47),yprof(1,48),
     *       yprof(1,49),yprof(1,50),yprof(1,51),yprof(1,52),
     *       yprof(1,53),yprof(1,54),yprof(1,55),yprof(1,56),
     *       yprof(1,57),yprof(1,58),yprof(1,59),yprof(1,60),
     *       yprof(1,61),yprof(1,62),yprof(1,63),yprof(1,64),
     *       yprof(1,65),yprof(1,66),yprof(1,67),yprof(1,68),
     *       yprof(1,69),yprof(1,70),yprof(1,71),yprof(1,72),
     *       yprof(1,73),yprof(1,74),yprof(1,75),yprof(1,76),
     *       yprof(1,77),yprof(1,78),yprof(1,79),yprof(1,80),
     *       yprof(1,81),yprof(1,82),yprof(1,83),yprof(1,84),
     *       yprof(1,85),yprof(1,86),yprof(1,87),yprof(1,88),
     *       yprof(1,89),yprof(1,90),yprof(1,91),yprof(1,92),
     *       yprof(1,93),yprof(1,94),yprof(1,95),yprof(1,96),
     *       yprof(1,97),yprof(1,98),yprof(1,99)/
     *       0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,
     *       0.000,8.24571E-4,5.89848E-4,0.00101411,0.00128996,
     *       0.00249922,0.00943542,0.0203621,0.040092,0.0685947,
     *       0.101941,0.156772,0.216,0.311201,0.394995,0.518268,
     *       0.711285,0.835409,0.920037,0.976559,1.000,0.995273,
     *       0.961847,0.920986,0.864348,0.813408,0.711992,0.608811,
     *       0.580253,0.569246,0.568333,0.570925,0.555097,0.490965,
     *       0.410172,0.299971,0.195028,0.13221,0.0715576,0.0429568,
     *       0.0283679,0.0128621,0.00745285,0.00513256,0.00284696,
     *       0.00318229,
     *       0.000,0.000,0.000,0.000,0.000,0.000,
     *       0.000,0.000,0.000,0.000,0.000,0.000,
     *       0.000,0.000,0.000,0.000,0.000,0.000,
     *       0.000,0.000,0.000,0.000,0.000,0.000,
     *       0.000,0.000,0.000,0.000,0.000,0.000,
     *       0.000,0.000,0.000,0.000,0.000,0.000,
     *       0.000,0.000,0.000,0.000,0.000,0.000,
     *       0.000,0.000,0.000/
c
c FILTER PROFILE FOR F210M.
c
	data xprof(2,1),xprof(2,2),xprof(2,3),xprof(2,4),
     *       xprof(2,5),xprof(2,6),xprof(2,7),xprof(2,8),
     *       xprof(2,9),xprof(2,10),xprof(2,11),xprof(2,12),
     *       xprof(2,13),xprof(2,14),xprof(2,15),xprof(2,16),
     *       xprof(2,17),xprof(2,18),xprof(2,19),xprof(2,20),
     *       xprof(2,21),xprof(2,22),xprof(2,23),xprof(2,24),
     *       xprof(2,25),xprof(2,26),xprof(2,27),xprof(2,28),
     *       xprof(2,29),xprof(2,30),xprof(2,31),xprof(2,32),
     *       xprof(2,33),xprof(2,34),xprof(2,35),xprof(2,36),
     *       xprof(2,37),xprof(2,38),xprof(2,39),xprof(2,40),
     *       xprof(2,41),xprof(2,42),xprof(2,43),xprof(2,44),
     *       xprof(2,45),xprof(2,46),xprof(2,47),xprof(2,48),
     *       xprof(2,49),xprof(2,50),xprof(2,51),xprof(2,52),
     *       xprof(2,53),xprof(2,54),xprof(2,55),xprof(2,56),
     *       xprof(2,57),xprof(2,58),xprof(2,59),xprof(2,60),
     *       xprof(2,61),xprof(2,62),xprof(2,63),xprof(2,64),
     *       xprof(2,65),xprof(2,66),xprof(2,67),xprof(2,68),
     *       xprof(2,69),xprof(2,70),xprof(2,71),xprof(2,72),
     *       xprof(2,73),xprof(2,74),xprof(2,75),xprof(2,76),
     *       xprof(2,77),xprof(2,78),xprof(2,79),xprof(2,80),
     *       xprof(2,81),xprof(2,82),xprof(2,83),xprof(2,84),
     *       xprof(2,85),xprof(2,86),xprof(2,87),xprof(2,88),
     *       xprof(2,89),xprof(2,90)/
     *       50.,1560.,1600.,1650.,1700.,1750.,1800.,1850.,
     *       1900.,1950.,2000.,2050.,2100.,2150.,2200.,2250.,
     *       2300.,2350.,2400.,2450.,2500.,2550.,2600.,2650.,
     *       2700.,2750.,2800.,2850.,2900.,2950.,3000.,3050.,
     *       3100.,3150.,3200.,3250.,3300.,3350.,3400.,3450.,
     *       3500.,3550.,3600.,3650.,3700.,3750.,3800.,3850.,
     *       3900.,3950.,4000.,4050.,4100.,4150.,4200.,4250.,
     *       4300.,4350.,4400.,4450.,4500.,4550.,4600.,4650.,
     *       4700.,4750.,4800.,4850.,4900.,4950.,5000.,5050.,
     *       5100.,5150.,5200.,5250.,5300.,5350.,5400.,5460.,
     *       5500.,5550.,5600.,5650.,5700.,5750.,5800.,5850.,
     *       5900.,2000000./
	data yprof(2,1),yprof(2,2),yprof(2,3),yprof(2,4),
     *       yprof(2,5),yprof(2,6),yprof(2,7),yprof(2,8),
     *       yprof(2,9),yprof(2,10),yprof(2,11),yprof(2,12),
     *       yprof(2,13),yprof(2,14),yprof(2,15),yprof(2,16),
     *       yprof(2,17),yprof(2,18),yprof(2,19),yprof(2,20),
     *       yprof(2,21),yprof(2,22),yprof(2,23),yprof(2,24),
     *       yprof(2,25),yprof(2,26),yprof(2,27),yprof(2,28),
     *       yprof(2,29),yprof(2,30),yprof(2,31),yprof(2,32),
     *       yprof(2,33),yprof(2,34),yprof(2,35),yprof(2,36),
     *       yprof(2,37),yprof(2,38),yprof(2,39),yprof(2,40),
     *       yprof(2,41),yprof(2,42),yprof(2,43),yprof(2,44),
     *       yprof(2,45),yprof(2,46),yprof(2,47),yprof(2,48),
     *       yprof(2,49),yprof(2,50),yprof(2,51),yprof(2,52),
     *       yprof(2,53),yprof(2,54),yprof(2,55),yprof(2,56),
     *       yprof(2,57),yprof(2,58),yprof(2,59),yprof(2,60),
     *       yprof(2,61),yprof(2,62),yprof(2,63),yprof(2,64),
     *       yprof(2,65),yprof(2,66),yprof(2,67),yprof(2,68),
     *       yprof(2,69),yprof(2,70),yprof(2,71),yprof(2,72),
     *       yprof(2,73),yprof(2,74),yprof(2,75),yprof(2,76),
     *       yprof(2,77),yprof(2,78),yprof(2,79),yprof(2,80),
     *       yprof(2,81),yprof(2,82),yprof(2,83),yprof(2,84),
     *       yprof(2,85),yprof(2,86),yprof(2,87),yprof(2,88),
     *       yprof(2,89),yprof(2,90)/
     *       0.00000,1.100000E-5,1.500000E-5,6.569375E-4,
     *       0.002499,0.0043185,0.006729,0.01055731,0.017402,
     *       0.03081538,0.058369,0.1074872,0.16234,0.1766188,
     *       0.13964,0.08547843,0.044227,0.021833,0.011164,
     *       0.006002937,0.003446,0.002087813,0.001318,
     *       0.001060367,7.696876E-4,5.875626E-4,4.570000E-4,
     *       3.730391E-4,3.055625E-4,2.648360E-4,2.150000E-4,
     *       1.755469E-4,1.469375E-4,1.247969E-4,1.150000E-4,
     *       1.047813E-4,9.337501E-5,9.111719E-5,8.400000E-5,
     *       9.158595E-5,8.893750E-5,8.791406E-5,8.500000E-5,
     *       8.960938E-5,8.406250E-5,8.532032E-5,8.600000E-5,
     *       8.421875E-5,8.706250E-5,8.919532E-5,8.400000E-5,
     *       8.406251E-5,8.568750E-5,8.461718E-5,8.300000E-5,
     *       8.933593E-5,8.525000E-5,8.485157E-5,9.200000E-5,
     *       8.856250E-5,8.856250E-5,8.714845E-5,9.100000E-5,
     *       8.611720E-5,9.231250E-5,9.361719E-5,9.200000E-5,
     *       8.950782E-5,9.300001E-5,8.869531E-5,9.100000E-5,
     *       9.494532E-5,9.418750E-5,9.080469E-5,9.200000E-5,
     *       9.051563E-5,9.474999E-5,9.522657E-5,9.400000E-5,
     *       9.525000E-5,9.487500E-5,9.788281E-5,1.050000E-4,
     *       9.500782E-5,1.198125E-4,1.095938E-4,1.060000E-4,
     *       1.271563E-4,1.435625E-4,0.0000/
c
c FILTER PROFILE FOR U.
c
	data xprof(3,1),xprof(3,2),xprof(3,3),xprof(3,4),
     *       xprof(3,5),xprof(3,6),xprof(3,7),xprof(3,8),
     *       xprof(3,9),xprof(3,10),xprof(3,11),xprof(3,12),
     *       xprof(3,13),xprof(3,14),xprof(3,15),xprof(3,16),
     *       xprof(3,17),xprof(3,18),xprof(3,19),xprof(3,20),
     *       xprof(3,21),xprof(3,22),xprof(3,23),xprof(3,24),
     *       xprof(3,25),xprof(3,26)/
     *       50.,3050.,3100.,3150.,3200.,3250.,3300.,3350.,
     *       3400.,3450.,3500.,3550.,3600.,3650.,3700.,3750.,
     *       3800.,3850.,3900.,3950.,4000.,4050.,4100.,4150.,
     *       4200.,2000000./
	data yprof(3,1),yprof(3,2),yprof(3,3),yprof(3,4),
     *       yprof(3,5),yprof(3,6),yprof(3,7),yprof(3,8),
     *       yprof(3,9),yprof(3,10),yprof(3,11),yprof(3,12),
     *       yprof(3,13),yprof(3,14),yprof(3,15),yprof(3,16),
     *       yprof(3,17),yprof(3,18),yprof(3,19),yprof(3,20),
     *       yprof(3,21),yprof(3,22),yprof(3,23),yprof(3,24),
     *       yprof(3,25),yprof(3,26)/
     *       0.000,0.000,0.020,0.077,0.135,0.204,0.282,0.385,
     *       0.493,0.600,0.705,0.820,0.900,0.959,0.993,1.000,
     *       0.975,0.850,0.645,0.400,0.223,0.125,0.057,0.005,
     *       0.000,0.000/
c
c FILTER PROFILE FOR B (USED FOR U-B)).
c
	data xprof(4,1),xprof(4,2),xprof(4,3),xprof(4,4),
     *       xprof(4,5),xprof(4,6),xprof(4,7),xprof(4,8),
     *       xprof(4,9),xprof(4,10),xprof(4,11),xprof(4,12),
     *       xprof(4,13),xprof(4,14),xprof(4,15),xprof(4,16),
     *       xprof(4,17),xprof(4,18),xprof(4,19),xprof(4,20),
     *       xprof(4,21),xprof(4,22),xprof(4,23),xprof(4,24),
     *       xprof(4,25),xprof(4,26),xprof(4,27),xprof(4,28),
     *       xprof(4,29),xprof(4,30),xprof(4,31),xprof(4,32),
     *       xprof(4,33),xprof(4,34),xprof(4,35),xprof(4,36),
     *       xprof(4,37),xprof(4,38),xprof(4,39),xprof(4,40),
     *       xprof(4,41),xprof(4,42)/
     *       50.,3600.,3650.,3700.,3750.,3800.,3850.,3900.,
     *       3950.,4000.,4050.,4100.,4150.,4200.,4250.,4300.,
     *       4350.,4400.,4450.,4500.,4550.,4600.,4650.,4700.,
     *       4750.,4800.,4850.,4900.,4950.,5000.,5050.,5100.,
     *       5150.,5200.,5250.,5300.,5350.,5400.,5450.,5500.,
     *       5550.,2000000./
	data yprof(4,1),yprof(4,2),yprof(4,3),yprof(4,4),
     *       yprof(4,5),yprof(4,6),yprof(4,7),yprof(4,8),
     *       yprof(4,9),yprof(4,10),yprof(4,11),yprof(4,12),
     *       yprof(4,13),yprof(4,14),yprof(4,15),yprof(4,16),
     *       yprof(4,17),yprof(4,18),yprof(4,19),yprof(4,20),
     *       yprof(4,21),yprof(4,22),yprof(4,23),yprof(4,24),
     *       yprof(4,25),yprof(4,26),yprof(4,27),yprof(4,28),
     *       yprof(4,29),yprof(4,30),yprof(4,31),yprof(4,32),
     *       yprof(4,33),yprof(4,34),yprof(4,35),yprof(4,36),
     *       yprof(4,37),yprof(4,38),yprof(4,39),yprof(4,40),
     *       yprof(4,41),yprof(4,42)/
     *       0.000,0.000,0.006,0.023,0.045,0.106,0.254,0.492,
     *       0.752,0.881,0.923,0.955,0.977,0.990,1.000,1.000,
     *       0.997,0.984,0.958,0.916,0.871,0.820,0.775,0.723,
     *       0.672,0.617,0.569,0.511,0.457,0.402,0.347,0.299,
     *       0.244,0.199,0.154,0.113,0.084,0.051,0.029,0.010,
     *       0.000,0.000/
c
c FILTER PROFILE FOR B (USED FOR B-V)).
c
	data xprof(5,1),xprof(5,2),xprof(5,3),xprof(5,4),
     *       xprof(5,5),xprof(5,6),xprof(5,7),xprof(5,8),
     *       xprof(5,9),xprof(5,10),xprof(5,11),xprof(5,12),
     *       xprof(5,13),xprof(5,14),xprof(5,15),xprof(5,16),
     *       xprof(5,17),xprof(5,18),xprof(5,19),xprof(5,20),
     *       xprof(5,21),xprof(5,22),xprof(5,23),xprof(5,24),
     *       xprof(5,25),xprof(5,26),xprof(5,27),xprof(5,28),
     *       xprof(5,29),xprof(5,30),xprof(5,31),xprof(5,32),
     *       xprof(5,33),xprof(5,34),xprof(5,35),xprof(5,36),
     *       xprof(5,37),xprof(5,38),xprof(5,39),xprof(5,40),
     *       xprof(5,41),xprof(5,42)/
     *       50.,3600.,3650.,3700.,3750.,3800.,3850.,3900.,
     *       3950.,4000.,4050.,4100.,4150.,4200.,4250.,4300.,
     *       4350.,4400.,4450.,4500.,4550.,4600.,4650.,4700.,
     *       4750.,4800.,4850.,4900.,4950.,5000.,5050.,5100.,
     *       5150.,5200.,5250.,5300.,5350.,5400.,5450.,5500.,
     *       5550.,2000000./
	data yprof(5,1),yprof(5,2),yprof(5,3),yprof(5,4),
     *       yprof(5,5),yprof(5,6),yprof(5,7),yprof(5,8),
     *       yprof(5,9),yprof(5,10),yprof(5,11),yprof(5,12),
     *       yprof(5,13),yprof(5,14),yprof(5,15),yprof(5,16),
     *       yprof(5,17),yprof(5,18),yprof(5,19),yprof(5,20),
     *       yprof(5,21),yprof(5,22),yprof(5,23),yprof(5,24),
     *       yprof(5,25),yprof(5,26),yprof(5,27),yprof(5,28),
     *       yprof(5,29),yprof(5,30),yprof(5,31),yprof(5,32),
     *       yprof(5,33),yprof(5,34),yprof(5,35),yprof(5,36),
     *       yprof(5,37),yprof(5,38),yprof(5,39),yprof(5,40),
     *       yprof(5,41),yprof(5,42)/
     *       0.000,0.000,0.006,0.030,0.060,0.134,0.302,0.567,
     *       0.841,0.959,0.983,0.996,1.000,0.996,0.987,0.974,
     *       0.957,0.931,0.897,0.849,0.800,0.748,0.698,0.648,
     *       0.597,0.545,0.497,0.447,0.397,0.345,0.297,0.252,
     *       0.207,0.166,0.129,0.095,0.069,0.043,0.024,0.009,
     *       0.000,0.000/
c
c FILTER PROFILE FOR V.
c
	data xprof(6,1),xprof(6,2),xprof(6,3),xprof(6,4),
     *       xprof(6,5),xprof(6,6),xprof(6,7),xprof(6,8),
     *       xprof(6,9),xprof(6,10),xprof(6,11),xprof(6,12),
     *       xprof(6,13),xprof(6,14),xprof(6,15),xprof(6,16),
     *       xprof(6,17),xprof(6,18),xprof(6,19),xprof(6,20),
     *       xprof(6,21),xprof(6,22),xprof(6,23),xprof(6,24),
     *       xprof(6,25),xprof(6,26),xprof(6,27),xprof(6,28),
     *       xprof(6,29),xprof(6,30),xprof(6,31),xprof(6,32),
     *       xprof(6,33),xprof(6,34),xprof(6,35),xprof(6,36),
     *       xprof(6,37),xprof(6,38),xprof(6,39),xprof(6,40),
     *       xprof(6,41),xprof(6,42),xprof(6,43),xprof(6,44),
     *       xprof(6,45),xprof(6,46),xprof(6,47),xprof(6,48),
     *       xprof(6,49),xprof(6,50),xprof(6,51),xprof(6,52),
     *       xprof(6,53),xprof(6,54),xprof(6,55),xprof(6,56)/
     *       50.,4750.,4800.,4850.,4900.,4950.,5000.,5050.,
     *       5100.,5150.,5200.,5250.,5300.,5350.,5400.,5450.,
     *       5500.,5550.,5600.,5650.,5700.,5750.,5800.,5850.,
     *       5900.,5950.,6000.,6050.,6100.,6150.,6200.,6250.,
     *       6300.,6350.,6400.,6450.,6500.,6550.,6600.,6650.,
     *       6700.,6750.,6800.,6850.,6900.,6950.,7000.,7050.,
     *       7100.,7150.,7200.,7250.,7300.,7350.,7400.,
     *       2000000./
	data yprof(6,1),yprof(6,2),yprof(6,3),yprof(6,4),
     *       yprof(6,5),yprof(6,6),yprof(6,7),yprof(6,8),
     *       yprof(6,9),yprof(6,10),yprof(6,11),yprof(6,12),
     *       yprof(6,13),yprof(6,14),yprof(6,15),yprof(6,16),
     *       yprof(6,17),yprof(6,18),yprof(6,19),yprof(6,20),
     *       yprof(6,21),yprof(6,22),yprof(6,23),yprof(6,24),
     *       yprof(6,25),yprof(6,26),yprof(6,27),yprof(6,28),
     *       yprof(6,29),yprof(6,30),yprof(6,31),yprof(6,32),
     *       yprof(6,33),yprof(6,34),yprof(6,35),yprof(6,36),
     *       yprof(6,37),yprof(6,38),yprof(6,39),yprof(6,40),
     *       yprof(6,41),yprof(6,42),yprof(6,43),yprof(6,44),
     *       yprof(6,45),yprof(6,46),yprof(6,47),yprof(6,48),
     *       yprof(6,49),yprof(6,50),yprof(6,51),yprof(6,52),
     *       yprof(6,53),yprof(6,54),yprof(6,55),yprof(6,56)/
     *       0.000,0.000,0.030,0.084,0.163,0.301,0.458,0.630,
     *       0.780,0.895,0.967,0.997,1.000,0.988,0.958,0.919,
     *       0.877,0.819,0.765,0.711,0.657,0.602,0.545,0.488,
     *       0.434,0.386,0.331,0.289,0.250,0.214,0.181,0.151,
     *       0.120,0.093,0.069,0.051,0.036,0.027,0.021,0.018,
     *       0.016,0.014,0.012,0.011,0.010,0.009,0.008,0.007,
     *       0.006,0.005,0.004,0.003,0.002,0.001,0.000,0.000/
c
c FILTER PROFILE FOR R (BESSELL 1990).
c
	data xprof(7,1),xprof(7,2),xprof(7,3),xprof(7,4),
     *       xprof(7,5),xprof(7,6),xprof(7,7),xprof(7,8),
     *       xprof(7,9),xprof(7,10),xprof(7,11),xprof(7,12),
     *       xprof(7,13),xprof(7,14),xprof(7,15),xprof(7,16),
     *       xprof(7,17),xprof(7,18),xprof(7,19),xprof(7,20),
     *       xprof(7,21),xprof(7,22),xprof(7,23),xprof(7,24),
     *       xprof(7,25),xprof(7,26)/
     *       50.,5500.,5600.,5700.,5800.,5900.,6000.,6100.,
     *       6200.,6300.,6400.,6500.,6600.,6700.,6800.,6900.,
     *       7000.,7100.,7200.,7300.,7400.,7500.,8000.,8500.,
     *       9000.,2000000./ 
	data yprof(7,1),yprof(7,2),yprof(7,3),yprof(7,4),
     *       yprof(7,5),yprof(7,6),yprof(7,7),yprof(7,8),
     *       yprof(7,9),yprof(7,10),yprof(7,11),yprof(7,12),
     *       yprof(7,13),yprof(7,14),yprof(7,15),yprof(7,16),
     *       yprof(7,17),yprof(7,18),yprof(7,19),yprof(7,20),
     *       yprof(7,21),yprof(7,22),yprof(7,23),yprof(7,24),
     *       yprof(7,25),yprof(7,26)/
     *       0.00000,0.00000,0.23000,0.74000,0.91000,0.98000,
     *       1.00000,0.98000,0.96000,0.93000,0.90000,0.86000,
     *       0.81000,0.78000,0.72000,0.67000,0.61000,0.56000,
     *       0.51000,0.46000,0.40000,0.35000,0.14000,0.03000,
     *       0.00000,0.00000/    
c
c FILTER PROFILE FOR I (BESSELL 1990).
c
	data xprof(8,1),xprof(8,2),xprof(8,3),xprof(8,4),
     *       xprof(8,5),xprof(8,6),xprof(8,7),xprof(8,8),
     *       xprof(8,9),xprof(8,10),xprof(8,11),xprof(8,12),
     *       xprof(8,13),xprof(8,14),xprof(8,15),xprof(8,16),
     *       xprof(8,17),xprof(8,18),xprof(8,19),xprof(8,20),
     *       xprof(8,21),xprof(8,22),xprof(8,23),xprof(8,24),
     *       xprof(8,25)/
     *       50.,7000.,7100.,7200.,7300.,7400.,7500.,
     *       7600.,7700.,7800.,7900.,8000.,8100.,8200.,
     *       8300.,8400.,8500.,8600.,8700.,8800.,8900.,
     *       9000.,9100.,9200.,2000000./
	data yprof(8,1),yprof(8,2),yprof(8,3),yprof(8,4),
     *       yprof(8,5),yprof(8,6),yprof(8,7),yprof(8,8),
     *       yprof(8,9),yprof(8,10),yprof(8,11),yprof(8,12),
     *       yprof(8,13),yprof(8,14),yprof(8,15),yprof(8,16),
     *       yprof(8,17),yprof(8,18),yprof(8,19),yprof(8,20),
     *       yprof(8,21),yprof(8,22),yprof(8,23),yprof(8,24),
     *       yprof(8,25)/
     *       0.00000,0.00000,0.02400,0.23200,0.55500,0.78500,
     *       0.91000,0.96500,0.98500,0.99000,0.99500,1.00000,
     *       1.00000,0.99000,0.98000,0.95000,0.91000,0.86000,
     *       0.75000,0.56000,0.33000,0.15000,0.03000,0.00000,
     *       0.00000/
c
c FILTER PROFILE FOR J.
c
	data xprof(9,1),xprof(9,2),xprof(9,3),xprof(9,4),
     *       xprof(9,5),xprof(9,6),xprof(9,7),xprof(9,8),
     *       xprof(9,9),xprof(9,10),xprof(9,11),xprof(9,12),
     *       xprof(9,13),xprof(9,14),xprof(9,15),xprof(9,16),
     *       xprof(9,17),xprof(9,18),xprof(9,19),xprof(9,20),
     *       xprof(9,21),xprof(9,22),xprof(9,23),xprof(9,24),
     *       xprof(9,25),xprof(9,26),xprof(9,27),xprof(9,28),
     *       xprof(9,29),xprof(9,30),xprof(9,31),xprof(9,32),
     *       xprof(9,33)/
     *       50.00, 9600.00, 9800.00,10000.00,10200.00,
     *       10400.00,10600.00,10800.00,11000.00,11200.00,     
     *       11400.00,11600.00,11800.00,12000.00,12200.00,     
     *       12400.00,12600.00,12800.00,13000.00,13200.00,     
     *       13400.00,13600.00,13800.00,14000.00,14200.00,     
     *       14400.00,14600.00,14800.00,15000.00,15200.00,     
     *       15400.00,15600.00,2000000./     
	data yprof(9,1),yprof(9,2),yprof(9,3),yprof(9,4),
     *       yprof(9,5),yprof(9,6),yprof(9,7),yprof(9,8),
     *       yprof(9,9),yprof(9,10),yprof(9,11),yprof(9,12),
     *       yprof(9,13),yprof(9,14),yprof(9,15),yprof(9,16),
     *       yprof(9,17),yprof(9,18),yprof(9,19),yprof(9,20),
     *       yprof(9,21),yprof(9,22),yprof(9,23),yprof(9,24),
     *       yprof(9,25),yprof(9,26),yprof(9,27),yprof(9,28),
     *       yprof(9,29),yprof(9,30),yprof(9,31),yprof(9,32),
     *       yprof(9,33)/
     *       0.00000,0.00000,0.02000,0.03000,0.06000,0.16000,
     *       0.35000,0.62000,0.93000,0.85000,0.78000,0.78000,
     *       0.80000,0.85000,0.93000,0.75000,0.64000,0.63000,
     *       0.63000,0.66000,0.68000,0.70000,0.70000,0.66000,
     *       0.60000,0.46000,0.27000,0.14000,0.09000,0.06000,
     *       0.02000,0.00000,0.00000/
c
c FILTER PROFILE FOR H.
c
	data xprof(10,1),xprof(10,2),xprof(10,3),xprof(10,4),
     *       xprof(10,5),xprof(10,6),xprof(10,7),xprof(10,8),
     *       xprof(10,9),xprof(10,10),xprof(10,11),xprof(10,12),
     *       xprof(10,13),xprof(10,14),xprof(10,15),xprof(10,16),
     *       xprof(10,17),xprof(10,18),xprof(10,19),xprof(10,20),
     *       xprof(10,21),xprof(10,22),xprof(10,23),xprof(10,24),
     *       xprof(10,25),xprof(10,26),xprof(10,27),xprof(10,28),
     *       xprof(10,29),xprof(10,30)/
     *       50.00,  12500.00,13000.00,13500.00,14000.00,    
     *       14500.00,15000.00,15200.00,15400.00,15600.00,     
     *       15800.00,16000.00,16200.00,16400.00,16600.00,     
     *       16800.00,17000.00,17200.00,17400.00,17600.00,     
     *       17800.00,18000.00,18200.00,18400.00,18600.00,     
     *       18800.00,19000.00,19500.00,20000.00,2000000./     
	data yprof(10,1),yprof(10,2),yprof(10,3),yprof(10,4),
     *       yprof(10,5),yprof(10,6),yprof(10,7),yprof(10,8),
     *       yprof(10,9),yprof(10,10),yprof(10,11),yprof(10,12),
     *       yprof(10,13),yprof(10,14),yprof(10,15),yprof(10,16),
     *       yprof(10,17),yprof(10,18),yprof(10,19),yprof(10,20),
     *       yprof(10,21),yprof(10,22),yprof(10,23),yprof(10,24),
     *       yprof(10,25),yprof(10,26),yprof(10,27),yprof(10,28),
     *       yprof(10,29),yprof(10,30)/
     *       0.00000,0.00000,0.01900,0.09300,0.58400,0.77100,
     *       0.84100,0.88800,0.89300,0.89300,0.94900,0.90700,
     *       0.88800,0.97200,0.98100,0.94900,0.94900,0.98100,
     *       1.00000,0.97700,0.93900,0.98600,0.97200,0.86000,
     *       0.88800,0.18700,0.02300,0.00500,0.00000,0.00000/
c
c FILTER PROFILE FOR K.
c
	data xprof(11,1),xprof(11,2),xprof(11,3),xprof(11,4),
     *       xprof(11,5),xprof(11,6),xprof(11,7),xprof(11,8),
     *       xprof(11,9),xprof(11,10),xprof(11,11),xprof(11,12),
     *       xprof(11,13),xprof(11,14),xprof(11,15),xprof(11,16),
     *       xprof(11,17),xprof(11,18),xprof(11,19)/
     *       50.00,18000.00,18500.00,19000.00,19500.00,     
     *       20000.00,20500.00,21000.00,21500.00,22000.00,     
     *       22500.00,23000.00,23500.00,24000.00,24500.00,     
     *       25000.00,25500.00,26000.00,2000000./
	data yprof(11,1),yprof(11,2),yprof(11,3),yprof(11,4),
     *       yprof(11,5),yprof(11,6),yprof(11,7),yprof(11,8),
     *       yprof(11,9),yprof(11,10),yprof(11,11),yprof(11,12),
     *       yprof(11,13),yprof(11,14),yprof(11,15),yprof(11,16),
     *       yprof(11,17),yprof(11,18),yprof(11,19)/
     *       0.00000,0.00000,0.10000,0.48000,0.95000,1.00000,
     *       0.98000,0.96000,0.95000,0.97000,0.96000,0.94000,
     *       0.95000,0.95000,0.84000,0.46000,0.08000,0.00000,
     *       0.00000/
c
c FILTER PROFILE FOR L.
c
	data xprof(12,1),xprof(12,2),xprof(12,3),xprof(12,4),
     *       xprof(12,5),xprof(12,6),xprof(12,7),xprof(12,8),
     *       xprof(12,9),xprof(12,10),xprof(12,11),xprof(12,12),
     *       xprof(12,13),xprof(12,14),xprof(12,15),xprof(12,16)/
     *       50.00,29000.00,30000.00,31000.00,32000.00,     
     *       33000.00,34000.00,35000.00,36000.00,37000.00,     
     *       38000.00,39000.00,40000.00,41000.00,42000.00,
     *       2000000./     
	data yprof(12,1),yprof(12,2),yprof(12,3),yprof(12,4),
     *       yprof(12,5),yprof(12,6),yprof(12,7),yprof(12,8),
     *       yprof(12,9),yprof(12,10),yprof(12,11),yprof(12,12),
     *       yprof(12,13),yprof(12,14),yprof(12,15),yprof(12,16)/
     *       0.00000,0.00000,0.14000,0.68000,0.95000,1.00000,
     *       1.00000,0.98000,0.85000,0.69000,0.39000,0.21000,
     *       0.10000,0.02000,0.00000,0.00000/
c
c NEW WAVELENGTH GRID FOR THE EMISSION COEFFICIENTS
c
	data xrange/10.,912.,913.,1300.,1500.,1800.,2200.,
     *       2855.,3331.,3421.,3422.,3642.,3648.,5700.,7000.,8207.,
     *       8209.,14583.,14585.,22787.,22789.,32813.,32815.,
     *       44680.,44682.,2000000./
c
c EMISSION COEFFCIENTS FOR H I (FF+FB+2PHOT) AND HE I (HE/H=0.1). TAKEN
c FROM ALLER (1984) AND FERLAND (1980). UNITS: 10^-40 ERG CM3 SEC^-1 HZ^-1.
c T = 10000 K.
c
	data gamma/0.,0.,2.11e-4,5.647,9.35,9.847,10.582,16.101,24.681,
     *       26.736,24.883,29.979,6.519,8.773,11.545,13.585,6.333,
     *       10.444,7.023,9.361,7.59,9.35,8.32,9.53,8.87,0./
c
c CHEMICAL YIELDS FROM SNII Z = 2 Zsol
c
        data ymass(5,1),yh(5,1),yhe(5,1),yc(5,1),yn(5,1),
     *       yo(5,1),ymg(5,1),ysi(5,1),ys(5,1),yfe(5,1),
     *       ymass(5,2),yh(5,2),yhe(5,2),yc(5,2),yn(5,2),
     *       yo(5,2),ymg(5,2),ysi(5,2),ys(5,2),yfe(5,2),
     *       ymass(5,3),yh(5,3),yhe(5,3),yc(5,3),yn(5,3),
     *       yo(5,3),ymg(5,3),ysi(5,3),ys(5,3),yfe(5,3),
     *       ymass(5,4),yh(5,4),yhe(5,4),yc(5,4),yn(5,4),
     *       yo(5,4),ymg(5,4),ysi(5,4),ys(5,4),yfe(5,4),
     *       ymass(5,5),yh(5,5),yhe(5,5),yc(5,5),yn(5,5),
     *       yo(5,5),ymg(5,5),ysi(5,5),ys(5,5),yfe(5,5),
     *       ymass(5,6),yh(5,6),yhe(5,6),yc(5,6),yn(5,6),
     *       yo(5,6),ymg(5,6),ysi(5,6),ys(5,6),yfe(5,6),
     *       ymass(5,7),yh(5,7),yhe(5,7),yc(5,7),yn(5,7),
     *       yo(5,7),ymg(5,7),ysi(5,7),ys(5,7),yfe(5,7),
     *       ymass(5,8),yh(5,8),yhe(5,8),yc(5,8),yn(5,8),
     *       yo(5,8),ymg(5,8),ysi(5,8),ys(5,8),yfe(5,8),
     *       ymass(5,9),yh(5,9),yhe(5,9),yc(5,9),yn(5,9),
     *       yo(5,9),ymg(5,9),ysi(5,9),ys(5,9),yfe(5,9),
     *       ymass(5,10),yh(5,10),yhe(5,10),yc(5,10),yn(5,10),
     *       yo(5,10),ymg(5,10),ysi(5,10),ys(5,10),yfe(5,10),
     *       ymass(5,11),yh(5,11),yhe(5,11),yc(5,11),yn(5,11),
     *       yo(5,11),ymg(5,11),ysi(5,11),ys(5,11),yfe(5,11),
     *       ymass(5,12),yh(5,12),yhe(5,12),yc(5,12),yn(5,12),
     *       yo(5,12),ymg(5,12),ysi(5,12),ys(5,12),yfe(5,12)/
     *       7,3.48,2.40,0.048,0.042,0.128,0.006,0.054,0.046,0.000,
     *       9,4.47,3.08,0.062,0.054,0.164,0.008,0.070,0.059,0.000,
     *       12,5.96,4.11,0.082,0.072,0.219,0.011,0.093,0.079,0.000,
     *       13,6.32,4.51,0.115,0.094,0.275,0.023,0.062,0.028,0.111,
     *       15,6.98,5.24,0.162,0.108,0.685,0.040,0.116,0.066,0.104,
     *       18,7.89,6.28,0.249,0.114,1.146,0.077,0.146,0.059,0.050,
     *       20,8.24,6.72,0.214,0.120,1.953,0.049,0.300,0.176,0.165,
     *       22,8.79,7.51,0.242,0.134,2.385,0.062,0.382,0.190,0.383,
     *       25,9.40,8.64,0.324,0.160,3.254,0.162,0.339,0.149,0.150,
     *       30,10.50,10.40,0.288,0.208,3.652,0.270,0.141,0.016,0.058,
     *       35,11.50,11.90,0.303,0.249,3.072,0.188,0.059,0.012,0.064,
     *       40,11.10,13.00,0.315,0.281,2.361,0.124,0.031,0.011,0.064/
c
c CHEMICAL YIELDS FROM SNII Z = 1 Zsol
c
        data ymass(4,1),yh(4,1),yhe(4,1),yc(4,1),yn(4,1),
     *       yo(4,1),ymg(4,1),ysi(4,1),ys(4,1),yfe(4,1),
     *       ymass(4,2),yh(4,2),yhe(4,2),yc(4,2),yn(4,2),
     *       yo(4,2),ymg(4,2),ysi(4,2),ys(4,2),yfe(4,2),
     *       ymass(4,3),yh(4,3),yhe(4,3),yc(4,3),yn(4,3),
     *       yo(4,3),ymg(4,3),ysi(4,3),ys(4,3),yfe(4,3),
     *       ymass(4,4),yh(4,4),yhe(4,4),yc(4,4),yn(4,4),
     *       yo(4,4),ymg(4,4),ysi(4,4),ys(4,4),yfe(4,4),
     *       ymass(4,5),yh(4,5),yhe(4,5),yc(4,5),yn(4,5),
     *       yo(4,5),ymg(4,5),ysi(4,5),ys(4,5),yfe(4,5),
     *       ymass(4,6),yh(4,6),yhe(4,6),yc(4,6),yn(4,6),
     *       yo(4,6),ymg(4,6),ysi(4,6),ys(4,6),yfe(4,6),
     *       ymass(4,7),yh(4,7),yhe(4,7),yc(4,7),yn(4,7),
     *       yo(4,7),ymg(4,7),ysi(4,7),ys(4,7),yfe(4,7),
     *       ymass(4,8),yh(4,8),yhe(4,8),yc(4,8),yn(4,8),
     *       yo(4,8),ymg(4,8),ysi(4,8),ys(4,8),yfe(4,8),
     *       ymass(4,9),yh(4,9),yhe(4,9),yc(4,9),yn(4,9),
     *       yo(4,9),ymg(4,9),ysi(4,9),ys(4,9),yfe(4,9),
     *       ymass(4,10),yh(4,10),yhe(4,10),yc(4,10),yn(4,10),
     *       yo(4,10),ymg(4,10),ysi(4,10),ys(4,10),yfe(4,10),
     *       ymass(4,11),yh(4,11),yhe(4,11),yc(4,11),yn(4,11),
     *       yo(4,11),ymg(4,11),ysi(4,11),ys(4,11),yfe(4,11),
     *       ymass(4,12),yh(4,12),yhe(4,12),yc(4,12),yn(4,12),
     *       yo(4,12),ymg(4,12),ysi(4,12),ys(4,12),yfe(4,12)/
     *       7,3.48,2.40,0.048,0.021,0.128,0.006,0.054,0.046,0.034,
     *       9,4.47,3.08,0.062,0.027,0.164,0.008,0.070,0.059,0.044,
     *       12,5.96,4.11,0.082,0.036,0.219,0.011,0.093,0.079,0.059,
     *       13,6.32,4.51,0.115,0.047,0.275,0.023,0.062,0.028,0.151,
     *       15,6.98,5.24,0.162,0.054,0.685,0.040,0.116,0.066,0.138,
     *       18,7.89,6.28,0.249,0.057,1.146,0.077,0.146,0.059,0.093,
     *       20,8.24,6.72,0.214,0.060,1.953,0.049,0.300,0.176,0.120,
     *       22,8.79,7.51,0.242,0.067,2.385,0.062,0.382,0.190,0.241,
     *       25,9.40,8.64,0.324,0.080,3.254,0.162,0.339,0.149,0.169,
     *       30,10.50,10.40,0.288,0.104,3.652,0.270,0.141,0.016,0.029,
     *       35,11.50,11.90,0.303,0.125,3.072,0.188,0.059,0.012,0.032,
     *       40,11.10,13.00,0.315,0.141,2.361,0.124,0.031,0.011,0.032/
c
c CHEMICAL YIELDS FROM SNII Z = 0.4 Zsol
c
        data ymass(3,1),yh(3,1),yhe(3,1),yc(3,1),yn(3,1),
     *       yo(3,1),ymg(3,1),ysi(3,1),ys(3,1),yfe(3,1),
     *       ymass(3,2),yh(3,2),yhe(3,2),yc(3,2),yn(3,2),
     *       yo(3,2),ymg(3,2),ysi(3,2),ys(3,2),yfe(3,2),
     *       ymass(3,3),yh(3,3),yhe(3,3),yc(3,3),yn(3,3),
     *       yo(3,3),ymg(3,3),ysi(3,3),ys(3,3),yfe(3,3),
     *       ymass(3,4),yh(3,4),yhe(3,4),yc(3,4),yn(3,4),
     *       yo(3,4),ymg(3,4),ysi(3,4),ys(3,4),yfe(3,4),
     *       ymass(3,5),yh(3,5),yhe(3,5),yc(3,5),yn(3,5),
     *       yo(3,5),ymg(3,5),ysi(3,5),ys(3,5),yfe(3,5),
     *       ymass(3,6),yh(3,6),yhe(3,6),yc(3,6),yn(3,6),
     *       yo(3,6),ymg(3,6),ysi(3,6),ys(3,6),yfe(3,6),
     *       ymass(3,7),yh(3,7),yhe(3,7),yc(3,7),yn(3,7),
     *       yo(3,7),ymg(3,7),ysi(3,7),ys(3,7),yfe(3,7),
     *       ymass(3,8),yh(3,8),yhe(3,8),yc(3,8),yn(3,8),
     *       yo(3,8),ymg(3,8),ysi(3,8),ys(3,8),yfe(3,8),
     *       ymass(3,9),yh(3,9),yhe(3,9),yc(3,9),yn(3,9),
     *       yo(3,9),ymg(3,9),ysi(3,9),ys(3,9),yfe(3,9),
     *       ymass(3,10),yh(3,10),yhe(3,10),yc(3,10),yn(3,10),
     *       yo(3,10),ymg(3,10),ysi(3,10),ys(3,10),yfe(3,10),
     *       ymass(3,11),yh(3,11),yhe(3,11),yc(3,11),yn(3,11),
     *       yo(3,11),ymg(3,11),ysi(3,11),ys(3,11),yfe(3,11),
     *       ymass(3,12),yh(3,12),yhe(3,12),yc(3,12),yn(3,12),
     *       yo(3,12),ymg(3,12),ysi(3,12),ys(3,12),yfe(3,12)/
     *       7,3.59,2.32,0.051,0.008,0.099,0.004,0.030,0.021,0.073,
     *       9,4.62,2.98,0.065,0.011,0.127,0.006,0.038,0.027,0.094,
     *       12,6.16,3.98,0.087,0.014,0.170,0.008,0.051,0.036,0.125,
     *       13,6.55,4.37,0.111,0.019,0.285,0.020,0.065,0.031,0.175,
     *       15,7.27,5.11,0.149,0.022,0.598,0.029,0.087,0.045,0.159,
     *       18,8.20,6.21,0.233,0.023,1.045,0.079,0.135,0.052,0.119,
     *       20,8.71,6.71,0.235,0.024,1.664,0.052,0.256,0.146,0.093,
     *       22,9.22,7.45,0.235,0.027,2.208,0.033,0.347,0.189,0.156,
     *       25,10.00,8.61,0.286,0.032,3.018,0.075,0.379,0.198,0.181,
     *       30,11.10,10.47,0.299,0.042,3.957,0.309,0.100,0.007,0.011,
     *       35,12.10,11.97,0.314,0.050,3.091,0.164,0.038,0.005,0.013,
     *       40,12.57,13.67,0.330,0.057,2.600,0.097,0.016,0.005,0.013/
c
c CHEMICAL YIELDS FROM SNII Z = 0.2 Zsol
c
        data ymass(2,1),yh(2,1),yhe(2,1),yc(2,1),yn(2,1),
     *       yo(2,1),ymg(2,1),ysi(2,1),ys(2,1),yfe(2,1),
     *       ymass(2,2),yh(2,2),yhe(2,2),yc(2,2),yn(2,2),
     *       yo(2,2),ymg(2,2),ysi(2,2),ys(2,2),yfe(2,2),
     *       ymass(2,3),yh(2,3),yhe(2,3),yc(2,3),yn(2,3),
     *       yo(2,3),ymg(2,3),ysi(2,3),ys(2,3),yfe(2,3),
     *       ymass(2,4),yh(2,4),yhe(2,4),yc(2,4),yn(2,4),
     *       yo(2,4),ymg(2,4),ysi(2,4),ys(2,4),yfe(2,4),
     *       ymass(2,5),yh(2,5),yhe(2,5),yc(2,5),yn(2,5),
     *       yo(2,5),ymg(2,5),ysi(2,5),ys(2,5),yfe(2,5),
     *       ymass(2,6),yh(2,6),yhe(2,6),yc(2,6),yn(2,6),
     *       yo(2,6),ymg(2,6),ysi(2,6),ys(2,6),yfe(2,6),
     *       ymass(2,7),yh(2,7),yhe(2,7),yc(2,7),yn(2,7),
     *       yo(2,7),ymg(2,7),ysi(2,7),ys(2,7),yfe(2,7),
     *       ymass(2,8),yh(2,8),yhe(2,8),yc(2,8),yn(2,8),
     *       yo(2,8),ymg(2,8),ysi(2,8),ys(2,8),yfe(2,8),
     *       ymass(2,9),yh(2,9),yhe(2,9),yc(2,9),yn(2,9),
     *       yo(2,9),ymg(2,9),ysi(2,9),ys(2,9),yfe(2,9),
     *       ymass(2,10),yh(2,10),yhe(2,10),yc(2,10),yn(2,10),
     *       yo(2,10),ymg(2,10),ysi(2,10),ys(2,10),yfe(2,10),
     *       ymass(2,11),yh(2,11),yhe(2,11),yc(2,11),yn(2,11),
     *       yo(2,11),ymg(2,11),ysi(2,11),ys(2,11),yfe(2,11),
     *       ymass(2,12),yh(2,12),yhe(2,12),yc(2,12),yn(2,12),
     *       yo(2,12),ymg(2,12),ysi(2,12),ys(2,12),yfe(2,12)/
     *       7,3.63,2.29,0.051,0.004,0.089,0.004,0.022,0.012,0.086,
     *       9,4.67,2.95,0.066,0.005,0.115,0.005,0.028,0.016,0.110,
     *       12,6.23,3.93,0.088,0.007,0.153,0.007,0.037,0.021,0.147,
     *       13,6.63,4.32,0.110,0.009,0.288,0.019,0.066,0.032,0.183,
     *       15,7.37,5.06,0.144,0.011,0.569,0.025,0.077,0.038,0.166,
     *       18,8.31,6.19,0.228,0.012,1.012,0.080,0.132,0.050,0.128,
     *       20,8.87,6.70,0.242,0.012,1.568,0.053,0.241,0.136,0.084,
     *       22,9.37,7.43,0.233,0.014,2.149,0.024,0.335,0.189,0.127,
     *       25,10.20,8.60,0.273,0.016,2.939,0.046,0.392,0.215,0.184,
     *       30,11.30,10.49,0.302,0.021,4.059,0.322,0.086,0.004,0.006,
     *       35,12.30,11.99,0.317,0.026,3.097,0.156,0.031,0.003,0.006,
     *       40,13.06,13.89,0.335,0.029,2.680,0.088,0.011,0.003,0.006/
c
c CHEMICAL YIELDS FROM SNII Z = 0.05 Zsol
c
        data ymass(1,1),yh(1,1),yhe(1,1),yc(1,1),yn(1,1),
     *       yo(1,1),ymg(1,1),ysi(1,1),ys(1,1),yfe(1,1),
     *       ymass(1,2),yh(1,2),yhe(1,2),yc(1,2),yn(1,2),
     *       yo(1,2),ymg(1,2),ysi(1,2),ys(1,2),yfe(1,2),
     *       ymass(1,3),yh(1,3),yhe(1,3),yc(1,3),yn(1,3),
     *       yo(1,3),ymg(1,3),ysi(1,3),ys(1,3),yfe(1,3),
     *       ymass(1,4),yh(1,4),yhe(1,4),yc(1,4),yn(1,4),
     *       yo(1,4),ymg(1,4),ysi(1,4),ys(1,4),yfe(1,4),
     *       ymass(1,5),yh(1,5),yhe(1,5),yc(1,5),yn(1,5),
     *       yo(1,5),ymg(1,5),ysi(1,5),ys(1,5),yfe(1,5),
     *       ymass(1,6),yh(1,6),yhe(1,6),yc(1,6),yn(1,6),
     *       yo(1,6),ymg(1,6),ysi(1,6),ys(1,6),yfe(1,6),
     *       ymass(1,7),yh(1,7),yhe(1,7),yc(1,7),yn(1,7),
     *       yo(1,7),ymg(1,7),ysi(1,7),ys(1,7),yfe(1,7),
     *       ymass(1,8),yh(1,8),yhe(1,8),yc(1,8),yn(1,8),
     *       yo(1,8),ymg(1,8),ysi(1,8),ys(1,8),yfe(1,8),
     *       ymass(1,9),yh(1,9),yhe(1,9),yc(1,9),yn(1,9),
     *       yo(1,9),ymg(1,9),ysi(1,9),ys(1,9),yfe(1,9),
     *       ymass(1,10),yh(1,10),yhe(1,10),yc(1,10),yn(1,10),
     *       yo(1,10),ymg(1,10),ysi(1,10),ys(1,10),yfe(1,10),
     *       ymass(1,11),yh(1,11),yhe(1,11),yc(1,11),yn(1,11),
     *       yo(1,11),ymg(1,11),ysi(1,11),ys(1,11),yfe(1,11),
     *       ymass(1,12),yh(1,12),yhe(1,12),yc(1,12),yn(1,12),
     *       yo(1,12),ymg(1,12),ysi(1,12),ys(1,12),yfe(1,12)/
     *       7,3.66,2.28,0.052,0.001,0.084,0.004,0.018,0.008,0.095,
     *       9,4.71,2.93,0.067,0.001,0.107,0.005,0.023,0.011,0.122,
     *       12,6.28,3.90,0.090,0.001,0.143,0.006,0.031,0.014,0.163,
     *       13,6.69,4.29,0.109,0.002,0.246,0.014,0.053,0.026,0.189,
     *       15,7.46,5.07,0.146,0.003,0.482,0.022,0.073,0.035,0.171,
     *       18,8.48,6.22,0.208,0.003,0.971,0.056,0.114,0.053,0.134,
     *       20,9.02,6.66,0.225,0.003,1.576,0.033,0.240,0.142,0.077,
     *       22,9.57,7.46,0.241,0.004,2.020,0.041,0.321,0.167,0.106,
     *       25,10.36,8.69,0.274,0.004,2.861,0.036,0.393,0.215,0.187,
     *       30,11.51,10.39,0.310,0.005,4.038,0.289,0.101,0.003,0.001,
     *       35,12.62,12.00,0.332,0.007,3.417,0.169,0.023,0.001,0.001,
     *       40,13.52,13.94,0.339,0.008,2.659,0.080,0.006,0.001,0.001/
c
	end
c
c *****************************************************************************
c *****************************************************************************
c *****************************************************************************
