SUBROUTINE TEMPER(ID,TAUF,ITGR)
C     ===============================
C
C     Auxiliary procedure for LTEGR
C     Evaluation of temperature, electron density, Rosseland opacity
C     and Planck mean opacity for at a given depth point
C
C     Input parameters:
C     ID     - depth index
C     TAUF   - Rosseland optical depth (if ITGR = -1, 0 or 1
C            - flux mean opacity (if ITGR > 1)
C     ITGR   = -1, 0, 1 -  means that TEMPER is called in the first
C                          iteration of the pseudo-grey model;
C                          temperature is evaluated;
C            > 1      -    next iterations; temperature is given,
C                          only evaluation of electron density and
C                          populations
C
      INCLUDE 'IMPLIC.FOR'
      INCLUDE 'BASICS.FOR'
      INCLUDE 'MODELQ.FOR'
      INCLUDE 'ALIPAR.FOR'
      COMMON/PRSAUX/VSND2(MDEPTH),HG1,HR1,RR1
      COMMON/FLXAUX/T4,PGAS,PRAD,PGM,PRADM,ITGMAX,ITGMX0
      COMMON/FACTRS/GAMJ(MDEPTH),GAMH,FAK0
      PARAMETER  (ERRT=1.D-3)
C
      IT=0
      IF(ITGR.GT.1.AND.ITGMAX.GT.0) THEN
         T=TEMP(ID)
         GO TO 10
      END IF
C
      IF(ID.EQ.1) THEN
         DDM=HALF*DM(ID)
       ELSE
         DDM=DM(ID)-DM(ID-1)
      END IF
C
C
C     Initial estimate of temperature for current values of Rosseland
C     and Planck mean opacities
C
      call tlocal(id,tauf,t)
C
C ********** Iteration loop for determining temperature at depth ID
C            for a given total pressure
C
   10 IT=IT+1
      TEMP(ID)=T
C
C     Estimate of the gas pressure
C
      PRAD=1.8912D-15*T4*(GAMH*5.7735D-1+TAUF-TAUTHE(ID))
      PTURB=HALF*DENS(ID)*VTURB(ID)*VTURB(ID)
      PGAS=PGS(ID)
      PTOT=PGAS+PRAD+PTURB
      PTOTAL(ID)=PTOT
      PRADT(ID)=PRAD
      IF(PGAS.LE.0.) WRITE(6,603) ID,IT,PGAS,PTOT,PTURB,PRAD
  603 format(' negative gas pressure!! id,it,pgas,p,pturb,prad =',
     *       2i3,1p4d9.2)
C
C     Determination of electron density from the known temperature
C     and total pressure
C
      if(ioptab.ge.-1) then
         AN=PGAS/T/BOLK
         CALL ELDENS(ID,T,AN,ANE,ENRG,ENTT,WM,1)
         ELEC(ID)=ANE
         DENS(ID)=WMM(ID)*(AN-ANE)
         PHMOL(ID)=AHMOL
         VSND2(ID)=PTOTAL(ID)/DENS(ID)
         if(ioptab.ge.0) then
            CALL WNSTOR(ID)
            CALL STEQEQ(ID,POP,1)
         end if
      end if
c     IF(IT.GT.1.AND.REL.LT.ERRT) GO TO 30
C
C     For itgr.gt.1 - only new electron density and populations
C
      IF(ITGR.GT.1) RETURN
C
C     Evaluation of the Rosseland and Planck mean opacities
C     for the new values of temperature, electron density, and
C     populations (OPROS - Rosseland opacity per 1 cm**3; OPPLA - Planck
C     mean opacity per 1 cm**3)
C
      if(ioptab.ge.0) then
         CALL OPACF0(ID,NFREQ)
         CALL MEANOP(T,ABSO,SCAT,OPROS,OPPLA)
         ABROS=OPROS/DENS(ID)
         ABPLA=OPPLA/DENS(ID)
         if(abpla.lt.abpmin) abpla=abpmin
         ABFLX=ABROS
         ABPLAD(ID)=ABPLA
         ABROSD(ID)=ABROS
       else if(ioptab.eq.-1) then
         rho=dens(id)
         call meanopt(t,id,rho,opros,oppla)
         abrosd(id)=opros
         abplad(id)=oppla
         abros=opros
         abpla=oppla
       else
         temp(id)=t
         rho=rhoeos(t,p)
         dens(id)=rho
         call meanopt(t,id,rho,opros,oppla)
         abrosd(id)=opros
         abplad(id)=oppla
         abros=opros
         abpla=oppla
      end if
c
      IF(IT.GT.1.AND.REL.LT.ERRT) GO TO 30
C
C     New values of the Rosseland opacity and function tauthe
C
      IF(ID.EQ.1) THEN
         TAUR=DM(ID)*ABROS
         TAUTHE(ID)=DM(ID)*ABFLX*THETA(ID)/(ZETA1+TWO)
       ELSE
         TAUR=TAUROS(ID-1)+DDM*HALF*(ABROSD(ID-1)+ABROS)
       ABFLXM=ABROSD(ID-1)
       ZETAD=ZETA0
       IF(DM(ID).LE.DMVISC*DM(ND)) ZETAD=ZETA1
       A0=(ABFLXM*DM(ID)-ABFLX*DM(ID-1))/DDM/(ZETAD+TWO)
       A1=(ABFLX-ABFLXM)/DDM/(ZETAD+3.D0)
         TAUTHE(ID)=TAUTHE(ID-1)+
     *              A0*(THETA(ID)*DM(ID)-THETA(ID-1)*DM(ID-1))+
     *              A1*(THETA(ID)*DM(ID)**2-THETA(ID-1)*DM(ID-1)**2)
      END IF
      TAUF=TAUR
C
C     New value of temperature
C
      call tlocal(id,tauf,t)
C
C     Convergence criterion for temperature
C     (if REL < 1e-3, temperature is not recalculated again, but for
C     consistency the electron density and pressures are still
C     calculated consistently with the last temperature)
C
      REL=ABS(T-TEMP(ID))/TEMP(ID)
      IF(IT.LE.5) GO TO 10
C
C     Store the final quantitites
C
   30 TEMP(ID)=T
      PGS(ID)=PGAS
      VSND2(ID)=PTOTAL(ID)/DENS(ID)
      ABROSD(ID)=ABROS
      ABPLAD(ID)=ABPLA
      TAUROS(ID)=TAUR
      TAUFLX(ID)=TAUF
      IF(ID.NE.1) RETURN
      DPRAD=1.8912D-15*T4*(TAUF-TAUTHE(ID))
      HG1=SQRT(2.D0*PGS(1)/DENS(1)/QGRAV)
      HR1=DPRAD/DM(1)/QGRAV
      RR1=HR1/HG1
      RETURN
      END