201 lines
6.3 KiB
Fortran
201 lines
6.3 KiB
Fortran
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
|