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