SUBROUTINE IROSET
C     =================
C
C     Initialization of opacity sampling for iron-peak lines
C
C     IOBS = 2 : ALL lines except lines to autoionized levels
C     IOBS = 1 : ALL lines
C     IOBS = 0 : only lines between observed levels
C
      INCLUDE 'IMPLIC.FOR'
      INCLUDE 'BASICS.FOR'
      INCLUDE 'ATOMIC.FOR'
      INCLUDE 'MODELQ.FOR'
      INCLUDE 'ODFPAR.FOR'
      REAL*4 VDOP,AGAM,SIG0,SIGT
      PARAMETER (CSIG=0.0149736)
      COMMON/LINED/WAVE(MLINE),VDOP(MLINE,MDODF),
     &             AGAM(MLINE,MDODF),SIG0(MLINE,MDODF),
     &             JTR(MLINE,2)
      DIMENSION SIGT(MDODF,MFREQ),DML(MDEPTH)
C
      JIDR(1)=1
      IF(JIDS.EQ.0) THEN
         JIDR(2)=INT(0.7*ND)
         JIDR(3)=ND
         JIDN=3
         JIDC=2
       ELSE
         I=1
         DO WHILE(JIDR(I).LT.ND)
            I=I+1
            JIDR(I)=JIDR(I-1)+JIDS
            IF(JIDR(I).LE.INT(0.7*ND)) JIDC=JIDR(I)
         END DO
         JIDN=I
         IF(JIDR(I).GT.ND) THEN
            IF(JIDR(I-1).GE.ND-5) JIDN=JIDN-1
            JIDR(JIDN)=ND
         END IF
         IF(JIDN.GT.MDODF)
     &   CALL QUIT(' Too many depths for Fe x-sections',JIDN,MDODF)
      END IF
c
      DO ID=1,ND
         DML(ID)=LOG(DM(ID))
      END DO
      DO I=1,JIDN-1
         DXI=DML(JIDR(I+1))-DML(JIDR(I))
         DO ID=JIDR(I)+1,JIDR(I+1)
            JIDI(ID)=I
            XJID(ID)=(DML(JIDR(I+1))-DML(ID))/DXI
         END DO
      END DO
      JIDI(1)=1
      XJID(1)=1.

      XFRMA=DLOG(FRS1)
      IJD=INT(9./DDNU)
      IF(IJD.LT.2) IJD=2
      NFTT=0
      NFTMX=0
C
      DO 500 ION=1,NION
         IND=INODF1(ION)
         IF(IND.LE.0) GO TO 500
         IF(NLLIM(ION).GE.NLEVS(ION)) THEN
            DO ID=1,ND
               DO I=NFIRST(ION),NLAST(ION)
                  WOP(I,ID)=UN
               END DO
            END DO
            GO TO 500
         END IF
C
C       Set up superlevels and read line data
C     
        IOBS=IKOBS(ION)
        CALL LEVCD(ION,IOBS)
        CALL INKUL(ION,IOBS)
c
        write(6,610) ion,typion(ion),nlinku
  610   format(/' *** superlines for ',i4,': ',a4,
     *  '   selected internal lines:',i10)
        if(nlinku.gt.mline) 
     *     call quit('too many internal lines',nlinku,mline)
