fmq/SpectraRust
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

git push -u origin main

Browse Source
This commit is contained in:
fmq
2026-03-19 14:05:33 +08:00
commit 1e30b7bc63
739 changed files with 572150 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
synspec/extracted/nltset.f
+403
View File
@@ -0,0 +1,403 @@
SUBROUTINE NLTSET(MODE,IL,IAT,ION,ALAM0,EXCL,EXCU,QL,QU,
* ISQL,ILQL,IPQL,ISQU,ILQU,IPQU,IEVEN,INNLT0,ILMATCH)
C ===============================================================
C
C NLTE option - automatic assignement of level indices
C
INCLUDE 'PARAMS.FOR'
INCLUDE 'MODELP.FOR'
INCLUDE 'SYNTHP.FOR'
INCLUDE 'LINDAT.FOR'
PARAMETER (MNION = MIOEX,
* MNLEV = MLEVEL,
* ECONST= 5.03411142E15)
PARAMETER (INLLEV = 13)
COMMON/NL2PAR/ELIMEV(MNION,MNLEV),ELIMOD(MNION,MNLEV),
* ELIML(MNION,MNLEV),
* ENREV(MNION,MNLEV),ENROD(MNION,MNLEV),
* INDEV(MNION,MNLEV),INDOD(MNION,MNLEV),
C * INDLV(MNION,MNLEV),
* INDLV(MNION,MNLEV),INDIO(MNION),
* NEVEN(MNION),NODD(MNION),NODD0,NLEVS(MNION),
* IATN(MNION),IONN(MNION),NNION
COMMON/PRINTP/TYPLEV
CHARACTER*10 TYPLEV(MLEVEL),typ
character*4 typ1
character*2 typ2
character*2 typin(60)
data typin /' 1',' 2',' 3',' 4',' 5',' 6',' 7',' 8',' 9','10',
* '11','12','13','14','15','16','17','18','19','20',
* '21','22','23','24','25','26','27','28','29','30',
* '31','32','33','34','35','36','37','38','39','40',
* '41','42','43','44','45','46','47','48','49','50',
* '51','52','53','54','55','56','57','58','59','60'/
C
C +++++++++++++++++++++++++++
C MODE = 0 - initialization
C +++++++++++++++++++++++++++
C
IF(MODE.EQ.0) THEN
NNION=0
READ(INLLEV,*,END=55,ERR=55) NNION
IF(NNION.LE.0) GO TO 55
DO I=1,NNION
READ(INLLEV,*) IATN(I),IONN(I)
READ(INLLEV,*) NEVEN(I)
IF(NEVEN(I).GT.0) THEN
DO J=1,NEVEN(I)
READ(INLLEV,*) ELIMEV(I,J)
END DO
READ(INLLEV,*) NODD(I)
NODD0=NODD(I)
IF(NODD(I).GT.0) THEN
DO J=1,NODD(I)
READ(INLLEV,*) ELIMOD(I,J)
END DO
ELSE
NODD(I)=NEVEN(I)
DO J=1,NODD(I)
ELIMOD(I,J)=ELIMEV(I,J)
END DO
END IF
INDION=0
DO IONEX=1,NION
N0I=NFIRST(IONEX)
IA=NUMAT(IATM(N0I))
IF(IA.EQ.IATN(I).AND.IZ(IONEX)-1.EQ.IONN(I)) INDION=IONEX
END DO
IF(INDION.LE.0) THEN
call quit(' INCONSISTENCY IN UNIT 13 INPUT - NLTE')
END IF
NOFF=NFIRST(INDION)-1
c
ine=1
ino=1
do ii=nfirst(indion),nlast(indion)
TYP=TYPLEV(II)
typ1=typ(2:5)
typ2=typ(8:9)
iev=0
if(typ1.eq.'even') iev=1
do k=1,60
if(typin(k).eq.typ2) ind=k
end do
if(iev.eq.1) then
indev(i,ine)=ii
write(11,*) 'super-e ',i,ii,ine,elimev(i,ine)
ine=ine+1
else
indod(i,ino)=ii
write(11,*) 'super-o ',i,ii,ino,elimod(i,ino)
ino=ino+1
end if
end do
END IF
END DO
C
55 CONTINUE
C
INDION=NNION
DO 90 IONEX=1,NION
N0I=NFIRST(IONEX)
IA=NUMAT(IATM(N0I))
if(isemex(ia).ge.1) go to 90
IONM1=IZ(IONEX)-1
IF(IA.EQ.1.OR.IA.EQ.2) GO TO 90
DO I=1,NNION
IF(IA.EQ.IATN(I).AND.IONM1.EQ.IONN(I)) GO TO 90
END DO
IF(NFIRST(IONEX).EQ.NLAST(IONEX)) GO TO 90
INDION=INDION+1
EION=ENION(NFIRST(IONEX))
NLEVS(INDION)=NLAST(IONEX)-NFIRST(IONEX)+1
INDIO(INDION)=IONEX
NEVEN(INDION)=0
IATN(INDION)=IA
IONN(INDION)=IONM1
DELE=0.
DO II=NFIRST(IONEX),NLAST(IONEX)
I=II-NFIRST(IONEX)+1
E=(EION-ENION(II))*ECONST
IF(II.LT.NLAST(IONEX)) THEN
E1=(EION-ENION(II+1))*ECONST
DELE=0.5*(E1-E)
ELIML(INDION,I)=E+DELE
ELSE
IF(INLTE.GE.2) THEN
ELIML(INDION,I)=E+DELE
ELSE
ELIML(INDION,I)=EION*ECONST
END IF
END IF
INDLV(INDION,I)=II
END DO
90 CONTINUE
NNION=INDION
C Header for the table with the level assignments
C
if(inlte.gt.0.and.iprin.ge.1)
* WRITE(11,*)'NLTSET: IAT ION LAMBDA EXCL '//
* ' EXCU ILWN IUN'
RETURN
END IF
C
C
C ++++++++++++++++++++++++++++++++++++++++++
C MODE > 0 - level indices for the line IL
C ++++++++++++++++++++++++++++++++++++++++++
C
IF(NNION.LE.0) RETURN
INION=0
IONM1=ION-1
DO I=1,NNION
IF(IAT.EQ.IATN(I).AND.IONM1.EQ.IONN(I)) INION=I
END DO
if(isemex(iat).ge.1) RETURN
IF(INION.LE.0) RETURN
IF(NEVEN(INION).EQ.0) IEVEN=2
IF(NEVEN(INION).LT.0) GOTO 400
C
IF(IEVEN.EQ.1) THEN
IND=0
DO 110 J=1,NEVEN(INION)
IF(EXCL.LE.ELIMEV(INION,J)) THEN
IND=J
GO TO 120
END IF
110 CONTINUE
ILWN=0
GO TO 145
120 CONTINUE
ILWN=INDEV(INION,IND)
C
IND=0
DO 130 J=1,NODD(INION)
IF(EXCU.LE.ELIMOD(INION,J)) THEN
IND=J
GO TO 140
END IF
130 CONTINUE
IUN=0
GO TO 145
140 CONTINUE
IUN=INDOD(INION,IND)
145 CONTINUE
C
ELSE IF(IEVEN.EQ.0) THEN
IND=0
DO 150 J=1,NODD(INION)
IF(EXCL.LE.ELIMOD(INION,J)) THEN
IND=J
GO TO 160
END IF
150 CONTINUE
ILWN=0
GO TO 200
160 CONTINUE
ILWN=INDOD(INION,IND)
C
IND=0
DO 170 J=1,NEVEN(INION)
IF(EXCU.LE.ELIMEV(INION,J)) THEN
IND=J
GO TO 180
END IF
170 CONTINUE
IUN=0
GO TO 200
180 CONTINUE
IUN=INDEV(INION,IND)
200 CONTINUE
c
c transition between levels without a distinction in parity
c
ELSE
IF (ILIMITS(INDIO(INION)).EQ.0.OR.INLIST.GE.10) THEN
C level identification: using only energy limits
C
IND=0
DO 210 J=1,NLEVS(INION)
IF(EXCL.LE.ELIML(INION,J)) THEN
IND=J
GO TO 220
END IF
210 CONTINUE
ILWN=0
IUN=0
GO TO 300
220 CONTINUE
ILWN=INDLV(INION,IND)
C
IND=0
DO 230 J=1,NLEVS(INION)
IF(EXCU.LE.ELIML(INION,J)) THEN
IND=J
GO TO 240
END IF
230 CONTINUE
IUN=0
GO TO 300
240 CONTINUE
IUN=INDLV(INION,IND)
300 CONTINUE
ELSE IF (ILIMITS(INDIO(INION)).EQ.1.and.inlist.lt.10) THEN
C
C level identification: using energy limits and quantum numbers
C
IND=0
INMATCHL=0
DO 310 J=1,NLEVS(INION)
IF(EXCL.GE.ENION1(INDLV(INION,J)) .AND.
* EXCL.LE.ENION2(INDLV(INION,J)). AND.
* ((IPQL.GE.PQUANT1(INDLV(INION,J)).AND.
* IPQL.LE.PQUANT2(INDLV(INION,J))).OR.
* (IPQL.EQ.-1)) .AND.
* ((ISQL.GE.SQUANT1(INDLV(INION,J)).AND.
* ISQL.LE.SQUANT2(INDLV(INION,J))).OR.
* (ISQL.EQ.-1)) .AND.
* ((ILQL.GE.LQUANT1(INDLV(INION,J)).AND.
* ILQL.LE.LQUANT2(INDLV(INION,J))).OR.
* (ILQL.EQ.-1))
* ) THEN
IND=J
INMATCHL=INMATCHL+1
C GO TO 320
END IF
310 CONTINUE
IF (INMATCHL.GT.1)
* WRITE(11,'(A55,1X,F12.4)')
* ' NLTSET: WARNING-- multiple matches for lower level of ',
* ALAM0
IF (INMATCHL.GT.0) GO TO 320
ILWN=0
IUN=0
GO TO 350
320 CONTINUE
ILWN=INDLV(INION,IND)
C
C
IND=0
INMATCHU=0
DO 330 J=1,NLEVS(INION)
IF(EXCU.GE.ENION1(INDLV(INION,J)) .AND.
* EXCU.LE.ENION2(INDLV(INION,J)). AND.
* ((IPQU.GE.PQUANT1(INDLV(INION,J)).AND.
* IPQU.LE.PQUANT2(INDLV(INION,J))).OR.
* (IPQU.EQ.-1)) .AND.
* ((ISQU.GE.SQUANT1(INDLV(INION,J)).AND.
* ISQU.LE.SQUANT2(INDLV(INION,J))).OR.
* (ISQU.EQ.-1)) .AND.
* ((ILQU.GE.LQUANT1(INDLV(INION,J)).AND.
* ILQU.LE.LQUANT2(INDLV(INION,J))).OR.
* (ILQU.EQ.-1))
* ) THEN
IND=J
INMATCHU=INMATCHU+1
C GO TO 340
END IF
330 CONTINUE
IF (INMATCHU.GT.1)
* WRITE(11,'(A55,1X,F12.4)')
* ' NLTSET: WARNING-- multiple matches for upper level of ',
* ALAM0
IF (INMATCHU.GT.0) GO TO 340
IUN=0
GO TO 350
340 CONTINUE
IUN=INDLV(INION,IND)
350 CONTINUE
IF (INMATCHL.EQ.0.or.INMATCHU.EQ.0) THEN
ILMATCH=0
ELSE IF (INMATCHL.GT.1.or.INMATCHU.GT.1) THEN
ILMATCH=2
ELSE
ILMATCH=1
ENDIF
ELSE
write(11,*)('ILIMITS is neither 0 or 1')
END IF
if(inlte.gt.0.and.iprin.ge.1)
* WRITE(11,'(10x,2(i2,1x),3x,3(F10.3,1x),2(i4,1x))')IAT,ION,
* ALAM0,EXCL,EXCU,ILWN,IUN
END IF
C
400 IF(NEVEN(INION).LT.0) THEN
NEV1=-NEVEN(INION)
IF(IEVEN.EQ.1) THEN
ILWN=0
J=1
DO WHILE (ILWN.EQ.0 .AND. J.LE.NEV1)
IF(QL.EQ.ELIMEV(INION,J)) THEN
DE=ENREV(INION,J)
IF(EXCL.NE.0.) DE=(EXCL-DE)/EXCL
IF(ABS(DE).LT.1.D-5) ILWN=INDEV(INION,J)
END IF
J=J+1
END DO
IUN=0
J=1
DO WHILE (IUN.EQ.0 .AND. J.LE.NODD(INION))
IF(QU.EQ.ELIMOD(INION,J)) THEN
DE=(EXCU-ENROD(INION,J))/EXCU
IF(ABS(DE).LT.1.D-5) IUN=INDOD(INION,J)
END IF
J=J+1
END DO
ELSE IF(IEVEN.EQ.0) THEN
ILWN=0
J=1
DO WHILE (ILWN.EQ.0 .AND. J.LE.NODD(INION))
IF(QL.EQ.ELIMOD(INION,J)) THEN
DE=ENROD(INION,J)
IF(EXCL.NE.0.) DE=(EXCL-DE)/EXCL
IF(ABS(DE).LT.1.D-5) ILWN=INDOD(INION,J)
END IF
J=J+1
END DO
IUN=0
J=1
DO WHILE (IUN.EQ.0 .AND. J.LE.NEV1)
IF(QU.EQ.ELIMEV(INION,J)) THEN
DE=(EXCU-ENREV(INION,J))/EXCU
IF(ABS(DE).LT.1.D-5) IUN=INDEV(INION,J)
END IF
J=J+1
END DO
END IF
END IF
C
IF(INLTE.EQ.5) THEN
INNLT0=INNLT0+1
INDNLT(IL)=INNLT0
ELSE IF(INLTE.EQ.4) THEN
IF(ILWN.GT.0.AND.IUN.GT.0) THEN
INDNLT(IL)=-1
END IF
ELSE IF(INLTE.EQ.3) THEN
IF(ILWN.GT.0) THEN
INDNLT(IL)=-1
END IF
ELSE
INDNLT(IL)=-1
END IF
BNUL(IL)=real(BN*(FREQ0(IL)*1.E-15)**3)
ILOWN(IL)=ILWN
IUPN(IL)=IUN
RETURN
END