188 lines
5.8 KiB
Fortran
188 lines
5.8 KiB
Fortran
SUBROUTINE BPOPE(ID)
|
|
C ====================
|
|
C
|
|
C the part of B-matrix corresponding to the population rows and
|
|
C the explicit frequency columns
|
|
C -- a variant for the full overlap case
|
|
C
|
|
INCLUDE 'IMPLIC.FOR'
|
|
INCLUDE 'BASICS.FOR'
|
|
INCLUDE 'ATOMIC.FOR'
|
|
INCLUDE 'MODELQ.FOR'
|
|
INCLUDE 'ODFPAR.FOR'
|
|
INCLUDE 'ALIPAR.FOR'
|
|
INCLUDE 'ITERAT.FOR'
|
|
INCLUDE 'ARRAY1.FOR'
|
|
DIMENSION AJIJ(MFREX,MLVEXP),EHKE(MFREX)
|
|
C
|
|
IF(NFREQE.LE.0) RETURN
|
|
NSE=NFREQE+INSE-1
|
|
DO I=1,NLVEXP
|
|
DO IJE=1,NFREQE
|
|
AJIJ(IJE,I)=0.
|
|
END DO
|
|
END DO
|
|
HKT=HK/TEMP(ID)
|
|
DO IJE=1,NFREQE
|
|
EHKE(IJE)=EXP(-HKT1(ID)*FREQ(IJFR(IJE)))
|
|
END DO
|
|
C
|
|
DO 100 IJ=1,NFREQ
|
|
IF(IJEX(IJ).LE.0) GO TO 100
|
|
IF(IJX(IJ).EQ.-1) GOTO 100
|
|
IJE=IJEX(IJ)
|
|
FR=FREQ(IJ)
|
|
FRINV=UN/FR
|
|
FR3INV=FRINV*FRINV*FRINV
|
|
C
|
|
C ---------------------
|
|
C Continuum transitions
|
|
C ---------------------
|
|
C
|
|
DO 10 IBFT=1,NTRANC
|
|
ITR=ITRBF(IBFT)
|
|
SG=CROSS(IBFT,IJ)
|
|
IF(SG.LE.0.) GO TO 10
|
|
I=ILOW(ITR)
|
|
IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 10
|
|
ICDW=MCDW(ITR)
|
|
IMER=IMRG(I)
|
|
II=IABS(IIEXP(I))
|
|
J=IUP(ITR)
|
|
IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 10
|
|
JJ=IABS(IIEXP(J))
|
|
NREFI=NREFS(IATM(I),ID)
|
|
IF(IFWOP(I).GE.0) THEN
|
|
IF(ICDW.GE.1) THEN
|
|
IZZ=IZ(IEL(I))
|
|
CALL DWNFR1(FR,FR0(ITR),ID,IZZ,DW1)
|
|
SG=SG*DW1
|
|
END IF
|
|
ELSE
|
|
CALL SGMER1(FRINV,FR3INV,IMER,ID,SGME1)
|
|
SG=SGME1
|
|
ENDIF
|
|
W0=W0E(IJ)
|
|
SGW0=SG*W0
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EHKE(IJE))*SGW0
|
|
IF(II.GT.0.AND.I.NE.NREFI.AND.ILTLEV(I).LE.0)
|
|
* AJIJ(IJE,II)=AJIJ(IJE,II)+APFR
|
|
IF(JJ.GT.0.AND.J.NE.NREFI.AND.ILTLEV(J).LE.0.
|
|
* and.iabs(imodl(i)).ne.4)
|
|
* AJIJ(IJE,JJ)=AJIJ(IJE,JJ)-APFR
|
|
10 CONTINUE
|
|
C
|
|
C ----------------
|
|
C Line transitions
|
|
C ----------------
|
|
C
|
|
IF(ISPODF.EQ.0) THEN
|
|
IF(IJLIN(IJ).GT.0) THEN
|
|
C
|
|
C the "primary" line at the given frequency
|
|
C
|
|
ITR=IJLIN(IJ)
|
|
IF(LINEXP(ITR)) GO TO 20
|
|
IF(.NOT.LEXP(ITR)) GO TO 20
|
|
I=ILOW(ITR)
|
|
IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 20
|
|
J=IUP(ITR)
|
|
IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 20
|
|
II=IABS(IIEXP(I))
|
|
JJ=IABS(IIEXP(J))
|
|
IF(II.LE.0.AND.JJ.LE.0) GO TO 20
|
|
NREFI=NREFS(IATM(I),ID)
|
|
SGW=PRFLIN(ID,IJ)*W0E(IJ)
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EHKE(IJE))*SGW
|
|
IF(II.GT.0.AND.I.NE.NREFI.AND.ILTLEV(I).LE.0)
|
|
* AJIJ(IJE,II)=AJIJ(IJE,II)+APFR
|
|
IF(JJ.GT.0.AND.J.NE.NREFI.AND.ILTLEV(J).LE.0.
|
|
* and.iabs(imodl(i)).ne.4)
|
|
* AJIJ(IJE,JJ)=AJIJ(IJE,JJ)-APFR
|
|
END IF
|
|
C
|
|
C the "overlapping" lines at the given frequency
|
|
C
|
|
20 IF(NLINES(IJ).LE.0) GO TO 100
|
|
DO 50 ILINT=1,NLINES(IJ)
|
|
ITR=ITRLIN(ILINT,IJ)
|
|
IF(LINEXP(ITR)) GO TO 50
|
|
I=ILOW(ITR)
|
|
IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 50
|
|
J=IUP(ITR)
|
|
IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 50
|
|
II=IABS(IIEXP(I))
|
|
JJ=IABS(IIEXP(J))
|
|
IF(II.LE.0.AND.JJ.LE.0) GO TO 50
|
|
NREFI=NREFS(IATM(I),ID)
|
|
IJ0=IFR0(ITR)
|
|
DO IJT=IJ0,IFR1(ITR)
|
|
IF(FREQ(IJT).LE.FR) THEN
|
|
IJ0=IJT
|
|
GO TO 40
|
|
END IF
|
|
END DO
|
|
40 IJ1=IJ0-1
|
|
X=W0E(IJ)/(FREQ(IJ1)-FREQ(IJ0))
|
|
A1=(FR-FREQ(IJ0))*X
|
|
A2=(FREQ(IJ1)-FR)*X
|
|
SGW=A1*PRFLIN(ID,IJ1)+A2*PRFLIN(ID,IJ0)
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EHKE(IJE))*SGW
|
|
IF(II.GT.0.AND.I.NE.NREFI.AND.ILTLEV(I).LE.0)
|
|
* AJIJ(IJE,II)=AJIJ(IJE,II)+APFR
|
|
IF(JJ.GT.0.AND.J.NE.NREFI.AND.ILTLEV(J).LE.0.
|
|
* and.iabs(imodl(i)).ne.4)
|
|
* AJIJ(IJE,JJ)=AJIJ(IJE,JJ)-APFR
|
|
50 CONTINUE
|
|
C
|
|
C Opacity sampling option
|
|
C
|
|
ELSE
|
|
IF(NLINES(IJ).LE.0) GO TO 100
|
|
DO 150 ILINT=1,NLINES(IJ)
|
|
ITR=ITRLIN(ILINT,IJ)
|
|
I=ILOW(ITR)
|
|
IF(ILTION(IEL(I)).GE.1.OR.IIFIX(IATM(I)).EQ.1) GO TO 150
|
|
J=IUP(ITR)
|
|
IF(IPZERO(I,ID).NE.0.OR.IPZERO(J,ID).NE.0) GO TO 150
|
|
KJ=IJ-IFR0(ITR)+KFR0(ITR)
|
|
II=IABS(IIEXP(I))
|
|
JJ=IABS(IIEXP(J))
|
|
IF(II.LE.0.AND.JJ.LE.0) GO TO 150
|
|
NREFI=NREFS(IATM(I),ID)
|
|
INDXPA=IABS(INDEXP(ITR))
|
|
IF(INDXPA.NE.3 .AND. INDXPA.NE.4) THEN
|
|
SG=PRFLIN(ID,KJ)
|
|
ELSE
|
|
KJD=JIDI(ID)
|
|
SG=EXP(XJID(ID)*SIGFE(KJD,KJ)+
|
|
* (UN-XJID(ID))*SIGFE(KJD+1,KJ))
|
|
END IF
|
|
APFR=(ABTRA(ITR,ID)-EMTRA(ITR,ID)*EHKE(IJE))*SG*W0E(IJ)
|
|
IF(II.GT.0.AND.I.NE.NREFI.AND.ILTLEV(I).LE.0)
|
|
* AJIJ(IJE,II)=AJIJ(IJE,II)+APFR
|
|
IF(JJ.GT.0.AND.J.NE.NREFI.AND.ILTLEV(J).LE.0.
|
|
* and.iabs(imodl(i)).ne.4)
|
|
* AJIJ(IJE,JJ)=AJIJ(IJE,JJ)-APFR
|
|
150 CONTINUE
|
|
END IF
|
|
100 CONTINUE
|
|
C
|
|
C elements of the B-matrix
|
|
C
|
|
DO I=1,NLVEXP
|
|
DO IJE=1,NFREQE
|
|
IF(IFPOPR.LE.3) THEN
|
|
SUM=0.
|
|
DO J=1,NLVEXP
|
|
SUM=SUM-ESEMAT(I,J)*AJIJ(IJE,J)
|
|
END DO
|
|
ELSE
|
|
SUM=AJIJ(IJE,I)
|
|
END IF
|
|
B(NSE+I,IJE)=SUM*CRSW(ID)
|
|
END DO
|
|
END DO
|
|
RETURN
|
|
END
|