SUBROUTINE BPOPT(ID)
C     ====================
C
C     the part of B-matrix corresponding to the population rows
C     and T and ne columns
C
      INCLUDE 'IMPLIC.FOR'
      INCLUDE 'BASICS.FOR'
      INCLUDE 'ATOMIC.FOR'
      INCLUDE 'MODELQ.FOR'
      INCLUDE 'ARRAY1.FOR'
      INCLUDE 'ALIPAR.FOR'
      INCLUDE 'ODFPAR.FOR'
      PARAMETER (TRHA=1.5D0)
      PARAMETER (CCOR=0.09,SIXTH=UN/6.)
      DIMENSION DCOL(MTRANS),DLOC(MTRANS),AM(MLEVEL)
C
      NSE=NFREQE+INSE-1
      IF(INRE.EQ.0.AND.INPC.EQ.0) GO TO 400  
      IF(IELH.GT.0) N0HN=NFIRST(IELH)
      NKH=IABS(IIEXP(NREFS(IATREF,ID)))
      T=TEMP(ID)
      ANE=ELEC(ID)
      HKT=HK/T
      TK=HKT/H
      ANMNE1=WMM(ID)*DENS1(ID)
      DO I=1,NTRANS
         DCOL(I)=0.
      END DO
      DO I=1,NLEVEL
         AM(I)=0.
      END DO
C
C     Derivatives of collisional rates wrt temperature - DCOL
C     Note that these derivatives are calculated numerically
C
      IF(.NOT.LTE.AND.INRE.GT.0.AND.ID.LT.IDLTE) THEN
         DELTAT=T*1.D-4
         CALL COLIS(ID,T+DELTAT,DCOL,DLOC)
         DO ITR=1,NTRANS
            DCOL(ITR)=(DCOL(ITR)-COLRAT(ITR,ID))/DELTAT
         end do
      END IF
C
C     Column corresponding to temperature and electron density, ie. the
C     (NFREQE+INRE)-th and (NFREQE+INPC)-t resach columns
C
C      ATT(I) - auxiliary vector = (derivative of rate matrix wrt
C              temperature) times (vector of populations)
C
C      ANN(I) - auxiliary vector = (derivative of rate matrix wrt
C              electron density) times (vector of populations)
C
C
C     a) contribution to AT and AN from true statistical equilibrium
C        equations (arising due to dependence of transition rates on
C        temperature and electron density);
C        derivatives contain the collisional-radiative switching
C        parameter CRSW
C
         IF(.NOT.LTE.AND.ID.LT.IDLTE) THEN
            DO 230 ITR=1,NTRANS
               I=ILOW(ITR)
               IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 230
               J=IUP(ITR)
               IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 230
               II=IABS(IIEXP(I))
               JJ=IABS(IIEXP(J))
               NREFI=NREFS(IATM(I),ID)
               IF(.NOT.LINE(ITR)) THEN
                  DLGT=-(TRHA+HKT*FR0(ITR))/T
                  DLGN=ELEC1(ID)
                ELSE
                  DLGT=-HKT*FR0(ITR)/T
                  DLGN=0.
               END IF
               POPI=ABTRA(ITR,ID)
               POPJ=EMTRA(ITR,ID)
               PJI=POPJ*(RRD(ITR,ID)+COLRAT(ITR,ID))
               AVT=(POPI-POPJ)*DCOL(ITR)-PJI*DLGT-
     *              POPJ*DRDT(ITR,ID)
               AVN=(POPI-POPJ)*COLRAT(ITR,ID)/ane-PJI*DLGN
C
               IF(I.NE.NREFI.AND.II.GT.0.AND.ILTLEV(I).LE.0) THEN
                  ATT(II)=ATT(II)+AVT
                  ANN(II)=ANN(II)+AVN
                  IF(JJ.EQ.0) THEN
                     ATT(II)=ATT(II)-PJI*DSBPST(J,ID)
                     ANN(II)=ANN(II)-PJI*DSBPSN(J,ID)
                  END IF
               END IF
               IF(J.NE.NREFI.AND.JJ.GT.0.AND.ILTLEV(J).LE.0.
     *         and.iabs(imodl(i)).ne.4) THEN
                  ATT(JJ)=ATT(JJ)-AVT
                  ANN(JJ)=ANN(JJ)-AVN
                  IF(II.EQ.0) THEN
                     PIJ=POPI*(RRU(ITR,ID)+COLRAT(ITR,ID))
                     ATT(JJ)=ATT(JJ)-PIJ*DSBPST(I,ID)
                     ANN(JJ)=ANN(JJ)-PIJ*DSBPSN(I,ID)
                  END IF
               END IF
  230       CONTINUE
         END IF
