SUBROUTINE INIFRS C ================= C C Setup frequencies in opacity sampling mode C INCLUDE 'IMPLIC.FOR' INCLUDE 'BASICS.FOR' INCLUDE 'ATOMIC.FOR' INCLUDE 'MODELQ.FOR' INCLUDE 'ODFPAR.FOR' PARAMETER (THIRD=UN/3.,FTH=4./3.) DIMENSION FRLEV(MLEVEL),IENS(MLEVEL),ITRL(MLEVEL) DIMENSION FRL0(MTRANS),FRL1(MTRANS),FRLC(5*MTRANS) DIMENSION IKC(5*MTRANS),ITKC(5*MTRANS),ITJNU(5*MTRANS) DIMENSION FLNU(2*MATOM+3),DLNU(2*MATOM+3),ILNU(2*MATOM+3) DIMENSION XMASS(30) DATA XMASS/ 1.008, 4.003, 6.941, 9.012,10.810,12.011,14.007, & 16.000,18.918,20.179,22.990,24.305,26.982,28.086, & 30.974,32.060,35.453,39.948,39.098,40.080,44.956, & 47.900,50.941,51.996,54.938,55.847,58.933,58.700, & 63.546,65.380/ C IF(TSNU.EQ.0.) TSNU=TEFF IF(VTNU.EQ.0.) VTNU=VTB IF(VTNU.LT.1.D4) VTNU=VTNU*1.D5 FRS1=CNU1*1.D11*TSNU FRS2=3.28805D15/CNU2/CNU2 C DO IAT=1,NATOM CDOP=TWO*BOLK/AMASS(IAT) DLNU(IAT)=0.375/2.997925D10*SQRT(CDOP*TSNU+VTNU*VTNU) DLNU(IAT+NATOM)=20.*DLNU(IAT) FLNU(IAT)=DLOG(FRS1) FLNU(IAT+NATOM)=DLOG(FRS1) END DO C XPNU=24. CDOP=TWO*BOLK/XMASS(1)/HMASS DLNU(2*NATOM+1)=50./2.997925D10*SQRT(CDOP*TSNU+VTNU*VTNU) DLNU(2*NATOM+2)=5.*DLNU(2*NATOM+1) FLNU(2*NATOM+1)=DLOG(FRS2) FLNU(2*NATOM+2)=DLOG(FRCMIN) NNU=2*NATOM+3 IF(ISPODF.EQ.1 .AND. DDNU.GT.0.) THEN CDOP=TWO*BOLK/AMASS(NATOM) IF(IELNU.GT.0) CDOP=TWO*BOLK/XMASS(IELNU)/HMASS DLNU(NNU)=DDNU/2.997925D10*SQRT(CDOP*TSNU+VTNU*VTNU) FLNU(NNU)=DLOG(FRS2) ELSE DLNU(NNU)=DLNU(2*NATOM+2) FLNU(NNU)=DLOG(FRS1) END IF CALL INDEXX(NNU,DLNU,ILNU) C C Store line and continua frequencies C NLIC=0 DO 10 ITR=1,NTRANS IJTC(ITR)=0 INDXPA=IABS(INDEXP(ITR)) IF(INDXPA.EQ.0) GO TO 10 IF(INDXPA.EQ.3 .OR. INDXPA.EQ.4) GO TO 10 IF(FR0(ITR).EQ.0.) GO TO 10 IF(LINE(ITR)) THEN ILV0=ILOW(ITR) IAT=IATM(ILV0) ITC=ITRA(ILV0,NNEXT(IEL(ILV0))) IF(ITC.EQ.0) ITC=ITRA(ILV0,NNEXT(IEL(ILV0))+1) IF(INDXPA.NE.2) THEN FRLC(NLIC+1)=FR0(ITR) ITKC(NLIC+1)=ITR IJTC(ITR)=NLIC+1 ITJNU(NLIC+1)=IAT FRLC(NLIC+2)=FREQ(IFR0(ITR)) FRL0(ITR)=FRLC(NLIC+2) ITKC(NLIC+2)=ITR IF(ITC.GT.0 .AND. FREQ(IFR0(ITR)).GT.FR0(ITC) .AND. * FR0(ITC).GT.FR0(ITR)) FRLC(NLIC+2)=0.999999*FR0(ITC) ITJNU(NLIC+2)=IAT FRLC(NLIC+3)=FREQ(IFR1(ITR)) FRL1(ITR)=FRLC(NLIC+3) ITKC(NLIC+3)=ITR ITJNU(NLIC+3)=2*NATOM+1 NLIC=NLIC+3 D0=DLOG(FRL0(ITR))-DLOG(FRL1(ITR)) IF(D0.GT.XPNU*DLNU(IAT)) THEN ITJNU(NLIC-1)=IAT+NATOM FRLC(NLIC+1)=EXP(DLOG(FR0(ITR))+XPNU*DLNU(IAT)) ITKC(NLIC+1)=ITR ITJNU(NLIC+1)=IAT FRLC(NLIC+2)=EXP(DLOG(FR0(ITR))-XPNU*DLNU(IAT)) ITKC(NLIC+2)=ITR ITJNU(NLIC+2)=IAT+NATOM NLIC=NLIC+2 END IF ELSE FRLC(NLIC+1)=0.999999*FR0(ITC) FRL0(ITR)=FRLC(NLIC+1) ITKC(NLIC+1)=ITR ITJNU(NLIC+1)=IAT FRLC(NLIC+2)=FREQ(IFR1(ITR-1)) FRL1(ITR)=FRLC(NLIC+2) ITKC(NLIC+2)=ITR ITJNU(NLIC+2)=2*NATOM+1 NLIC=NLIC+2 END IF ELSE NLIC=NLIC+1 FRLC(NLIC)=FR0(ITR) ITKC(NLIC)=ITR IJTC(ITR)=NLIC ITJNU(NLIC)=0 END IF 10 CONTINUE C IKC(1)=1 IF(NLIC.GT.1) CALL INDEXX(NLIC,FRLC,IKC) DO IJ=1,MFREQ FREQ(IJ)=0. W(IJ)=0. WCH(IJ)=0. NLINES(IJ)=0 END DO C C Sort continuum limits C CALL INDEXX(NLEVEL,ENION,IENS) DO IL=1,NLEVEL ILS=IENS(NLEVEL-IL+1) FRLEV(IL)=ENION(ILS)/H ITRL(IL)=ITRA(ILS,NNEXT(IEL(ILS))) END DO IF(FRCMAX.LT.1.01*FRLEV(1) .AND. FRCMAX.GT.0.) THEN ILS=IENS(NLEVEL) ILN=NNEXT(IEL(ILS)) ITR0=ITRA(ILS,ILN) WRITE(10,640) FRLEV(1),ILS,ILN,ITR0 640 FORMAT(1PE12.4,3I7) CALL QUIT(' Edge at frequency larger than FRCMAX; ii,itr:', * ils,itr0) END IF C C Highest frequency tail C IF(FRCMAX.LE.0.) FRCMAX=FRLEV(1)*CFRMAX IF(FRS1.GT.FRCMAX) THEN FRCMAX=FRS1 NFTAIL=0 END IF IF(NFTAIL.GT.0) THEN NFTA1=NFTAIL/2+1 FREQ(1)=FRCMAX NEND=0 IL=1 KJ=1 DO WHILE(FRLEV(IL).GT.FRS1) NEND1=NEND+NFTA1 NEND=NEND+NFTAIL ITR=ITRL(IL) IFR0(ITR)=1 IFR1(ITR)=NEND FREQ(NEND)=1.000001*FRLEV(IL) FREQ(NEND+1)=0.999999*FRLEV(IL) FREQ(NEND1)=FREQ(KJ)-(UN-DFTAIL)*(FREQ(KJ)-FREQ(NEND)) XEND=UN/FLOAT(NFTA1-1) D121=XEND*(FREQ(KJ)-FREQ(NEND1)) DO IJ=KJ+1,NEND1-1 FREQ(IJ)=FREQ(IJ-1)-D121 END DO D121=THIRD*(FREQ(KJ)-FREQ(KJ+1)) DO IJ=KJ+1,NEND1-1,2 W(IJ)=4.*D121 W(IJ-1)=W(IJ-1)+D121 W(IJ+1)=W(IJ+1)+D121 END DO D121=XEND*(FREQ(NEND1)-FREQ(NEND)) DO IJ=NEND1+1,NEND-1 FREQ(IJ)=FREQ(IJ-1)-D121 END DO D121=THIRD*(FREQ(NEND1)-FREQ(NEND1+1)) DO IJ=NEND1+1,NEND-1,2 W(IJ)=4.*D121 W(IJ-1)=W(IJ-1)+D121 W(IJ+1)=W(IJ+1)+D121 END DO D121=HALF*(FREQ(NEND)-FREQ(NEND+1)) W(NEND)=W(NEND)+D121 W(NEND+1)=W(NEND+1)+D121 IL=IL+1 KJ=NEND+1 END DO NEND1=NEND+NFTA1 NEND=NEND+NFTAIL FREQ(NEND)=FRS1 FREQ(NEND1)=FREQ(KJ)-(UN-DFTAIL)*(FREQ(KJ)-FREQ(NEND)) XEND=UN/FLOAT(NFTA1-1) D121=XEND*(FREQ(KJ)-FREQ(NEND1)) DO IJ=KJ+1,NEND1-1 FREQ(IJ)=FREQ(IJ-1)-D121 END DO D121=THIRD*(FREQ(KJ)-FREQ(KJ+1)) DO IJ=KJ+1,NEND1-1,2 W(IJ)=4.*D121 W(IJ-1)=W(IJ-1)+D121 W(IJ+1)=W(IJ+1)+D121 END DO D121=XEND*(FREQ(NEND1)-FREQ(NEND)) DO IJ=NEND1+1,NEND-1 FREQ(IJ)=FREQ(IJ-1)-D121 END DO D121=THIRD*(FREQ(NEND1)-FREQ(NEND1+1)) DO IJ=NEND1+1,NEND-1,2 W(IJ)=4.*D121 W(IJ-1)=W(IJ-1)+D121 W(IJ+1)=W(IJ+1)+D121 END DO ELSE FREQ(1)=FRS1 NEND=1 END IF NFREQC=NEND DO IJ=1,NFREQC IFREQB(IJ)=IJ END DO NFRS1=NFREQC C C Setup frequency points C DO IT=1,NTRANS IFR0(IT)=0 IFR1(IT)=0 END DO C IL=NLIC DO WHILE(FRLC(IKC(IL)).GT.FRS1) IL=IL-1 END DO NFREQ=NEND XFRA=DLOG(FRS1) DO WHILE(IL.GT.0) ITR=ITKC(IKC(IL)) NFS=0 XFRB=DLOG(FRLC(IKC(IL))) IF(XFRA.GT.XFRB) THEN IKNU=ITJNU(IKC(IL)) IDN=1 DO WHILE(FLNU(ILNU(IDN)).GE.XFRA .AND. IDN.LT.NNU) IDN=IDN+1 END DO DXNU=DLNU(ILNU(IDN)) IF(IKNU.EQ.0) XFRB=DLOG(1.000001*FRLC(IKC(IL))) NFS=INT((XFRA-XFRB)/DXNU)+1 XFS0=(XFRA-XFRB)/FLOAT(NFS) DO IJ=NFREQ+1,NFREQ+NFS XFR=DLOG(FREQ(IJ-1))-XFS0 FREQ(IJ)=EXP(XFR) END DO NFREQ=NFREQ+NFS IF(DLOG(FR0(ITR)).EQ.XFRB) IJTC(ITR)=NFREQ IF(IKNU.EQ.0) THEN IFR0(ITR)=1 IFR1(ITR)=NFREQ NFREQ=NFREQ+1 FREQ(NFREQ)=0.999999*FRLC(IKC(IL)) XFRB=DLOG(FREQ(NFREQ)) ELSE IF(IKNU.LE.2*NATOM) THEN IF(IFR0(ITR).EQ.0) THEN IFR0(ITR)=NFREQ D0=DLOG(FR0(ITR)) IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 IF(IABS(INDEXP(ITR)).EQ.2) THEN D0=DLOG(FR0(ITR-1)) IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 END IF ELSE IFR1(ITR)=NFREQ IF(IKNU.LE.NATOM) THEN IAT=IATM(ILOW(ITR)) D0=DLOG(FR0(ITR))-XPNU*DLNU(IAT) D1=DLOG(FRL1(ITR)) IF(D1.GT.D0) D0=D1 IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 ELSE D0=DLOG(FRL1(ITR)) IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 END IF END IF ELSE IF(IFR0(ITR).EQ.0) THEN IFR0(ITR)=NFREQ ELSE IFR1(ITR)=NFREQ END IF END IF ELSE IF(XFRA.EQ.XFRB) THEN IKNU=ITJNU(IKC(IL)) IF(IKNU.EQ.0) THEN FREQ(NFREQ)=1.000001*FRLC(IKC(IL)) FREQ(NFREQ+1)=0.999999*FRLC(IKC(IL)) IFR0(ITR)=1 IFR1(ITR)=NFREQ NFREQ=NFREQ+1 XFRB=DLOG(FREQ(NFREQ)) ELSE IF(IKNU.LE.2*NATOM) THEN IF(IFR0(ITR).EQ.0) THEN IFR0(ITR)=NFREQ D0=DLOG(FR0(ITR)) IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 IF(IABS(INDEXP(ITR)).EQ.2) THEN D0=DLOG(FR0(ITR-1)) IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 END IF ELSE IFR1(ITR)=NFREQ IF(IKNU.LE.NATOM) THEN IAT=IATM(ILOW(ITR)) D0=DLOG(FR0(ITR))-XPNU*DLNU(IAT) D1=DLOG(FRL1(ITR)) IF(D1.GT.D0) D0=D1 IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 ELSE D0=DLOG(FRL1(ITR)) IF(FLNU(IKNU).GT.D0) FLNU(IKNU)=D0 END IF IF(DLOG(FR0(ITR)).EQ.XFRB) IJTC(ITR)=NFREQ END IF ELSE IF(IFR0(ITR).EQ.0) THEN IFR0(ITR)=NFREQ ELSE IFR1(ITR)=NFREQ IF(DLOG(FR0(ITR)).EQ.XFRB) IJTC(ITR)=NFREQ END IF END IF END IF IL=IL-1 XFRA=XFRB IF(XPNU.EQ.24. .AND. FREQ(NFREQ).LT.FRS2) THEN XPNU=HALF*XPNU DO IAT=1,NATOM DLNU(IAT)=TWO*DLNU(IAT) DLNU(IAT+NATOM)=TWO*DLNU(IAT+NATOM) END DO END IF END DO C XFRB=DLOG(FRCMIN) IF(XFRA.GT.XFRB) THEN DXNU=DLNU(NNU-1) NFS=INT((XFRA-XFRB)/DXNU)+1 XFS0=(XFRA-XFRB)/FLOAT(NFS) DO IJ=NFREQ+1,NFREQ+NFS XFR=DLOG(FREQ(IJ-1))-XFS0 FREQ(IJ)=EXP(XFR) END DO NFREQ=NFREQ+NFS END IF FREQ(NFREQ)=FRCMIN DO 20 ITR=1,NTRANS IF(LINEXP(ITR)) GO TO 20 DO IJ=IFR0(ITR),IFR1(ITR) NLINES(IJ)=NLINES(IJ)+1 END DO 20 CONTINUE C C Choose continuum frequency points in the global set C FRLEV(NLEVEL+1)=FRCMIN IL=1 DO WHILE(FRLEV(IL).GT.FRS1) IL=IL+1 END DO IB0=NFRS1 NUB=2*NATOM+1 XFRA=DLOG(FRS1) DO WHILE(IL.LE.NLEVEL+1) IF(FRLEV(IL).LT.FRCMIN) GO TO 490 IF(IL.GT.1 .AND. IL.LE.NLEVEL) THEN IF(FRLEV(IL).GE.FRLEV(IL-1)) GO TO 490 END IF IF(IL.LE.NLEVEL) ITR=ITRL(IL) FRLV0=FRLEV(IL) IB1=IB0 DO WHILE(FREQ(IB1).GT.FRLV0) IB1=IB1+1 XFRB=DLOG(FREQ(IB1)) IF(IFREQB(NFREQC).LT.IB1) THEN IF(NLINES(IB1).EQ.0 .AND. ISPODF.GT.1) THEN NFREQC=NFREQC+1 IFREQB(NFREQC)=IB1 XFRA=XFRB ELSE IF((XFRA-XFRB).GT.DLNU(NUB)) THEN NFREQC=NFREQC+1 IFREQB(NFREQC)=IB1 XFRA=XFRB END IF END IF END DO IF(IL.LE.NLEVEL) THEN IFR0(ITR)=1 IFR1(ITR)=IB1-1 IJTC(ITR)=IFR1(ITR) END IF IF(IFREQB(NFREQC).LT.(IB1-1)) THEN NFREQC=NFREQC+1 IFREQB(NFREQC)=IB1-1 END IF IF(IFREQB(NFREQC).LT.IB1) THEN NFREQC=NFREQC+1 IFREQB(NFREQC)=IB1 END IF XFRA=DLOG(FREQ(IB1)) IB0=IB1 490 IL=IL+1 IF(FRLEV(IL).LT.FRS2) NUB=2*NATOM+2 END DO C IF(IFREQB(NFREQC).LT.NFREQ) THEN NFREQC=NFREQC+1 IFREQB(NFREQC)=NFREQ END IF C NFREQL=0 XBL=DLOG(FRS1) NFLX=0 DO 410 IT=1,NTRANS IF(LINEXP(IT)) GO TO 410 IF(FR0(IT).LT.FRCMIN) GO TO 410 INDXPA=ABS(INDEXP(IT)) IF(INDXPA.GT.2 .AND. INDXPA.LE.4) GO TO 410 IL0=ILOW(IT) ITC=ITRA(IL0,NNEXT(IEL(IL0))) IF(ITC.EQ.0) ITC=ITRA(IL0,NNEXT(IEL(IL0))+1) IF(IFR1(IT).LE.IFR1(ITC)) GO TO 411 IF(IFR0(IT).LE.IFR1(ITC) .AND. ITC.GT.0) IFR0(IT)=IFR1(ITC)+1 411 NF=IFR1(IT)-IFR0(IT)+1 KFR0(IT)=NFREQL+1 KFR1(IT)=NFREQL+NF NFREQL=NFREQL+NF IF(INDXPA.EQ.2) THEN FR02H=HALF*(FREQ(IFR0(IT))+FREQ(IFR1(IT))) IJTC(IT)=IFR1(IT) DO WHILE(FR02H.GT.FREQ(IJTC(IT)) .AND. IJTC(IT).GT.1) IJTC(IT)=IJTC(IT)-1 END DO END IF al=2.997926e18/fr0(it) io=iel(il0) write(42,642) it,typion(io),il0,iup(it),iatm(il0), * il0-nfirst(io)+1,iup(it)-nfirst(io)+1,al, * ifr0(it),ifr1(it),nf 642 format(i7,a6,2i7,3i5,f12.3,3i7) IF(NF.GT.MFREQL) THEN WRITE(10,*) IL0,IT,NF CALL QUIT('Too many frequencies in a line - nf.gt.mfreql', * nf,mfreql) END IF IF(NF.GT.NFLX) NFLX=NF IF(KFR1(IT).GT.MFREQP) * CALL QUIT('Too many cross-sections to store in PRFLIN', * kfr1(it),mfreqp) 410 CONTINUE C DO IT=1,NTRANS MODW=IABS(INDEXP(IT)) IF(MODW.EQ.5 .OR. MODW.EQ.15) THEN IJTC(IT)=IFR1(IT) FRLV0=FR0PC(IT) IB1=NFRS1 DO WHILE(FREQ(IB1).GT.FRLV0) IB1=IB1+1 END DO IFR0(IT)=1 IFR1(IT)=IB1-1 END IF END DO C C Weights C DO IJ=NFRS1+1,NFREQ D121=HALF*(FREQ(IJ-1)-FREQ(IJ)) W(IJ-1)=W(IJ-1)+D121 W(IJ)=W(IJ)+D121 END DO C DO IJ=1,NFREQ IJALI(IJ)=1 IJX(IJ)=1 JIK(IJ)=IJ END DO NPPX=NFREQ C write(10,*) nfreq,nfreqc,nfreql,nflx IF(NFREQ.GT.MFREQ) THEN WRITE(10,1000) NFREQ 1000 FORMAT(' Number of frequencies:',I10) CALL QUIT('nfreq.gt.mfreq',nfreq,mfreq) END IF C RETURN END