SUBROUTINE OPACON(ID,CROSS,ABSOC,EMISC,SCATC)
C     ============================================
C
C     Absorption, emission, and scattering coefficients
C     at depth ID and for several frequencies (some or all)
C
C     Input: ID    - depth index
C            CROSS - two dimensional array of photoionization
C                    cross-sections
C     Output: ABSO - array of absorption coefficient
C             EMIS - array of emission coefficient
C             SCAT - array of scattering coefficient
C
C
      INCLUDE 'PARAMS.FOR'
      INCLUDE 'MODELP.FOR'
      INCLUDE 'LINDAT.FOR'
      INCLUDE 'SYNTHP.FOR'
      INCLUDE 'WINCOM.FOR'
      DIMENSION CROSS(MCROSS,MFRQ)
      DIMENSION ABSOC(MFREQC),EMISC(MFREQC),SCATC(MFREQC)
      COMMON/BLAPAR/RELOP,SPACE0,CUTOF0,TSTD,DSTD,ALAMC
      common/dissol/fropc(mlevel),indexp(mlevel)
      PARAMETER (UN=1.,TEN15=1.E-15,CSB=2.0706E-16,CFF=3.694E8)
C
      T=TEMP(ID)
      ANE=ELEC(ID)
      T1=UN/T
      HKT=HK*T1
      TK=HKT/H
      SRT=UN/SQRT(T)
      SGFF=CFF*SRT
      CON=CSB*T1*SRT
      ABLY=0.
      EMLY=0.
      SCLY=0.
      sce=ane*sige
C
C     Opacity and emissivity in continuum
C     **** calculated only for the continuum frequencies *****
C
      DO 200 IJ=1,NFREQC
         FR=FREQC(IJ)
         FR15=FR*TEN15
         BNU=BN*FR15*FR15*FR15
         HKF=HKT*FR
         ABF=0.
         EBF=0.
         AFF=0.
         DO 100 IL=1,NION
            N0I=NFIRST(IL)
            N1I=NLAST(IL)
            NKE=NNEXT(IL)
            XN=POPUL(NKE,ID)
C
C           Bound-free contribution + possibly
c           pseudo-continuum (accounting for dissolved fraction)
C
            DO 10 II=N0I,N1I
               SG=0.
               IF(IFWOP(II).LT.0) THEN
                  SG=SGMERG(II,ID,FR)
                ELSE
                  SG=CROSS(II,IJ)
                  if(sg.le.0.) go to 10
                  IF(INDEXP(II).EQ.5) THEN
                     IZZ=IZ(IEL(II))
                     FR0=ENION(II)/6.6256E-27
                     CALL DWNFR1(FR,FR0,ID,IZZ,DW1)
                     SG=SG*DW1
                  END IF
               END IF
               if(popul(ii,id).lt.1.e-20.or.xn.lt.1.e-20) go to 10
               ABF=ABF+SG*POPUL(II,ID)
               XX=SG*XN*EXP(ENION(II)*TK-hkf)*WOP(II,ID)
               ee=exp(enion(ii)*tk-hkf)
               EBF=EBF+XX*CON*G(II)/G(NKE)
c            if(id.eq.1.or.id.eq.50) write(*,*)'opacon',id,ij,ii,
c    *       popul(ii,id),sg,abf
   10       CONTINUE
            IT=IFREE(IL)
            IF(IT.EQ.0) GO TO 100
C
C           Free-free contribution
C
            IE=IL
            IF(IE.EQ.IELHM) GO TO 65
            CH=IZ(IL)*IZ(IL)
            SF1=CH*XN*SGFF/(FR*FR*FR)
C
C           The following expression is the so-called modified free-free
C           opacity, ie. allowing for the photoionization from higher,
C           non-explicit, LTE energy levels of the ion IL
C
            IF(IT.NE.2) GO TO 50
            SG=GFREE(T,FR/CH)
            SF2=SF2+SG-UN
   50       SFF=SF1
            GO TO 70
   65       SFF=SFFHMI(XN,FR,T)
   70       AFF=AFF+SFF
  100    CONTINUE
C
C        Additional opacities
C
         CALL OPADD(0,ID,FR,ABAD,EMAD,SCAD)
         IF(IOPHLI.NE.0) CALL LYMLIN(ID,FR,ABLY,EMLY,SCLY)
C
C        Total opacity and emissivity
C
         X=EXP(-HKF)
         X1=UN-X
         BNE=BNU*X*ANE
         ABSOC(IJ)=ABF+ANE*(X1*AFF-EBF)+ABAD+ABLY
         EMISC(IJ)=BNE*AFF+BNU*ANE*EBF+EMAD+EMLY
         SCATC(IJ)=SCAD+SCLY+sce
c            if(id.eq.1.or.id.eq.50) write(*,*)'opacon-tot',id,ij,
c    *   abf,ane,absoc(ij)

  200 CONTINUE
C
      CALL PHTION(ID,ABSOC,EMISC,FREQC,NFREQC)
      CALL PHTX(ID,ABSOC,EMISC,FREQC,1)
C
      RETURN
      END