C
C       Assign line to supertransition and compute cross-section
C
        N1=NFIRST(ION)
        NLII=NLAST(ION)-N1+1
        DO IL=1,NLII-1
           KEVL=0
           KODL=0
           IF(JEN(IL).LE.NEVKU(ION)) THEN
              KEVL=JEN(IL)
            ELSE
              KODL=JEN(IL)-NEVKU(ION)
           END IF
           ILOK=N1+IL-1
           DO IU=IL+1,NLII
              IUPK=N1+IU-1
              ITR=ITRA(ILOK,IUPK)
              INDXPA=ABS(INDEXP(ITR))
              W1=0.
              W2=0.
              IFRKU=0
              NFT=0
              NLT=0
              KEVU=0
              KODU=0
              IF(JEN(IU).LE.NEVKU(ION)) THEN
                 KEVU=JEN(IU)
               ELSE
                 KODU=JEN(IU)-NEVKU(ION)
              END IF
              IF(KEVL.NE.0) THEN
                 KEV=KEVL
                 KOD=KODU
                 IEO=0
                 GSUPER=YMKU(JEN(IL),1)
               ELSE
                 KEV=KEVU
                 KOD=KODL
                 IEO=1
                 GSUPER=YMKU(JEN(IL)-NEVKU(ION),2)
              END IF
              DO IJ=1,MFREQ
                 DO I=1,MDODF
                    SIGT(I,IJ)=0.
                 END DO
              END DO
              FCOL=0.
              DO 10 K=1,NLINKU
                 IF(KSEV(JTR(K,1)).NE.KEV) GO TO 10
                 IF(KSOD(JTR(K,2)).NE.KOD) GO TO 10
                 NLT=NLT+1
                 FRL=CAS/WAVE(K)
                 IJL=NINT((XFRMA-DLOG(FRL))/DXNU)+NFRS1
                 D0=ABS((FREQ(IJL)-FRL)/(FREQ(IJL)-FREQ(IJL+1)))
                 IF(D0.GT.HALF) THEN
                    DO WHILE(FRL.GT.FREQ(IJL))
                       IJL=IJL-1
                    END DO
                    DO WHILE(FRL.LT.FREQ(IJL))
                       IJL=IJL+1
                    END DO
                    D1=FRL-FREQ(IJL)
                    D2=FREQ(IJL-1)-FRL
                    IF(D2.LT.D1) IJL=IJL-1
                 END IF  
                 IJ0=IJL-IJD
                 IJ1=IJL+IJD
                 IF(IJ0.LT.1) IJ0=1
                 IF(IJ1.GT.NFREQ) IJ1=NFREQ
                 IF(IFRKU.EQ.0) IFRKU=IJ0
                 NFT=IJ1-IFRKU+1
                 DO IJ=IJ0,IJ1
                    DNU=FREQ(IJ)-FRL
                    DO I=1,JIDN
                       VV=DNU*dble(VDOP(K,I))
                       PRFK=VOIGTE(real(VV),AGAM(K,I))/GSUPER
                       SIGT(I,IJ)=SIGT(I,IJ)+SIG0(K,I)*real(PRFK)
                    END DO
                 END DO
                 FCOL=FCOL+SIG0(K,JIDC)/VDOP(K,JIDC)
   10         CONTINUE
              OSC0(ITR)=0.
              IF(INDXPA.EQ.3 .OR. INDXPA.EQ.4) OSC0(ITR)=STRLX
              IF(FCOL.GT.0.) OSC0(ITR)=FCOL/GSUPER/CSIG
              IF(NLT.GT.0) THEN
                 W1=CAS/FREQ(IFRKU)
                 W2=CAS/FREQ(IFRKU+NFT-1)
              END IF
              IF(NFT.GT.0) THEN
                 IFR0(ITR)=IFRKU
                 IFR1(ITR)=IFRKU+NFT-1
                 KFR0(ITR)=NFTT+1
                 KFR1(ITR)=NFTT+NFT
                 NFTT=NFTT+NFT
                 itrl=itr
                 DO IJ=IFR0(ITR),IFR1(ITR)
                    KJ=IJ-IFR0(ITR)+KFR0(ITR)
                    DO I=1,JIDN
                       sxx=log(dble(sigt(i,ij))+1.d-40)
                       SIGFE(I,KJ)=real(sxx)
                    END DO
                 END DO
              END IF
              IF(KJ.GT.MCFE) 
     &           CALL QUIT(' Too many Fe cross-sect. to store',
     &                    KJ,MCFE)
                 WRITE(41,313) IL,IU,W1,W2,IFRKU,NFT,NLT,OSC0(ITR)
              IF(NFT.GT.NFTMX) NFTMX=NFT
           END DO
        END DO
  500 CONTINUE
      WRITE(10,*) ' Max. number of freq. per transition:',NFTMX
      WRITE(10,*) ' Number of iron line cross-sections: ',NFTT
  313 FORMAT(2I4,2F12.3,3I10,1PE12.3)
C     
      CALL IJALI2   
      RETURN
      END