C
C      simple expressions in the case of LTE
C
      LLT=LTE.OR.ID.GE.IDLTE
      DO IAT=1,NATOM
         DO I=N0A(IAT),NKA(IAT)
            II=IABS(IIEXP(I))
            IF(II.NE.0.AND.I.NE.NREFS(IAT,ID)) THEN
               IF(LLT.OR.ILTION(IEL(I)).GE.1.OR.ILTLEV(I).GE.1) THEN
                  ATT(II)=ATT(II)-POPUL(I,ID)*DSBPST(I,ID)
                  ANN(II)=ANN(II)-POPUL(I,ID)*DSBPSN(I,ID)
               END IF
            END IF
         END DO
      END DO
C
C
C      b) contribution to AT and AN (and AM - for total particle density)
C         from the abundance definition equations
C
      DO IAT=1,NATOM
         IF(IIFIX(IAT).NE.1) THEN
         NREFII=IABS(IIEXP(NREFS(IAT,ID)))
         IF(NREFII.NE.0) THEN
         DO I=N0A(IAT),NKA(IAT)
            IL=ILK(I)
            II=IIEXP(I)
            IF(IL.EQ.0) THEN
               IF(II.EQ.0) THEN
                  ATT(NREFII)=ATT(NREFII)+POPUL(I,ID)*DSBPST(I,ID)
                  ANN(NREFII)=ANN(NREFII)+POPUL(I,ID)*DSBPSN(I,ID)
               END IF
             ELSE
               ATT(NREFII)=ATT(NREFII)+POPUL(I,ID)*DUSUMT(IL)*ANE
               ANN(NREFII)=ANN(NREFII)+
     *                     POPUL(I,ID)*(USUM(IL)+ANE*DUSUMN(IL))
            END IF
         END DO
         if(ifmol.eq.0.or.t.gt.tmolim) then
            ANN(NREFII)=ANN(NREFII)+UN/YTOT(ID)*ABUND(IAT,ID)
            AM(NREFII)=AM(NREFII)-UN/YTOT(ID)*ABUND(IAT,ID)
         end if
         END IF
         END IF
      END DO
C
C -----------------------
C     Having evaluated auxiliary vectors AT, AN, AM, we may now set up
C     the columns corresponding to temperature, el.density, and total
C     particle number density
C
      DO I=1,NLVEXP
         IF(IFPOPR.LE.3) THEN
         AVT=0.
         AVN=0.
         AVM=0.
         DO J=1,NLVEXP
            AVT=AVT-ESEMAT(I,J)*ATT(J)
            AVN=AVN-ESEMAT(I,J)*ANN(J)
            AVM=AVM-ESEMAT(I,J)*AM(J)
         END DO
         ELSE
            AVT=ATT(I)
            AVN=ANN(I)
            AVM=AM(I)
         END IF
         IF(INHE.NE.0) B(NSE+I,NFREQE+INHE)=B(NSE+I,NFREQE+INHE)+AVM
         IF(INRE.NE.0) B(NSE+I,NFREQE+INRE)=B(NSE+I,NFREQE+INRE)+AVT
         IF(INPC.NE.0) B(NSE+I,NFREQE+INPC)=B(NSE+I,NFREQE+INPC)+AVN
      END DO
C
C     Columns corresponding to populations
C
  400 CONTINUE
      IF(IFPOPR.LE.3) THEN
         DO I=1,NLVEXP
            B(NSE+I,NSE+I)=B(NSE+I,NSE+I)-UN
            IF(IABS(IFPOPR).GE.3) THEN
               SUM=0.
               DO J=1,NLVEXP
                  SUM=SUM+ESEMAT(I,J)*BESE(J)
               END DO
               VECL(NSE+I)=POPGRP(I)-SUM
            END IF
         END DO
       ELSE IF(IFPOPR.LE.5) THEN
         DO I=1,NLVEXP
            SUM=0.
            DO J=1,NLVEXP
               SUM=SUM+ESEMAT(I,J)*POPGRP(J)
               B(NSE+I,NSE+J)=B(NSE+I,NSE+J)+ESEMAT(I,J)
            END DO
            VECL(NSE+I)=BESE(I)-SUM
         END DO
      END IF
      RETURN
      END