SUBROUTINE OPAC(ID,CROSS,ABSO,EMIS,SCAT)
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 (all scattering
C                    mechanisms except electron scattering)
C
C
      INCLUDE 'PARAMS.FOR'
      INCLUDE 'MODELP.FOR'
      INCLUDE 'LINDAT.FOR'
      INCLUDE 'SYNTHP.FOR'
      DIMENSION CROSS(MCROSS,MFRQ)
      DIMENSION ABSO(MFREQ),EMIS(MFREQ),SCAT(MFREQ),
     *          ABLIN(MFREQ),EMLIN(MFREQ)
      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
      IF(IMODE.EQ.-1.AND.ID.NE.IDSTD) RETURN
      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
      conts=1.e-36/con
      ABLY=0.
      EMLY=0.
      SCLY=0.
      sce=ane*sige
      IJ0=2
      IF(NFREQ.EQ.1) IJ0=1
      IF(IMODE.EQ.2) IJ0=NFREQ
      M=3
      IF(ICONTL.EQ.1) M=1
C
C     Opacity and emissivity in continuum
C     **** calculated only in the first and the last frequency *****
C
      DO 200 IJ=1,IJ0
         FR=FREQ(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(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(sg.le.0.) go to 10
               ABF=ABF+SG*POPUL(II,ID)
               XX=SG*XN*EXP(ENION(II)*TK)*WOP(II,ID)
               IF(XX.lt.conts) go to 10
               EBF=EBF+XX*CON*G(II)/G(NKE)
   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
            HKFM=HKT*MIN(FF(IL),FR)
            SF2=EXP(HKFM)
            IF(IT.NE.2) GO TO 50
            SG=GFREE(T,FR/CH)
            SF2=SF2+SG-UN
   50       SFF=SF1*SF2
            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
c        ABSO(IJ)=ABF+ANE*(X1*AFF-X*EBF)+ABAD+ABLY
         ABSO(IJ)=ABF+ANE*(X1*AFF-X*EBF)+ABAD
         EMIS(IJ)=BNE*(AFF+EBF)+EMAD+EMLY
         SCAT(IJ)=SCAD+SCLY+sce
         IF(IJ.EQ.1) THEN
         ABLY1=ABLY
         EMLY1=EMLY
         SCLY1=SCLY
         END IF
  200 CONTINUE
      AVAB=(ABSO(1)+ABSO(2)+SCAT(1)+SCAT(2))*0.5*RELOP
      IF(NFREQ.LE.2.OR.IMODE.EQ.-1) RETURN
      IF(IMODE.EQ.2) GO TO 225
C
C     interpolated continuum opacity, emissivity, and scattering
C     for all frequencies
C
      DO IJ=3,NFREQ
         ABSO(IJ)=FRX1(IJ)*ABSO(2)+FRX2(IJ)*ABSO(1)
         EMIS(IJ)=FRX1(IJ)*EMIS(2)+FRX2(IJ)*EMIS(1)
         SCAT(IJ)=FRX1(IJ)*SCAT(2)+FRX2(IJ)*SCAT(1)
      END DO
C
C    hydrogen lines -- for IHYL = 0
C     *** calculated only for the first and the last frequency
C     and interpolated hydrogen line opacity and emissivity
C     for all frequencies
C
      IF(IHYL.EQ.0) THEN
      CALL HYDLIN(ID,1,2,ABLIN,EMLIN)
      DO IJ=M,NFREQ
         ABSO(IJ)=ABSO(IJ)+FRX1(IJ)*ABLIN(2)+FRX2(IJ)*ABLIN(1)
         EMIS(IJ)=EMIS(IJ)+FRX1(IJ)*EMLIN(2)+FRX2(IJ)*EMLIN(1)
      END DO
      END IF
C
C     **** Opacity and emissivity in lines ****
C
      CALL LINOP(ID,ABLIN,EMLIN,AVAB)
      DO IJ=3,NFREQ
         ABSO(IJ)=ABSO(IJ)+ABLIN(IJ)
         EMIS(IJ)=EMIS(IJ)+EMLIN(IJ)
      END DO
C
C     **** Opacity and emissivity in molecular lines ****
C
      if(ifmol.gt.0) then
      do ilist=1,nmlist
      CALL MOLOP(ID,ABLIN,EMLIN,AVAB,ILIST)
      DO IJ=3,NFREQ
         ABSO(IJ)=ABSO(IJ)+ABLIN(IJ)
         EMIS(IJ)=EMIS(IJ)+EMLIN(IJ)
      END DO
      end do
      end if
  225 CONTINUE
C
C     **** Detailed opacity and emissivity in hydrogen lines ****
C          (for IHYL=1)
C
      IF(IHYL.GT.0.OR.IMODE.EQ.2) THEN
      CALL HYDLIN(ID,M,NFREQ,ABLIN,EMLIN)
      DO IJ=M,NFREQ
         ABSO(IJ)=ABSO(IJ)+ABLIN(IJ)
         EMIS(IJ)=EMIS(IJ)+EMLIN(IJ)
      END DO
      END IF
C
C     **** Detailed opacity and emissivity in HE II lines ****
C          (for IHE2L=1)
C
      IF(IHE2L.GT.0) THEN
      CALL HE2LIN(ID,M,NFREQ,ABLIN,EMLIN)
      DO IJ=M,NFREQ
         ABSO(IJ)=ABSO(IJ)+ABLIN(IJ)
         EMIS(IJ)=EMIS(IJ)+EMLIN(IJ)
      END DO
      END IF
C
C     opacity due to detailed photoinization cross-section
C     (from tables; including resonance features)
C     The two routines may be called and correspond to different formats
C     as well as difference in INPUT!
C
      CALL PHTION(ID,ABSO,EMIS,FREQ,NFREQ)
      CALL PHTX(ID,ABSO,EMIS,FREQ,0)
C
       if(imode.ge.0) then
          do ij=1,nfreq
             abso(ij)=abso(ij)+scat(ij)
          end do
       end if
C
      IF(ICONTL.EQ.1) RETURN
      ABSO(1)=ABSO(1)-ABLY1
      EMIS(1)=EMIS(1)-EMLY1
      SCAT(1)=SCAT(1)-SCLY1
      ABSO(2)=ABSO(2)-ABLY
      EMIS(2)=EMIS(2)-EMLY
      SCAT(2)=SCAT(2)-SCLY
      RETURN
      END