SUBROUTINE RDATA(ION) C ===================== C INCLUDE 'PARAMS.FOR' INCLUDE 'MODELP.FOR' INCLUDE 'SYNTHP.FOR' PARAMETER (WI1=911.753578, WI2=227.837832) PARAMETER (T15=1.D-15) PARAMETER (ECONST= 5.03411142E15) PARAMETER (MCFIT=10) CHARACTER*10 TYPLEV(MLEVEL) CHARACTER*40 FIDATA(MION),FIODF1(MION),FIODF2(MION),FIBFCS(MION) CHARACTER*1 A CHARACTER*1000 CADENA CHARACTER(len=100) :: DUM COMMON/IONDAT/IATI(MION),IZI(MION),NLEVS(MION),NLLIM(MION) COMMON/IONFIL/FIDATA,FIODF1,FIODF2,FIBFCS COMMON/TOPCS/CTOP(MFIT,MCROSS), !sigma=alog10(sigma/10^-18) of fit point * XTOP(MFIT,MCROSS) ! x = alog10(nu/nu0) of fit point COMMON/PRINTP/TYPLEV COMMON/INUNIT/IUNIT COMMON/STRPAR/IMER,ITR,IC,IL,IP,NLASTE,NHOD common/dissol/fropc(mlevel),indexp(mlevel) common/quasex/iexpl(mlevel),iltot(mlevel) dimension CTEMP(MCFIT),CRATE(MCFIT) data iexp0/0/ C c IUNIT=IUNIT+1 IUNIT=94 OPEN(IUNIT,FILE=FIDATA(ION),STATUS='OLD') C C read the first record - a label for the energy level input C READ(IUNIT,501) A 501 FORMAT(A1) C C ----------------------------------------------------- C input parameters for explicit energy levels C ----------------------------------------------------- C C If ILIMITS(ION) < 0, the program finds out whether energy and C quantum numbers are included in the input data files IF (ILIMITS(ION).LT.0) THEN READ(IUNIT,'(1000A)')CADENA BACKSPACE(IUNIT) CALL COUNT_WORDS(CADENA,NOW) IF (NOW.LT.14) THEN ILIMITS(ION)=0 ELSE ILIMITS(ION)=1 ENDIF ENDIF C Standard format: ENION(I),G(I),NQUANT(I),TYPLEV(I),ifwop(i) IF (ILIMITS(ION).EQ.0) THEN C DO IL=1,NLEVS(ION) I=IL+NFIRST(ION)-1 IE=IEL(I) N0I=NFIRST(IE) NKI=NNEXT(IE) ia=numat(iatm(n0i)) if(isemex(ia).le.1) then iexp0=iexp0+1 iexpl(i)=iexp0 iltot(iexp0)=i c write(6,671) il,i,ia,ion,isemex(ia),iexp0,iltot(iexp0) if(il.eq.nlevs(ion)) then if(nki.eq.nka(iatm(i))) then iexp0=iexp0+1 iexpl(nki)=iexp0 iltot(iexp0)=nki c write(6,671) il+1,nki,ia,ion,isemex(ia),iexp0,iltot(iexp0) end if end if c 671 format('il,i,ia,ion,isem,iexp,iltot',7i4) end if IQ=I-N0I+1 X=IQ*IQ ifwop(i)=0 IZZ=IZ(IE) READ(IUNIT,*) * ENION(I),G(I),NQUANT(I),TYPLEV(I),ifwop(i) if(ifwop(i).lt.0.and.i.ne.nlast(ie)) * call quit('conflict in negative ifwop') if(ifwop(i).ge.2) ifwop(i)=0 IF(I.LT.NKI) THEN E=ENION(I) E0=E IF(E.LT.0.) THEN E=-E E0=E END IF IF(E.EQ.0.) THEN c if(izz.le.2) then if(izz.le.-2) then w0=wi1 if(izz.eq.2) w0=wi2 WL0=W0*X IF(WL0.GT.2000.) THEN ALM=1.E8/(WL0*WL0) XN1=64.328+29498.1/(146.-ALM)+255.4/(41.-ALM) WL0=WL0/(XN1*1.D-6+1.D0) END IF E0=H*CL*1.D8/WL0 else E0=EH*IZZ*IZZ/X end if END IF IF(E.GT.1.D-7.AND.E.LT.100.) E0=1.6018D-12*E IF(E.GT.100..AND.E.LT.1.D7) E0=1.9857D-16*E IF(E.GT.1.D7) E0=H*E IF(ENION(I).GE.0.) THEN ENION(I)=E0 ELSE ENION(I)=-E0 ENDIF IF(G(I).EQ.0.) G(I)=2.D0*X IF(NQUANT(I).EQ.0) NQUANT(I)=IQ ELSE c if(modref.ge.0) nref(iatm(i))=nka(iatm(i)) IF(G(I).EQ.0..AND.NKI.EQ.NKA(IATM(I))) G(I)=1. END IF if(ifwop(i).lt.0) then enion(i)=0. ff(ie)=0. IMER=IMER+1 IMRG(I)=IMER IIMER(IMER)=I endif fropc(i)=0. END DO C Upgraded format including limits for energies, and quantum numbers ELSE DO IL=1,NLEVS(ION) I=IL+NFIRST(ION)-1 IE=IEL(I) N0I=NFIRST(IE) NKI=NNEXT(IE) ia=numat(iatm(n0i)) if(isemex(ia).le.1) then iexp0=iexp0+1 iexpl(i)=iexp0 iltot(iexp0)=i if(il.eq.nlevs(ion)) then if(nki.eq.nka(iatm(i))) then iexp0=iexp0+1 iexpl(nki)=iexp0 iltot(iexp0)=nki end if end if end if IQ=I-N0I+1 X=IQ*IQ ifwop(i)=0 IZZ=IZ(IE) READ(IUNIT,*) * ENION(I),G(I),NQUANT(I),TYPLEV(I),ifwop(i),frdodf,imodl, * ENION1(I),ENION2(I), * SQUANT1(I),SQUANT2(I), * LQUANT1(I),LQUANT2(I), * PQUANT1(I),PQUANT2(I) if(ifwop(i).lt.0.and.i.ne.nlast(ie)) * call quit('conflict in negative ifwop') if(ifwop(i).ge.2) ifwop(i)=0 IF(I.LT.NKI) THEN C check and, if necessary, transform ENION(I) E=ENION(I) E0=E IF(E.LT.0.) THEN E=-E E0=E END IF IF(E.EQ.0.) THEN c if(izz.le.2) then if(izz.le.-2) then w0=wi1 if(izz.eq.2) w0=wi2 WL0=W0*X IF(WL0.GT.2000.) THEN ALM=1.E8/(WL0*WL0) XN1=64.328+29498.1/(146.-ALM)+255.4/(41.-ALM) WL0=WL0/(XN1*1.D-6+1.D0) END IF E0=H*CL*1.D8/WL0 else E0=EH*IZZ*IZZ/X end if END IF IF(E.GT.1.D-7.AND.E.LT.100.) E0=1.6018D-12*E IF(E.GT.100..AND.E.LT.1.D7) E0=1.9857D-16*E IF(E.GT.1.D7) E0=H*E IF(ENION(I).GE.0.) THEN ENION(I)=E0 ELSE ENION(I)=-E0 ENDIF C check and, if necessary, transform ENION1(I) E=ENION1(I) E0=E IF(E.LT.0.) THEN E=-E E0=E END IF IF(E.EQ.0.) THEN c if(izz.le.2) then if(izz.le.-2) then w0=wi1 if(izz.eq.2) w0=wi2 WL0=W0*X IF(WL0.GT.2000.) THEN ALM=1.E8/(WL0*WL0) XN1=64.328+29498.1/(146.-ALM)+255.4/(41.-ALM) WL0=WL0/(XN1*1.D-6+1.D0) END IF E0=H*CL*1.D8/WL0 else E0=EH*IZZ*IZZ/X end if END IF IF(E.GT.1.D-7.AND.E.LT.100.) E0=1.6018D-12*E IF(E.GT.100..AND.E.LT.1.D7) E0=1.9857D-16*E IF(E.GT.1.D7) E0=H*E IF(ENION1(I).GE.0.) THEN ENION1(I)=E0 ELSE ENION1(I)=-E0 ENDIF C check and, if necessary, transform ENION2(I) E=ENION2(I) E0=E IF(E.LT.0.) THEN E=-E E0=E END IF IF(E.EQ.0.) THEN c if(izz.le.2) then if(izz.le.-2) then w0=wi1 if(izz.eq.2) w0=wi2 WL0=W0*X IF(WL0.GT.2000.) THEN ALM=1.E8/(WL0*WL0) XN1=64.328+29498.1/(146.-ALM)+255.4/(41.-ALM) WL0=WL0/(XN1*1.D-6+1.D0) END IF E0=H*CL*1.D8/WL0 else E0=EH*IZZ*IZZ/X end if END IF IF(E.GT.1.D-7.AND.E.LT.100.) E0=1.6018D-12*E IF(E.GT.100..AND.E.LT.1.D7) E0=1.9857D-16*E IF(E.GT.1.D7) E0=H*E IF(ENION2(I).GE.0.) THEN ENION2(I)=E0 ELSE ENION2(I)=-E0 ENDIF C C Enforce an energy tolerance of 10% when the input files C do not have any (e.g. pure levels in MODION models) C IF((ENION1(I)-ENION(I))/ENION(I).LT.1e-6) * ENION1(I)=ENION(I)*(1.+ERANGE) IF((ENION(I)-ENION2(I))/ENION(I).LT.1e-6) * ENION2(I)=ENION(I)*(1.-ERANGE) C C Convert ENION1,ENION2 to cm-1 from the ground level C so they can be directly used in NLTSET C ENION1(I)=(ENION(N0I)-ENION1(I))*ECONST ENION2(I)=(ENION(N0I)-ENION2(I))*ECONST IF(G(I).EQ.0.) G(I)=2.D0*X IF(NQUANT(I).EQ.0) NQUANT(I)=IQ ELSE c if(modref.ge.0) nref(iatm(i))=nka(iatm(i)) IF(G(I).EQ.0..AND.NKI.EQ.NKA(IATM(I))) G(I)=1. END IF if(ifwop(i).lt.0) then write(*,*)'RDATA: IFWOP<0 and ILIMITS is not 0' stop enion(i)=0. ff(ie)=0. IMER=IMER+1 IMRG(I)=IMER IIMER(IMER)=I endif fropc(i)=0. END DO END IF c C ---------------------------------------------------------------------- C C skip lines if more levels than needed, and skip the continuum transition C label C 5 READ(IUNIT,501) A IF(A.NE.'*') GO TO 5 II0=NFIRST(ION)-1 ILLIM=NLLIM(ION)+II0 JCORR=0 C C ----------------------------------------------------- C input parameters for continuum transitions C ----------------------------------------------------- C 10 CONTINUE c READ(IUNIT,*,END=20,ERR=15) II,JJ,MODE,IFANCY,ICOLIS, c * IFRQ0,IFRQ1,OSC,CPARAM READ(IUNIT,'(A100)',END=20) DUM READ(DUM,*,IOSTAT=KSTAT) II,JJ,MODE, * IFANCY,ICOLIS, * IFRQ0,IFRQ1,OSC,CPARAM,NCOL IF (KSTAT.NE.0) THEN READ(DUM,*,ERR=15) II,JJ,MODE, * IFANCY,ICOLIS, * IFRQ0,IFRQ1,OSC,CPARAM NCOL=0 END IF IF (NCOL.NE.0) THEN DO IIC=1,NCOL READ(IUNIT,*) ITYPE, NCTEMP READ(IUNIT,*) (CTEMP(IFIT),IFIT=1,NCTEMP) READ(IUNIT,*) (CRATE(IFIT),IFIT=1,NCTEMP) END DO END IF c IF(II.EQ.0) THEN IF(JJ.EQ.0) GO TO 30 II0=JJ-1 GO TO 10 END IF IF(IABS(MODE).GT.100) READ(IUNIT,*) FR0INP if(iabs(mode).eq.2) then READ(IUNIT,*) kdo go to 10 end if IF(IFANCY.GT.49.and.ifancy.lt.100) IASV=1 if(iabs(mode).eq.3.or.iabs(mode).eq.4) go to 10 IF(IABS(MODE).EQ.5 .OR. IABS(MODE).EQ.15) THEN READ(IUNIT,*) FROPCI if(ion.eq.ielh) then if(ii.eq.1.and.cutlym.ne.0) fropci=-cutlym if(ii.eq.2.and.cutbal.ne.0) fropci=-cutbal end if if(abs(fropci).lt.1.e10) fropci=2.997925e18/fropci END IF IF(II.EQ.1) JCORR=NLEVS(ION)+1-JJ II=II+II0 JJ=JJ+II0+JCORR FROPC(II)=FROPCI N0I=NFIRST(IE) NKI=NNEXT(IE) IF(JJ.GE.NKI) THEN LPC=.FALSE. IF(IELHE2.GE.0) THEN IF(II.GE.NFIRST(IELHE2).AND.II.LE.NLAST(IELHE2) * .AND.IFWOP(II).GE.0) LPC=.TRUE. END IF IF(II.GE.N0HN.AND.II.LE.N1H.AND.IFWOP(II).GE.0) LPC=.TRUE. IF(LPC) THEN MODE=5 XI=NQUANT(II) X2=XI+3. if(ii.ge.8) x2=xi+2. IF(FROPC(II).GE.0.) THEN FROPC(II)=ENION(II)/6.6256E-27*(1.-XI*XI/(X2*X2)) ELSE FROPC(II)=ABS(FROPC(II)) END IF c write(6,671) ii,fropc(ii),enion(ii)/h,2.997925e18/fropc(ii) c 671 format(i4,1p2e13.5,0pf10.1) END IF END IF IF(MODE.EQ.0) THEN IF(II.LT.NLAST(ION)) GO TO 10 IF(II.EQ.NLAST(ION)) GO TO 15 END IF C C ----------------------------------------------------- C Additional input parameters for continuum transitions C ----------------------------------------------------- C C Only for IFANCY = 2, 3, or 4 C S0BF, ALFBF, BETBF, GAMBF - parameters for evaluation the C photoionization cross-section C IF(IFANCY.GE.2.AND.IFANCY.LE.4) * READ(IUNIT,*) S0BF(II),ALFBF(II),BETBF(II),GAMBF(II) C C ----------------------------------------------------- C Additional input parameters for continuum transitions -TOPBASE DATA C ----------------------------------------------------- C C Only for IFANCY > 100 there are IFANCY-100 fit points C C XTOP(MFIT,MCROSS) - x = alog10(nu/nu0) of a fit point C CTOP(MFIT,MCROSS) - sigma = alog10(sigma/10^-18) of a fit point C C there are IFANCY-100 fit points C IF(IFANCY.GT.100) THEN NFIT=IFANCY-100 IF(NFIT.GT.MFIT) call quit(' nfit too large (TOPBASE fits)') READ(IUNIT,*) (XTOP(IFIT,II),IFIT=1,NFIT) READ(IUNIT,*) (CTOP(IFIT,II),IFIT=1,NFIT) END IF IBF(II)=IFANCY INDEXP(II)=IABS(MODE) IF(II.LT.NLAST(ION)) GO TO 10 15 READ(IUNIT,501) A IF(A.NE.'*') GO TO 15 C C ----------------------------------------------------------- C Input parameters for line transitions C ----------------------------------------------------------- C 20 CONTINUE READ(IUNIT,*,END=30,ERR=30) II,JJ,MODE,IFANCY,ICOLIS, * IFRQ0,IFRQ1,OSC,CPARAM IF(IABS(MODE).GT.100) READ(IUNIT,*) FR0INP IF(JJ.GT.NLEVS(ION)) THEN IF(IABS(MODE).EQ.2) THEN READ(IUNIT,*) K1,K2,K3,X1,X2,X3,K4 GO TO 20 END IF IF(IABS(MODE).EQ.1) READ(IUNIT,*) LCMP IF(IABS(IFANCY).EQ.1) READ(IUNIT,*) GAMR,STARK1,STARK2, * STARK3,VDWH GO TO 20 END IF if(iabs(mode).eq.2) then READ(IUNIT,*) K1,K2,K3,X1,X2,X3,K4 go to 20 end if if(iabs(mode).eq.3.or.iabs(mode).eq.4) go to 20 IF(MODE.EQ.0) GO TO 20 C C ----------------------------------------------------------- C Additional input parameters for "clasical" line transitions C (i.e. those not represented by ODF's - ie ABS(MODE)=1) C ----------------------------------------------------------- C READ(IUNIT,*) LCOMP,INTMOD,NF,XMAX,TSTD IF(IABS(IFANCY).EQ.1) READ(IUNIT,*) GAMR,STARK1,STARK2, * STARK3,VDWH GO TO 20 C 30 CONTINUE close(iunit) RETURN END