      PROGRAM PROMCOR


      OPEN ( UNIT=2, FILE='model.dat', STATUS='OLD' )
      READ ( 2, * ) NZ, HKM
      CALL P5EXE ( NZ, HKM )
      CLOSE ( UNIT=2)

      STOP
      END
      SUBROUTINE P5EXE ( NZ, HKM )

  PARAMETER ( NFR=35, NMU=3, NPSOR= 201 &
    , NMUV=1, NFRC=20, NFIMX=201, NCMX=6 &

    , NN=21, NTT=(NN*(NN-1))/2, NTAB=11 &

    , NTAC=NN-1, NTAR=((NN-2)*(NN-3))/2+4 )

  INTEGER, DIMENSION(NTT) :: NINF, NSUP, ITP
  INTEGER, DIMENSION(NTAR) :: NFINT, NTR, ICTR, IOPRN, IOPERA
  INTEGER, DIMENSION(NTAC) :: IOPECO, NTC, ICTC
  REAL, DIMENSION(NZ) :: XM, Z, TE, PG, VT, HNH, HNE, XMOD &
    , TO, EPS, BEN, GIBAR,CSI0, ETA0, Y0
  REAL, DIMENSION(NN) :: FRN, POM
  REAL, DIMENSION(NTAR) :: AJI, BIJ, BJI, RXRO, FADIR, GIOM &
    , DNDREF, DLDREF, DL1, DL2, TOTOL, ETOT, FWHM, RRSV
  REAL, DIMENSION(NTAC) :: FADIC, RXIK, TOTOC, RCSV
  REAL, DIMENSION(NFR) :: XFR
  REAL, DIMENSION(NFRC) :: XFRC
  REAL, DIMENSION(NMUV) :: PMU
  REAL, DIMENSION(NTAB) :: TAB
  REAL, DIMENSION(NZ,NN) :: HN, HNSV
  REAL, DIMENSION(NZ,NTT) :: CIJ, CJI
  REAL, DIMENSION(NZ,NTAR) :: HJBAR, FPES, BRN, BRP, CAC, DCAC, SC &
    , CARR, COHER, DNDR, AMR, BRNSV, HJBSV
  REAL, DIMENSION(NZ,NTAC) :: TR, RIK, RKI, RIKP, RIKSV, RKISV
  REAL, DIMENSION(NFR,NZ) :: GI
  REAL, DIMENSION(NFR,NTAR) :: FRR, FIIR, FISR
  REAL, DIMENSION(NFRC,NTAC) :: FRC, FIIC, FISC
  REAL, DIMENSION(NFIMX,NTAR) :: FRFI, FINT
  REAL, DIMENSION(NCMX,NTAR) :: CPOL
  REAL, DIMENSION(NTAB,NTT) :: OIS
  REAL, DIMENSION(NFR,NZ,NTAR) :: FEVK, FEVL, SR, STR, PHIX
  REAL, DIMENSION(NFRC,NZ,NTAC) :: FKTC, FLTC, STC
  REAL, DIMENSION(NFR*NFR,NZ,NTAR) :: RDMAT
  REAL, DIMENSION(NFRC,NMUV,NTAC) :: HIEMC

  XFR = (/ 0.0, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.35, 0.4, 0.45, 0.5, 0.55, &
       & 0.6, 0.65, 0.7, 0.8, 0.9, 1.0, &
       & 1.5, 2.0, 2.5, 3.0, 3.5, 4.0, 5.0, 6.0 &
       & , 8.0, 10.0, 14.0, 20.0, 28.0, 38.0, 50.0, 70.0, 100.0 /)
!
!      Options
!



  DO I = 1, NTAR
  IOPRN(I) = 1
  IOPERA(I) = 0
  DL1(I) = 0.0
  DL2(I) = 0.0
  END DO
  DO I = 1, NTAC
  IOPECO(I) = 0
  RXIK(I) = 0.0
  END DO
  ITGMAX = 50
  ICRMAX = 8
  IEHMAX = 100
  RXY = 0.75
  CRITCR = 2.E-4
  CRITY = 1.E-4
  IOPMRU = 0
  IOPRN(1) = 4 !  Lyman-alpha, PRD
  IOPRN(2) = 3 !  Lyman-beta, PRD
  IOPFEV = 1
  IVERT = 1
  IPROF = 1
  IOPMIC = 0
  IVHYD = 0
  INIDLD = 1
  IOPRA = 1
  IOPERA(1) = 1
  IOPERA(2) = 1
  IOPERA(3) = 1
  IOPERA(4) = 1 
  IOPERA(5) = 1 
  IOPERA(6) = 1
  IOPERA(8) = 1 
  IOPERA(9) = 1 
  IOPERA(11) = 1 
  IOPERA(15) = 1 
  NVLI = 10 

  DL2(1) = 2.0
  DL2(2) = 1.0
  DL2(3) = 7.0
  DL2(4) = 1.0
  DL2(5) = 5.0
  DL2(6) = 12.0
  DL2(8) = 5.0  
  DL2(9) = 12.0
  DL2(11) = 5.0
  DL2(15) = 5.0
  PMU(1) = 1.0
  IOPECO(1) = 1
  IOPECO(2) = 0
  IOPECO(3) = 0
  IOPECO(4) = 0
  IOPECO(5) = 0
  NVCO = 1
  IOPCAC = 0! sans absorption / 3 ! avec absorption continue
  IOPEAC = 1  
  IOPATM = 1
  IOPTTC = 0
  IOPPOP = 1 
  IOPREN = 0
  DO I = 1, NTAR
  RXRO(I) = 0.8
  END DO
  RXIK(1) = 0.0
  RXTR = 0.0
  IVTR = 0
!
  CALL INIMET ( C1, C2 )
!
!      Automatic definition of permitted transitions beyond
!    level 5
!
  K = 0
  DO J = 2, NN-1
  DO I = 1, J-1
  IT = ( (J-1) * (J-2) ) / 2 + I
  IF ( J .LE. 5 ) THEN
  K = K + 1
  NTR(K) = IT
  ICTR(K) = 1
  ELSE
  IF ( I .NE. 1 ) THEN
  K = K + 1
  NTR(K) = IT
  ICTR(K) = 5
  END IF
  END IF
  END DO
  END DO
  DO I = 1, NN-1
  IT = ( (NN-1) * (NN-2) ) / 2 + I
  NTC(I) = IT
  ICTC(I) = 5
  IF ( I .LE. 5 ) ICTC(I) = 3
  IF ( I .LE. 2 ) ICTC(I) = 1
  END DO
!
!          Exceptions for H-delta and H-epsilon
!
  ICTR(11) = 1
  ICTR(15) = 1
!
      OPEN ( UNIT=21, FILE='profil.dat' )
!
!        Read atmospheric parameters
!
      DO I = 1, NZ
      READ ( 2, * ) TE(I), PG(I), ZKM, VTKMS
      Z(I) = 1.E5 * ZKM
      VT(I) = 1.E5 * VTKMS
      Y0(I) = 0.5
      END DO
      TEREF = TE(NZ)
      VTUR = 1.E-5 * VT(NZ)
!
  CALL INIFEVH ( NZ, NTAR, NTAC, NFR, NFRC, FEVK, FEVL, FKTC, FLTC )
  CALL INIHYV3 ( NZ, NN, NTT, NTAR, NTAC, NFRC, NTAB, INIDLD &
    , VTUR, TEREF, NTR, NTC, NINF, NSUP, ITP, POM, FRN, AJI, BIJ, BJI &
    , TAB, OIS, XFRC, CAC, DCAC, SC, DLDREF, DNDREF, BRN, BRP, FPES &
    , IVHYD )
  CALL SOLINH ( NN, NTT, NTAR, NFIMX, NCMX &
    , NINF, NSUP, FRN, NTR, ICTR, NFINT, FRFI, FINT, CPOL )
  CALL INTALT ( HKM, NTAR, NTAC, NCMX, CPOL, FADIR, FADIC )
  CALL COLHV3 ( NZ, NN, NTT, NTAR, NTAC, NFR, NFRC, NFIMX &
    , NTR, ICTR, NINF, NSUP, FRN, DNDREF, AJI, TE, VT, XFR &
    , NFINT, FRFI, FINT, FADIR, FADIC, NTC, XFRC &
    , FRR, FIIR, FISR, GIOM, FRC, FIIC, FISC )
  DO IRS = 1, NTAR
  DO IZ = 1, NZ
  HJBAR(IZ,IRS) = GIOM(IRS)
  END DO
  END DO
  CALL INITR1 ( NZ, NN, NTT, NTAC, NFRC, NTC, NINF &
    , FRN, XFRC, FADIC, RIK, TE, TR )
!
  RRSV(:) = RXRO(:)
  RCSV(:) = RXIK(:)
  NTIT = 0
!
      DO ITG = 1, ITGMAX
!
  WRITE ( 6, 177 ) ITG
 177  FORMAT ( / ' ITG = ', I5 )
  CALL HYESV3 ( PG, IOPMIC, CRITY, IEHMAX, RXY &
    , NZ, NN, NTT, NTAR, NTAC, NFRC, C1, C2, Y0 &
    , ITP, NINF, NSUP, NTC, FRN, POM, XFRC, Z, XM, TE, VT, HNH, HNE &
    , HN, NTAB, TAB, OIS, CIJ, CJI, AJI, BIJ, BJI, HJBAR, BRN, FPES &
    , TR, RIK, RIKP, RKI, ICV )
  IF ( ICV .LT. 0 ) GO TO 480
  IF ( IOPCAC .EQ. 3 ) CALL ABSCON ( 0, NZ, NN, NTT, NTAR, NN, TE &
    , Z, HNH, HNE, HN, NTR, NINF, NSUP, FRN, SC, DCAC, CAC )
  DO IT = 1, NTAR
  IF ( ICTR(IT) .GE. 3 ) CYCLE
  CALL RPCDEH ( IT, IOPMRU, NZ, NN, NTT, NTAR, NFR, 0 &
    , IOPRN(IT), NTR, NINF, NSUP, FRN, AJI, TE, VT, HNE, HN &
    , DNDR(1,IT), AMR(1,IT), COHER(1,IT), FRR(1,IT) &
    , PHIX(1,1,IT), RDMAT(1,1,IT) )
  END DO
  IF ( IOPFEV .GE. 3 ) THEN
  DO IT = 1, NTAR
  IF ( IOPERA(IT) .EQ. 0 ) CYCLE
  CALL ECRFEV ( 1, IT, NZ, NFR, FEVK(1,1,IT) )
  END DO
  DO IT = 1, NTAC
  IF ( IOPECO(IT) .EQ. 0 ) CYCLE
  CALL ECRFEV ( 2, IT, NZ, NFRC, FKTC(1,1,IT) )
  END DO
  END IF
!
  RXRO(:) = RRSV(:)
  RXIK(:) = RCSV(:)
  DO J = 1, NN
  DO IZ = 1, NZ
  HNSV(IZ,J) = HN(IZ,J)
  END DO
  END DO
  DO J = 1, NTAR
  DO IZ = 1, NZ
  HJBSV(IZ,J) = HJBAR(IZ,J)
  BRNSV(IZ,J) = BRN(IZ,J)
  END DO
  END DO
  DO J = 1, NTAC
  DO IZ = 1, NZ
  RIKSV(IZ,J) = RIK(IZ,J)
  RKISV(IZ,J) = RKI(IZ,J)
  END DO
  END DO
 200  CONTINUE
  ICV = 1
!
  DO ICR = 1, ICRMAX
  NTIT = NTIT + 1
!
!     Bound-free transitions
!
  CALL EQSTHV3 ( NZ, NN, NTT, NTAR, NTAC, ITP, NINF, NSUP, CIJ, CJI &
    , AJI, BIJ, BJI, HJBAR, BRN, FPES, RIK, RKI, HNH, HN, IZERR )
  IF ( IZERR > 0 ) THEN
  print *, ' population negative trouvee au 1er appel de EQSTHV3'
  ICV = -2
  GO TO 300
  END IF
  DO ITAC = 1, NTAC
  IF ( ICTC(ITAC) .GE. 3 ) CYCLE
  CALL HCONTI ( ITAC, IVERT, NZ, NN, NTT, NTAR, NTAC, NFRC, NMU &
    , NMUV, IOPECO, IOPFEV &
    , ITP, NTC, NINF, FRN, FRC, POM, TE, HNH, HNE, Z, CIJ, CJI, RIK &
    , RKI, HN, CSI0, ETA0, TO, L1, L2, FIIC, FISC, FKTC, FLTC, GIBAR &
    , STC, RIKP, PMU, HIEMC )
  END DO
  CALL COMPACH ( NZ, NTAC, RIK, RIKP, EMIN, EMAX )
  ECMX = AMAX1 ( ABS(EMIN), ABS(EMAX) )
!
!     Bound-bound transitions
!
  DO IRS = 1, NTAR
  IF ( ICTR(IRS) .GE. 3 ) CYCLE
  CALL RPRHV3 ( IRS, NZ, NN, NTT, NTAR, NTAC, NFR, NMU &
    , Z, TE, NTR, NINF, NSUP, AJI, BIJ, BJI, HJBAR, FPES &
    , BRN, BRP, ITP, CIJ, CJI, RIK, RKI, FRN, POM, HN, DNDR(1,IRS) &
    , FRR(1,IRS), PHIX(1,1,IRS) &
    , RDMAT(1,1,IRS), CAC(1,IRS), DCAC(1,IRS), SC(1,IRS) &
    , FEVK(1,1,IRS), FEVL(1,1,IRS), FIIR(1,IRS), FISR(1,IRS) &
    , CARR(1,IRS), TO, L1, L2, EPS, BEN, GI, SR(1,1,IRS) &
    , STR(1,1,IRS) )
  END DO
  CALL COMPARH ( NZ, NTAR, BRN, BRP, EMIN1, EMAX1, EMIN2, EMAX2 &
    , EMIN3, EMAX3 )
  WRITE ( 6, 287 ) EMIN1, EMAX1, EMIN2, EMAX2, EMIN3, EMAX3, EMIN &
    , EMAX
 287  FORMAT ( 8(3X,F12.6) )
  ECMX = AMAX1 ( ECMX, ABS(EMIN1) )
  ECMX = AMAX1 ( ECMX, ABS(EMAX1) )
  ECMX = AMAX1 ( ECMX, ABS(EMIN2) )
  ECMX = AMAX1 ( ECMX, ABS(EMAX2) )
  ECMX = AMAX1 ( ECMX, ABS(EMIN3) )
  ECMX = AMAX1 ( ECMX, ABS(EMAX3) )
!
!     Preparation of the next iteration
!
  CALL NOVRIK ( NZ, NTAC, ICTC, RXIK, RIK, RIKP )
  CALL NOVBRV3 ( NZ, NTAR, ICTR, RXRO, BRN, BRP )
!
  END DO !  (ICR = 1, ICRMAX)
!
  CALL NOVTR2 ( ITG, IVTR, RXTR, NZ, NN, NTT, NTAC, NFRC &
    , ICTC, NTC, NINF, FRN, XFRC, RIK, TE, TR, DTRMX )
  WRITE ( 6, 297 ) DTRMX
 297  FORMAT ( ' DTRMX = ', F10.3 )
  IF ( DTRMX .LT. 1.0 .AND. ECMX .LT. CRITCR ) THEN
  WRITE ( 6, * ) ' Convergence reached '
  GO TO 320
  END IF
 300  CONTINUE
  IF ( ICV < 0 ) THEN
  DO I = 1, NTAR
  RXRO(I) = RXRO(I) * 0.5 + 0.5
  END DO
  RXIK(1) = RXIK(1) * 0.5 + 0.5
  IF ( RXIK(1) > 0.99 ) STOP
  PRINT *, ' Retour en arriere avec augmentation des parametres' &
    , ' de relaxation', RXRO(1), RXIK(1)
  DO J = 1, NN
  DO IZ = 1, NZ
  HN(IZ,J) = HNSV(IZ,J)
  END DO
  END DO
  DO J = 1, NTAR
  DO IZ = 1, NZ
  HJBAR(IZ,J) = HJBSV(IZ,J)
  BRN(IZ,J) = BRNSV(IZ,J)
  END DO
  END DO
  DO J = 1, NTAC
  DO IZ = 1, NZ
  RIK(IZ,J) = RIKSV(IZ,J)
  RKI(IZ,J) = RKISV(IZ,J)
  END DO
  END DO
  GO TO 200
  END IF
!
      END DO !  (ITG = 1, ITGMAX)
      WRITE ( 6, "( / ' Non-convergence ... ' / )" )
      ICV = -3
      GO TO 480
!
 320  CONTINUE
  WRITE ( 6, 323 ) NTIT, ICRMAX*ITGMAX
 323  FORMAT ( / " Total number of iterations : ", I5 / &
     " over a maximum of : ", I5 / )
!
  IF ( IOPFEV .GE. 2 ) THEN
  DO IT = 1, NTAR
  IF ( IOPERA(IT) .EQ. 0 ) CYCLE
  CALL ECRFEV ( 1, IT, NZ, NFR, FEVK(1,1,IT) )
  END DO
  DO IT = 1, NTAC
  IF ( IOPECO(IT) .EQ. 0 ) CYCLE
  CALL ECRFEV ( 2, IT, NZ, NFRC, FKTC(1,1,IT) )
  END DO
  END IF
!
  WRITE ( 6, 401 )
 401  FORMAT ( / 20X, " Final test for this model" / )
  IF ( IOPATM .GT. 0 ) CALL EXOATM ( NZ, C1, C2, XM, TE &
    , VT, Z, HNH, HNE )

  IF ( IOPCAC .EQ. 3 ) CALL ABSCON ( IOPEAC, NZ, NN, NTT, NTAR, NN &
    , TE, Z, HNH, HNE, HN, NTR, NINF, NSUP, FRN, SC, DCAC, CAC )

  CALL EQSTHV3 ( NZ, NN, NTT, NTAR, NTAC, ITP, NINF, NSUP, CIJ, CJI &
    , AJI, BIJ, BJI, HJBAR, BRN, FPES, RIK, RKI, HNH, HN, IZERR )
  IF ( IOPPOP .GT. 0 ) CALL ECRIPOP ( 1, NZ, NN, HN )
  DO IRS = 1, NTAR
  IF ( ICTR(IRS) .GE. 3 ) CYCLE
  CALL RPCDEH ( IRS, IOPMRU, NZ, NN, NTT, NTAR, NFR, IOPREN &
    , IOPRN(IRS), NTR, NINF, NSUP, FRN, AJI, TE, VT, HNE, HN &
    , DNDR(1,IRS), AMR(1,IRS), COHER(1,IRS), FRR(1,IRS) &
    , PHIX(1,1,IRS), RDMAT(1,1,IRS) )
  CALL RPRHV3 ( IRS, NZ, NN, NTT, NTAR, NTAC, NFR, NMU &
    , Z, TE, NTR, NINF, NSUP, AJI, BIJ, BJI, HJBAR, FPES &
    , BRN, BRP, ITP, CIJ, CJI, RIK, RKI, FRN, POM, HN, DNDR(1,IRS) &
    , FRR(1,IRS), PHIX(1,1,IRS) &
    , RDMAT(1,1,IRS), CAC(1,IRS), DCAC(1,IRS), SC(1,IRS) &
    , FEVK(1,1,IRS), FEVL(1,1,IRS), FIIR(1,IRS), FISR(1,IRS) &
    , CARR(1,IRS), TO, L1, L2, EPS, BEN, GI, SR(1,1,IRS) &
    , STR(1,1,IRS) )
  IF ( IOPERA(IRS) .EQ. 0 ) CYCLE
  IF ( IOPRA .EQ. 1 ) CALL SUMRA ( IRS, NZ, NN, NTT, NTAR, NTR &
    , NINF, NSUP, FRN, L1, L2, Z, TO, CARR(1,IRS), CAC(1,IRS) &
    , DNDR(1,IRS), AMR(1,IRS), EPS, BEN, COHER(1,IRS), HJBAR(1,IRS) )

  CALL PROFLI ( IRS, NZ, NN, NTT, NTAR, NFR &
    , NMUV, NPSOR, NTR, NINF, NSUP, FRN, DL1(IRS), DL2(IRS), PMU &
    , FRR(1,IRS), STR(1,1,IRS), DNDR(1,IRS), AMR(1,IRS), CARR(1,IRS) &
    , CAC(1,IRS), TO, NFINT(IRS), FRFI(1,IRS), FINT(1,IRS) &
    , TOTOL(IRS), ETOT(IRS), FWHM(IRS) )

  END DO !  (IRS = 1, NTAR)

  DO ITAC = 1, NTAC
  IF ( ICTC(ITAC) .GE. 3 ) CYCLE
  CALL HCONTI ( ITAC, IVERT, NZ, NN, NTT, NTAR, NTAC, NFRC, NMU &
    , NMUV, IOPECO, IOPFEV &
    , ITP, NTC, NINF, FRN, FRC, POM, TE, HNH, HNE, Z, CIJ, CJI, RIK &
    , RKI, HN, CSI0, ETA0, TO, L1, L2, FIIC, FISC, FKTC, FLTC, GIBAR &
    , STC, RIKP, PMU, HIEMC )
  TOTOC(ITAC) = 2.0 * TO(NZ)
  IF ( IOPECO(ITAC) .GT. 0 ) CALL PROFCO ( ITAC, NN, NTT, NTAC &
    , NMUV, NFRC, NTC, NINF, FRN, PMU, XFRC, HIEMC )
  END DO !  (ITAC = 1, NTAC)
  CALL COMPARH ( NZ, NTAR, BRN, BRP, EMIN1, EMAX1, EMIN2, EMAX2 &
    , EMIN3, EMAX3 )
  CALL COMPACH ( NZ, NTAC, RIK, RIKP, EMIN, EMAX )
  WRITE ( 6, 433 ) EMIN1, EMAX1, EMIN2, EMAX2, EMIN3, EMAX3, EMIN &
    , EMAX
 433  FORMAT ( 8(3X,F12.6) )
!
 480  CONTINUE
!
  CLOSE ( UNIT=21 )
!
      IF ( IPROF .GE. 1 ) THEN
      OPEN ( UNIT=21, FILE='profil.dat', STATUS='OLD' )
      CALL PSDEB ( 'profil.ps' )
      CALL VISU21L ( NVLI, NPSOR, NMUV, 1, 0, 0 )
      CALL PSFIN
      CLOSE ( UNIT=21 )
      END IF

      
  WRITE ( 6, 900 )
 900  FORMAT ( / ' Normal end ' / )

  RETURN
  END
  SUBROUTINE EPSBHV3 ( NZ, NN, NTT, NTAR, NTAC, TE, FRN, POM, ITP &
    , NINF, NSUP, CIJ, CJI, NTR, AJI, BIJ, BJI, HJBAR, BRN, FPES &
    , RIK, RKI, IRS, IVERB, EPS, BEN )
!
!          Computation of coupling coefficients for an equivalent
!     two-level atom (hydrogen atom)
!
  PARAMETER ( HP=6.6262E-27, CL=2.997925E10, BOLT=1.3806E-16 )
  PARAMETER ( C4=2.0*HP/(CL*CL) )
!
  REAL, DIMENSION(NZ) :: TE, EPS, BEN
  REAL, DIMENSION(NN) :: FRN, POM
  INTEGER, DIMENSION(NTT) :: ITP, NINF, NSUP
  REAL, DIMENSION(NZ,NTT) :: CIJ, CJI
  INTEGER, DIMENSION(NTAR) :: NTR
  REAL, DIMENSION(NTAR) :: AJI, BIJ, BJI
  REAL, DIMENSION(NZ,NTAR) :: BRN, HJBAR, FPES
  REAL, DIMENSION(NZ,NTAC) :: RIK, RKI
  REAL, DIMENSION(NN,NN) :: P
  REAL, DIMENSION(NN-2,NN-2) :: B
  REAL, DIMENSION(NN-2) :: ALPHA, BETA
  INTEGER, DIMENSION(NN-2) :: NIV
!
  NT = NTR(IRS)
  NI = NINF(NT)
  NS = NSUP(NT)
  FR0 = FRN(NS) - FRN(NI)
!
  NZS2 = NZ / 2
  IF ( IVERB > 0 ) PRINT "( / ' IRS =', I4 )", IRS
  DO J = 1, NN
  IF ( J == NI .OR. J == NS ) CYCLE
  IF ( J < NI ) NIV(J) = J
  IF ( J > NI .AND. J < NS ) NIV(J-1) = J
  IF ( J > NS ) NIV(J-2) = J
  END DO
!
      DO IZ = 1, NZ
!
  DO IT = 1, NTT
  JTP = ITP(IT)
  I = NINF(IT)
  J = NSUP(IT)
  P(I,J) = CIJ(IZ,IT)
  P(J,I) = CJI(IZ,IT)
  IF ( JTP .EQ. 0 ) CYCLE
  IF ( NSUP(IT) .NE. NN ) THEN
  RIJ = ( 1.0 - FPES(IZ,JTP) ) * BIJ(JTP) * HJBAR(IZ,JTP)
  RJI = FPES(IZ,JTP) * AJI(JTP) * BRN(IZ,JTP) + &
     ( 1.0 - FPES(IZ,JTP) ) * ( AJI(JTP) + BJI(JTP) * HJBAR(IZ,JTP) )
  P(I,J) = CIJ(IZ,IT) + RIJ
  P(J,I) = CJI(IZ,IT) + RJI
  ELSE
  ITAC = JTP - NTAR
  P(I,J) = CIJ(IZ,IT) + RIK(IZ,ITAC)
  P(J,I) = CJI(IZ,IT) + RKI(IZ,ITAC)
  END IF
  END DO !  (IT = 1, NTT)
!
  DO I = 1, NN
  P(I,I) = 0.0
  DO J = 1, NN
  IF ( I .EQ. J ) CYCLE
  P(I,I) = P(I,I) - P(I,J)
  END DO !  (J = 1, NN)
  END DO !  (I = 1, NN)
!
  EXPFT = EXP ( - HP * FR0 / ( BOLT * TE(IZ) ) )
  EPSC = ( 1.0 - EXPFT ) * CJI(IZ,NT) / AJI(IRS)
  BENC = C4 * FR0**3 / ( 1.0 / EXPFT - 1.0 )
!
  DO KK = 1, NN-2
  K = NIV(KK)
  DO JJ = 1, NN-2
  J = NIV(JJ)
  B(JJ,KK) = P(K,J)
  END DO
  END DO
  CALL INVMAT ( B, NN-2 )
!
  DO JJ = 1, NN-2
  ALPHA(JJ) = 0.0
  BETA(JJ) = 0.0
  DO KK = 1, NN-2
  K = NIV(KK)
  ALPHA(JJ) = ALPHA(JJ) - B(JJ,KK) * P(NI,K)
  BETA(JJ) = BETA(JJ) - B(JJ,KK) * P(NS,K)
  END DO
  END DO
!
  FSI = 0.0
  DO KK = 1, NN-2
  K = NIV(KK)
  FSI = FSI + BETA(KK) * P(K,NI)
  END DO
!
  FIS = 0.0
  DO KK = 1, NN-2
  K = NIV(KK)
  FIS = FIS + ALPHA(KK) * P(K,NS)
  END DO
  IF ( IVERB > 0 .AND. IZ == NZS2 ) &
     PRINT "( / '  FIS =', 1PE16.8, '     FSI =', 1PE16.8 )", FIS, FSI
!
  EPSI = ( FSI / AJI(IRS) ) * ( 1.0 - POM(NI) * FIS / &
      ( POM(NS) * FSI ) )
  BENI = C4 * FR0**3 / ( POM(NS) * FSI / ( POM(NI) * FIS ) - 1.0 )
  EPS(IZ) = ( EPSC + EPSI ) / ( 1.0 + EPSC + EPSI )
  BEN(IZ) = ( EPSC * BENC + EPSI * BENI ) / ( EPSC + EPSI )
!
  IF ( IVERB > 0 .AND. IZ == NZS2 ) THEN
  PRINT 111
 111  FORMAT ( / '    EPSC      BENC      EPSI      BENI      EPS', &
    '       BEN ' )
  PRINT "( 1X, 1P, 6E10.2 )", EPSC, BENC, EPSI, BENI, EPS(IZ) &
    , BEN(IZ)
  END IF
!
      END DO !  (IZ = 1, NZ)
!
  RETURN
  END
  SUBROUTINE RPRHV3 ( IRS, NZ, NN, NTT, NTRD, NTRC, NFR, NMU &
    , Z, TE, NTR, NINF, NSUP, AJI, BIJ, BJI, HJBAR, FPES &
    , BRN0, BRN1, ITP, CIJ, CJI, RIK, RKI, FRN, POM, HN, DND &
    , FR, PHIX, RDMAT, CAC, DCAC, SC, FEVK, FEVL, FIINF &
    , FISUP, CAR, TO, L1, L2, EPS, BEN, GI, SR, STR )
!
  PARAMETER ( TOMIN=1.E-3, CRIT=1.E-3, TL1=-1.0, TL2=1.0 )
  PARAMETER ( PI=3.141592653589, CL=2.997925E10, HP=6.6262E-27 )
  PARAMETER ( C4=2.0*HP/(CL*CL) )
!
  INTEGER, DIMENSION(NTT) :: ITP, NINF, NSUP
  INTEGER, DIMENSION(NTRD) :: NTR
  REAL, DIMENSION(NZ) :: Z, TE, DND, CAC, DCAC, SC, CAR, TO, EPS, BEN, RF
  REAL, DIMENSION(NTRD) :: AJI, BIJ, BJI
  REAL, DIMENSION(NN) :: FRN, POM
  REAL, DIMENSION(NFR) :: FR, FIINF, FISUP
  REAL, DIMENSION(NZ,NN) :: HN
  REAL, DIMENSION(NZ,NTT) :: CIJ, CJI
  REAL, DIMENSION(NZ,NTRD) :: HJBAR, FPES, BRN0, BRN1
  REAL, DIMENSION(NZ,NTRC) :: RIK, RKI
  REAL, DIMENSION(NFR,NZ) :: PHIX, FEVK, FEVL, GI, SR, STR, AUX &
    , TAUNU
  REAL, DIMENSION(NFR*NFR,NZ) :: RDMAT
!
  SQPI = SQRT ( PI )
  NT = NTR(IRS)
  NI = NINF(NT)
  NS = NSUP(NT)
  FR0 = FRN(NS) - FRN(NI)
!
  COEF = HP * FR0 / ( 4. * PI * SQPI )
  DO IZ = 1, NZ
  CAR(IZ) = COEF * ( HN(IZ,NI) * BIJ(IRS) - HN(IZ,NS) * BJI(IRS) ) &
     / DND(IZ)
  RF(IZ) = CAC(IZ) / CAR(IZ)
  END DO
  DO IB = 1, NFR
  TAUNU(IB,1) = 0.0
  END DO
  TO(1) = 0.0
  L1 = 1
  DO IZ = 2, NZ
  DTO = 0.5 * ( CAR(IZ) + CAR(IZ-1) ) * ( Z(IZ) - Z(IZ-1) )
  TO(IZ) = TO(IZ-1) + DTO
  IF ( TO(IZ) .LT. TOMIN ) L1 = IZ
  DO IB = 1, NFR
  PHIMOY = 0.5 * SQPI * ( PHIX(IB,IZ) + PHIX(IB,IZ-1) )
  TAUNU(IB,IZ) = TAUNU(IB,IZ-1) + DTO * ( PHIMOY + 0.5 * ( RF(IZ) + &
       RF(IZ-1) ) )
  END DO
  END DO
      DO IZ = 1, NZ
      IF ( TO(IZ) > 1.E-20 ) THEN
      TOL = LOG10 ( TO(IZ) )
      ELSE
      TOL = -20.0
      END IF
      IF ( TOL .LE. TL1 ) THEN
      FPES(IZ,IRS) = 0.0
      ELSE
      IF ( TOL .LE. TL2 ) THEN
      FPES(IZ,IRS) = ( TOL - TL1 ) / ( TL2 - TL1 )
      ELSE
      FPES(IZ,IRS) = 1.0
      END IF
      END IF
      END DO
  L2 = NZ
  IVERB = 0
  IVERT = 1
  CALL EPSBHV3 ( NZ, NN, NTT, NTRD, NTRC, TE, FRN, POM, ITP &
    , NINF, NSUP, CIJ, CJI, NTR, AJI, BIJ, BJI, HJBAR, BRN0, FPES &
    , RIK, RKI, IRS, IVERB, EPS, BEN )
      DO ITFEV = 1, 5
  CALL TFRFEV ( NZ, NFR, L1, L2, IVERT, FR, PHIX, RF, TO, DCAC, SC &
    , EPS, BEN, FIINF, FISUP, RDMAT, FEVK, FEVL, GI, HJBAR(1,IRS) &
    , SR, STR )
  DO IZ = 1, NZ
  DO IB = 1, NFR
  AUX(IB,IZ) = FEVK(IB,IZ)
  END DO
  END DO
  CALL NOVFEV ( NZ, NFR, NMU, L1, L2, IVERT, TAUNU &
    , FIINF, FISUP, STR, FEVK, FEVL )
  EMAX = 0.0
  DO IZ = 1, NZ
  DO IB = 1, NFR
  EMAX = AMAX1 ( EMAX, ABS(AUX(IB,IZ)-FEVK(IB,IZ)) )
  END DO
  END DO
  IF ( EMAX .LE. CRIT ) EXIT !  (ITFEV = 1, 5)
      END DO !  (ITFEV = 1, 5)
  DO IZ = 1, NZ
  SRCE = EPS(IZ) * BEN(IZ) + ( 1. - EPS(IZ) ) * HJBAR(IZ,IRS)
  BRN1(IZ,IRS) = EPS(IZ) * ( BEN(IZ) - HJBAR(IZ,IRS) ) / SRCE
  END DO
!
  RETURN
  END
  SUBROUTINE INIHYV3 ( NZ, NN, NTT, NTAR, NTAC, NFRC, NTAB, INIDLD &
    , VTUR, TSLAB, NTR, NTC, NINF, NSUP, ITP, POM, FRN, AJI, BIJ, BJI &
    , TAB, OIS, XFRC, CAC, DCAC, SC, DLDREF, DNDREF, BRN, BRP, FPES &
    , IVISU )
!
!    Initialization of statistical equilibrium parameters for
!    hydrogen.
!
  PARAMETER ( CL=2.997925E10, HP=6.6262E-27, BOLT=1.3806E-16 &
    , UMA=1.660E-24 )
  PARAMETER ( C4=2.0*HP/(CL*CL) )
!
  INTEGER, DIMENSION(NTT) :: NINF, NSUP, ITP
  INTEGER, DIMENSION(NTAR) :: NTR
  INTEGER, DIMENSION(NTAC) :: NTC
  REAL, DIMENSION(NTAR) :: AJI, BIJ, BJI, DLDREF, DNDREF
  REAL, DIMENSION(NN) :: FRN, POM, TSP
  REAL, DIMENSION(NTAB) :: TAB
  REAL, DIMENSION(NTAB,NTT) :: OIS
  REAL, DIMENSION(NFRC) :: XFRC
  REAL, DIMENSION(NZ,NTAR) :: CAC, DCAC, SC, BRN, BRP, FPES
  CHARACTER*1 X, XX
!
 1    FORMAT ( //// )
 2    FORMAT ( / 10X, 'Number of levels', 5X, 'NN =', I3 )
 3    FORMAT (/10X, 'Total number of transitions' ,5X, 'NTT =', I3 )
 4    FORMAT ( / 10X, 'Number of permitted transitions :' / &
     10X, 'A) Lines : NTAR =', I4 / 10X, 'B) Continua : NTAC =', I3 )
 9    FORMAT ( /// 20X, "List of transitions" // 10X, "NO.", 8X, &
     "LL", 8X, "UL", 7X, "F/P", 7X, "C/L", 6X, "lambda" / )
 10   FORMAT ( 2X, 3I10, 2(9X,A1), F10.1 )
!
  HMA = 1.0
  DO JS = 2, NN
  JSM = JS - 1
  DO JI = 1, JSM
  IT = ( (JS-1) * (JS-2) ) / 2 + JI
  NINF(IT) = JI
  NSUP(IT) = JS
  ITP(IT) = 0
  DO ITAR = 1, NTAR
  JT = NTR(ITAR)
  IF ( JT .EQ. IT ) ITP(IT) = ITAR
  END DO
  DO ITAC = 1, NTAC
  JT = NTC(ITAC)
  IF ( JT .EQ. IT ) ITP(IT) = ITAC + NTAR
  END DO
  END DO
  END DO
  TSP(NN) = 109678.76
  DO J = 1, NN-1
  POM(J) = 2.0 * FLOAT ( J * J )
  TSP(J) = TSP(NN) * ( 1.0 - 2.0 / POM(J) )
  END DO
  POM(NN) = 1.0
  DO J = 1, NN
  FRN(J) = CL * TSP(J)
  END DO
!
!           Spontaneous emission probabilities
!
  DO IT = 1, NTAR
  NT = NTR(IT)
  NI = NINF(NT)
  NS = NSUP(NT)
  AJI(IT) = AEMS ( NI, NS )
  FR0 = FRN(NS) - FRN(NI)
  BJI(IT) = AJI(IT) / ( C4 * FR0**3 )
  BIJ(IT) = BJI(IT) * POM(NS) / POM(NI)
  END DO
write(*,*) 'A(3,2)=',AJI(3)
write(*,*) 'A(3,1)=',AJI(2)

!
!      Collisional excitation and ionization coefficients
!
  TAB(1) = 5000.
  TAB(2) = 7000.
  TAB(3) = 10000.
  TAB(4) = 14000.
  TAB(5) = 20000.
  TAB(6) =  5.E4
  TAB(7) =  1.E5
  TAB(8) = 2.E5
  TAB(9) = 5.E5
  TAB(10) = 1.E6
  TAB(11) = 2.E6

  DO K = 1, NTT
  NI = NINF(K)
  NS = NSUP(K)
  EIJ = HP * ( FRN(NS) - FRN(NI) )
  DO ITAB = 1, NTAB
  IF ( NS .EQ. NN ) THEN
  OIS(ITAB,K) = CICHC ( NI, TAB(ITAB) )
  ELSE
  OIS(ITAB,K) = CECH ( NI, NS, TAB(ITAB) )
  END IF
  END DO
  DO ITAB = 1, NTAB
  OIS(ITAB,K) = OIS(ITAB,K) * EXP ( EIJ / ( BOLT * TAB(ITAB) ) )
  END DO
  END DO
!
!      List of transitions
!
  IF ( IVISU .GE. 1 ) THEN
  WRITE ( 66, 1 )
  WRITE ( 66, 2 ) NN
  WRITE ( 66, 3 ) NTT
  WRITE ( 66, 4 ) NTAR, NTAC
  WRITE ( 66, 9 )
  DO IT = 1, NTT
  NI = NINF(IT)
  NS = NSUP(IT)
  X = 'F'
  IF ( ITP(IT) .NE. 0 ) X = 'P'
  XX = 'L'
  IF ( NS .EQ. NN ) XX = 'C'
  ONDE = 1.E8 / ( TSP(NS) - TSP(NI) )
  WRITE ( 66, 10 ) IT, NI, NS, X, XX, ONDE
  END DO
  END IF
!
!      Automatic definition of a frequency mesh for bound-free
!   transitions (optimized for a variation in 1/fr**3 )
!
  DO J = 1, NFRC
  QJ = FLOAT ( NFRC + 1 - J ) / FLOAT ( NFRC )
  XFRC(J) = 1.0 / SQRT ( QJ )
  END DO
!
!         Doppler widths : conversion from Angstroms to Hertz.
!     If INIDLD = 1, the reference Doppler widths (DLDREF) are
!     automatically initialized.
!
  DO IT = 1, NTAR
  NT = NTR(IT)
  NI = NINF(NT)
  NS = NSUP(NT)
  FR = FRN(NS) - FRN(NI)
  IF ( INIDLD == 1 ) THEN
  ONDE = 1.E8 / ( TSP(NS) - TSP(NI) )
  HM = HMA * UMA
  VMIC = 1.E5 * VTUR
  DLDREF(IT) = ONDE * SQRT ( VMIC*VMIC + 2.0*BOLT*TSLAB/HM ) / CL
  END IF
  DNDREF(IT) = FR**2 * DLDREF(IT) * 1.E-8 / CL
  END DO
!
!          Initial arrays are set to zero
!
  DO IT = 1, NTAR
  DO IZ = 1, NZ
  BRN(IZ,IT) = 0.0
  BRP(IZ,IT) = 0.0
  FPES(IZ,IT) = 0.0
  CAC(IZ,IT) = 0.0
  SC(IZ,IT) = 0.0
  DCAC(IZ,IT) = 0.0
  END DO
  END DO
!
  RETURN
  END
  SUBROUTINE EQSTHV3 ( NZ, NN, NTT, NTAR, NTAC, ITP, NINF, NSUP, CIJ &
    , CJI, AJI, BIJ, BJI, HJBAR, BRN, FPES, RIK, RKI, HNT, HN, IZERR )
!
!          Solution of statistical equilibrium equations for
!     level populations (special hydrogen).
!
  INTEGER, DIMENSION(NTT) :: ITP, NINF, NSUP
  REAL, DIMENSION(NZ) :: HNT
  REAL, DIMENSION(NTAR) :: AJI, BIJ, BJI
  REAL, DIMENSION(NZ,NTAR) :: HJBAR, BRN, FPES
  REAL, DIMENSION(NZ,NTT) :: CIJ, CJI
  REAL, DIMENSION(NZ,NTAC) :: RIK, RKI
  REAL, DIMENSION(NZ,NN) :: HN
  REAL, DIMENSION(NN,NN) :: P, A
  REAL, DIMENSION(NN) :: B
!
      IZERR = 0
      DO IZ = 1, NZ
!
  DO IT = 1, NTT
  JTP = ITP(IT)
  I = NINF(IT)
  J = NSUP(IT)
  P(I,J) = CIJ(IZ,IT)
  P(J,I) = CJI(IZ,IT)
  IF ( JTP .EQ. 0 ) CYCLE
  IF ( NSUP(IT) .NE. NN ) THEN
  RIJ = ( 1.0 - FPES(IZ,JTP) ) * BIJ(JTP) * HJBAR(IZ,JTP)
  RJI = FPES(IZ,JTP) * AJI(JTP) * BRN(IZ,JTP) + &
     ( 1.0 - FPES(IZ,JTP) ) * ( AJI(JTP) + BJI(JTP) * HJBAR(IZ,JTP) )
  P(I,J) = CIJ(IZ,IT) + RIJ
  P(J,I) = CJI(IZ,IT) + RJI
  ELSE
  ITAC = JTP - NTAR
  P(I,J) = CIJ(IZ,IT) + RIK(IZ,ITAC)
  P(J,I) = CJI(IZ,IT) + RKI(IZ,ITAC)
  END IF
  END DO
  DO I = 1, NN
  P(I,I) = 0.0
  A(I,I) = 0.0
  DO J = 1, NN
  IF ( I .EQ. J ) CYCLE
  A(I,J) = P(J,I)
  A(I,I) = A(I,I) - P(I,J)
  END DO
  END DO
  DO J = 1, NN
  A(NN,J) = 1.0
  END DO
  B(:) = 0.0
  B(NN) = HNT(IZ)
  CALL SOSYS ( A, B, NN )
  DO I = 1, NN
  HN(IZ,I) = B(I)
  END DO
!
  IBON = 1
  DO I = 1, NN
  IF ( B(I) .LT. 0.0 ) IBON = -1
  END DO
      IF ( IBON > 0 ) CYCLE !  (IZ = 1, NZ)
!
  IZERR = IZ
!
      END DO !  (IZ = 1, NZ)
!
  RETURN
  END
  SUBROUTINE HYESV3 ( PG, IOPMIC, CRITY, IEHMAX, RXY &
    , NZ, NN, NTT, NTAR, NTAC, NFRC, C1, C2, Y0 &
    , ITP, NINF, NSUP, NTC, FRN, POM, XFRC, Z, XM, TE, VT, HNH, HNE &
    , HN, NTAB, TAB, OIS, CIJ, CJI, AJI, BIJ, BJI, HJBAR, BRN, FPES &
    , TR, RIK, RIKP, RKI, ICV )
!
!        Solution of statistical and ionization equilibria, for
!   specified pressures and temperatures.
!
  PARAMETER ( BOLT=1.3806E-16 )
!
  INTEGER, DIMENSION(NN) :: INFH
  INTEGER, DIMENSION(NTT) :: ITP, NINF, NSUP, ITCH
  INTEGER, DIMENSION(NTAC) :: NTC
  REAL, DIMENSION(NN) :: FRN, POM
  REAL, DIMENSION(NTT) :: SIGMH
  REAL, DIMENSION(NZ) :: Z, XM, TE, VT, HNH, HNE, PG, Y0, Y1, Y2 &
    , HNT, DELTAM
  REAL, DIMENSION(NTAR) :: AJI, BIJ, BJI
  REAL, DIMENSION(NTAB) :: TAB
  REAL, DIMENSION(NFRC) :: XFRC
  REAL, DIMENSION(NZ,NTAR) :: HJBAR, BRN, FPES
  REAL, DIMENSION(NZ,NTAC) :: TR, RIK, RIKP, RKI
  REAL, DIMENSION(NZ,NTT) :: CIJ, CJI
  REAL, DIMENSION(NZ,NN) :: HN
  REAL, DIMENSION(NTAB,NTT) :: OIS
!
  DO 150 J = 1, NTT
  ITCH(J) = J
 150  CONTINUE
  INFH(1) = 1
  DO 170 J = 2, NN-1
  INFH(J) = 0
 170  CONTINUE
  INFH(NN) = 1
!
  IEH = 0
  DO 200  I = 1, NZ
  Y1(I) = Y0(I)
 200  CONTINUE
 300  CONTINUE
  IEH = IEH + 1
  IF ( IOPMIC .NE. 0 ) THEN
  DO I = 1, NZ
  HNH(I) = PG(I) / ( 0.5 * C1 * VT(I)**2 + ( C2 + Y1(I) ) * BOLT &
     * TE(I) )
  HNE(I) = HNH(I) * Y1(I)
  END DO
  ELSE
  DO I = 1, NZ
  HNH(I) = PG(I) / ( ( C2 + Y1(I) ) * BOLT * TE(I) )
  HNE(I) = HNH(I) * Y1(I)
  END DO
  END IF
!
!          Determination of altitudes
!
  DO 330 I = 2, NZ
  DELTAM(I) = ( Z(I) - Z(I-1) ) * C1 * 0.5 * ( HNH(I) + HNH(I-1) )
 330  CONTINUE
  XM(1) = 0.0
  DO 335 I = 2, NZ
  XM(I) = XM(I-1) + DELTAM(I)
 335  CONTINUE
!
!          Computation of collisional transition probabilities
!
  CALL TXCOLL ( 1, NZ, NN, NTT, NTT, NTAB, ITCH, NINF, NSUP, INFH &
    , POM, FRN, SIGMH, TAB, OIS, TE, HNE, CIJ, CJI )
!
  DO 340 IT = 1, NTAC
  CALL INIRIKH ( IT, 3, NZ, NN, NTT, NTAC, NFRC, NTC &
    , ITP, NINF, FRN, XFRC, TE, HNE, POM, TR, RKI, RIK, RIKP )
 340  CONTINUE
  DO I = 1, NZ
  HNT(I) = HNH(I)
  END DO
  CALL EQSTHV3 ( NZ, NN, NTT, NTAR, NTAC, ITP, NINF, NSUP, CIJ, CJI &
    , AJI, BIJ, BJI, HJBAR, BRN, FPES, RIK, RKI, HNT, HN, IZERR )
  IF ( IZERR > 0 ) THEN
  PRINT *, ' population negative; appel de EQSTHV3 par HYESV3'
  GO TO 999
  END IF
  ICVY = 0
  DO I = 1, NZ
  CALL SAHARA ( 1, TE(I), HNH(I), HN(I,NN), DEL )
  Y2(I) = DEL / HNH(I)
  ECAR = ( Y2(I) - Y1(I) ) / Y1(I)
  IF ( ABS ( ECAR ) .GT. CRITY ) ICVY = 1
  END DO
  IF ( ICVY .EQ. 0 ) GO TO 500
  IF ( IEH .GT. IEHMAX ) GO TO 900
  DO I = 1, NZ
  Y1(I) = Y2(I) * ( 1. - RXY ) + Y1(I) * RXY
  END DO
  GO TO 300
 500  CONTINUE
!
!     Normal exit
!
  ICV = 1
  EYMIN = 0.
  EYMAX = 0.
  DO 550 I = 1, NZ
  ECAR = Y2(I) - Y0(I)
  IF ( ECAR .LT. EYMIN ) EYMIN = ECAR
  IF ( ECAR .GT. EYMAX ) EYMAX = ECAR
  Y0(I) = Y1(I)
 550  CONTINUE
  WRITE ( 6, 557 ) IEH, EYMIN, EYMAX
 557  FORMAT ( / " Ionization equilibrium", 10X, "IEH =", I3, 5X &
    , "EYMIN =", E10.3, 5X, "EYMAX =", E10.3 / )
  RETURN
!
 900  CONTINUE
!     Exit in the case of convergence failure
  PRINT 977, IEH, ( Y0(I), Y1(I), Y2(I), I = 1, NZ )
 977  FORMAT ( '1 Non-convergence in HYESV3 after',I5,' iterations' &
    , 10(/10G12.5) // )
 999  CONTINUE
  ICV = -1
  RETURN
!
  END
  SUBROUTINE NOVBRV3 ( NZ, NTRD, ICTR, RXRO, BRN0, BRN1 )
!
  INTEGER, DIMENSION(NTRD) :: ICTR
  REAL, DIMENSION(NTRD) :: RXRO
  REAL, DIMENSION(NZ,NTRD) :: BRN0, BRN1
!
  DO J = 1, NTRD
  IF ( ICTR(J) > 1 ) CYCLE
  RA = RXRO(J)
  RB = 1. - RA
  DO IZ = 1, NZ
  BRN0(IZ,J) = RA * BRN0(IZ,J) + RB * BRN1(IZ,J)
  END DO
  END DO
!
  RETURN
  END
  SUBROUTINE COLHV3 ( NZ, NN, NTT, NTRD, NTRC, NFR, NFRC, NFIMX &
    , ITRD, ICTR, NINF, NSUP, FRN, DNDREF, AJI, TE, VT, XFR &
    , NFINT, FRFI, FINT, FADIR, FADIC, NTC, XFRC &
    , FRR, FIIR, FISR, GIOM, FRC, FIIC, FISC )
!
   PARAMETER ( PI=3.141592653589, CL=2.997925E10, HP=6.6262E-27 &
    , BOLT=1.3806E-16, UMA=1.66053E-24 )
   PARAMETER ( C4=2.0*HP/(CL*CL) )
   BENU(F,T) = 2.0*HP*F*(F/CL)*(F/CL) / ( EXP(HP*F/BOLT/T) - 1.0 )
!
  INTEGER, DIMENSION(NTT) :: NINF, NSUP
  INTEGER, DIMENSION(NTRD) :: ITRD, ICTR, NFINT
  INTEGER, DIMENSION(NTRC) :: NTC
  REAL, DIMENSION(NZ) :: TE, VT
  REAL, DIMENSION(NN) :: FRN
  REAL, DIMENSION(NTRD) :: DNDREF, AJI, FADIR, GIOM
  REAL, DIMENSION(NFR) :: XFR, FLJ, VV, AMV, PHI, WFR
  REAL, DIMENSION(NFRC) :: XFRC
  REAL, DIMENSION(NTRC) :: FADIC
  REAL, DIMENSION(NFIMX,NTRD) :: FRFI, FINT
  REAL, DIMENSION(NFR,NTRD) :: FRR, FIIR, FISR
  REAL, DIMENSION(NFRC,NTRC) :: FRC, FIIC, FISC
!
  FIZERO = 1.0 / SQRT(PI)
  HM = UMA  !  (H)
!
!          Boundary conditions for lines
!
      DO IT = 1, NTRD
  NT = ITRD(IT)
  NI = NINF(NT)
  NS = NSUP(NT)
  FR0 = FRN(NS) - FRN(NI)
      IF ( ICTR(IT) .LE. 2 ) THEN
  DO J = 1, NFR
  FRR(J,IT) = DNDREF(IT) * XFR(J)
  CALL INTERL ( NFINT(IT), FRFI(1,IT), FINT(1,IT), FRR(J,IT) &
    , FLJ(J) )
  FIIR(J,IT) = 0.0
  FISR(J,IT) = FADIR(IT) * FLJ(J)
  END DO
  GAMA = 0.0
  IF ( NI > 1 ) THEN
  DO I = 1, NI-1
  KT = I + ((NI-1)*(NI-2)) / 2
  DO K = 1, NTRD
  IF ( ITRD(K) == KT ) GAMA = GAMA + AJI(K)
  END DO
  END DO
  END IF
  DO I = 1, NS-1
  KT = I + ((NS-1)*(NS-2)) / 2
  DO K = 1, NTRD
  IF ( ITRD(K) == KT ) GAMA = GAMA + AJI(K)
  END DO
  END DO
  DFRNA = GAMA / ( 4.0 * PI )
  DND = ( FR0 / CL ) * SQRT ( VT(1)**2 + 2.0 * BOLT * TE(1) / HM )
  AM = DFRNA / DND
  DO J = 1, NFR
  VV(J) = FRR(J,IT) / DND
  AMV(J) = AM
  END DO
  CALL VOIGTV ( NFR, AMV, VV, PHI )
  CALL TRAPEZ ( NFR, FRR(1,IT), WFR )
  SOM = 0.0
  DO J = 1, NFR
  WFR(J) = WFR(J) * PHI(J)
  SOM = SOM + WFR(J)
  END DO
  GIOM(IT) = 0.0
  DO J = 1, NFR
  GIOM(IT) = GIOM(IT) + WFR(J) * FISR(J,IT)
  END DO
  GIOM(IT) = GIOM(IT) / SOM
      ELSE
  AMBDA = 1.E4 * CL / FR0
  TB = TEMBRI ( AMBDA )
  HJB = C4 * FR0**3 / ( EXP(HP*FR0/(BOLT*TB)) - 1.0 )
  GIOM(IT) = FADIR(IT) * HJB
      END IF
      END DO !  (IT = 1, NTRD)
!
!       Boundary conditions for bound-free transitions
!
      DO IT = 1, NTRC
  NT = NTC(IT)
  NI = NINF(NT)
  FR0 = FRN(NN) - FRN(NI)
  DO J = 1, NFRC
  FRC(J,IT) = FR0 * XFRC(J)
  AMBDA = 1.E4 * CL / FRC(J,IT)
  TB = TEMBRI ( AMBDA )
  FIIC(J,IT) = 0.0
  FISC(J,IT) = BENU ( FRC(J,IT), TB ) * FADIC(IT)
  END DO
      END DO !  (IT = 1, NTRC)
!
  RETURN
  END
  FUNCTION ERFCA ( X )
!
!   Approximation of erfc(x) (relative error < 1.e-3)
!
  PARAMETER ( A1=0.254829592, A2=-0.284496736, &
     A3=1.421413741, A4=-1.453152027, A5=1.061405429 )
  IF ( X .GT. 20. ) GO TO 20
  IF ( X .GT. 3.0 ) GO TO 30
  T = 1. / ( 1. + .3275911 * X )
  A = T*(A1+T*(A2+T*(A3+T*(A4+T*A5))))
  ERFCA = A * EXP ( - X * X )
  RETURN
 20   CONTINUE
  ERFCA = 0.0
  RETURN
 30   CONTINUE
  Z = 0.5 / ( X * X )
  A = 1. + Z * ( -1. + Z * ( 3. - Z * 15. ) )
  ERFCA = A * EXP ( - X*X ) / ( 1.7724538509 * X )
  RETURN
  END
  FUNCTION VOIGT ( A, V )
!
!    Voigt function
!        Humlicek (1982) JQSRT 27, 437
!
  COMPLEX Z, W4
!
  Z = CMPLX ( V, A )
  VOIGT = REAL ( W4(Z) )
  RETURN
  END
  COMPLEX FUNCTION W4(Z)
! COMPUTES THE COMPLEX PROBABILITY FUNCTION W(Z)=EXP(-Z**2)*ERFC(-I*Z)
! IN THE UPPER HALF-PLANE Z=X+I*Y (I.E. FOR Y>=0)
! MAXIMUM RELATIVE ERROR OF BOTH REAL AND IMAGINARY PARTS IS <1*10**(-4)
  COMPLEX Z,T,U
  X=REAL(Z)
  Y=AIMAG(Z)
  T=CMPLX(Y,-X)
  S=ABS(X)+Y
  IF(S.LT.15.)GOTO 1
! *** REGION I
  W4=T*.5641896/(.5+T*T)
  RETURN
1 IF(S.LT.5.5)GOTO 2
! *** REGION II
  U=T*T
  W4=T*(1.410474+U*.5641896)/(.75+U*(3.+U))
  RETURN
2 IF(Y.LT..195*ABS(X)-.176)GOTO 3
! *** REGION III
  W4=(16.4955+T*(20.20933+T*(11.96482+T*(3.778987+T*.5642236))))/ &
    (16.4955+T*(38.82363+T*(39.27121+T*(21.69274+T*(6.699398+T)))))
  RETURN
! *** REGION IV
3 U=T*T
  W4= EXP(U)-T*(36183.31-U*(3321.9905-U*(1540.787-U*(219.0313-U* &
    (35.76683-U*(1.320522-U*.56419))))))/(32066.6-U*(24322.84-U* &
    (9022.228-U*(2186.181-U*(364.2191-U*(61.57037-U*(1.841439-U)))))))
  RETURN
  END
  SUBROUTINE VOIGTV ( N, A, V, H )
!
!    Vector subroutine for the computation of the Voigt function.
!    Combination of Humlicek (1982, JQSRT 27, 437) and
!    Hui et al. (1978, JQSRT 19, 509) methods.
!
  PARAMETER ( BIFUR=1.E-2 )
  PARAMETER ( A0 = 122.607931777, B0 = 122.607931774 &
    ,           A1 = 214.382388695, B1 = 352.730625111 &
    ,           A2 = 181.928533092, B2 = 457.334478784 &
    ,           A3 = 93.1555804581, B3 = 348.703917719 &
    ,           A4 = 30.1801421962, B4 = 170.354001821 &
    ,           A5 = 5.91262620977, B5 = 53.9929069129 &
    ,           A6 = .564189583563, B6 = 10.4798571143 )
!
  REAL, DIMENSION(N) :: A, V, H
  COMPLEX, DIMENSION(N) :: Z, U, W, F
!
  WHERE ( A(1:N) <= BIFUR )
  Z(:) = CMPLX ( A(:), -V(:) )
  U(:) = Z(:) * Z(:)
  W(:) = EXP(U(:)) - Z(:) * ( 36183.31 - U(:) * ( 3321.9905 - U(:) &
         * ( 1540.787 - U(:) * ( 219.0313 - U(:) * ( 35.76683 - U(:) &
         * ( 1.320522 - U(:) * .56419 ) ) ) ) ) ) / &
         ( 32066.6 - U(:) * ( 24322.84 - U(:) * ( 9022.228 - U(:) * &
         ( 2186.181 - U(:) * ( 364.2191 - U(:) * ( 61.57037 - U(:) * &
         ( 1.841439 - U(:) ) ) ) ) ) ) )
  H(:) = REAL ( W(:) )
  ELSEWHERE
  Z(:) = CMPLX ( A(:), -ABS(V(:)) )
  F(:) = ( A0 + Z(:) * ( A1 + Z(:) * ( A2 + Z(:) * ( A3 + Z(:) * ( &
     A4 + Z(:) * ( A5 + Z(:) * A6 ) ) ) ) ) ) &
     /  ( B0 + Z(:) * ( B1 + Z(:) * ( B2 + Z(:) * ( B3 + Z(:) * ( &
     B4 + Z(:) * ( B5 + Z(:) * ( B6 + Z(:) ) ) ) ) ) ) )
  H(:) = REAL ( F(:) )
  END WHERE
!
  RETURN
  END
  SUBROUTINE ABSALU ( NZ, FREQ, T, XNH, XNE, CAB )
!
!     Continuous absorption by aluminiun (LTE)
!         cf. Vernazza, Avrett & Loeser (1976) ApJS 30, 1
!
  PARAMETER ( HP=6.6262E-27, CL=2.997925E10, BOLT=1.3806E-16 &
    , C5=4828965274185857. )
!      ( C5 = 2 * ( 2 * pi * m * k / h**2 ) ** 1.5 )
!
  DIMENSION T(NZ), XNH(NZ), XNE(NZ), CAB(NZ) &
    , CAT(NZ), XNT(NZ), SOM(NZ), XN(NZ,9)
!
  DIMENSION GPS(9), WLION(8), A(8), S(8)
!
  DATA ABON / 2.81E-6 /
  DATA NC / 9 /
  DATA GPS / 6.0, 2.0, 6.0, 10.0, 6.0, 2.0, 10.0, 6.0, 1.0 /
  DATA WLION / 0.2076, 0.4360, 0.5205, 0.6311, 0.6525, 0.9442 &
    , 1.0698, 1.2495 /
  DATA A / 65.0, 10.0, 10.0, 47.0, 14.5, 56.7, 50.0, 50.0 /
  DATA S / 4.4, 2.0, 2.0, 1.83, 1.0, 1.9, 3.0, 3.0 /
!
  WL = 1.E4 * CL / FREQ
  FR1 = 1.E4 * CL / WLION(1)
  DO IZ = 1, NZ
  CAT(IZ) = BOLT * T(IZ)
  XNT(IZ) = XNH(IZ) * ABON
  XN(IZ,1) = 1.0
  SOM(IZ) = 1.0
  END DO
  NM1 = NC - 1
  DO I = 2, NM1
  DFR = FR1 - 1.E4 * CL / WLION(I)
  DO IZ = 1, NZ
  XN(IZ,I) = ( GPS(I) / GPS(1) ) * EXP ( - HP * DFR / CAT(IZ) )
  SOM(IZ) = SOM(IZ) + XN(IZ,I)
  END DO
  END DO
  DO IZ = 1, NZ
  XN(IZ,NC) = C5 * T(IZ)**1.5 * EXP ( - HP * FR1 / CAT(IZ) ) * &
       GPS(NC) / ( GPS(1) * XNE(IZ) )
  SOM(IZ) = SOM(IZ) + XN(IZ,NC)
  END DO
  DO I = 1, NC
  DO IZ = 1, NZ
  XN(IZ,I) = XN(IZ,I) * XNT(IZ) / SOM(IZ)
  END DO
  END DO
  DO IZ = 1, NZ
  SOM(IZ) = 0.0
  END DO
  DO I = 1, NM1
  IF ( WL .GT. WLION(I) ) CYCLE
  SEFF = A(I) * ( WL / WLION(I) ) ** S(I)
  DO IZ = 1, NZ
  SOM(IZ) = SOM(IZ) + XN(IZ,I) * SEFF
  END DO
  END DO
  DO IZ = 1, NZ
  CAB(IZ) = SOM(IZ) * 1.E-18 * ( 1.0 - EXP ( - HP * FREQ / CAT(IZ) ) )
  END DO
!
  RETURN
  END
  SUBROUTINE ABSCAR ( NZ, FREQ, T, XNH, XNE, CAB )
!
!     Continuous absorption by carbon (LTE)
!         cf. Vernazza, Avrett & Loeser (1976) ApJS 30, 1
!
  PARAMETER ( HP=6.6262E-27, CL=2.997925E10, BOLT=1.3806E-16 &
    , C5=4828965274185857. )
!
  DIMENSION T(NZ), XNH(NZ), XNE(NZ), CAB(NZ) &
    , CAT(NZ), XNT(NZ), SOM(NZ), XN(NZ,9)
!
  DIMENSION GPS(9), WLION(8), A(8), S(8), AP(3), SP(3)
!
  DATA ABON / 3.55E-4 /
  DATA NC / 9 /
  DATA GPS / 9.0, 5.0, 1.0, 5.0, 9.0, 3.0, 15.0, 27.0, 6.0 /
  DATA WLION / 0.1100, 0.1239, 0.1444, 0.1745, 0.3257, 0.3437 &
    , 0.3705, 0.6316 /
  DATA A / 38.6, 28.7, 33.6, 1.0, 0.2, 1.54, 16.0, 2.1 /
  DATA S / 2.0, 1.5, 1.5, 3.0, 1.2, 1.2, 3.0, 1.5 /
  DATA AP / 28.2, 18.4, 24.0 /
  DATA SP / 3.0, 2.5, 2.5 /
!
  WL = 1.E4 * CL / FREQ
  FR1 = 1.E4 * CL / WLION(1)
  DO IZ = 1, NZ
  CAT(IZ) = BOLT * T(IZ)
  XNT(IZ) = XNH(IZ) * ABON
  XN(IZ,1) = 1.0
  SOM(IZ) = 1.0
  END DO
  NM1 = NC - 1
  DO I = 2, NM1
  DFR = FR1 - 1.E4 * CL / WLION(I)
  DO IZ = 1, NZ
  XN(IZ,I) = ( GPS(I) / GPS(1) ) * EXP ( - HP * DFR / CAT(IZ) )
  SOM(IZ) = SOM(IZ) + XN(IZ,I)
  END DO
  END DO
  DO IZ = 1, NZ
  XN(IZ,NC) = C5 * T(IZ)**1.5 * EXP ( - HP * FR1 / CAT(IZ) ) * &
                GPS(NC) / ( GPS(1) * XNE(IZ) )
  SOM(IZ) = SOM(IZ) + XN(IZ,NC)
  END DO
  DO I = 1, NC
  DO IZ = 1, NZ
  XN(IZ,I) = XN(IZ,I) * XNT(IZ) / SOM(IZ)
  END DO
  END DO
  DO IZ = 1, NZ
  SOM(IZ) = 0.0
  END DO
  DO I = 1, NM1
  IF ( WL .GT. WLION(I) ) CYCLE
  SEFF = A(I) * ( WL / WLION(I) ) ** S(I)
  IF ( I .LE. 3 ) SEFF = SEFF - AP(I) * ( WL / WLION(I) ) ** SP(I)
  DO IZ = 1, NZ
  SOM(IZ) = SOM(IZ) + XN(IZ,I) * SEFF
  END DO
  END DO
  DO IZ = 1, NZ
  CAB(IZ) = SOM(IZ) * 1.E-18 * ( 1.0 - EXP(-HP*FREQ/CAT(IZ)) )
  END DO
!
  RETURN
  END
  SUBROUTINE ABSFER ( NZ, FREQ, T, XNH, XNE, CAB )
!
!     Continuous absorption by iron (LTE)
!         cf. Vernazza, Avrett & Loeser (1976) ApJS 30, 1
!
  PARAMETER ( HP=6.6262E-27, CL=2.997925E10, BOLT=1.3806E-16 &
    , C5=4828965274185857. )
!
  DIMENSION T(NZ), XNH(NZ), XNE(NZ), CAB(NZ) &
    , CAT(NZ), XNT(NZ), SOM(NZ), XN(NZ,3)
!
  DIMENSION GPS(3), WLION(2), A(2), S(2)
!
  DATA ABON / 3.16E-5 /
  DATA NC / 3 /
  DATA GPS / 9.0, 11.0, 25.0 /
  DATA WLION / 0.1570, 0.1761 /
  DATA A / 6.3, 5.04 /
  DATA S / 3.0, 3.0 /
!
  WL = 1.E4 * CL / FREQ
  FR1 = 1.E4 * CL / WLION(1)
  DO IZ = 1, NZ
  CAT(IZ) = BOLT * T(IZ)
  XNT(IZ) = XNH(IZ) * ABON
  XN(IZ,1) = 1.0
  SOM(IZ) = 1.0
  END DO
  NM1 = NC - 1
  DO I = 2, NM1
  DFR = FR1 - 1.E4 * CL / WLION(I)
  DO IZ = 1, NZ
  XN(IZ,I) = ( GPS(I) / GPS(1) ) * EXP ( - HP * DFR / CAT(IZ) )
  SOM(IZ) = SOM(IZ) + XN(IZ,I)
  END DO
  END DO
  DO IZ = 1, NZ
  XN(IZ,NC) = C5 * T(IZ)**1.5 * EXP ( - HP * FR1 / CAT(IZ) ) * &
                GPS(NC) / ( GPS(1) * XNE(IZ) )
  SOM(IZ) = SOM(IZ) + XN(IZ,NC)
  END DO
  DO I = 1, NC
  DO IZ = 1, NZ
  XN(IZ,I) = XN(IZ,I) * XNT(IZ) / SOM(IZ)
  END DO
  END DO
  DO IZ = 1, NZ
  SOM(IZ) = 0.0
  END DO
  DO I = 1, NM1
  IF ( WL .GT. WLION(I) ) CYCLE
  SEFF = A(I) * ( WL / WLION(I) ) ** S(I)
  DO IZ = 1, NZ
  SOM(IZ) = SOM(IZ) + XN(IZ,I) * SEFF
  END DO
  END DO
  DO IZ = 1, NZ
  CAB(IZ) = SOM(IZ) * 1.E-18 * ( 1.0 - EXP (-HP*FREQ/CAT(IZ)) )
  END DO
!
  RETURN
  END
  SUBROUTINE ABSHYD ( FREQ, NZ, T, XNE, NNH, XNH, CABH, FSCH )
!
!     Continuous absorption by hydrogen (NLTE)
!     (CABH: absoption coefficient, FSCH: source function)
!
  PARAMETER ( HP=6.6262E-27, CL=2.997925E10, BOLT=1.3806E-16 &
    , C5=4828965274185857., TSPINF=109678.76, RYD=HP*CL*TSPINF )
!
  DIMENSION T(NZ), XNE(NZ), XNH(NZ,NNH), CABH(NZ), FSCH(NZ)
  DIMENSION CEMH(NZ), ETLJC(NZ), FSCJ(NZ)
!
  HNU = HP * FREQ
  NC = NNH
  DO IZ = 1, NZ
  CABH(IZ) = 0.0
  CEMH(IZ) = 0.0
  END DO
  DO J = 1, NNH-1
  XJ2 = FLOAT ( J * J )
  EJK = RYD / XJ2
  IF ( HNU .LT. EJK ) CYCLE
  POMJ = XJ2 + XJ2
  SEJ = SEPION ( FREQ, J )
  DO IZ = 1, NZ
  CABH(IZ) = CABH(IZ) + XNH(IZ,J) * SEJ
  END DO
  DO IZ = 1, NZ
  ETLJC(IZ) = XNE(IZ) * POMJ * EXP ( EJK / ( BOLT * T(IZ) ) ) / &
     ( C5 * T(IZ)**1.5 )
  FSCJ(IZ) = 2.0 * HNU * (FREQ/CL)**2 * EXP ( - HNU / ( BOLT * T(IZ) &
     ) ) * XNH(IZ,NC) * ETLJC(IZ) / XNH(IZ,J)
  CEMH(IZ) = CEMH(IZ) + XNH(IZ,J) * SEJ * FSCJ(IZ)
  END DO
  END DO
  IF ( CABH(1) .NE. 0.0 ) THEN
  DO IZ = 1, NZ
  FSCH(IZ) = CEMH(IZ) / CABH(IZ)
  END DO
  ELSE
  DO IZ = 1, NZ
  FSCH(IZ) = 0.0
  END DO
  END IF
!
  RETURN
  END
  FUNCTION SEPION ( FR, NI )
!
!     Photoionization cross-section for hydrogen from level
!  NI at frequency FR.
!
  X5 = FLOAT (NI*NI*NI*NI*NI)
  SEPION = GAUNT ( FR, NI ) * 2.815E29 / ( X5 * FR * FR * FR )
  RETURN
  END
  FUNCTION GAUNT ( FREQ, K )
!
!------GAUNT FACTORS FOR BOUND-FREE HYDROGEN,GINGERICH,MARCH 1964
!------K IS LEVEL FOR GAUNT FACTOR
!
  W=2.9979E15/FREQ
  IF ( K > 6 ) GO TO 7
    GO TO ( 1, 2, 3, 4, 5, 6 ) K
    1 GAUNT=0.9916+(9.068E-3-0.2524*W)*W
      RETURN
    2 GAUNT=1.105+(-7.922E-02+4.536E-3*W)*W
      RETURN
    3 GAUNT=1.101+(-3.290E-2+1.152E-3*W)*W
      RETURN
    4 GAUNT=1.101+(-1.923E-2+5.110E-4*W)*W
      RETURN
    5 GAUNT=1.102+(-0.01304+2.638E-4*W)*W
      RETURN
    6 GAUNT=1.0986+(-0.00902+1.367E-4*W)*W
      RETURN
    7 GAUNT=1.0
      RETURN
  END
  SUBROUTINE ABSMAG ( NZ, FREQ, T, XNH, XNE, CAB )
!
!     Continuous absorption by magnesiun (LTE)
!         cf. Vernazza, Avrett & Loeser (1976) ApJS 30, 1
!
  PARAMETER ( HP=6.6262E-27, CL=2.997925E10, BOLT=1.3806E-16 &
    , C5=4828965274185857. )
!
  DIMENSION T(NZ), XNH(NZ), XNE(NZ), CAB(NZ) &
    , CAT(NZ), XNT(NZ), SOM(NZ), XN(NZ,9)
!
  DIMENSION GPS(9), WLION(8), A(8), S(8)
!
  DATA ABON / 4.17E-5 /
  DATA NC / 9 /
  DATA GPS / 1.0, 9.0, 3.0, 3.0, 1.0, 5.0, 9.0, 15.0, 2.0 /
  DATA WLION / 0.1621, 0.2513, 0.3756, 0.4884, 0.5504, 0.6549 &
    , 0.7236, 0.7292 /
  DATA A / 1.1, 20.0, 16.0, 2.1, 0.43, 45.0, 25.0, 33.8 /
  DATA S / 10.0, 2.7, 2.1, 2.6, 2.6, 2.7, 2.7, 2.8 /
!
  WL = 1.E4 * CL / FREQ
  FR1 = 1.E4 * CL / WLION(1)
  DO IZ = 1, NZ
  CAT(IZ) = BOLT * T(IZ)
  XNT(IZ) = XNH(IZ) * ABON
  XN(IZ,1) = 1.0
  SOM(IZ) = 1.0
  END DO
  NM1 = NC - 1
  DO I = 2, NM1
  DFR = FR1 - 1.E4 * CL / WLION(I)
  DO IZ = 1, NZ
  XN(IZ,I) = ( GPS(I) / GPS(1) ) * EXP ( - HP * DFR / CAT(IZ) )
  SOM(IZ) = SOM(IZ) + XN(IZ,I)
  END DO
  END DO
  DO IZ = 1, NZ
  XN(IZ,NC) = C5 * T(IZ)**1.5 * EXP ( - HP * FR1 / CAT(IZ) ) * &
                GPS(NC) / ( GPS(1) * XNE(IZ) )
  SOM(IZ) = SOM(IZ) + XN(IZ,NC)
  END DO
  DO I = 1, NC
  DO IZ = 1, NZ
  XN(IZ,I) = XN(IZ,I) * XNT(IZ) / SOM(IZ)
  END DO
  END DO
  DO IZ = 1, NZ
  SOM(IZ) = 0.0
  END DO
  DO I = 1, NM1
  IF ( WL .GT. WLION(I) ) CYCLE
  SEFF = A(I) * ( WL / WLION(I) ) ** S(I)
  IF ( I .EQ. 3 ) SEFF = SEFF - 7.8 * ( WL / WLION(I) ) ** 9.5
  DO IZ = 1, NZ
  SOM(IZ) = SOM(IZ) + XN(IZ,I) * SEFF
  END DO
  END DO
  DO IZ = 1, NZ
  CAB(IZ) = SOM(IZ) * 1.E-18 * ( 1.0 - EXP(-HP*FREQ/CAT(IZ)) )
  END DO
!
  RETURN
  END
  SUBROUTINE ABSSIL ( NZ, FREQ, T, XNH, XNE, CAB )
!
!     Continuous absorption by siliciun (LTE)
!         cf. Vernazza, Avrett & Loeser (1976) ApJS 30, 1
!
  PARAMETER ( HP=6.6262E-27, CL=2.997925E10, BOLT=1.3806E-16 &
    , C5=4828965274185857. )
!
  DIMENSION T(NZ), XNH(NZ), XNE(NZ), CAB(NZ) &
    , CAT(NZ), XNT(NZ), SOM(NZ), XN(NZ,9)
!
  DIMENSION GPS(9), WLION(8), A(8), S(8)
!
  DATA ABON / 3.55E-5 /
  DATA NC / 9 /
  DATA GPS / 9.0, 5.0, 1.0, 5.0, 9.0, 3.0, 15.0, 27.0, 6.0 /
  DATA WLION / 0.1525, 0.1682, 0.1986, 0.3085, 0.3864, 0.4040 &
    , 0.4892, 0.5840 /
  DATA A / 37.0, 35.0, 46.0, 15.0, 1.25, 4.09, 18.0, 14.1 /
  DATA S / 5.0, 3.0, 0.5, 3.0, 2.0, 2.0, 3.0, 3.0 /
!
  WL = 1.E4 * CL / FREQ
  FR1 = 1.E4 * CL / WLION(1)
  DO IZ = 1, NZ
  CAT(IZ) = BOLT * T(IZ)
  XNT(IZ) = XNH(IZ) * ABON
  XN(IZ,1) = 1.0
  SOM(IZ) = 1.0
  END DO
  NM1 = NC - 1
  DO I = 2, NM1
  DFR = FR1 - 1.E4 * CL / WLION(I)
  DO IZ = 1, NZ
  XN(IZ,I) = ( GPS(I) / GPS(1) ) * EXP ( - HP * DFR / CAT(IZ) )
  SOM(IZ) = SOM(IZ) + XN(IZ,I)
  END DO
  END DO
  DO IZ = 1, NZ
  XN(IZ,NC) = C5 * T(IZ)**1.5 * EXP ( - HP * FR1 / CAT(IZ) ) * &
                GPS(NC) / ( GPS(1) * XNE(IZ) )
  SOM(IZ) = SOM(IZ) + XN(IZ,NC)
  END DO
  DO I = 1, NC
  DO IZ = 1, NZ
  XN(IZ,I) = XN(IZ,I) * XNT(IZ) / SOM(IZ)
  END DO
  END DO
  DO IZ = 1, NZ
  SOM(IZ) = 0.0
  END DO
  DO I = 1, NM1
  IF ( WL .GT. WLION(I) ) CYCLE
  IF ( I .GT. 1 ) THEN
  SEFF = A(I) * ( WL / WLION(I) ) ** S(I)
  ELSE
  SEFF = A(1)
  IF ( WL .LT. 0.135 ) SEFF = A(1) * ( WL / 0.135 ) ** S(1)
  END IF
  DO IZ = 1, NZ
  SOM(IZ) = SOM(IZ) + XN(IZ,I) * SEFF
  END DO
  END DO
  DO IZ = 1, NZ
  CAB(IZ) = SOM(IZ) * 1.E-18 * ( 1.0 - EXP ( - HP * FREQ / CAT(IZ) ) )
  END DO
!
  RETURN
  END
  SUBROUTINE CABHM ( FREQ, NZ, T, HNEUT, XNE, CAB )
!
!     Continuous absorption by the negative hydrogen ion (LTE)
!           cf. T. L. John (1988) A&A 193, 189
!
  PARAMETER ( CLMIC=2.997925E14, BOLT=1.3806E-16, WL0=1.6419 &
    ,  HPLA=6.6262E-27, ALPHA=HPLA*CLMIC/BOLT )
!
  DIMENSION T(NZ), HNEUT(NZ), XNE(NZ), CAB(NZ)
  DIMENSION CABF(NZ), CAFF(NZ)
!
  REAL, DIMENSION(6), SAVE :: CBF, A, B, C, D, E, F, AUX
  REAL, DIMENSION(4), SAVE :: AA, BB, CC, DD, EE, FF
!
  DATA CBF / 152.519, 49.534, -118.858, 92.536, -34.194, 4.982 /
  DATA A / 0., 2483.346, -3449.889, 2200.040, -696.271, 88.283 /
  DATA B / 0., 285.827, -1158.382, 2427.719, -1841.400, 444.517 /
  DATA C / 0., -2054.291, 8746.523, -13651.105, 8624.97, -1863.864 /
  DATA D / 0., 2827.776, -11485.632, 16755.524, -10051.53, 2095.288/
  DATA E / 0., -1341.537, 5303.609, -7510.494, 4400.067, -901.788 /
  DATA F / 0., 208.952, -812.939, 1132.738, -655.020, 132.985 /
  DATA AA / 518.1021, 473.2636, -482.2089, 115.5291 /
  DATA BB / -734.8666, 1443.4137, -737.1616, 169.6374 /
  DATA CC / 1021.1775, -1977.3395, 1096.8827, -245.6490 /
  DATA DD / -479.0721, 922.3575, -521.1341, 114.2430 /
  DATA EE / 93.1373, -178.9275, 101.7963, -21.9972 /
  DATA FF / -6.4285, 12.3600, -7.0571, 1.5097 /
!
  WL = CLMIC / FREQ
!
!               "bound-free"
!
  IF ( WL .LT. 0.125 .OR. WL .GT. WL0 ) GO TO 400
  FLA = 0.0
  COEF = 1.0 / WL - 1.0 / WL0
  DO J = 1, 6
  FLA = FLA + CBF(J) * COEF**(0.5*FLOAT(J-1))
  END DO
  SIG = 1.E-18 * WL**3 * COEF**1.5 * FLA
  DO IZ = 1, NZ
  CABF(IZ) = ( 0.75 / T(IZ)**2.5 ) * EXP ( ALPHA/(WL0*T(IZ)) ) &
     * ( 1.0 - EXP ( - ALPHA/(WL*T(IZ)) ) ) * SIG
  END DO
  GO TO 500
 400  CONTINUE
  DO IZ = 1, NZ
  CABF(IZ) = 0.0
  END DO
 500  CONTINUE
!
!                "free-free"
!
  DO IZ = 1, NZ
  CAFF(IZ) = 0.0
  END DO
  IF ( WL .LT. 0.182 ) GO TO 900
  IF ( WL .GT. 0.3645 ) THEN
  AUX(1) = 0.0
  DO J = 2, 6
  AUX(J) = WL * WL * A(J) + B(J) + ( C(J) + ( D(J) + &
     ( E(J) + F(J) / WL ) / WL ) / WL ) / WL
  END DO
  ELSE
  DO J = 1, 4
  AUX(J) = WL * WL * AA(J) + BB(J) + ( CC(J) + ( DD(J) + &
     ( EE(J) + FF(J) / WL ) / WL ) / WL ) / WL
  END DO
  AUX(5) = 0.0
  AUX(6) = 0.0
  END IF
  DO J = 1, 6
  DO IZ = 1, NZ
  CAFF(IZ) = CAFF(IZ) + AUX(J) * 1.E-29 * &
         (5040./T(IZ))**(0.5*FLOAT(J+1))
  END DO
  END DO
 900  CONTINUE
  DO IZ = 1, NZ
  CAB(IZ) = ( CABF(IZ) + CAFF(IZ) ) * HNEUT(IZ) * XNE(IZ) * &
       BOLT * T(IZ)
  END DO
!
  RETURN
  END
  SUBROUTINE DIFRAY ( FR, NZ, XNH, CAB )
!
!     Rayleigh scattering for neutral H
!
  PARAMETER ( CLANG=2.997925E18, CLMIC=2.997925E14, WLYA=1300. )
  PARAMETER ( A0=1.05E-6, A1=0.072747, A2=19.045, A3=92.299 &
    , A4=245.89 )
!
  DIMENSION XNH(NZ), CAB(NZ)
!
  IF ( CLANG/FR .GT. WLYA ) THEN
  DW = ABS ( CLMIC/FR - 0.122 )
  SIGMA = 1.E-26 / ( A0 + DW * ( A1 + DW * ( A2 + DW * &
             ( A3 + DW * A4 ) ) ) )
  DO IZ = 1, NZ
  CAB(IZ) = XNH(IZ) * SIGMA
  END DO
  ELSE
  DO IZ = 1, NZ
  CAB(IZ) = 0.0
  END DO
  END IF
!
  RETURN
  END
  SUBROUTINE DIFTHO ( NZ, XNE, CAB )
!
!      Thomson scattering
!   SIGMA_E = (8 PI/3) (E^2/MC^2)^2
!
  DIMENSION XNE(NZ), CAB(NZ)
!
  DO IZ = 1, NZ
  CAB(IZ) = 6.6524E-25 * XNE(IZ)
  END DO
!
  RETURN
  END
  SUBROUTINE FONSOC2 ( L, TAUC, SABS, CRDP, HINC, GINU, S )
!
  DIMENSION TAUC(L), SABS(L), CRDP(L), GINU(L), S(L)
  DIMENSION D(L), F(L)
!
  XMU02 = 1.0 / 3.0
  XMU0 = SQRT ( XMU02 )
  DTOP = TAUC(2) - TAUC(1)
  IF ( DTOP .EQ. 0.0 ) GO TO 400
  C1 = XMU0 / DTOP
  B1 = 1.0 + C1
  E1 = HINC
  D(1) = C1 / B1
  F(1) = E1 / B1
  LM1 = L - 1
  DO 200 I = 2, LM1
  DTOM = TAUC(I) - TAUC(I-1)
  DTOP = TAUC(I+1) - TAUC(I)
  IF ( DTOP .EQ. 0.0 ) GO TO 400
  DTO = 0.5 * ( DTOM + DTOP )
  AI = XMU02 / ( DTO * DTOM )
  CI = XMU02 / ( DTO * DTOP )
  BI = AI + CI + 1.0 - CRDP(I)
  EI = ( 1.0 - CRDP(I) ) * SABS(I)
  D(I) = CI / ( BI - AI * D(I-1) )
  F(I) = ( EI + AI * F(I-1) ) / ( BI - AI * D(I-1) )
 200  CONTINUE
  AL = 1.0
  BL = 1.0
  EL = 0.0
  GINU(L) = ( EL + AL * F(LM1) ) / ( BL - AL * D(LM1) )
  S(L) = CRDP(L) * GINU(L) + ( 1.0 - CRDP(L) ) * SABS(L)
  DO 300 II = 1, LM1
  I = L - II
  GINU(I) = D(I) * GINU(I+1) + F(I)
  S(I) = CRDP(I) * GINU(I) + ( 1.0 - CRDP(I) ) * SABS(I)
 300  CONTINUE
  RETURN
!
 400  CONTINUE
  PRINT 1
  PRINT 2, ( TAUC(I), I = 1, L )
 1    FORMAT ( // ' PROFONDEURS OPTIQUES INCORRECTES DANS FONSOC2 ' // )
 2    FORMAT ( 10(3X,1PE10.3) )
  DO 500 I = 1, L
  GINU(I) = SABS(I)
  S(I) = SABS(I)
 500  CONTINUE
  STOP
  END
  SUBROUTINE TRALA ( N, TO, S, HIL, PMU, HI )
  DIMENSION TO(N), S(N)
  XI = - TO(1) / PMU
  IF ( XI .LT. -100. ) GO TO 50
  XI = EXP ( XI )
  SI = S(1)
  IF ( N < 1 ) GO TO 70
  IF ( N == 0 )  GO TO 60
  DXI = 1. - XI
  HI = DXI * SI
  DO I = 2, N
  XIM = XI
  SIM = SI
  XI = - TO(I) / PMU
  IF ( XI .LT. -100. ) GO TO 30
  XI = EXP(XI)
  SI = S(I)
  DXI = XIM - XI
  HI = HI + DXI * ( SIM + SI ) * 0.5
  END DO
!          SORTIE DANS LE CAS OPTIQUEMENT MINCE
  HI = HI + XI * HIL
  RETURN
 30   CONTINUE
!          SORTIE DANS LE CAS OPTIQUEMENT EPAIS
  DXI = XIM
  HI = HI + DXI * SIM
  RETURN
 60   CONTINUE
  HI = HIL * XI + SI * ( 1. - XI )
  RETURN
!
 50   CONTINUE
  PRINT 1,(TO(I),I=1,N)
 1    FORMAT (//' Abnormal optical depths in subroutine TRALA' &
     / 10(3X,G10.4) // )
  STOP
!
 70   CONTINUE
  PRINT 2, N
 2    FORMAT ( // ' Abnormal numerical value in TRALA :  N =', I5 // )
  STOP
!
  END
  SUBROUTINE COEFQG ( N, A, B, T, H )
  DIMENSION T(N), H(N)
  GO TO ( 101, 102, 103, 104, 105 ) N
 101  CONTINUE
  T(1) = 0.0
  H(1) = 2.0
  GO TO 200
 102  CONTINUE
  T(1) = -.577350269189626
  T(2) = - T(1)
  H(1) = 1.0
  H(2) = H(1)
  GO TO 200
 103  CONTINUE
  T(1) = -.774596669241483
  T(2) = 0.0
  T(3) = - T(1)
  H(1) =  .555555555555556
  H(2) = .888888888888888
  H(3) = H(1)
  GO TO 200
 104  CONTINUE
  T(1) = -.861136311594053
  T(2) = -.339981043584856
  T(3) = - T(2)
  T(4) = -T(1)
  H(1) = .347854845137454
  H(2) = .652145154862546
  H(3) = H(2)
  H(4) = H(1)
  GO TO 200
 105  CONTINUE
  T(1) = -.906179845938664
  T(2) = -.538469310105683
  T(3) = 0.0
  T(4) = - T(2)
  T(5) = -T(1)
  H(1) = .236926885056189
  H(2) = .478628670499366
  H(3) = .568888888888889
  H(4) = H(2)
  H(5) = H(1)
 200  CONTINUE
  IF ( A .EQ. -1.0 .AND. B .EQ. 1.0 ) RETURN
  VM = 0.5 * ( A + B )
  DL = 0.5 * ( B - A )
  DO I = 1 , N
  T(I) = VM + DL * T(I)
  H(I) = DL * H(I)
  END DO
  RETURN
  END
  SUBROUTINE TRAPEZ ( KMAX, V, H )
!
  DIMENSION V(KMAX), H(KMAX)
!
  DO K = 2, KMAX-1
  H(K) = 0.5 * ( V(K+1) - V(K-1) )
  END DO
  H(1) = 0.5 * ( V(2) - V(1) )
  H(KMAX) = 0.5 * ( V(KMAX) - V(KMAX-1) )
  RETURN
!
  END
  SUBROUTINE INTERL ( N, XT, YT, X, Y )
!
!             INTERPOLATION LINEAIRE
!
  REAL, DIMENSION(N) :: XT, YT
  INTEGER, SAVE :: I
!
  DATA I / 1 /
!
  IF ( I .LE. 0 ) I = 1
  IF ( I .GE. N ) I = N - 1
 100  CONTINUE
  IF ( X .LT. XT(I) ) GO TO 200
  IF ( X .GT. XT(I+1) ) GO TO 300
  J = I + 1
  Y = YT(I) + ( YT(J) - YT(I) ) * ( X - XT(I) ) / ( XT(J) - XT(I) )
  RETURN
 200  I = I - 1
  IF ( I .LE. 0 ) GO TO 400
  GO TO 100
 300  I = I + 1
  IF ( I .GE. N ) GO TO 500
  GO TO 100
 400  Y = YT(1)
  RETURN
 500  Y = YT(N)
  RETURN
  END
  SUBROUTINE SPLDEF ( N, XT, YT, HM )
  DIMENSION XT(N), YT(N), HM(N), P(N), Q(N)
  P(1) = 0.0
  Q(1) = 0.0
  DO 20 JJ = 3 , N
  J = JJ - 1
  HJ = XT(J) - XT(J-1)
  HJP = XT(J+1) - XT(J)
  XLA = HJP / ( HJ + HJP )
  XMU = 1. - XLA
  COEF = 2. - XMU * P(J-1)
  P(J) = XLA / COEF
  DJ = (YT(J+1)-YT(J))/HJP - (YT(J)-YT(J-1))/HJ
  DJ = 6. * DJ / ( HJ + HJP )
  Q(J) = ( DJ - XMU * Q(J-1) ) / COEF
 20   CONTINUE
  HM(N) = 0.0
  DO 40 JJ = 2 , N
  J = N + 1 - JJ
  HM(J) = Q(J) - P(J) * HM(J+1)
 40   CONTINUE
  RETURN
  END
  SUBROUTINE SPLUSE ( N, XT, YT, HM, X, S )
  DIMENSION XT(N), YT(N), HM(N)
  DO 20 JP = 2, N
  IF ( XT(JP) .GE. X ) GO TO 30
 20   CONTINUE
 30   CONTINUE
  JM = JP - 1
  DXP = XT(JP) - X
  DXM = X - XT(JM)
  H = XT(JP) - XT(JM)
  S = HM(JM) * DXP**3 / ( 6. * H )
  S = S + HM(JP) * DXM**3 / ( 6. * H )
  S = S + ( YT(JM)/H - HM(JM)*H/6. ) * DXP
  S = S + ( YT(JP)/H - HM(JP)*H/6. ) * DXM
  RETURN
  END
  SUBROUTINE SPLINT ( N1, X1, Y1, X2, Y2 )
!
! Spline interpolation (same parameter list as INTERL)
!
  DIMENSION X1(N1), Y1(N1), HM(N1)
!
  CALL SPLDEF ( N1, X1, Y1, HM )
  CALL SPLUSE ( N1, X1, Y1, HM, X2, Y2 )
  RETURN
!
  END
  SUBROUTINE ABSCON ( IVISU, NZ, NN, NTT, NTRD, NNHYD, TE, Z, HNH &
    , HNE, XNHYD, ITRD, NINF, NSUP, FRN, SC, DCAC, CAC )
!
!      Computation of continuum absorption in the neighbourhood
!   of lines under consideration
!
  PARAMETER ( NARA=10, CL=2.997925E10 )
!
  DIMENSION TE(NZ), Z(NZ), HNH(NZ), HNE(NZ), XNHYD(NZ,NNHYD) &
    , ITRD(NTRD) &
    , NINF(NTT), NSUP(NTT), FRN(NN), SC(NZ,NTRD), DCAC(NZ,NTRD) &
    , CAC(NZ,NTRD)
  DIMENSION TAUC(NZ), ARA(NZ,NARA)
!
 1    FORMAT ( // 30X, 'ABSORPTION CONTINUE POUR LA RAIE NO. ', I3 &
    , 10X, 'LAMBDA = ', F10.2, ' ANGSTROMS' // &
    ,8X,'TAU',8X,'CAC',6X,'RAYLEIGH',6X,'H2+',7X,' H-',5X,'THOMSON' &
    ,6X,'H',9X,'C',8X,'MG',8X,'AL',8X,'SI',8X,'FE' / )
 2    FORMAT ( 1X, I3, 2(2X,1PE9.2), 10(1X,0PF9.6) )
 3    FORMAT ( 1X )
!
      DO IT = 1, NTRD
  NT = ITRD(IT)
  NI = NINF(NT)
  NS = NSUP(NT)
  FREQ = FRN(NS) - FRN(NI)
  AMBDA = 1.E8 * CL / FREQ
  CALL PROFSC ( 1, FREQ, NZ, NNHYD, TE, Z, HNH, HNE, XNHYD &
    , NARA, ARA, TAUC, SC(1,IT), DCAC(1,IT), CAC(1,IT) )
  DO J = 1, NARA
  DO IZ = 1, NZ
  ARA(IZ,J) = ARA(IZ,J) / CAC(IZ,IT)
  END DO
  END DO
  IF ( IVISU > 0 ) THEN
  DO IZ = 1, NZ
  IF ( MOD(IZ,50) .EQ. 1 ) WRITE ( 66, 1 ) IT, AMBDA
  IF ( MOD(IZ,10) .EQ. 1 ) WRITE ( 66, 3 )
  WRITE ( 66,2) IZ, TAUC(IZ), CAC(IZ,IT), ( ARA(IZ,J), J = 1, NARA )
  END DO
  END IF
      END DO
!
  RETURN
  END
  SUBROUTINE PROFSC ( IOPHBF, FREQ, NZ, NNHYD, TE, Z, HNH, HNE &
    , XNHYD, NARA, ARA, TAUC, FSC, CSCAT, CABCO )
!
!        Computation of optical depths ( TAUC ), continuous
!     source functions ( FSC ) and coherent scattering ratios
!     ( CSCAT ) for a given frequency ( FREQ )
!     CABCO : continuous absorption coefficient
!
!          Option :
!     IOPHBF = 0 : the hydrogen bound-free absorption and emission
!     are not included
!     IOPHBF = 1 : hydrogen bound-free is included
!
   PARAMETER ( HP=6.6262E-27, CL=2.997925E10, BOLT=1.3806E-16 )
   BENU(F,T) = 2.0*HP*F*(F/CL)*(F/CL) / ( EXP(HP*F/BOLT/T) - 1.0 )
!
  DIMENSION TE(NZ), Z(NZ), HNH(NZ), HNE(NZ), XNHYD(NZ,NNHYD) &
    , ARA(NZ,NARA), TAUC(NZ), FSC(NZ), CSCAT(NZ), CABCO(NZ)
!
  DIMENSION HNEUT(NZ), HPLUS(NZ), CABA(NZ), FSCA(NZ) &
    , CABH(NZ), FSCH(NZ), CABD(NZ), DTAU(NZ)
!
  DO 120 IZ = 1, NZ
  HPLUS(IZ) = XNHYD(IZ,NNHYD)
  HNEUT(IZ) = HNH(IZ) - HPLUS(IZ)
 120  CONTINUE
  CALL DIFRAY ( FREQ, NZ, HNEUT, ARA(1,1) )
  DO 200 IZ = 1, NZ
  ARA(IZ,2) = 0.0
 200  CONTINUE
  CALL CABHM ( FREQ, NZ, TE, HNEUT, HNE, ARA(1,3) )
  CALL DIFTHO ( NZ, HNE, ARA(1,4) )
  IF ( IOPHBF .EQ. 1 ) THEN
  CALL ABSHYD ( FREQ, NZ, TE, HNE, NNHYD, XNHYD, CABH, FSCH )
  ELSE
  DO 230 IZ = 1, NZ
  CABH(IZ) = 0.0
  FSCH(IZ) = 0.0
 230  CONTINUE
  END IF
  CALL ABSCAR ( NZ, FREQ, TE, HNH, HNE, ARA(1,6) )
  CALL ABSMAG ( NZ, FREQ, TE, HNH, HNE, ARA(1,7) )
  CALL ABSALU ( NZ, FREQ, TE, HNH, HNE, ARA(1,8) )
  CALL ABSSIL ( NZ, FREQ, TE, HNH, HNE, ARA(1,9) )
  CALL ABSFER ( NZ, FREQ, TE, HNH, HNE, ARA(1,10) )
  DO 240 IZ = 1, NZ
  ARA(IZ,5) = CABH(IZ)
  CABD(IZ) = ARA(IZ,1) + ARA(IZ,4)
  CABA(IZ) = ARA(IZ,2) + ARA(IZ,3) + ARA(IZ,6) + ARA(IZ,7) + &
               ARA(IZ,8) + ARA(IZ,9) + ARA(IZ,10)
  CABCO(IZ) = CABH(IZ) + CABD(IZ) + CABA(IZ)
 240  CONTINUE
  DO 260 IZ = 1, NZ
  FSCA(IZ) = BENU ( FREQ, TE(IZ) )
 260  CONTINUE
  DO 280 IZ = 1, NZ
  FSC(IZ) = ( CABH(IZ) * FSCH(IZ) + CABA(IZ) * FSCA(IZ) ) / ( &
              CABH(IZ) + CABA(IZ) )
 280  CONTINUE
  DO 300 IZ = 2, NZ
  DTAU(IZ) = ( Z(IZ) - Z(IZ-1) ) * 0.5 * ( CABCO(IZ-1) + CABCO(IZ) )
 300  CONTINUE
  TAUC(1) = 0.0
  DO 320 IZ = 2, NZ
  TAUC(IZ) = TAUC(IZ-1) + DTAU(IZ)
 320  CONTINUE
  DO 340 IZ = 1, NZ
  CSCAT(IZ) = CABD(IZ) / CABCO(IZ)
 340  CONTINUE
!
  RETURN
  END
  SUBROUTINE ECRFEV ( NATRA, NT, NZ, NFR, FEVK )
!
!     Print Variable Eddington Factors
!
  DIMENSION FEVK(NFR,NZ)
!
 1    FORMAT ( // ' Eddington factor for the line no.', I3 / )
 2    FORMAT ( // ' Eddington factor for the bound-free transition no.' &
    , I3 / )
 3    FORMAT ( / 50X, '***  K / J  ***' / )
 4    FORMAT ( 8X, 20('  FR',I2) )
 5    FORMAT ( ' IZ=', I2, 2X, 20F6.3 )
!
  NFMX = MIN0 ( 20, NFR )
  IF ( NATRA .EQ. 1 ) WRITE ( 66, 1 ) NT
  IF ( NATRA .EQ. 2 ) WRITE ( 66, 2 ) NT
  WRITE ( 66, 3 )
  WRITE ( 66, 4 )  ( J, J = 1, NFMX )
  DO 200 I = 1, NZ
  WRITE ( 66, 5 ) I, ( FEVK(J,I), J = 1, NFMX )
 200  CONTINUE
!
  RETURN
  END
  SUBROUTINE ECRIPOP ( IOP, NZ, NN, HN )
!
  DIMENSION HN(NZ,NN)
!
 1    FORMAT ( // )
 2    FORMAT ( 20X, 'LEVEL POPULATIONS' / )
 3    FORMAT ( // 30X, 'LEVEL ', I3 / )
 4    FORMAT ( 10(3X,G10.4) )
 5    FORMAT ( 2I8 )
 6    FORMAT ( 10(1X,1PE11.3) )
!
  IF ( IOP .LE. 10 ) THEN
  WRITE ( 66, 1 )
  WRITE ( 66, 2 )
  DO 50 I = 1, NN
  WRITE ( 66, 3 ) I
  WRITE ( 66, 4 ) ( HN(IZ,I), IZ = 1, NZ )
 50   CONTINUE
  ELSE
  WRITE ( IOP, 5 ) NZ, NN
  DO 100 I = 1, NN
  WRITE ( IOP, 6 ) ( HN(IZ,I), IZ = 1, NZ )
 100  CONTINUE
  END IF
!
  RETURN
  END
  SUBROUTINE EXOATM ( NZ, C1, C2, XM, TE, VT, Z, HNH, HNE )
!
 1    FORMAT ( //// 9X, 'ATMOSPHERIC PARAMETERS' / )
 2    FORMAT (   '  NO. I    MASS     I  ALTITUDE   I TEMPERATURE I', &
        '  MIC. VEL.  I     NH      I     Ne      I  (Ne/NH)    I', &
        '  PRESSURE   I  DENSITY ' )
 3    FORMAT (   '      I  (G.CM-2)   I    (KM)     I  (KELVIN)   I', &
        '  (KM/S)     I   (CM-3)    I   (CM-3)    I             I', &
        ' (DYNE/CM2)  I  (G/CM3) ' )
 4    FORMAT ( 1X, 132('-') )
 5    FORMAT ( 1X, I4, 9(' I ',G11.4) )
 6    FORMAT ( //// )
!
  PARAMETER ( BOLT=1.3806E-16 )
!
  DIMENSION XM(NZ), TE(NZ), VT(NZ), Z(NZ), HNH(NZ), HNE(NZ)
!
  WRITE ( 66, 1 )
  DO 200 I = 1, NZ
  IF ( MOD(I,50) .NE. 1 ) GO TO 100
  IF ( I .NE. 1 ) WRITE ( 66,6)
  WRITE ( 66, 2 )
  WRITE ( 66, 3 )
  WRITE ( 66, 4 )
 100  CONTINUE
  ALT = -1.E-5 * Z(I)
  VIM = 1.E-5 * VT(I)
  YION = HNE(I) / HNH(I)
  CAT = BOLT * TE(I)
  PA = C2 * HNH(I) * CAT
  PE = HNE(I) * CAT
  PT = 0.5 * C1 * HNH(I) * VT(I) * VT(I)
  PRES = PA + PE + PT
  DENS = C1 * HNH(I)
  WRITE ( 66, 5 ) I, XM(I), ALT, TE(I), VIM, HNH(I), HNE(I) &
    , YION, PRES, DENS
 200  CONTINUE
  RETURN
  END
  SUBROUTINE INIMET ( C1, C2 )
!
!    1:He  2:C    3:N   4:O    5:Ne   6:Na   7:Mg   8:Al   9:Si  10:P
!   11:S  12:Ar  13:K  14:Ca  15:Cr  16:Mn  17:Fe  18:Co  19:Ni  20:H
!
  PARAMETER ( NEL=20, UMA=1.660E-24 )
  COMMON /ELEMTS/ ABON(NEL), HM(NEL), NEI(NEL), PIO(NEL,4) &
    , U(NEL,5), HNION(5,NEL)
!
  ABON = (/ 11.00, 8.54, 8.06, 8.83, 7.55, 6.45, 7.54, 6.45, 7.65 &
    , 5.45, 7.21, 6.75, 5.70, 6.40, 6.00, 5.55, 7.72, 5.35, 6.40 &
    , 12.00 /)
  HM = (/ 4.003, 12.01, 14.01, 16.00, 20.18, 23.00, 24.32, 26.97 &
    , 28.09, 30.97, 32.07, 39.94, 39.10, 40.08, 52.01, 54.93, 55.85 &
    , 58.94, 58.69, 1.008 /)
  NEI = (/ 3, 2, 2, 2, 2, 2, 2, 2, 2, 2 &
    ,        2, 2, 2, 2, 2, 2, 2, 2, 2, 2 /)
  PIO(:,1) = (/ 24.58, 11.26, 14.53, 13.61, 21.55 &
    , 5.14, 7.64, 5.98, 8.15, 10.48 &
    , 10.35, 15.75, 4.33, 6.11, 6.76 &
    , 7.43, 7.83, 7.86, 7.63, 13.60 /)
  PIO(1,2) = 58.40
  U(:,1) = (/ 1.0, 9.28, 4.07, 8.70, 1.00 &
    , 2.02, 1.01, 5.83, 9.26, 4.46 &
    , 8.12, 1.0, 2.18, 1.03, 10.3 &
    , 6.45, 24.5, 31.6, 28.8, 2.00 /)
  U(:,2) = (/ 2.0, 5.94, 8.91, 3.98, 5.37 &
    , 1.00, 2.01, 1.03, 5.82, 8.12 &
    , 4.16, 4.89, 1.00, 2.29, 7.24 &
    , 7.76, 39.2, 27.5, 10.0, 1.00 /)
  U(1,3) = 1.0
!
  C1 = 0.
  C2 = 0.
  DO I = 1, NEL
  XM = UMA * HM(I)
  X = 10.**(ABON(I)-12.)
  C1 = C1 + XM * X
  C2 = C2 + X
  END DO
!
  RETURN
  END
  SUBROUTINE INTEME ( RMU, FRL, NZ, NFR, FR, S, DND, AM, RF &
    , TO, IVERT, NFINT, FRFI, FINT, HI )
!
!   Computation of emergent intensity in a spectral line from the
!   source function, the absorption coefficient and the boundary
!   conditions.
!
  PARAMETER ( FIZERO=0.5641895835 )
!
  DIMENSION FR(NFR), S(NFR,NZ), DND(NZ), AM(NZ), RF(NZ) &
    , TO(NZ), FRFI(NFINT), FINT(NFINT)
  DIMENSION TOZ(2*NZ), SZ(2*NZ), HAV(NZ), PHIZM(NZ), VVV(NZ)
!
  FRA = ABS ( FRL )
!
  DO IZ = 1, NZ
  CALL INTERL ( NFR, FR, S(1,IZ), FRA, SZ(IZ) )
  END DO
  DO IZ = 1, NZ
  VVV(IZ) = FRA / DND(IZ)
  END DO
  CALL VOIGTV ( NZ, AM, VVV, HAV )
  DO IZ = 2, NZ
  PHIZM(IZ) = 0.5 * ( HAV(IZ) + HAV(IZ-1) + RF(IZ) + RF(IZ-1) )
  END DO
  TOZ(1) = 0.0
  DO IZ = 2, NZ
  TOZ(IZ) = TOZ(IZ-1) + ( TO(IZ) - TO(IZ-1) ) * PHIZM(IZ)
  END DO
!
  GO TO ( 200, 300, 400 ) IVERT+2
!
!          Semi-infinite atmosphere
!
 200  CONTINUE
  HIL = SZ(NZ)
  CALL TRALA ( NZ, TOZ, SZ, HIL, RMU, HI )
  RETURN
!
!    Horizontal plane-parallel slab with upward incident radiation
!
 300  CONTINUE
  CALL INTERL ( NFINT, FRFI, FINT, FRA, HIL )
  CALL TRALA ( NZ, TOZ, SZ, HIL, RMU, HI )
  RETURN
!
!       Vertical plane-parallel slab: reconstitution of the full
!     symmetric slab from the computed half-slab.
!
 400  CONTINUE
  NZM = NZ - 1
  NZCC = NZ + NZM
  DO I = 1, NZM
  DTOZ = TOZ(NZ-I+1) - TOZ(NZ-I)
  TOZ(NZ+I) = TOZ(NZ+I-1) + DTOZ
  SZ(NZ+I) = SZ(NZ-I)
  END DO
  HIL = 0.0
  CALL TRALA ( NZCC, TOZ, SZ, HIL, RMU, HI )
  RETURN
!
  END
  SUBROUTINE NOVFEV ( NZ, NF, NMU, L1, L2, IVERT, TAU &
    , FIINF, FISUP, S, FEVK, FEVL )
!
!          Computation of new Eddington factors from source
!     functions, for a finite plane-parallel slab.
!     (Valid for discrete or bound-free transitions).
!
  PARAMETER ( EOLIM=0.05 )
!
  DIMENSION TAU(NF,NZ), FIINF(NF), FISUP(NF), S(NF,NZ) &
    , FEVK(NF,NZ), FEVL(NF,NZ)
  DIMENSION HMU(NMU), H(NMU), A(NMU*NF,NZ), B(NMU*NF,NZ) &
    , C(NMU*NF,NZ), E(NMU*NF,NZ), D(NMU*NF,NZ), F(NMU*NF,NZ) &
    , Y(NMU*NF,NZ)
!
  IF ( TAU(1,NZ) .LT. EOLIM ) RETURN
!
  NFM = NF * NMU
  NF2 = NF * NF
  CALL COEFQG ( NMU, 0.0, 1.0, HMU, H )
!
  DO 300 I = L1, L2
  IF ( I .GT. L1 ) GO TO 150
!
  DO IA = 1, NMU
  DO IB = 1, NF
  J = NMU * IB - NMU + IA
  DTOP = TAU(IB,I+1) - TAU(IB,I)
  B(J,I) = HMU(IA)**2 / DTOP + HMU(IA) + 0.5 * DTOP
  C(J,I) = HMU(IA)**2 / DTOP
  E(J,I) = HMU(IA) * FISUP(IB) + 0.5 * DTOP * S(IB,I)
  END DO
  END DO
  GO TO 300
!
 150  CONTINUE
  IF ( I .EQ. L2 ) GO TO 250
!
!          Intermediate depths
!
  DO IA = 1, NMU
  DO IB = 1, NF
  J = NMU * IB - NMU + IA
  DTOP = TAU(IB,I+1) - TAU(IB,I)
  DTOM = TAU(IB,I) - TAU(IB,I-1)
  DTO = 0.5 * ( DTOM + DTOP )
  A(J,I) = HMU(IA)**2 / DTOM
  C(J,I) = HMU(IA)**2 / DTOP
  B(J,I) = A(J,I) + C(J,I) + DTO
  E(J,I) = DTO * S(IB,I)
  END DO
  END DO
  GO TO 300
!
 250  CONTINUE
  DO IA = 1, NMU
  DO IB = 1, NF
  J = NMU * IB - NMU + IA
  DTOM = TAU(IB,I) - TAU(IB,I-1)
  A(J,I) = HMU(IA)**2 / DTOM
  B(J,I) = HMU(IA)**2 / DTOM + 0.5 * DTOM
  E(J,I) = 0.5 * DTOM * S(IB,I)
  IF ( IVERT .NE. 1 ) THEN
  B(J,I) = B(J,I) + HMU(IA)
  E(J,I) = E(J,I) + HMU(IA) * FIINF(IB)
  END IF
  END DO
  END DO
 300  CONTINUE
!
!          Solution of the tridiagonal system
!
  DO J = 1, NFM
  D(J,L1) = C(J,L1) / B(J,L1)
  F(J,L1) = E(J,L1) / B(J,L1)
  END DO
  DO I = L1+1, L2-1
  DO J = 1, NFM
  D(J,I) = C(J,I) / ( B(J,I) - A(J,I) * D(J,I-1) )
  F(J,I) = ( E(J,I) + A(J,I) * F(J,I-1) ) &
           / ( B(J,I) - A(J,I) * D(J,I-1) )
  END DO
  END DO
  DO J = 1, NFM
  Y(J,L2) = ( E(J,L2) + A(J,L2) * F(J,L2-1) ) &
            / ( B(J,L2) - A(J,L2) * D(J,L2-1) )
  END DO
  DO I = L2-1, L1, -1
  DO J = 1, NFM
  Y(J,I) = D(J,I) * Y(J,I+1) + F(J,I)
  END DO
  END DO
!
!    Computation of Eddington factors
!
  DO IB = 1, NF
  DO I = L1, L2
  A(IB,I) = 0.0
  B(IB,I) = 0.0
  C(IB,I) = 0.0
  END DO
  END DO
  DO IA = 1, NMU
  DO IB = 1, NF
  DO I = L1, L2
  A(IB,I) = A(IB,I) + H(IA) * Y(NMU*IB-NMU+IA,I)
  B(IB,I) = B(IB,I) + H(IA) * HMU(IA) * Y(NMU*IB-NMU+IA,I)
  C(IB,I) = C(IB,I) + H(IA) * HMU(IA)**2 * Y(NMU*IB-NMU+IA,I)
  END DO
  END DO
  END DO
  DO IB = 1, NF
  DO I = L1, L2
  FEVL(IB,I) = B(IB,I) / A(IB,I)
  FEVK(IB,I) = C(IB,I) / A(IB,I)
  END DO
  END DO
      DO IZ = 1, NZ
  IF ( IZ .LT. L1 ) THEN
  DO IB = 1, NF
  FEVK(IB,IZ) = FEVK(IB,L1)
  FEVL(IB,IZ) = FEVL(IB,L1)
  END DO
  END IF
  IF ( IZ .GT. L2 ) THEN
  DO IB = 1, NF
  FEVK(IB,IZ) = FEVK(IB,L2)
  FEVL(IB,IZ) = FEVL(IB,L2)
  END DO
  END IF
      END DO
!
  RETURN
  END
  SUBROUTINE PROFLI ( IRS, NZ, NN, NTT, NTRD, NFR, NMUV, NPSOR &
    , ITRD, NINF, NSUP, FRN, DL1, DL2, PMU &
    , FR, STR, DND, AM, CAR, CAC, TO, NFINT, FRFI, FINT &
    , TOTO, ETOT, FWHM )
!
!    Computation of emergent line profiles for several different
!    "mu" and writing on logical unit 21.
!
  PARAMETER ( CL=2.997925E10 )
!
  DIMENSION ITRD(NTRD), NINF(NTT), NSUP(NTT), FRN(NN) &
    , PMU(NMUV), FR(NFR), STR(NFR,NZ), DND(NZ), AM(NZ), CAR(NZ) &
    , CAC(NZ), TO(NZ), FRFI(NFINT), FINT(NFINT)
  DIMENSION XX(NPSOR), YY(NPSOR,NMUV), RF(NZ)


!write(*,*) 'NPSOR=',NPSOR

  IVERT = 1
  NT = ITRD(IRS)
  NI = NINF(NT)
  NS = NSUP(NT)
  FR0 = FRN(NS) - FRN(NI)
  AMBDA = CL / FR0
  DO IZ = 1, NZ
  RF(IZ) = CAC(IZ) / CAR(IZ)
  END DO
  DO IP = 1, NPSOR
  DLA = DL1 + ( DL2 - DL1 ) * FLOAT(IP-1) / FLOAT(NPSOR-1)
  FREQ = CL / ( AMBDA + 1.E-8 * DLA )
  XX(IP) = DLA
  DO IC = 1, NMUV
  CALL INTEME ( PMU(IC), FREQ-FR0, NZ, NFR, FR, STR, DND, AM &
    , RF, TO, IVERT, NFINT, FRFI, FINT, YPHZ )
  YY(IP,IC) = YPHZ * FR0 / ( 1.E8 * AMBDA )
  END DO
  END DO



  WRITE ( 21, 107 ) NI, NS, FR0
 107  FORMAT ( 2(1X,I10), 2X, E16.7 )
  WRITE ( 21, 108 ) ( PMU(IC), IC = 1, NMUV )
 108  FORMAT ( 6(1X,1PE12.3) )
  WRITE ( 21, 108 ) ( XX(IP), IP = 1, NPSOR )

  DO IC = 1, NMUV
  WRITE ( 21, 108 ) ( YY(IP,IC), IP = 1, NPSOR )
  END DO


 write(210,107) NI, NS, FR0
 
 WRITE(210,108) ( PMU(IC), IC = 1, NMUV )
 
 do ip = 1,NPSOR
    write(210,108) XX(ip),YY(ip,1)
 enddo

  TOTO = 2.0 * TO(NZ)
  ETOT = 0.0
  DO IP = 2, NPSOR
  ETOT = ETOT + ( XX(IP) - XX(IP-1) ) * ( YY(IP-1,NMUV) + &
      YY(IP,NMUV) )
  END DO

  HIMOY = 0.5 * AMAXI ( YY(1,NMUV), NPSOR )

  DO IP = 2, NPSOR-1

  IF ( YY(IP-1,NMUV) .GE. HIMOY .AND. YY(IP,NMUV) .LE. HIMOY ) &
     GO TO 410

  END DO
 410  CONTINUE

  XMOY = XX(IP-1) + ( XX(IP) - XX(IP-1) ) * ( YY(IP-1,NMUV) - HIMOY &
      ) / ( YY(IP-1,NMUV) - YY(IP,NMUV) )
  FWHM = XMOY + XMOY
!
  RETURN
  END
  SUBROUTINE SUMRA ( IRS, NZ, NN, NTT, NTRD, ITRD, NINF, NSUP, FRN &
    , L1, L2, Z, TO, CAR, CAC, DND, AM, EPS, BEN, COHE, GIBAR )
!
  PARAMETER ( CL=2.997925E10 )
!
  DIMENSION ITRD(NTRD), NINF(NTT), NSUP(NTT), FRN(NN), Z(NZ) &
    , TO(NZ), CAR(NZ), CAC(NZ), DND(NZ), AM(NZ), EPS(NZ), BEN(NZ) &
    , COHE(NZ), GIBAR(NZ)
!
 1    FORMAT ( //// )
 2    FORMAT ( 20X, 'RADIATIVE TRANSFER FOR THE LINE NO. ', I3 )
 3    FORMAT ( 20X, 40('-') // )
 4    FORMAT ( '   BOUNDARIES', 2(10X,I5,'   ( ', F7.0, ' KM )' ) )
 5    FORMAT ( 30X, 'LAMBDA  ', F10.2 // )
 6    FORMAT (   '  NO. I OPT. DEPTH  I DOP. WIDTH  I A (DAMPING  I', &
        '   EPS*      I   BEN*      I  ABSORPTION I  COHERENCE  I', &
        '   MEAN      I  NET RAD.' )
 7    FORMAT (   '      I  AT CENTER  I (ANGSTROMS) I  CONSTANT)  I', &
        '             I (C.G.S.)    I  RATIO      I COEFFICIENT I', &
        ' INTENSITY   I BRACKET  ' )
 8    FORMAT ( 1X, 132('-') )
 9    FORMAT ( 1X, I4, 9(' I ',G11.4) )
!
  NT = ITRD(IRS)
  NI = NINF(NT)
  NS = NSUP(NT)
  FR0 = FRN(NS) - FRN(NI)
  WRITE ( 66, 1 )
  WRITE ( 66, 2 ) IRS
  WRITE ( 66, 3 )
  AMBDA = 1.E8 * CL / FR0
  WRITE ( 66, 5 ) AMBDA
  Z1 = -1.E-5 * Z(L1)
  Z2 = -1.E-5 * Z(L2)
  WRITE ( 66, 4 ) L1, Z1, L2, Z2
  DO 200 I = 1, NZ
  IF ( MOD(I,50) .NE. 1 ) GO TO 100
  IF ( I .NE. 1 ) WRITE ( 66, 1 )
  WRITE ( 66, 6 )
  WRITE ( 66, 7 )
  WRITE ( 66, 8 )
 100  CONTINUE
  DLD = DND(I) * AMBDA / FR0
  SRCE = EPS(I) * BEN(I) + ( 1.0 - EPS(I) ) * GIBAR(I)
  BIL = EPS(I) * ( BEN(I) - GIBAR(I) ) / SRCE
  RF = CAC(I) / CAR(I)
  WRITE ( 66, 9 ) I, TO(I), DLD, AM(I), EPS(I), BEN(I), RF &
    , COHE(I), GIBAR(I), BIL
 200  CONTINUE
!
  RETURN
  END
  SUBROUTINE TFCFEV ( NZ, NFRC, L1, L2, IVERT, FR, PHI, TAU, RAE &
    , CAE, SAE, CSI0, ETA0, FIINF, FISUP, WF, TE, FEVK, FEVL, GIBAR &
    , S )
!
!     Solution of radiative transfer equations for a bound-free
! transition, with external absorption sources.
!     Finite-difference method with variable Eddington factors.
!
  PARAMETER ( HP=6.6262E-27, BOLT=1.3806E-16 )
!
  DIMENSION FR(NFRC), PHI(NFRC), TAU(NFRC,NZ), RAE(NZ,NFRC) &
    , CAE(NZ,NFRC), SAE(NZ,NFRC), CSI0(NZ), ETA0(NZ) &
    , FIINF(NFRC), FISUP(NFRC), WF(NFRC), TE(NZ) &
    , FEVK(NFRC,NZ), FEVL(NFRC,NZ), GIBAR(NZ), S(NFRC,NZ)
  DIMENSION GI(NFRC,NZ), CSI(NFRC,NZ), ETA(NFRC,NZ) &
    , D(NFRC,NFRC,NZ), F(NFRC,NZ), A(NFRC), B(NFRC,NFRC), C(NFRC) &
    , E(NFRC), AUXM(NFRC,NFRC), AUXV(NFRC), DTOM(NFRC), DTOP(NFRC) &
    , DTO(NFRC)
!
  DO IZ = 1, NZ
  DO J = 1, NFRC
  AUXV(J) = ( FR(J) / FR(1) ) ** 3 * EXP ( - HP * ( FR(J) - FR(1) ) &
              / ( BOLT * TE(IZ) ) )
  CSI(J,IZ) = CSI0(IZ) * AUXV(J)
  ETA(J,IZ) = ETA0(IZ) * AUXV(J)
  END DO
  END DO
!
  DO 500 IZ = L1, L2
  IF ( IZ .EQ. L1 ) GO TO 200
  IF ( IZ .EQ. L2 ) GO TO 400
  GO TO 300
!
 200  CONTINUE
  DO J = 1, NFRC
  DTOP(J) = TAU(J,IZ+1) - TAU(J,IZ)
  END DO
  DO K = 1, NFRC
  DO J = 1, NFRC
  B(J,K) = - 0.5 * DTOP(J) * PHI(J) * CSI(J,IZ) * WF(K) / &
             ( PHI(J) + RAE(IZ,J) )
  END DO
  END DO
  DO J = 1, NFRC
  B(J,J) = B(J,J) + FEVK(J,IZ) / DTOP(J) + FEVL(J,IZ) + 0.5 * &
             DTOP(J) - 0.5 * DTOP(J) * RAE(IZ,J) * CAE(IZ,J) / &
             ( PHI(J) + RAE(IZ,J) )
  C(J) = FEVK(J,IZ+1) / DTOP(J)
  E(J) = 0.5 * DTOP(J) * ( PHI(J) * ETA(J,IZ) + RAE(IZ,J) * &
           ( 1.0 - CAE(IZ,J) ) * SAE(IZ,J) ) / ( PHI(J) + RAE(IZ,J) ) &
           + 0.5 * FISUP(J)
  END DO
  CALL INVMAT ( B, NFRC )
  DO K = 1, NFRC
  DO J = 1, NFRC
  D(J,K,L1) = B(J,K) * C(K)
  END DO
  END DO
  CALL PROMAV ( B, E, F(1,L1), NFRC )
  GO TO 500
!
 300  CONTINUE
  DO J = 1, NFRC
  DTOM(J) = TAU(J,IZ) - TAU(J,IZ-1)
  DTOP(J) = TAU(J,IZ+1) - TAU(J,IZ)
  DTO(J) = 0.5 * ( DTOM(J) + DTOP(J) )
  END DO
  DO K = 1, NFRC
  DO J = 1, NFRC
  B(J,K) = - DTO(J) * PHI(J) * CSI(J,IZ) * WF(K) / ( PHI(J) + &
             RAE(IZ,J) )
  END DO
  END DO
  DO J = 1, NFRC
  A(J) = FEVK(J,IZ-1) / DTOM(J)
  C(J) = FEVK(J,IZ+1) / DTOP(J)
  B(J,J) = B(J,J) + FEVK(J,IZ) * ( 1.0 / DTOM(J) + 1.0 / DTOP(J) ) &
             + DTO(J) - DTO(J) * CAE(IZ,J) * RAE(IZ,J) / &
             ( PHI(J) + RAE(IZ,J) )
  E(J) = DTO(J) * ( PHI(J) * ETA(J,IZ) + RAE(IZ,J) * ( 1.0 - &
           CAE(IZ,J) ) * SAE(IZ,J) ) / ( PHI(J) + RAE(IZ,J) )
  END DO
  GO TO 480
!
 400  CONTINUE
  DO J = 1, NFRC
  DTOM(J) = TAU(J,L2) - TAU(J,L2-1)
  END DO
  DO K = 1, NFRC
  DO J = 1, NFRC
  B(J,K) = - 0.5 * DTOM(J) * PHI(J) * CSI(J,IZ) * WF(K) / &
             ( PHI(J) + RAE(IZ,J) )
  END DO
  END DO
  DO J = 1, NFRC
  A(J) = FEVK(J,IZ-1) / DTOM(J)
  B(J,J) = B(J,J) + FEVK(J,IZ) / DTOM(J) + 0.5 * DTOM(J) &
             - 0.5 * DTOM(J) * RAE(IZ,J) * CAE(IZ,J) / &
             ( PHI(J) + RAE(IZ,J) )
  E(J) = 0.5 * DTOM(J) * ( PHI(J) * ETA(J,IZ) + RAE(IZ,J) * &
           ( 1.0 - CAE(IZ,J) ) * SAE(IZ,J) ) / ( PHI(J) + RAE(IZ,J) )
  END DO
  IF ( IVERT .NE. 1 ) THEN
  DO J = 1, NFRC
  B(J,J) = B(J,J) + FEVL(J,IZ)
  E(J) = E(J) + 0.5 * FIINF(J)
  END DO
  END IF
!
 480  CONTINUE
  DO K = 1, NFRC
  DO J = 1, NFRC
  AUXM(J,K) = B(J,K) - A(J) * D(J,K,IZ-1)
  END DO
  END DO
  CALL INVMAT ( AUXM, NFRC )
  DO K = 1, NFRC
  DO J = 1, NFRC
  D(J,K,IZ) = AUXM(J,K) * C(K)
  END DO
  END DO
  DO J = 1, NFRC
  AUXV(J) = E(J) + A(J) * F(J,IZ-1)
  END DO
  CALL PROMAV ( AUXM, AUXV, F(1,IZ), NFRC )
 500  CONTINUE
!
      DO IZ = L2, L1, -1
  IF ( IZ .EQ. L2 ) THEN
  DO J = 1, NFRC
  GI(J,IZ) = F(J,IZ)
  END DO
  ELSE
  CALL PROMAV ( D(1,1,IZ), GI(1,IZ+1), AUXV, NFRC )
  DO J = 1, NFRC
  GI(J,IZ) = AUXV(J) + F(J,IZ)
  END DO
  END IF
      END DO
  DO IZ = L1, L2
  GIBAR(IZ) = 0.0
  END DO
  DO J = 1, NFRC
  DO IZ = L1, L2
  GIBAR(IZ) = GIBAR(IZ) + WF(J) * GI(J,IZ)
  END DO
  END DO
!
      DO IZ = 1, NZ
  IF ( IZ .LT. L1 ) THEN
  GIBAR(IZ) = GIBAR(L1)
  DO J = 1, NFRC
  GI(J,IZ) = GI(J,L1)
  END DO
  END IF
  IF ( IZ .GT. L2 ) THEN
  GIBAR(IZ) = GIBAR(L2)
  DO J = 1, NFRC
  GI(J,IZ) = GI(J,L2)
  END DO
  END IF
      END DO
!
!          Computation of source functions
!
  DO IZ = 1, NZ
  DO J = 1, NFRC
  S(J,IZ) = ( PHI(J) * ( CSI(J,IZ) * GIBAR(IZ) + ETA(J,IZ) ) + &
            RAE(IZ,J) * ( CAE(IZ,J) * GI(J,IZ) + ( 1.0 - CAE(IZ,J) ) &
            * SAE(IZ,J)  ) ) / ( PHI(J) + RAE(IZ,J) )
  END DO
  END DO
!
  RETURN
  END
  SUBROUTINE TFCOM ( NZ, NFRC, IVERT, FR, PHI, RAE, CAE, SAE, CSI0, ETA0 &
    , FIINF, FISUP, WF, TE, GIBAR, S )
!
!   TFCOM replaces TFCFEV in the optically thin case
!
  PARAMETER ( HP=6.6262E-27, BOLT=1.3806E-16 )
!
  DIMENSION FR(NFRC), PHI(NFRC), RAE(NZ,NFRC) &
    , CAE(NZ,NFRC), SAE(NZ,NFRC), CSI0(NZ), ETA0(NZ) &
    , FIINF(NFRC), FISUP(NFRC), WF(NFRC), TE(NZ) &
    , GIBAR(NZ), S(NFRC,NZ)
  DIMENSION GI(NFRC,NZ), CSI(NFRC,NZ), ETA(NFRC,NZ) &
    , AUXV(NFRC)
!
  DO IZ = 1, NZ
  DO J = 1, NFRC
  AUXV(J) = ( FR(J) / FR(1) ) ** 3 * EXP ( - HP * ( FR(J) - FR(1) ) &
              / ( BOLT * TE(IZ) ) )
  CSI(J,IZ) = CSI0(IZ) * AUXV(J)
  ETA(J,IZ) = ETA0(IZ) * AUXV(J)
  END DO
  END DO
!
  GIBAR(1) = 0.0
  DO J = 1, NFRC
  IF ( IVERT .EQ. 1 ) THEN
  GI(J,1) = FISUP(J)
  ELSE
  GI(J,1) = 0.5 * ( FIINF(J) + FISUP(J) )
  END IF
  GIBAR(1) = GIBAR(1) + WF(J) * GI(J,1)
  END DO
  DO IZ = 2, NZ
  GIBAR(IZ) = GIBAR(1)
  DO J = 1, NFRC
  GI(J,IZ) = GI(J,1)
  END DO
  END DO
!
  DO IZ = 1, NZ
  DO J = 1, NFRC
  S(J,IZ) = ( PHI(J) * ( CSI(J,IZ) * GIBAR(IZ) + ETA(J,IZ) ) + &
            RAE(IZ,J) * ( CAE(IZ,J) * GI(J,IZ) + ( 1.0 - CAE(IZ,J) ) &
            * SAE(IZ,J)  ) ) / ( PHI(J) + RAE(IZ,J) )
  END DO
  END DO
!
  RETURN
  END
  SUBROUTINE TFRFEV ( NZ, NFR, L1, L2, IVERT, FR, PHIX, RF, TO, DDC &
    , SC, EPS, BEN, FIINF, FISUP, RDMAT, FEVK, FEVL, GI, GIBAR, SL, ST )
!
!          Solution of radiative transfer equations for a line
!     by the finite-difference method with variable Eddington
!     factors :
!     - Finite plane-parallel slab
!     - 3 options : atmosphere (IVERT=-1)
!                   horizontal slab (IVERT=0)
!                   vertical half-slab (IVERT=1)
!     - Continuous absorption
!     - Partial frequency redistribution
!
  PARAMETER ( PI=3.141592653589, EOLIM=0.05 )
!
  REAL, DIMENSION(NZ) :: RF, TO, DDC, SC, EPS, BEN, GIBAR
  REAL, DIMENSION(NFR) :: FR, FIINF, FISUP, HF, A, C, E, AUXV
  REAL, DIMENSION(NFR,NZ) :: PHIX, FEVK, FEVL, GI, SL, ST, F, DTO, DTOM &
    , DTOP, PHI
  REAL, DIMENSION(NFR,NFR) :: B, AUXM
  REAL, DIMENSION(NFR*NFR,NZ) :: RDMAT
  REAL, DIMENSION(NFR,NFR,NZ) :: D
!
  SQPI = SQRT ( PI )
  CALL TRAPEZ ( NFR, FR, HF )
  DO J = 1, NFR
  DO I = 1, NZ
  PHI(J,I) = SQPI * PHIX(J,I)
  END DO
  END DO
!
  IF ( TO(NZ) .LT. EOLIM ) GO TO 600
!
    DO J = 1, NFR
  DO I = L1, L2-1
  DTOP(J,I) = ( TO(I+1) - TO(I) ) * 0.5 * ( PHI(J,I) + PHI(J,I+1) &
                + RF(I) + RF(I+1) )
  DTOM(J,I+1) = DTOP(J,I)
  END DO
  DO I = L1+1, L2-1
  DTO(J,I) = 0.5 * ( DTOM(J,I) + DTOP(J,I) )
  END DO
    END DO
!
  DO 300 I = L1, L2
  IF ( I .GT. L1 ) GO TO 200
!
  DO K = 1, NFR
  DO J = 1, NFR
  B(J,K) = 0.5 * DTOP(J,I) * ( EPS(I) - 1.0 ) * RDMAT(NFR*K-NFR+J,I) &
      * SQPI / ( PHI(J,I) + RF(I) )
  END DO
  END DO
  DO J = 1, NFR
  B(J,J) = B(J,J) + FEVK(J,I) / DTOP(J,I) + FEVL(J,I) + 0.5 * &
             DTOP(J,I) - 0.5 * DTOP(J,I) * RF(I) * DDC(I) / ( PHI(J,I) &
             + RF(I) )
  C(J) = FEVK(J,I+1) / DTOP(J,I)
  E(J) = 0.5 * FISUP(J) + 0.5 * DTOP(J,I) * ( PHI(J,I) * EPS(I) * &
           BEN(I) + RF(I) * ( 1.0 - DDC(I) ) * SC(I) ) / ( PHI(J,I) &
           + RF(I) )
  END DO
  CALL INVMAT ( B, NFR )
  DO K = 1, NFR
  DO J = 1, NFR
  D(J,K,L1) = B(J,K) * C(K)
  END DO
  END DO
  CALL PROMAV ( B, E, F(1,L1), NFR )
  GO TO 300
!
 200  CONTINUE
  IF ( I .EQ. L2 ) GO TO 250
!
  DO J = 1, NFR
  A(J) = FEVK(J,I-1) / DTOM(J,I)
  C(J) = FEVK(J,I+1) / DTOP(J,I)
  E(J) = ( RF(I) * ( 1.0 - DDC(I) ) * SC(I) + PHI(J,I) * EPS(I) * &
     BEN(I) ) * DTO(J,I) / ( RF(I) + PHI(J,I) )
  END DO
  DO K = 1, NFR
  DO J = 1, NFR
  B(J,K) = ( EPS(I) - 1.0 ) * DTO(J,I) * RDMAT(NFR*K-NFR+J,I) * &
             SQPI / ( RF(I) + PHI(J,I) )
  END DO
  END DO
  DO J = 1, NFR
  B(J,J) = B(J,J) + DTO(J,I) + FEVK(J,I) / DTOM(J,I) + FEVK(J,I) / &
             DTOP(J,I) - DTO(J,I) * RF(I) * DDC(I) / ( PHI(J,I) &
             + RF(I) )
  END DO
  GO TO 290
!
 250  CONTINUE
  DO K = 1, NFR
  DO J = 1, NFR
  B(J,K) = 0.5 * DTOM(J,I) * ( EPS(I) - 1.0 ) * RDMAT(NFR*K-NFR+J,I) &
             * SQPI  / ( PHI(J,I) + RF(I) )
  END DO
  END DO
  DO J = 1, NFR
  A(J) = FEVK(J,I-1) / DTOM(J,I)
  B(J,J) = B(J,J) + FEVK(J,I) / DTOM(J,I) + 0.5 * DTOM(J,I) &
             - 0.5 * DTOM(J,I) * RF(I) * DDC(I) / ( PHI(J,I) + RF(I) )
  E(J) = 0.5 * DTOM(J,I) * ( PHI(J,I) * EPS(I) * BEN(I) + &
           RF(I) * ( 1.0 - DDC(I) ) * SC(I) ) / ( PHI(J,I) + RF(I) )
  END DO
  IF ( IVERT .NE. 1 ) THEN
  DO J = 1, NFR
  B(J,J) = B(J,J) + FEVL(J,I)
  E(J) = E(J) + 0.5 * FIINF(J)
  END DO
  END IF
 290  CONTINUE
  DO K = 1, NFR
  DO J = 1, NFR
  AUXM(J,K) = B(J,K) - A(J) * D(J,K,I-1)
  END DO
  END DO
  CALL INVMAT ( AUXM, NFR )
  DO K = 1, NFR
  DO J = 1, NFR
  D(J,K,I) = AUXM(J,K) * C(K)
  END DO
  END DO
  DO J = 1, NFR
  AUXV(J) = E(J) + A(J) * F(J,I-1)
  END DO
  CALL PROMAV ( AUXM, AUXV, F(1,I), NFR )
 300  CONTINUE
!
      DO II = L1, L2
  I = L1 + L2 - II
  IF ( I .EQ. L2 ) THEN
  DO J = 1, NFR
  GI(J,I) = F(J,I)
  END DO
  ELSE
  CALL PROMAV ( D(1,1,I), GI(1,I+1), AUXV, NFR )
  DO J = 1, NFR
  GI(J,I) = AUXV(J) + F(J,I)
  END DO
  END IF
  GIBAR(I) = 0.0
  SOM = 0.0
  DO J = 1, NFR
  COEF = HF(J) * PHI(J,I)
  GIBAR(I) = GIBAR(I) + COEF * GI(J,I)
  SOM = SOM + COEF
  END DO
  GIBAR(I) = GIBAR(I) / SOM
      END DO !  (II = L1, L2)
!
  DO 500 I = 1, NZ
  IF ( I .LT. L1 ) GO TO 420
  IF ( I .GT. L2 ) GO TO 460
  GO TO 500
 420  CONTINUE
  GIBAR(I) = GIBAR(L1)
  DO J = 1, NFR
  GI(J,I) = GI(J,L1)
  END DO
  GO TO 500
 460  CONTINUE
  GIBAR(I) = GIBAR(L2)
  DO J = 1, NFR
  GI(J,I) = GI(J,L2)
  END DO
 500  CONTINUE
  GO TO 800
!
!          Optically thin case : the mean intensity is taken as
!     the average of incident intensities.
!
 600  CONTINUE
  DO I = 1, NZ
  GIBAR(I) = 0.0
  SOM = 0.0
  DO J = 1, NFR
  IF ( IVERT .EQ. 0 ) GI(J,I) = 0.5 * FIINF(J)
  IF ( IVERT .EQ. 1 ) GI(J,I) = FISUP(J)
  COEF = HF(J) * PHI(J,I)
  GIBAR(I) = GIBAR(I) + COEF * GI(J,I)
  SOM = SOM + COEF
  END DO
  GIBAR(I) = GIBAR(I) / SOM
  END DO
!
!          Computation of source functions
!
 800  CONTINUE
  DO I = 1, NZ
  CALL PROMAV ( RDMAT(1,I), GI(1,I), SL(1,I), NFR )
  END DO
  DO J = 1, NFR
  DO I = 1, NZ
  SL(J,I) = EPS(I) * BEN(I) + ( 1.0 - EPS(I) ) * SL(J,I) / PHIX(J,I)
  END DO
  DO I = 1, NZ
  ST(J,I) = ( RF(I) * ( 1.0 - DDC(I) ) * SC(I) + &
              RF(I) * DDC(I) * GI(J,I) + PHI(J,I) * SL(J,I) ) / &
              ( PHI(J,I) + RF(I) )
  END DO
  END DO
!
  RETURN
  END
  SUBROUTINE TXCOLL ( IVAL, NZ, NN, NTT, NTC, NTAB, ITC, NINF, NSUP &
    , INF, POM, FRN, SIGM, TAB, OIS, TE, HNE, CIJ, CJI )
!
!   Computation of collisional transition probabilities
!   (CIJ and CJI)
!   Options :
!   IVAL = 0 : use of mean cross sections (SIGM)
!   IVAL = 1 : use of VAL type coefficients (OIS)
!
  PARAMETER ( PI=3.141592653589, HP=6.6262E-27, BOLT=1.3806E-16 &
    , ELM=0.910956E-27 )
!
  DIMENSION ITC(NTC), NINF(NTT), NSUP(NTT), INF(NN), POM(NN) &
    , FRN(NN), SIGM(NTC), TAB(NTAB), OIS(NTAB,NTC), TE(NZ), HNE(NZ) &
    , CIJ(NZ,NTC), CJI(NZ,NTC)
!
  DIMENSION CAT(NZ), XXX(NZ), ETLIS(NZ), AUX(NZ)
!
  C5 = 2.0 * (2.0*PI*ELM*BOLT/HP**2)**1.5
!
      DO K = 1, NTC
  IT = ITC(K)
  NI = NINF(IT)
  NS = NSUP(IT)
  FREQ = FRN(NS) - FRN(NI)
  HNU  = HP * FREQ
  IF ( IVAL .LE. 0 ) THEN
  DO IZ = 1, NZ
  CAT(IZ) = BOLT * TE(IZ)
  XXX(IZ) = EXP ( HNU / CAT(IZ) )
  COEF = 4. * SIGM(K) * ( HNU + CAT(IZ) ) / &
           ( XXX(IZ) * SQRT ( 2. * PI * ELM * CAT(IZ) ) )
  CIJ(IZ,K) = HNE(IZ) * COEF
  END DO
  ELSE
  DO IZ = 1, NZ
  CALL INTERL ( NTAB, TAB, OIS(1,K), TE(IZ), AUX(IZ) )
  END DO
  DO IZ = 1, NZ
  CAT(IZ) = BOLT * TE(IZ)
  XXX(IZ) = EXP ( HNU / CAT(IZ) )
  CIJ(IZ,K) = HNE(IZ) * AUX(IZ) / XXX(IZ)
  END DO
  END IF
  IF ( INF(NS) .EQ. 0 ) THEN
  DO IZ = 1, NZ
  ETLIS(IZ) = XXX(IZ) * POM(NI) / POM(NS)
  END DO
  ELSE
  DO IZ = 1, NZ
  ETLIS(IZ) = HNE(IZ) * POM(NI) * XXX(IZ) / &
     ( POM(NS) * C5 * TE(IZ)**1.5 )
  END DO
  END IF
  DO IZ = 1, NZ
  CJI(IZ,K) = CIJ(IZ,K) * ETLIS(IZ)
  END DO
      END DO !  (K = 1, NTC)
!
  RETURN
  END
  SUBROUTINE MAREDI ( L, PHIX, AMRT, X, R, COHE, XNORM )
!
!        COMPUTATION OF A REDISTRIBUTION MATRIX.
!
! Case of a resonance line with a frequency-independent
! coherence coefficient.
! Half-profile frequency mesh (static atmosphere).
! Piecewise representation of the mean intensity.
!
  PARAMETER ( DXMAX=0.2, XBL=3.0 )
!
  DIMENSION PHIX(L), X(L), R(L*L), XNORM(L)
  DIMENSION NDY(L), KFJ(L), AUX(L)
!
  IF ( COHE .EQ. 0.0 ) THEN
!
!     Case of complete redistribution
!
  CALL TRAPEZ ( L, X, AUX )
  DO I = 1, L
  DO J = 1, L
  R(L*J-L+I) = PHIX(I) * PHIX(J) * AUX(J) * 2.0
  END DO
  END DO
!
  ELSE
!
!     Partial redistribution
!
  K = 0
  LM = L - 1
  DO I = 1, LM
  NDY(I) = IFIX ( ( X(I+1) - X(I) ) / DXMAX ) + 1
  END DO
  NDY(L) = IFIX ( XBL / DXMAX ) + 1
  DO I = 1, L
  NXX = NDY(I)
  DO ISD = 1, NXX
  K = K + 1
  IF ( ISD .EQ. 1 ) KFJ(I) = K
  END DO
  END DO
  NY = K + 1
  CALL SUBMRD ( L, AMRT, X, R, NY, NDY, KFJ )
  END IF
!
  IF ( COHE .NE. 1.0 ) THEN
  CALL TRAPEZ ( L, X, AUX )
  DO I = 1, L
  DO J = 1, L
  IJ = L * J - L + I
  R(IJ) = COHE * R(IJ) + ( 1. - COHE ) * PHIX(I) * PHIX(J) * &
       AUX(J) * 2.0
  END DO
  END DO
  END IF
!
!     Renormalization of the R matrix
!
  DO I = 1, L
  AUX(I) = 0.0
  DO J = 1, L
  AUX(I) = AUX(I) + R(L*J-L+I)
  END DO
  XNORM(I) = AUX(I) / PHIX(I)
  END DO
  DO I = 1, L
  DO J = 1 , L
  IJ = L * J - L + I
  R(IJ) = R(IJ) / XNORM(I)
  END DO
  END DO
!
  RETURN
  END
  SUBROUTINE SUBMRD ( L, AMRT, X, R, NY, NDY, KFJ )
!
!  Scattering coherent in atom's frame
!
  PARAMETER ( DXMAX=0.2, XBL=3.0 )
!
  DIMENSION X(L), R(L*L), NDY(L), KFJ(L)
  DIMENSION Y(NY), RR(NY), XINF(NY), XSUP(NY), RRP(NY), RRM(NY)
!
!     Frequency mesh for the integration of R
!
  K = 0
  LM = L - 1
  DO I = 1, L
  NXX = NDY ( I )
  DO ISD = 1, NXX
  K = K + 1
  IF ( ISD .NE. 1 ) THEN
  IF ( I .EQ. L ) THEN
  DELTAX = XBL
  ELSE
  DELTAX = X(I+1) - X(I)
  END IF
  Y(K) = X(I) + DELTAX * FLOAT (ISD-1) / FLOAT (NXX)
  ELSE
  Y(K) = X(I)
  KFJ(I) = K
  END IF
  END DO
  END DO
  Y(NY) = X(L) + XBL
!
      DO I = 1, L
  DO K = 1, NY
  XINF(K) = AMIN1 ( X(I), Y(K) )
  XSUP(K) = AMAX1 ( X(I), Y(K) )
  END DO
  CALL RIIVEC ( NY, AMRT, XINF, XSUP, RRP )
  DO K = 1, NY
  XINF(K) = - XINF(K)
  END DO
  CALL RIIVEC ( NY, AMRT, XINF, XSUP, RRM )
  DO K = 1, NY
  RR(K) = RRP(K) + RRM(K)
  END DO
      DO J = 1, L
  IJ = L * J - L + I
  R(IJ) = 0.0
  IF ( J .NE. 1 ) THEN
!
!     Integration from X(J-1) to X(J)
!
  K1 = KFJ(J-1)
  MK = NDY(J-1)
  K2 = K1 + MK
  DO K = K1, K2
  COEF = ( X(J) - X(J-1) ) * FLOAT ( K - K1 ) / FLOAT ( MK * MK )
  IF ( K .EQ. K1 .OR. K .EQ. K2 ) COEF = 0.5 * COEF
  R(IJ) = R(IJ) + COEF * RR(K)
  END DO
  END IF
!
!     Integration from X(J) to X(J+1)
!
  K1 = KFJ(J)
  MK = NDY(J)
  K2 = K1 + MK
  DO K = K1, K2
  IF ( J .EQ. L ) THEN
  COEF = XBL / FLOAT ( MK )
  ELSE
  COEF = ( X(J+1) - X(J) ) * FLOAT ( K2 - K ) / FLOAT ( MK * MK )
  END IF
  IF ( K .EQ. K1 .OR. K .EQ. K2 ) COEF = 0.5 * COEF
  R(IJ) = R(IJ) + COEF * RR(K)
  END DO
      END DO
      END DO
!
  RETURN
  END
  SUBROUTINE MARALA ( L, PHIX, AMRT, X, R, COHE, XNORM )
!
!          Computation of a redistribution matrix.
!
!   Special version for the hydrogen Lyman-alpha line
! (frequency dependent coherence coefficient).
! Half-profile frequency mesh (static atmosphere).
! Piecewise representation of the mean intensity.
!
  PARAMETER ( DXMAX=0.2, XBL=3.0 )
!
  DIMENSION PHIX(L), X(L), COHE(L), XNORM(L), R(L*L)
  DIMENSION NDY(L), KFJ(L), AUX(L)
!
  K = 0
  LM = L - 1
  DO I = 1, LM
  NDY(I) = IFIX ( ( X(I+1) - X(I) ) / DXMAX ) + 1
  END DO
  NDY(L) = IFIX ( XBL / DXMAX ) + 1
  DO I = 1, L
  NXX = NDY ( I )
  DO ISD = 1, NXX
  K = K + 1
  IF ( ISD .EQ. 1 ) KFJ(I) = K
  END DO
  END DO
  NY = K + 1
!
  CALL SUBMRD ( L, AMRT, X, R, NY, NDY, KFJ )
!
  CALL TRAPEZ ( L, X, AUX )
  DO I = 1, L
  DO J = 1, L
  IJ = L * J - L + I
  R(IJ) = COHE(J) * R(IJ) + ( 1.0 - COHE(J) ) * PHIX(I) * PHIX(J) * &
       AUX(J) * 2.0
  END DO
  END DO
!
  DO I = 1, L
  AUX(I) = 0.0
  DO J = 1, L
  AUX(I) = AUX(I) + R(L*J-L+I)
  END DO
  XNORM(I) = AUX(I) / PHIX(I)
  END DO
  DO I = 1, L
  DO J = 1 , L
  IJ = L * J - L + I
  R(IJ) = R(IJ) / XNORM(I)
  END DO
  END DO
!
  RETURN
  END
  FUNCTION EXPINT ( M, T )
!
  PARAMETER ( A0=0.2677737343, A1=8.6347608925 &
    , A2=18.0590169730, A3=8.5733287401, B0=3.9584969228 &
    , B1=21.0996530827, B2=25.6329561486, B3=9.5733223454 )
!
  IF ( T < 0.0 ) GO TO 900
  IF ( T == 0.0 ) GO TO 20
  IF ( M .EQ. 0 ) GO TO 200
  IF ( T .GT. 1.0 ) GO TO 2
  E1 = -.57721566490153 -  LOG ( T )
  N = 1
  A = 1.0
 10   CONTINUE
  A = - A * T / FLOAT ( N )
  B = A / FLOAT ( N )
  E1 = E1 - B
  IF ( N .LE. 2 ) GO TO 11
  IF ( ABS(B) .LT. (1.E-14*E1) ) GO TO 50
 11   CONTINUE
  N= N+1
  GO TO 10
 2    CONTINUE
  IF ( T .LE. 670. ) GO TO 3
  EXPINT = 0.0
  RETURN
 3    CONTINUE
  HUM = A0 + T * ( A1 + T * ( A2 + T * ( A3 + T ) ) )
  DEN = B0 + T * ( B1 + T * ( B2 + T * ( B3 + T ) ) )
  E1 = ( HUM / DEN ) * EXP ( - T ) / T
 50   CONTINUE
  EXPINT = E1
  IF ( M .EQ. 1 ) RETURN
  DO 40 I = 2, M
  EXPINT = ( EXP ( - T ) - T * EXPINT ) / FLOAT ( I - 1 )
 40   CONTINUE
  RETURN
 20   CONTINUE
  IF ( M .LE. 1 ) GO TO 900
  EXPINT = 1.0 / FLOAT ( M - 1 )
  RETURN
 200  CONTINUE
  EXPINT = EXP ( - T ) / T
  RETURN
!
 900  CONTINUE
  PRINT 999
 999  FORMAT ( // ' NEGALIVE OR ZERO ARGUMENT IN EXPINT ' // )
  STOP
  END
  SUBROUTINE COHEVA ( NFR, XNE, XN1, T, DFR, COHLA )
!
!     Computation of the frequency-dependent coherence coefficient
!     for the Lyman-alpha line of hydrogen.
!
  DIMENSION DFR(NFR), COHLA(NFR)
!
!          Natural broadening
!
  GAMNA = 4.7E8
!
!          Resonance broadening
!      (Lortet & Roueff, 1969, A&A 3, 462)
!
  GAMRE = 4.93E-8 * XN1
!
!          Stark broadening
!     (Yelnik et al. 1981, Ap. J. 248, 705).
!
  FRPE = 8.979E3 * SQRT ( XNE )
  FRCE = 5.209E9 * T
  FRPI = 0.02342 * FRPE
  FRCI = 1.097E-3 * FRCE
  COEFB = 0.27
  COEFC = 9.13E-7 * SQRT ( XNE ) / T
  GEIMP = 1.03E-4 * ( XNE / SQRT ( T ) ) * ( COEFB - &
             LOG ( 4.0*COEFC*COEFC ) )
  GEHOL = 16.76 * XNE / SQRT ( FRCE )
  GIIMP = 3.13E-3 * ( XNE / SQRT ( T ) ) * ( COEFB - &
             LOG ( 3.67E3*COEFC*COEFC ) )
  GIHOL = 16.76 * XNE / SQRT ( FRCI )
  DO 300 J = 1, NFR
! ... (1) electrons
  IF ( DFR(J) .LE. FRPE ) GO TO 210
  IF ( DFR(J) .GE. FRCE ) GO TO 220
  XS =  LOG ( DFR(J) )
  XS1 =  LOG ( FRPE )
  XS2 =  LOG ( FRCE )
  GSEL = GEIMP + ( GEHOL - GEIMP ) * ( XS - XS1 ) / ( XS2 - XS1 )
  GO TO 250
 210  GSEL = GEIMP
  GO TO 250
 220  GSEL = 16.76 * XNE / SQRT ( DFR(J) )
 250  CONTINUE
! ... (2) ions (protons)
  IF ( DFR(J) .LE. FRPI ) GO TO 260
  IF ( DFR(J) .GE. FRCI ) GO TO 270
  XS =  LOG ( DFR(J) )
  XS1 =  LOG ( FRPI )
  XS2 =  LOG ( FRCI )
  GSION = GIIMP + ( GIHOL - GIIMP ) * ( XS - XS1 ) / ( XS2 - XS1 )
  GO TO 280
 260  GSION = GIIMP
  GO TO 280
 270  GSION = 16.76 * XNE / SQRT ( DFR(J) )
 280  CONTINUE
  GCOL = GAMRE + GSEL + GSION
  COHLA(J) = GAMNA / ( GAMNA + GCOL )
 300  CONTINUE
  RETURN
  END
  SUBROUTINE ELCOH1 ( IR, NZ, NTT, NTAR, NTR, NINF, NSUP, T, HNEUT &
    , XNE, DFRCO )
!
!     Collisional broadening in hydrogen lines.
!
  PARAMETER ( PI=3.1415926536, EXPHN=2.65, EXPS=2./3. )
!
  DIMENSION NTR(NTAR), NINF(NTT), NSUP(NTT), T(NZ), HNEUT(NZ) &
    , XNE(NZ), DFRCO(NZ)
  DIMENSION PSR(6)
!
  DATA PSR / 0.0, 4.94E-8, 7.93E-9, 2.75E-9, 1.29E-9, 7.14E-10 /
!
  NT = NTR(IR)
  NI = NINF(NT)
  NS = NSUP(NT)
!
!     Resonance and Van der Waals broadening
!  (Lortet & Roueff, 1969, A&A 3, 462)
!
  IF ( NI .EQ. 1 ) NRES = NS
  IF ( NI .GT. 1 ) NRES = NI
  CVDW = 1.61E-33 * FLOAT ( NS**4 - NI**4 )
  IF ( NRES .LE. 6 ) THEN
  PSIR = PSR(NRES)
  DO 200 IZ = 1, NZ
  VHH = 20596. * SQRT ( T(IZ) )
  PSIW = 17.0 * CVDW**0.4 * VHH**0.6
  PSI = ( PSIR**EXPHN + PSIW**EXPHN ) ** (1.0/EXPHN)
  DFRCO(IZ) = HNEUT(IZ) * PSI / ( 4.0 * PI )
 200  CONTINUE
  ELSE
  DO 300 IZ = 1, NZ
  VHH = 20596. * SQRT ( T(IZ) )
  PSIW = 17.0 * CVDW**0.4 * VHH**0.6
  DFRCO(IZ) = HNEUT(IZ) * PSIW / ( 4.0 * PI )
 300  CONTINUE
  END IF
!
!   Stark broadening (Sutton, 1978, JQSRT 20, 333 )
!
  A1 = 1.0
  IF ( NS-NI .EQ. 1 ) A1 = 0.642
  COEF = 0.255 * A1 * FLOAT(NS*NS-NI*NI)
  DO 400 IZ = 1, NZ
  DFRCO(IZ) = DFRCO(IZ) + COEF * XNE(IZ)**EXPS
 400  CONTINUE
!
  RETURN
  END
  FUNCTION AEMS ( I, J )
!
!          Einstein coefficient for spontaneous emission in
!     the hydrogen atom (L. C. Johnson, 1972)
!          I    : lower level
!          J    : upper level
!
  PARAMETER ( PI = 3.1415926536, HPLA = 6.6262E-27 &
              , RYD = 2.17875E-11 )
!
  XI = FLOAT ( I )
  XJ = FLOAT ( J )
  POMI = 2. * XI * XI
  POMJ = 2. * XJ * XJ
  COEF = 32. / ( 3. * SQRT(3.) * PI )
  X = 1.0 - ( XI / XJ )**2
  XM1 = 1.0 / X
  IF ( I == 1 ) GO TO 120
  IF ( I == 2 ) GO TO 140
  GO TO 160
 120  CONTINUE
  G0 = 1.1330
  G1 = -0.4059
  G2 = 0.07014
  GO TO 200
 140  CONTINUE
  G0 = 1.0785
  G1 = -0.2319
  G2 = 0.02947
  GO TO 200
 160  CONTINUE
  G0 = 0.9935 + ( 0.2328 - 0.1296 / XI ) / XI
  G1 = - ( 0.6282 - ( 0.5598 - 0.5299 / XI ) / XI ) / XI
  G2 = ( 0.3887 - ( 1.181 - 1.470 / XI ) / XI ) / XI / XI
 200  CONTINUE
  FIJ = COEF * XI * ( G0 + ( G1 + G2 * XM1 ) * XM1 ) / ( X * XJ )**3
  GF = POMI * FIJ
  EIJ = RYD * ( 1. / XI**2 - 1. / XJ**2 )
  AMBDA = HPLA * 3.E14 / EIJ
  AEMS = 0.6670E8 * GF / ( POMJ * AMBDA * AMBDA )
!
  RETURN
  END
  FUNCTION CECH ( I, J, TE )
!
!          Excitation coefficient by electron collisions for
!     the hydrogen atom (Johnson, 1972)
!          I    : lower level
!          J    : upper level
!          TE   : temperature
!     Use :
!              Cij = Ne * CECH(i,j,T) * exp(-Eij/kT)
!
  PARAMETER ( PI = 3.1415926536, PIA02 = 8.79737E-17 &
    , BOLT = 1.3806E-16, XMEL = 9.10956E-28, CSE = 8.0*BOLT/PI/XMEL &
    , RYD = 2.17875E-11 )
!
  XI = FLOAT ( I )
  XJ = FLOAT ( J )
  COEF = 32. / ( 3. * SQRT(3.) * PI )
  X = 1.0 - ( XI / XJ )**2
  XM1 = 1.0 / X
  IF ( I == 1 ) GO TO 120
  IF ( I == 2 ) GO TO 140
  GO TO 160
 120  CONTINUE
  G0 = 1.1330
  G1 = -0.4059
  G2 = 0.07014
  GO TO 200
 140  CONTINUE
  G0 = 1.0785
  G1 = -0.2319
  G2 = 0.02947
  GO TO 200
 160  CONTINUE
  G0 = 0.9935 + ( 0.2328 - 0.1296 / XI ) / XI
  G1 = - ( 0.6282 - ( 0.5598 - 0.5299 / XI ) / XI ) / XI
  G2 = ( 0.3887 - ( 1.181 - 1.470 / XI ) / XI ) / XI / XI
 200  CONTINUE
  FIJ = COEF * XI * ( G0 + ( G1 + G2 * XM1 ) * XM1 ) / ( X * XJ )**3
  A = 2.0 * XI * XI * XM1 * FIJ
  IF ( I .EQ. 1 ) THEN
  PBN = -0.603
  RN = 0.45
  ELSE
  YN = 1.0 / XI
  PBN = YN * ( 4.0 + YN * ( -18.63 + YN * ( 36.24 - YN * 28.09 ) ) )
  RN = 1.94 * YN**1.57
  END IF
  B = 4.0 * XI * ( XI / XJ )**3 * XM1 * XM1 * ( 1.0 + XM1 * ( 4./3. &
        + XM1 * PBN ) )
  EIJ = RYD * ( 1.0 / XI**2 - 1.0 / XJ**2 )
  Y = EIJ / ( BOLT * TE )
  R = RN * X
  Z = R + Y
  T1 = A * ( ( 1./Y + 0.5 ) * EXPINT ( 1, Y ) - ( 1./Z + 0.5 ) &
         * EXPINT ( 1, Z ) )
  T2 = ( B - A *  LOG ( 2. * XI * XI * XM1 ) ) * ( EXPINT ( 2, Y ) &
     / Y - EXPINT ( 2, Z ) / Z )
  CECH = SQRT ( CSE * TE ) * 2. * XI * XI * XM1 * PIA02 * Y * Y * &
             ( T1 + T2 )
!
  RETURN
  END
  FUNCTION CICHC ( I, TE )
!
!          Ionization coefficient by electron collisions for
!     the hydrogen atom (Clark, Abdallah & Mann, 1991,
!     Ap. J. 381, 597)
!          I    : lower level
!          TE   : temperature
!     Use :
!              Cic = Ne * CICHC(i,T) * exp(-Ei/kT)
!
  PARAMETER ( BOLT = 1.3806E-16, RYD = 2.17875E-11, C1=1.5369 &
    , C2=0.99656, C3=-0.61916, C4=2.4463, C5=-2.4773, C6=3.2151 &
    , C7=-1.4512, C8=1.7230, C9=-0.47075 )
!
  XI = FLOAT ( I )
  G = ( XI - 1. ) * ( 4. * XI + 1. ) / ( 6. * XI )
  EIR = 1.0 / XI**2
  EIK = RYD * EIR
  Y = EIK / ( BOLT * TE )
  TEV = TE / 11600.
  F = 5.89E-9 * SQRT ( TEV ) * Y / EIR**2
  EY = EXP ( -Y )
  E1Y = EXPINT ( 1, Y )
  E2Y = EXPINT ( 2, Y )
  CICHC = F * ( ( C1 + ( C2 + C3 * G ) / XI ) * E1Y + &
     ( C4 + ( C5 + C6 * G ) / XI ) * ( EY - Y * E1Y ) + &
     ( C7 + ( C8 + C9 * G ) / XI ) * ( EY - 2. * Y * E1Y + Y * E2Y ) )
!
  RETURN
  END
  FUNCTION TEMBRI ( AMBDA )
!
!          Brightness temperature for the solar flux (full disk)
!     at wavelength AMBDA (microns).
!
  PARAMETER ( N=45 )
  DIMENSION WL(N), TB(N)
!
  WL =   (/ 0.0114, 0.0137, 0.0171, 0.0195, 0.0228 &
    ,         0.0279, 0.0359, 0.0419, 0.0504, 0.0592 &
    ,         0.0718, 0.0803, 0.09118 &
    ,       0.0912,   0.12,   0.15,    0.18,  0.20 &
    ,         0.22,   0.24,   0.26,    0.28,  0.30 &
    ,     0.35,   0.40,  0.5,   0.6,   0.7 &
    ,     0.8,    0.9,   1.0,  1.2,  1.4 &
    ,     1.6,    1.8,   2.0,  3.0,  4.0 &
    ,     5.0,         10. &
    ,     20.,    50.,   100.,   200.,   300. /)
  TB =   (/ 23480., 22560., 21160., 20240., 18920. &
    ,         16920., 13500., 11700.,  9600.,  8500. &
    ,          7200.,  6700.,  6500. &
    ,    5000.,  5200.,  4761.,  4884.,  4965. &
    ,    5201.,  4978.,  5116.,  5207.,  5483. &
    ,    5604.,  5694.,  5906.,  5845.,  5850. &
    ,    5792.,  5729.,  5786.,  5880.,  6049. &
    ,    6302.,  6286.,  6072.,  5730.,  5500. &
    ,    5450.,       5050. &
    ,    4740.,  4500.,  4370.,  4400.,  4550. /)
!
  CALL INTERL ( N, WL, TB, AMBDA, T )
  TEMBRI = T
!
  RETURN
  END
  SUBROUTINE SAHARA ( IOP, T, HNH, HNP, HNE )
!
  PARAMETER ( NEL=20, PI=3.141592653589, HP=6.6262E-27 &
    , BOLT=1.3806E-16, EV=1.6021E-12, ELM=0.910956E-27 )
!
  DIMENSION HNT(NEL), F(NEL,4)
!
  COMMON /ELEMTS/ ABON(NEL), HM(NEL), NEI(NEL), PIO(NEL,4) &
    , U(NEL,5), HNION(5,NEL)
!
  C5 = 2. * ( 2. * PI * ELM * BOLT / HP**2 )**1.5
  C6 = EV / BOLT
  NELU = NEL - IOP
  DO 10 I = 1, NELU
  HNT(I) = HNH * 10.**(ABON(I)-12.)
  DO 20 J = 1, 4
  IF ( J .GE. NEI(I) ) GO TO 30
  F1 = - C6 * PIO(I,J) / T
  F2 = C5 * T**1.5 * U(I,J+1) / U(I,J)
  F(I,J) = F2 * EXP(F1)
  GO TO 20
 30   CONTINUE
  F(I,J) = 0.
 20   CONTINUE
 10   CONTINUE
  HMIN = HNP
  IF ( HNP .EQ. 0. ) HMIN = 1.
  HMAX = HNP
  DO 40 I = 1, NELU
  HMAX = HMAX + HNT(I) * ( NEI(I) - 1. )
 40   CONTINUE
  A = 0.
  B = 1.
  X = A
  INDEX = 1
  GO TO 200
 110  CONTINUE
  FA = FX
  X = B
  INDEX = 2
  GO TO 200
 120  CONTINUE
  FB = FX
 140  CONTINUE
  C = 0.5 * ( A + B )
  X = C
  INDEX = 3
  GO TO 200
 130  CONTINUE
  FC = FX
!!!!  IF ( FA*FC ) 160, 300, 150
  IF ( FA*FC < 0.0 ) GO TO 160
  IF ( FA*FC == 0.0 ) GO TO 300
 150  CONTINUE
  A = C
  FA = FC
  GO TO 170
 160  CONTINUE
  B = C
  FB = FC
 170  CONTINUE
!!!!  IF ( ABS ( B - A ) - 1.E-12 ) 300, 140, 140
  IF ( ABS ( B - A ) < 1.E-12 ) GO TO 300
  GO TO 140
 200  CONTINUE
  HNE = HMIN + ( HMAX - HMIN ) * X
  HNPE = HNP
  DO I = 1, NELU
  Z = 3. + 4. * F(I,4) / HNE
  Z =2. + Z * F(I,3) / HNE
  Z = 1. + Z * F(I,2) / HNE
  Z = Z * F(I,1) / HNE
  D = 1. + F(I,4) / HNE
  D = 1. + D * F(I,3) / HNE
  D = 1. + D * F(I,2) / HNE
  D = 1. + D * F(I,1) / HNE
  HNPE = HNPE + HNT(I) * Z / D
  END DO
  FX = ( HNPE - HNE ) / HMAX
!!!!  IF ( INDEX - 2 ) 110, 120, 130
  IF ( INDEX < 2 ) GO TO 110
  IF ( INDEX == 2 ) GO TO 120
  GO TO 130
 300  CONTINUE
  HNE = HNPE
  DO I = 1, NELU
  HNION(1,I) = 1.0
  SOM = 1.0
  DO J = 2, 5
  HNION(J,I) = HNION(J-1,I) * F(I,J-1) / HNE
  SOM = SOM + HNION(J,I)
  END DO
  DO J = 1, 5
  HNION(J,I) = HNT(I) * HNION(J,I) / SOM
  END DO
  END DO
!
  RETURN
  END
  SUBROUTINE RPCDEH ( IRS, IOPMRU, NZ, NN, NTT, NTRD, NFR, IVISU &
    , IOP, ITRD, NINF, NSUP, FRN, AE, TE, VT, HNE &
    , HN, DND, AM, COHE, FR, PHIX, RDMAT )
!
!    Special version of "RPCDEF" for hydrogen
!
 1    FORMAT ( //// )
 2    FORMAT ( ' Renormalization coefficients for line no.', I3 )
 3    FORMAT ( 1X )
 4    FORMAT ( 1X, I3, 1X, 25F5.2 )
 5    FORMAT ( ' Coherence coefficients for Lyman-alpha' )
 6    FORMAT ( 1X, I3, 1X, 20F6.4 )
!
  PARAMETER ( PI=3.141592653589, CL=2.997925E10, BOLT=1.3806E-16 &
    , UMA=1.660E-24 )
!
  DIMENSION ITRD(NTRD), NINF(NTT), NSUP(NTT), FRN(NN), AE(NTRD) &
    , TE(NZ), VT(NZ), HNE(NZ), HN(NZ,NN), DND(NZ) &
    , AM(NZ), COHE(NZ), FR(NFR), PHIX(NFR,NZ), RDMAT(NFR*NFR,NZ)
  DIMENSION VV(NFR), FI(NFR), XNORM(NFR), AMV(NFR), AUX(NFR) &
    , DFRCO(NZ), COHLA(NFR)
!
  IF ( IOP .EQ. 0 ) RETURN
  HMA = 1.0
  FIZERO = 1.0 / SQRT ( PI )
  HM = HMA * UMA
  NT = ITRD(IRS)
  NI = NINF(NT)
  NS = NSUP(NT)
  FR0 = FRN(NS) - FRN(NI)
!.........     Computation of the broadening constants
  GAMA = 0.0
  NIM = NI - 1
  NSM = NS - 1
  IF ( NI > 1 ) THEN
  DO I = 1, NIM
  IT = I + ((NI-1)*(NI-2))/2
  DO K = 1, NTRD
  IF ( ITRD(K) .EQ. IT ) GAMA = GAMA + AE(K)
  END DO
  END DO
  END IF
  DO I = 1, NSM
  IT = I + ((NS-1)*(NS-2))/2
  DO K = 1, NTRD
  IF ( ITRD(K) .EQ. IT ) GAMA = GAMA + AE(K)
  END DO
  END DO
  DFRNA = GAMA / ( 4.0 * PI )
  CALL ELCOH1 ( IRS, NZ, NTT, NTRD, ITRD, NINF, NSUP, TE, HN(1,1) &
    , HNE, DFRCO )
  IF ( IOPMRU .EQ. 1 ) THEN
  NZ1 = NZ / 2 + 1
  NZ2 = NZ1
  ELSE
  NZ1 = 1
  NZ2 = NZ
  END IF
  DO IZ = NZ1, NZ2
  DND(IZ) = (FR0/CL) * SQRT ( VT(IZ)**2 + 2. * BOLT * TE(IZ) / HM )
  ELA = DFRNA + DFRCO(IZ)
  COHE(IZ) = AE(IRS) / ( 4.0 * PI * ELA )
  AM(IZ) = ELA / DND(IZ)
  IF ( IOP .EQ. 1 ) COHE(IZ) = 0.0
  IF ( IOP .EQ. 2 ) COHE(IZ) = 1.0
  END DO
  DO IZ = NZ1, NZ2
  DO IB = 1, NFR
  VV(IB) = FR(IB) / DND(IZ)
  AMV(IB) = AM(IZ)
  END DO
  CALL VOIGTV ( NFR, AMV, VV, AUX )
  DO IB = 1, NFR
  PHIX(IB,IZ) = FIZERO * AUX(IB)
  END DO
  END DO
  IF ( IOPMRU .EQ. 1 ) THEN
  DNDM = DND(NZ1)
  AMN = AM(NZ1)
  COHEM = COHE(NZ1)
  DO IZ = 1, NZ
  DND(IZ) = DNDM
  AM(IZ) = AMN
  COHE(IZ) = COHEM
  END DO
  DO IB = 1, NFR
  PHIXM = PHIX(IB,NZ1)
  DO IZ = 1, NZ
  PHIX(IB,IZ) = PHIXM
  END DO
  END DO
  END IF
!
  IF ( IVISU .EQ. 1 ) WRITE ( 66, 1 )
  IF ( IVISU .EQ. 1 ) WRITE ( 66, 2 ) IRS
      DO IZ = NZ1, NZ2
  DO IB = 1, NFR
  FI(IB) = PHIX(IB,IZ)
  VV(IB) = FR(IB) / DND(IZ)
  END DO
  IF ( IOP .EQ. 4 ) THEN
  CALL COHEVA ( NFR, HNE(IZ), HN(IZ,1), TE(IZ), FR, COHLA )
  CALL MARALA ( NFR, FI, AM(IZ), VV, RDMAT(1,IZ), COHLA, XNORM )
  ELSE
  CALL MAREDI ( NFR, FI, AM(IZ), VV, RDMAT(1,IZ), COHE(IZ), XNORM )
  END IF
!
  IF ( IVISU .EQ. 1 ) THEN
  IF ( IZ .EQ. 51 ) WRITE ( 66, 1 )
  IF ( MOD ( IZ, 10 ) .EQ. 1 ) WRITE ( 66, 3 )
  WRITE ( 66, 4 ) IZ, ( XNORM(J), J = 1, NFR )
  END IF
  IF ( IVISU .EQ. 1 .AND. IOP .EQ. 4 ) THEN
  WRITE ( 66, 5 )
  WRITE ( 66, 6 ) IZ, ( COHLA(J), J = 1, NFR )
  END IF
      END DO
  IF ( IOPMRU .EQ. 1 ) THEN
  DO J = 1, NFR*NFR
  RDM = RDMAT(J,NZ1)
  DO IZ = 1, NZ
  RDMAT(J,IZ) = RDM
  END DO
  END DO
  END IF
!
  RETURN
  END
  SUBROUTINE  CSIETA ( NT, CNORM, NZ, NN, NTT, NTAR, NTAC, NINF &
    , ITP, FRN, TE, HNE, POM, CIJ, CJI, RIK, RKI, HN, CSI0, ETA0 )
!
  PARAMETER ( PI=3.141592653589, HP=6.6262E-27, CL=2.997925E10 &
    , BOLT=1.3806E-16, ELM=0.910956E-27 )
  PARAMETER ( C4=2.0*HP/(CL*CL) )
!
  DIMENSION NINF(NTT), ITP(NTT), FRN(NN), TE(NZ), HNE(NZ) &
    , POM(NN), CIJ(NZ,NTT), CJI(NZ,NTT), RIK(NZ,NTAC), RKI(NZ,NTAC) &
    , HN(NZ,NN), CSI0(NZ), ETA0(NZ)
  DIMENSION PJK(NN)
!
  C5 = 2.0 * (2.0*PI*ELM*BOLT/HP**2)**1.5
  NI = NINF(NT)
  NTP = ITP(NT)
  NTPC = NTP - NTAR
  FR0 = FRN(NN) - FRN(NI)
  DO 100 IZ = 1, NZ
  TZ = TE(IZ)
  CAT = BOLT * TZ
  XXX = EXP(HP*FR0/CAT)
  BBB = C4 * FR0**3 / XXX
  ETLIS = HNE(IZ) * POM(NI) * XXX / ( POM(NN) * C5 * TZ**1.5 )
  PJK(NN) = 0.
  DO 20 J = 1 , NN-1
  IT = ((NN-1) * (NN-2)) / 2 + J
  PJK(J) = CIJ(IZ,IT)
  PKJ = CJI(IZ,IT)
  JTP = ITP(IT)
  IF ( JTP .EQ. 0 ) GO TO 50
  ITAC = JTP - NTAR
  PJK(J) = PJK(J) + RIK(IZ,ITAC)
  PKJ = PKJ + RKI(IZ,ITAC)
 50   CONTINUE
  PJK(NN) = PJK(NN) - PKJ
 20   CONTINUE
  XIS = - 1. / PJK(NN)
  YIS = 0.
  DO 60 J = 1, NN-1
  IF ( J .EQ. NI ) GO TO 60
  XX = PJK(J) * HN(IZ,J) / HN(IZ,NI)
  YIS = YIS - XX
 60   CONTINUE
  YIS = YIS / PJK(NN)
  CIS = CIJ(IZ,NT)
  CSI0(IZ) = 4.0 * PI * XIS * ETLIS * CNORM * BBB
  ETA0(IZ) = BBB * ETLIS * ( XIS * CIS + YIS )
 100  CONTINUE
  RETURN
  END
  SUBROUTINE TEMPRH ( ITAC, NZ, NN, NTT, NTAC, NFRC, NTC, NINF, FRN &
    , XFRC, RIK, TE, TR )
!
!          TEMPRH determines the radiation temperatures
!     corresponding to given photoionization rates in the
!     bound-free transition of hydrogen no. "ITAC".
!
 1    FORMAT ( /// 20X, "Error in TEMPRH" / 15X, &
     "Depth no.  ", I3 / 15X, "Photoionization rate   ", &
     G12.5 / 15X, "Number of iterations :  ", I4 /// )
!
  PARAMETER ( PI=3.141592653589, HP=6.6262E-27 )
!
  INTEGER, DIMENSION(NTAC) :: NTC
  INTEGER, DIMENSION(NTT) :: NINF
  REAL, DIMENSION(NZ) :: TE
  REAL, DIMENSION(NN) :: FRN
  REAL, DIMENSION(NFRC) :: XFRC, FR, WF
  REAL, DIMENSION(NZ,NTAC) :: RIK, TR
!
  NT = NTC(ITAC)
  NI = NINF(NT)
  FR0 = FRN(NN) - FRN(NI)
  ALP0 = SEPION ( FR0, NI )
  DO J = 1, NFRC
  FR(J) = FR0 * XFRC(J)
  END DO
  CALL TRAPEZ ( NFRC, FR, WF )
  CNORM = 0.0
  DO J = 1, NFRC
  WF(J) = WF(J) * SEPION ( FR(J), NI ) / ( HP * FR(J) )
  CNORM = CNORM + WF(J)
  END DO
  DO J = 1, NFRC
  WF(J) = WF(J) / CNORM
  END DO
      DO IZ = 1, NZ
  RIS = RIK(IZ,ITAC)
  IF ( RIS .LE. 0.0 ) GO TO 900
  GIB = RIS / ( 4.0 * PI * CNORM )
  NIT = 0
  TMIN = 0.
  TMAX = TE(IZ)
 180  CONTINUE
  GIMAX = GIBMOY ( TMAX, NFRC, FR, WF )
  IF ( GIMAX .GT. GIB ) GO TO 200
  TMAX = TMAX + TMAX
  GO TO 180
 200  CONTINUE
  NIT = NIT + 1
  IF ( NIT .GT. 100 ) GO TO 900
  TRAY = 0.5 * ( TMIN + TMAX )
  FTRAY = GIBMOY ( TRAY, NFRC, FR, WF )
  PREC = ABS ( ( FTRAY - GIB ) / ( FTRAY + GIB ) )
  IF ( PREC .LT. 1.E-6 ) GO TO 260
  IF ( FTRAY > GIB ) GO TO 240
  TMIN = TRAY
  GO TO 200
 240  CONTINUE
  TMAX = TRAY
  GO TO 200
 260  CONTINUE
  TR(IZ,ITAC) = TRAY
      END DO !  (IZ = 1, NZ)
  RETURN
!
 900  CONTINUE
  PRINT 1, IZ, RIS, NIT
  STOP
!
  END
  FUNCTION GIBMOY ( TR, NFRC, FR, WF )
!
   PARAMETER ( HP=6.6262E-27, CL=2.997925E10, BOLT=1.3806E-16 )
   BENU(F,T) = 2.0*HP*F*(F/CL)*(F/CL) / ( EXP(HP*F/BOLT/T) - 1.0 )
!
  REAL, DIMENSION(NFRC) :: FR, WF
!
  GIBMOY = 0.0
  DO J = 1, NFRC
  GIBMOY = GIBMOY + WF(J) * BENU ( FR(J), TR )
  END DO
!
  RETURN
  END
  SUBROUTINE INITR1 ( NZ, NN, NTT, NTAC, NFRC, NTC, NINF &
    , FRN, XFRC, FADIC, RIK, TE, TR )
!
!     Initialization of internal radiation temperatures (TR)
!     for hydrogen bound-free transitions from the incident
!     radiation temperatures and dilution factors (FADIC).
!
   PARAMETER ( PI=3.141592653589 )
   PARAMETER ( HP=6.6262E-27, CL=2.997925E10, BOLT=1.3806E-16 )
   BENU(F,T) = 2.0*HP*F*(F/CL)*(F/CL) / ( EXP(HP*F/BOLT/T) - 1.0 )
!
  INTEGER, DIMENSION(NTAC) :: NTC
  INTEGER, DIMENSION(NTT) :: NINF
  REAL, DIMENSION(NZ) :: TE
  REAL, DIMENSION(NN) :: FRN
  REAL, DIMENSION(NTAC) :: FADIC
  REAL, DIMENSION(NFRC) :: XFRC, FR, WF
  REAL, DIMENSION(NZ,NTAC) :: RIK, TR
!
      DO ITAC = 1, NTAC
  NT = NTC(ITAC)
  NI = NINF(NT)
  FR0 = FRN(NN) - FRN(NI)
  DO J = 1, NFRC
  FR(J) = FR0 * XFRC(J)
  END DO
  CALL TRAPEZ ( NFRC, FR, WF )
  DO J = 1, NFRC
  SEP = SEPION ( FR(J), NI )
  WF(J) = WF(J) * SEP / ( HP * FR(J) )
  END DO
  XX = 0.0
  DO J = 1, NFRC
  AMBDA = 1.E4 * CL / FR(J)
  TB = TEMBRI ( AMBDA )
  XX = XX + WF(J) * BENU ( FR(J), TB )
  END DO
  RIK0 = 4.0 * PI * XX * FADIC(ITAC)
  DO IZ = 1, NZ
  RIK(IZ,ITAC) = RIK0
  END DO
  CALL TEMPRH ( ITAC, NZ, NN, NTT, NTAC, NFRC, NTC, NINF, FRN &
    , XFRC, RIK, TE, TR )
      END DO !  (ITAC = 1, NTAC)
!
  RETURN
  END
  SUBROUTINE NOVTR2 ( ITG, IVTR, RXTR, NZ, NN, NTT, NTAC, NFRC &
    , ICTC, NTC, NINF, FRN, XFRC, RIKP, TE, TR, DTRMX )
!
!          Update of radiation temperatures in the bound-free
!     transitions of hydrogen.
!
 1    FORMAT ( / ' Iteration no. ', I3 / &
     ' Update of radiation temperatures for the ' &
    , I3, 'th bound-free transition' )
 2    FORMAT ( // 20X, 'Initial values' / )
 3    FORMAT ( // 20X, 'Solution of the radiative transfer equation' / )
 4    FORMAT ( // 20X, 'Differences' / )
 5    FORMAT ( 10(2X,G11.4) )
 6    FORMAT ( / ' Iteration ', I3, ' , Continuum ', I3, ' : Radiation' &
    , ' temperature differences' )
 7    FORMAT ( 1X, 10F7.0 )
!
  DIMENSION ICTC(NTAC), NTC(NTAC), NINF(NTT), FRN(NN), XFRC(NFRC) &
    , RIKP(NZ,NTAC), TE(NZ), TR(NZ,NTAC)
  DIMENSION TRZERO(NZ)
!
  DTRMX = 0.0
  DO 300 IT = 1, NTAC
  IF ( ICTC(IT) .GE. 3 ) GO TO 300
  IF ( IVTR .EQ. 1 ) WRITE ( 6, 6 ) ITG, IT
  IF ( IVTR .EQ. 2 ) WRITE ( 6, 1 ) ITG, IT
  DO 150 I = 1, NZ
  TRZERO(I) = TR(I,IT)
 150  CONTINUE
  IF ( IVTR .EQ. 2 ) WRITE ( 6, 2 )
  IF ( IVTR .EQ. 2 ) WRITE ( 6, 5 ) ( TRZERO(I), I = 1, NZ )
  CALL TEMPRH ( IT, NZ, NN, NTT, NTAC, NFRC, NTC, NINF, FRN &
    , XFRC, RIKP, TE, TR )
  IF ( IVTR .EQ. 2 ) WRITE ( 6, 3 )
  IF ( IVTR .EQ. 2 ) WRITE ( 6, 5 ) ( TR(I,IT), I = 1, NZ )
  IF ( IVTR .EQ. 2 ) WRITE ( 6, 4 )
  IF (IVTR.EQ.1) WRITE ( 6, 7 ) ( TR(I,IT)-TRZERO(I), I = 1, NZ )
  IF (IVTR.EQ.2) WRITE ( 6, 5 ) ( TR(I,IT)-TRZERO(I), I = 1, NZ )
  DO 200 I = 1, NZ
  DTRMX = AMAX1 ( DTRMX, ABS ( TR(I,IT) - TRZERO(I) ) )
 200  CONTINUE
  DO 250 I = 1, NZ
  TR(I,IT) = RXTR * TRZERO(I) + ( 1. - RXTR ) * TR(I,IT)
 250  CONTINUE
 300  CONTINUE
  RETURN
  END
  SUBROUTINE INIRIKH ( ITAC, IOP, NZ, NN, NTT, NTAC, NFRC, NTC &
    , ITP, NINF, FRN, XFRC, TE, HNE, POM, TR, RKI, RIK, RIKP )
!
!          Initialization of photoionization probabilities
!     for hydrogen, from radiation temperatures.
!
   PARAMETER ( PI=3.141592653589, ELM=0.910956E-27 )
   PARAMETER ( HP=6.6262E-27, CL=2.997925E10, BOLT=1.3806E-16 )
   PARAMETER ( C4=2.0*HP/(CL*CL) )
   BENU(F,T) = 2.0*HP*F*(F/CL)*(F/CL) / ( EXP(HP*F/BOLT/T) - 1.0 )
!
  INTEGER, DIMENSION(NTAC) :: NTC
  INTEGER, DIMENSION(NTT) :: ITP, NINF
  REAL, DIMENSION(NZ) :: TE, HNE
  REAL, DIMENSION(NN) :: FRN, POM
  REAL, DIMENSION(NFRC) :: XFRC, FR, WF
  REAL, DIMENSION(NZ,NTAC) :: TR, RIK, RKI, RIKP
  REAL, DIMENSION(NFRC,NZ) :: GINU
!
  C5 = 2.0 * (2.0*PI*ELM*BOLT/HP**2)**1.5
  NT = NTC(ITAC)
  NTP = ITP(NT)
  NI = NINF(NT)
  FR0 = FRN(NN) - FRN(NI)
  DO J = 1, NFRC
  FR(J) = FR0 * XFRC(J)
  END DO
  CALL TRAPEZ ( NFRC, FR, WF )
  DO J = 1, NFRC
  WF(J) = WF(J) * SEPION ( FR(J), NI ) / ( HP * FR(J) )
  END DO
      DO I = 1, NZ
  TZ = TE(I)
  DE = HNE(I)
  CAT = BOLT * TZ
  XXX = EXP ( HP * FR0 / CAT )
  ETLIS = DE * POM(NI) * XXX / ( POM(NN) * C5 * TZ**1.5 )
  XX = 0.0
  DO J = 1, NFRC
  GINU(J,I) = BENU ( FR(J), TR(I,ITAC) )
  XX = XX + WF(J) * EXP ( - HP * FR(J) / CAT ) * ( C4 * FR(J)**3 + GINU(J,I) )
  END DO
  RKI(I,ITAC) = 4.0 * PI * ETLIS * XX
  XX = 0.0
  DO J = 1, NFRC
  XX = XX + WF(J) * GINU(J,I)
  END DO
  RIS = 4.0 * PI * XX
  IF ( IOP .NE. 2 ) RIK(I,ITAC) = RIS
  IF ( IOP .NE. 1 ) RIKP(I,ITAC) = RIS
      END DO !  (I = 1, NZ)
!
  RETURN
  END
  SUBROUTINE RAOPMI ( ITAR, NZ, NN, NTT, NTAR, NTR, NINF, NSUP, FRN &
    , GIOM, POM, HN, BRP )
!
!   Hydrogen : optically thin lines : simplified treatment when
!     ICTR(ITAR) = 5
!
  PARAMETER ( HP=6.6262E-27, CL=2.997925E10 )
  PARAMETER ( C4=2.0*HP/(CL*CL) )
!
  DIMENSION NTR(NTAR), NINF(NTT), NSUP(NTT), FRN(NN), GIOM(NTAR) &
    , POM(NN), HN(NZ,NN), BRP(NZ,NTAR)
!
  NT = NTR(ITAR)
  NI = NINF(NT)
  NS = NSUP(NT)
  FR0 = FRN(NS) - FRN(NI)
  TRUC = GIOM(ITAR) / ( C4 * FR0**3 )
  RAPSI = POM(NS) / POM(NI)
  DO 200 IZ = 1, NZ
  BRP(IZ,ITAR) = 1.0 + TRUC * ( 1.0 - RAPSI * HN(IZ,NI) / &
                   HN(IZ,NS) )
 200  CONTINUE
!
  RETURN
  END
  SUBROUTINE COMPARH ( NZ, NTAR, BRN, BRP, EMIN1, EMAX1, EMIN2 &
    , EMAX2, EMIN3, EMAX3 )
!
  DIMENSION BRN(NZ,NTAR), BRP(NZ,NTAR)
!
  DO 200 IT = 1, NTAR
  EMIN = BRP(1,IT) - BRN(1,IT)
  EMAX = EMIN
  DO 100 IZ = 1, NZ
  ER = BRP(IZ,IT) - BRN(IZ,IT)
  IF ( ER .LT. EMIN ) EMIN = ER
  IF ( ER .GT. EMAX ) EMAX = ER
 100  CONTINUE
  IF ( IT .EQ. 1 ) EMIN1 = EMIN
  IF ( IT .EQ. 1 ) EMAX1 = EMAX
  IF ( IT .EQ. 2 ) EMIN2 = EMIN
  IF ( IT .EQ. 2 ) EMAX2 = EMAX
  IF ( IT .EQ. 3 ) EMIN3 = EMIN
  IF ( IT .EQ. 3 ) EMAX3 = EMAX
 200  CONTINUE
!
  RETURN
  END
  SUBROUTINE COMPACH ( NZ, NTAC, RIK, RIKP, EMIN, EMAX )
!
  DIMENSION RIK(NZ,NTAC), RIKP(NZ,NTAC)
!
  ITAC = 1
  AAA = RIKP(1,ITAC)
  BBB = RIK(1,ITAC)
  ER = ( AAA - BBB ) / ( AAA + BBB )
  EMIN = ER
  EMAX = ER
  DO 300 IZ = 2, NZ
  AAA = RIKP(IZ,ITAC)
  BBB = RIK(IZ,ITAC)
  ER = ( AAA - BBB ) / ( AAA + BBB )
  IF ( ER .LT. EMIN ) EMIN = ER
  IF ( ER .GT. EMAX ) EMAX = ER
 300  CONTINUE
!
  RETURN
  END
  SUBROUTINE NOVRIK ( NZ, NTAC, ICTC, RXIK, RIK, RIKP )
!
  DIMENSION ICTC(NTAC), RXIK(NTAC), RIK(NZ,NTAC), RIKP(NZ,NTAC)
!
  DO 200 ITAC = 1, NTAC
  IF ( ICTC(ITAC) .GT. 2 ) GO TO 200
  R1 = RXIK ( ITAC )
  R2 = 1.0 - R1
  DO 100 I = 1, NZ
  RIK1 = RIK(I,ITAC)
  RIK2 = RIKP(I,ITAC)
  IF ( RIK2 .LT. 0. ) RIK2 = 0.
  RIK(I,ITAC) = R1 * RIK1 + R2 * RIK2
 100  CONTINUE
 200  CONTINUE
  RETURN
  END
  SUBROUTINE HPROBA ( NZ, NN, NTT, NTAR, NTAC, ITP, NINF, NSUP &
    , CIJ, CJI, AE, HNP, BRN, BRP, RIK, RIKP, RKI, TR )
!
  DIMENSION ITP(NTT), NINF(NTT), NSUP(NTT), CIJ(NZ,NTT), CJI(NZ,NTT) &
    , AE(NTAR), HNP(NZ,NN), BRN(NZ,NTAR), BRP(NZ,NTAR), RIK(NZ,NTAC) &
    , RIKP(NZ,NTAC), RKI(NZ,NTAC), TR(NZ,NTAC)
!
 1    FORMAT ( //// )
 2    FORMAT ( ' TRANSITION PROBABILITIES BETWEEN LEVELS ', I2, &
     ' AND ', I2 / 1X, 49('-') / )
 3    FORMAT ( 1X )
 4    FORMAT ( ' NO.', 5X, 'C/IS', 8X, 'C/SI',  8X, 'BRN1', 8X, &
      'BRN2', 8X, 'P*IS', 8X, 'P*SI', 8X, 'R/IS', 8X, 'R/SI', 8X, &
      'P/IS', 8X, 'P/SI' )
 5    FORMAT ( ' NO.', 5X, 'C/IS', 8X, 'C/SI', 8X, 'T/R ', 8X, &
     'R1IS', 8X, 'R2IS', 8X, 'R/SI', 8X, 'P/IS', 8X, 'P/SI', 7X, &
     'NI*PIS' )
 6    FORMAT ( 1X, I3, 10(2X,1PG10.3) )
!
  DO 500 IT = 1, NTT
  IF ( ITP(IT) .EQ. 0 ) GO TO 500
  NI = NINF(IT)
  NS = NSUP(IT)
  WRITE ( 66, 1 )
  WRITE ( 66, 2 ) NI, NS
  IF ( NS .EQ. NN ) GO TO 300
!
!        Print transition probabilities for a line
!
  ITAR = ITP(IT)
  DO 200 IZ = 1, NZ
  IF ( IZ .EQ. 51 ) WRITE ( 66, 1 )
  IF ( MOD ( IZ, 50 ) .EQ. 1 ) WRITE ( 66, 4 )
  IF ( MOD ( IZ, 10 ) .EQ. 1 ) WRITE ( 66, 3 )
  CIS = CIJ(IZ,IT)
  CSI = CJI(IZ,IT)
  PIS = CIS
  PSI = CSI + AE(ITAR) * BRP(IZ,ITAR)
  RIS = AE(ITAR) * ( 1.0 - BRP(IZ,ITAR) ) * HNP(IZ,NS) / HNP(IZ,NI)
  RSI = AE(ITAR)
  PSIS = CIS + RIS
  PSSI = CSI + RSI
  WRITE ( 66, 6 ) IZ, CIS, CSI, BRN(IZ,ITAR), BRP(IZ,ITAR), PIS, PSI &
    , RIS, RSI, PSIS, PSSI
 200  CONTINUE
  GO TO 500
 300  CONTINUE
!
!        Print transition probabilities for a continuum
!
  ITAC = ITP(IT) - NTAR
  DO 400 IZ = 1, NZ
  IF ( IZ .EQ. 51 ) WRITE ( 66, 1 )
  IF ( MOD ( IZ, 50 ) .EQ. 1 ) WRITE ( 66, 5 )
  IF ( MOD ( IZ, 10 ) .EQ. 1 ) WRITE ( 66, 3 )
  CIS = CIJ(IZ,IT)
  CSI = CJI(IZ,IT)
  PSIS = CIS + RIKP(IZ,ITAC)
  PSSI = CSI + RKI(IZ,ITAC)
  TRATO = HNP(IZ,NI) * PSIS
  WRITE ( 66, 6 ) IZ, CIS, CSI, TR(IZ,ITAC), RIK(IZ,ITAC) &
    , RIKP(IZ,ITAC), RKI(IZ,ITAC), PSIS, PSSI, TRATO
 400  CONTINUE
 500  CONTINUE
  RETURN
  END
  SUBROUTINE PROFCO ( ITAC, NN, NTT, NTAC, NMUV, NFRC &
    , NTC, NINF, FRN, PMU, XFRC, HIEMC )
!
  PARAMETER ( CL=2.997925E10 )
!
  DIMENSION NTC(NTAC), NINF(NTT), FRN(NN), PMU(NMUV), XFRC(NFRC) &
    , HIEMC(NFRC,NMUV,NTAC)
  DIMENSION FRC(NFRC), AMBDA(NFRC)
!
  NT = NTC(ITAC)
  NI = NINF(NT)
  FR0 = FRN(NN) - FRN(NI)
  WRITE ( 21, 111 ) NI, FR0
 111  FORMAT ( 1X, I10, 2X, E16.7 )
  WRITE ( 21, 133 ) ( PMU(K), K = 1, NMUV )
 133  FORMAT ( 5E15.6 )
  DO 200 J = 1, NFRC
  FRC(J) = FR0 * XFRC(J)
  AMBDA(J) = 1.E8 * CL / FRC(J)
 200  CONTINUE
  WRITE ( 21, 133 ) ( AMBDA(J), J = 1, NFRC )
  DO 300 K = 1, NMUV
  WRITE ( 21, 133 ) ( HIEMC(J,K,ITAC)*FRC(J)/AMBDA(J), J = 1, NFRC )
 300  CONTINUE
!
  RETURN
  END
  SUBROUTINE HCONTI ( IT, IVERT, NZ, NN, NTT, NTAR, NTAC, NFRC &
    , NMU, NMUV, IOPECO, IOPFEV, ITP, NTC, NINF, FRN &
    , FRC, POM, TE, HNH, HNE, Z, CIJ, CJI &
    , RIK, RKI, HN, CSI0, ETA0, TO, L1, L2 &
    , FIIC, FISC, FKTC, FLTC, GIBAR, STC, RIKP, PMU, HIEMC )
!
!          HCONTI solves non-LTE radiative transfer equations for
!     bound-free transitions of the hydrogen atom, in order to
!     compute intensities and transition probabilities.
!          This version corresponds to a finite plane-parallel slab.
!     Absorbing matter other than hydrogen are taken into account.
!     The transfer equation itself is solved in the associated
!     subroutine "TFCFEV".
!
  PARAMETER ( PI=3.141592653589, HP=6.6262E-27, CL=2.997925E10 &
    , BOLT=1.3806E-16, ELM=0.910956E-27 )
  PARAMETER ( TOMIN=1.E-3, CRIT=1.E-3, NARA=10, EOLIM=0.05 )
!
  DIMENSION IOPECO(NTAC)
  DIMENSION ITP(NTT), NTC(NTAC), NINF(NTT), FRN(NN), FRC(NFRC,NTAC) &
    , POM(NN), TE(NZ), HNH(NZ), HNE(NZ), Z(NZ) &
    , CIJ(NZ,NTT), CJI(NZ,NTT) &
    , RIK(NZ,NTAC), RKI(NZ,NTAC), HN(NZ,NN), CSI0(NZ), ETA0(NZ) &
    , TO(NZ), FIIC(NFRC,NTAC), FISC(NFRC,NTAC), FKTC(NFRC,NZ,NTAC) &
    , FLTC(NFRC,NZ,NTAC), GIBAR(NZ), STC(NFRC,NZ,NTAC), RIKP(NZ,NTAC) &
    , PMU(NMUV), HIEMC(NFRC,NMUV,NTAC)
!
  DIMENSION ARA(NZ,NARA), FR(NFRC), WF(NFRC), PHI(NFRC) &
    , SAE(NZ,NFRC), CAE(NZ,NFRC), RAE(NZ,NFRC), BIDON(NZ) &
    , AUX(NFRC,NZ), TAUNU(NFRC,NZ), TOZ(2*NZ), SZ(2*NZ), DTOZ(NZ)
!
  C5 = 2.0 * (2.0*PI*ELM*BOLT/HP**2)**1.5
  NT = NTC(IT)
  NI = NINF(NT)
  FR0 = FRN(NN) - FRN(NI)
  ALP0 = SEPION ( FR0, NI )
  DO J = 1, NFRC
  FR(J) = FRC(J,IT)
  PHI(J) = SEPION ( FR(J), NI ) / ALP0
  END DO
  CALL TRAPEZ ( NFRC, FR, WF )
  CNORM = 0.0
  DO J = 1, NFRC
  WF(J) = WF(J) * SEPION ( FR(J), NI ) / ( HP * FR(J) )
  CNORM = CNORM + WF(J)
  END DO
  DO J = 1, NFRC
  WF(J) = WF(J) / CNORM
  END DO
!  DO 180 I = 1, NZ
!  ETLIS = HNE(I) * POM(NI) * EXP ( HP * FR0 / ( BOLT * TE(I) ) ) / &
!     ( POM(NN) * C5 * TE(I)**1.5 )
!  XX = 0.0
!  DO 160 J = 1, NFRC
!  XX = XX + WF(J) * BWIEN ( FR(J), TE(I) )
! 160  CONTINUE
!  RKI(I,IT) = 4.0 * PI * ETLIS * CNORM * XX
! 180  CONTINUE
  CALL CSIETA ( NT, CNORM, NZ, NN, NTT, NTAR, NTAC, NINF &
    , ITP, FRN, TE, HNE, POM, CIJ, CJI, RIK, RKI, HN, CSI0, ETA0 )
  TO(1) = 0.
  CA = HN(1,NI) * ALP0
  L1 = 1
  DO IZ = 2, NZ
  CAM = CA
  CA = HN(IZ,NI) * ALP0
  DZ = Z(IZ) - Z(IZ-1)
  TO(IZ) = TO(IZ-1) + 0.5 * ( CAM + CA ) * DZ
  IF ( TO(IZ) .LE. TOMIN ) L1 = IZ
  END DO
  L2 = NZ
  IF ( IVERT .NE. 1 ) THEN
  DO I = 2, NZ
  IZ = NZ - I + 1
  IF ( TO(NZ)-TO(IZ) .LT. TOMIN ) L2 = IZ
  END DO
  END IF
!
  DO J = 1, NFRC
  CALL PROFSC ( 0, FR(J), NZ, NN, TE, Z, HNH, HNE, HN, NARA, ARA &
    , BIDON, SAE(1,J), CAE(1,J), RAE(1,J) )
  DO I = 1, NZ
  RAE(I,J) = RAE(I,J) / ( ALP0 * HN(I,NI) )
  END DO
  END DO
  DO J = 1, NFRC
  TAUNU(J,1) = 0.0
  END DO
  DO IZ = 2, NZ
  DO J = 1, NFRC
  TAUNU(J,IZ) = TAUNU(J,IZ-1) + ( TO(IZ) - TO(IZ-1) ) * &
                ( PHI(J) + 0.5 * ( RAE(IZ,J) + RAE(IZ-1,J) ) )
  END DO
  END DO
!
  IF ( TO(NZ) .GE. EOLIM ) THEN
 300  CONTINUE
  CALL TFCFEV ( NZ, NFRC, L1, L2, IVERT, FRC(1,IT), PHI, TAUNU &
    , RAE, CAE, SAE, CSI0, ETA0, FIIC(1,IT), FISC(1,IT), WF, TE &
    , FKTC(1,1,IT), FLTC(1,1,IT), GIBAR, STC(1,1,IT) )
  IF ( IOPFEV .EQ. 0 ) GO TO 380
  DO IZ = 1, NZ
  DO J = 1, NFRC
  AUX(J,IZ) = FKTC(J,IZ,IT)
  END DO
  END DO
  CALL NOVFEV ( NZ, NFRC, NMU, L1, L2, IVERT, TAUNU, FIIC(1,IT) &
    , FISC(1,IT), STC(1,1,IT), FKTC(1,1,IT), FLTC(1,1,IT) )
  EMAX = 0.0
  DO IZ = 1, NZ
  DO J = 1, NFRC
  EMAX = AMAX1 ( EMAX, ABS(AUX(J,IZ)-FKTC(J,IZ,IT)) )
  END DO
  END DO
  IF ( IOPFEV .GE. 2 ) PRINT 341, IT, EMAX
 341  FORMAT ( 10X, 'C.F.E.', 10X, 'Continu no.', I4, 10X, 'Emax =' &
    ,        F10.5 )
  IF ( EMAX .GT. CRIT ) GO TO 300
 380  CONTINUE
  DO I = 1, NZ
  RIKP(I,IT) = 4.0 * PI * CNORM * GIBAR(I)
  END DO
!
!       Optically thin case
!
  ELSE
  CALL TFCOM ( NZ, NFRC, IVERT, FRC(1,IT), PHI, RAE, CAE, SAE, CSI0, ETA0 &
    , FIIC(1,IT), FISC(1,IT), WF, TE, GIBAR, STC(1,1,IT) )
  DO I = 1, NZ
  GIBAR(I) = RIK(I,IT) / ( 4.0 * PI * CNORM )
  RIKP(I,IT) = RIK(I,IT)
  END DO
  END IF
!
!       Computation of emergent intensities
!
  IF ( IOPECO(IT) .EQ. 0 ) RETURN
      DO J = 1, NFRC
  NZCC = NZ
  DO IZ = 1, NZ
  TOZ(IZ) = TAUNU(J,IZ)
  SZ(IZ) = STC(J,IZ,IT)
  END DO
  HIL = FIIC(J,IT)
  IF ( IVERT .EQ. 1 ) THEN
  NZCC = 2 * NZ - 1
  DO IZ = 1, NZ-1
  DTOZ(IZ) = TOZ(IZ+1) - TOZ(IZ)
  END DO
  DO IZ = NZ+1, NZCC
  TOZ(IZ) = TOZ(IZ-1) + DTOZ(2*NZ-IZ)
  SZ(IZ) = SZ(2*NZ-IZ)
  END DO
  HIL = 0.0
  END IF
  DO K = 1, NMUV
  CALL TRALA ( NZCC, TOZ, SZ, HIL, PMU(K), HIEMC(J,K,IT) )
  END DO
      END DO !  (J = 1, NFRC)
!
  RETURN
  END
  SUBROUTINE INIFEVH ( NZ, NTAR, NTAC, NFR, NFRC, FEVK, FEVL &
    , FKTC, FLTC )
!
!     Initialization of Eddington factors for permitted transitions
! (lines and continua).
!
  PARAMETER ( COEFK=1./3., COEFL=1./2. )
!
  DIMENSION FEVK(NFR,NZ,NTAR), FEVL(NFR,NZ,NTAR) &
    , FKTC(NFRC,NZ,NTAC), FLTC(NFRC,NZ,NTAC)
!
  DO IT = 1, NTAR
  DO J = 1, NFR
  DO I = 1, NZ
  FEVK(J,I,IT) = COEFK
  FEVL(J,I,IT) = COEFL
  END DO
  END DO
  END DO
!
  DO IT = 1, NTAC
  DO J = 1, NFRC
  DO I = 1, NZ
  FKTC(J,I,IT) = COEFK
  FLTC(J,I,IT) = COEFL
  END DO
  END DO
  END DO
!
  RETURN
  END
  SUBROUTINE INTALT ( ALTI, NTAR, NTAC, NCMX, CPOL, FADIR, FADIC )
!
!	Computation of dilution factors, taking into account the
!	limb darkening and the altitude of the prominence.
!	(no limb darkening for Lyman lines).
!
  IMPLICIT NONE
  REAL ALTI
  INTEGER NTAR, NTAC, NCMX, I
  REAL K, RS, K2, G1, G2, G3, G4, GINU0, GINU1, GINU2, GINU3, GINU4 &
    , GINU5
  REAL CPOL(NCMX,NTAR), FADIR(NTAR), FADIC(NTAC)
!
  PARAMETER ( RS = 6.96E10 )
!
  K = RS / ( RS + ALTI*1.E5 )
  K2 = K * K
  G1 = 1. - K2
  G2 = SQRT(G1)
  G3 = LOG( (1.+K)/G2 )
  G4 = 1. - G1 * G3 / K
  DO 100 I = 1, NTAR
  IF ( ALL ( CPOL(:,I) == 0.0 ) ) THEN
  FADIR(I) = 0.5 * ( 1. - G2 )
  ELSE
  GINU0 = CPOL(1,I) * 0.5 * ( 1. - G2 )
  GINU1 = CPOL(2,I) * 0.25 * G4
  GINU2 = CPOL(3,I) * ( 1. - 2 * G1 * ( 1. - G2 ) / K2 ) / 6.
  GINU3 = CPOL(4,I) * 0.125 * (1. - 1.5 * G1 * G4 / K2 )
  GINU4 = CPOL(5,I) * 0.1 * ( 1. - 4. * G1 * (1. - 2. * G1 * ( 1. - &
     G2 ) / K2 ) / ( 3. * K2 ) )
  GINU5 = CPOL(6,I) * ( 1. - 1.25 * G1 * ( 1.- 1.5 * G1 * G4 / K2 )/ &
     K2 ) / 12.
  FADIR(I) = GINU0 + GINU1 + GINU2 + GINU3 + GINU4 + GINU5
  END IF
 100  CONTINUE
!
  DO 200 I = 1, NTAC
  FADIC(I) = 0.5 * ( 1. - G2 )
 200  CONTINUE
!
  RETURN
  END
  SUBROUTINE SOLINH ( NN, NTT, NTAR, NFIMX, NCMX, NINF, NSUP, FRN &
    , NTR, ICTR, NFINT, FRFI, FINT, CPOL )
!
!        Definition of intensities emitted by the solar disk in
!   hydrogen lines, in order to provide boundary conditions for
!   solving radiative transfer equations.
!
   PARAMETER ( HP=6.6262E-27, CL=2.997925E10, BOLT=1.3806E-16 )
   BENU(F,T) = 2.0*HP*F*(F/CL)*(F/CL) / ( EXP(HP*F/BOLT/T) - 1.0 )
!
  DIMENSION NINF(NTT), NSUP(NTT), FRN(NN), NTR(NTAR), ICTR(NTAR)
  DIMENSION NFINT(NTAR), FRFI(NFIMX,NTAR), FINT(NFIMX,NTAR) &
    , CPOL(NCMX,NTAR)
!
!          Lines of order lower or equal to 10 :
!     Intensities are resd on the external file "intinc.dat".
!
  CPOL = 0.0
  OPEN ( UNIT=4, FILE='intinc.dat', STATUS='OLD' )
  DO 300 K = 1, 10
  READ ( 4, * ) IT
  READ ( 4, * ) NFINT(IT), COEF
  READ ( 4, * ) ( CPOL(I,IT), I = 1, NCMX )
  DO 220 I = 1, NFINT(IT)
  READ ( 4, * ) FRFI(I,IT), FINT(I,IT)
 220  CONTINUE
  FR0 = FRN(NSUP(IT)) - FRN(NINF(IT))
  CCLF = 1.E-8 * FR0 * FR0 / CL
  DO 240 I = 1, NFINT(IT)
  FRFI(I,IT) = CCLF * FRFI(I,IT)
  FINT(I,IT) = COEF * FINT(I,IT)
 240  CONTINUE
 300  CONTINUE
  CLOSE ( UNIT=4 )
!
!          Lines of order higher than 10 : the brightness
!     temperature table (function TEMBRI) is used.
!
  IF ( NTAR .LE. 10 ) RETURN
  DO 600 IT = 11, NTAR
  IF ( ICTR(IT) .EQ. 5 ) GO TO 600
  NFINT(IT) = 2
  FRFI(1,IT) = 0.0
  FRFI(2,IT) = 1.E12
  NT = NTR(IT)
  FR0 = FRN(NSUP(NT)) - FRN(NINF(NT))
  AMBDA = 1.E4 * CL / FR0
  TB = TEMBRI ( AMBDA )
  HJB = BENU ( FR0, TB )
  FINT(1,IT) = HJB
  FINT(2,IT) = HJB
 600  CONTINUE
!
  RETURN
  END
  SUBROUTINE SERLYM ( FREQ, NZ, NN, NTAR, NFR &
    , FRN, DNDR, AMR, FRR, SR, CARR, CAB, CEM )
!
!          Computation of absorption (CAB) and emission (CEM)
!     coefficients due to Lyman lines, at frequency FREQ.
!
  PARAMETER ( PI=3.141592653589, CL=2.997925E10, WLYA=1300. )
!
  DIMENSION FRN(NN), DNDR(NZ,NTAR), AMR(NZ,NTAR), FRR(NFR,NTAR) &
    , SR(NFR,NZ,NTAR), CARR(NZ,NTAR)
  DIMENSION CAB(NZ), CEM(NZ)
  DIMENSION AUX1(NZ), AUX2(NZ)
!
  FIZERO = 1.0 / SQRT ( PI )
  FR1 = 1.E8 * CL / WLYA
  FR2 = 3.3E15
!
  DO 320 IZ = 1, NZ
  CAB(IZ) = 0.0
  CEM(IZ) = 0.0
 320  CONTINUE
!
  IF ( FREQ .LT. FR1 .OR. FREQ .GT. FR2 ) RETURN
!
!              Lyman-alpha
!
  DFR = ABS ( FREQ - FRN(2) )
  DO 420 IZ = 1, NZ
  AUX1(IZ) = DFR / DNDR(IZ,1)
 420  CONTINUE
  CALL VOIGTV ( NZ, AMR(1,1), AUX1, AUX2 )
  DO 440 IZ = 1, NZ
  CALL INTERL ( NFR, FRR(1,1), SR(1,IZ,1), DFR, AUX1(IZ) )
 440  CONTINUE
  DO 460 IZ = 1, NZ
  CAB(IZ) = CAB(IZ) + CARR(IZ,1) * FIZERO * AUX2(IZ)
  CEM(IZ) = CEM(IZ) + CARR(IZ,1) * FIZERO * AUX2(IZ) * AUX1(IZ)
 460  CONTINUE
!
!              Lyman-beta
!
  DFR = ABS ( FREQ - FRN(3) )
  DO 520 IZ = 1, NZ
  AUX1(IZ) = DFR / DNDR(IZ,2)
 520  CONTINUE
  CALL VOIGTV ( NZ, AMR(1,2), AUX1, AUX2 )
  DO 540 IZ = 1, NZ
  CALL INTERL ( NFR, FRR(1,2), SR(1,IZ,2), DFR, AUX1(IZ) )
 540  CONTINUE
  DO 560 IZ = 1, NZ
  CAB(IZ) = CAB(IZ) + CARR(IZ,2) * FIZERO * AUX2(IZ)
  CEM(IZ) = CEM(IZ) + CARR(IZ,2) * FIZERO * AUX2(IZ) * AUX1(IZ)
 560  CONTINUE
!
  RETURN
  END
  FUNCTION AMAXI ( A, N )
  DIMENSION A(N)
  XMAX = A(1)
  DO 100 J = 2, N
  XMAX = AMAX1 ( XMAX, A(J) )
 100  CONTINUE
  AMAXI = XMAX
  RETURN
  END
  FUNCTION AMINI ( A, N )
  DIMENSION A(N)
  XMIN = A(1)
  DO 100 J = 2, N
  XMIN = AMIN1 ( XMIN, A(J) )
 100  CONTINUE
  AMINI = XMIN
  RETURN
  END
  SUBROUTINE PROMAV ( A, B, C, N )
!
  DIMENSION A(N,N), B(N), C(N)
!
  C = MATMUL ( A, B )
!
  RETURN
  END
  SUBROUTINE INVMAT ( A, N )
!
  DIMENSION A(N,N)
!
  CALL IMPS90 ( A, N )
  RETURN
  END
  SUBROUTINE IMPS90 ( T, N )
!
  DIMENSION T(N,N)
!
  DO L = 1, N
  PIV = T(L,L)
  IF ( PIV .EQ. 0.0 ) GO TO 900
  DO J = 1, N
  T(L,J) = T(L,J) / PIV
  END DO
  T(L,L) = 1.0 / PIV
  DO I = 1, N
  IF ( I .EQ. L ) CYCLE
  COEF = T(I,L)
  DO J = 1, N
  IF ( J .EQ. L ) CYCLE
  T(I,J) = T(I,J) - T(L,J) * COEF
  END DO
  T(I,L) = - COEF / PIV
  END DO
  END DO
  RETURN
!
 900  PRINT 901, L
 901  FORMAT ( // ' IMPS90 : pivot vanishes at line ', I3 // )
  STOP
  END
  SUBROUTINE SOSYS ( A, B, N )
!
  REAL, DIMENSION(N) :: B
  REAL, DIMENSION(N,N) :: A
!
 1    FORMAT (/' Undetermined equation system encountered in SOSYS'/)
!
  DO I = 1, N
  K = 0
  PIV = 0.0
  API = 0.0
  DO J = 1, N
  AP2 = ABS ( A(I,J) )
  IF ( AP2 .LE. API ) CYCLE
  K = J
  PIV = A(I,J)
  API = AP2
  END DO !  (J = 1, N)
  IF ( K .EQ. 0 ) GO TO 99
  B(I) = B(I) / PIV
  DO J = 1, N
  IF (A(I,J) .EQ. 0.0 ) CYCLE
  A(I,J) = A(I,J) / PIV
  END DO !  (J = 1, N)
  DO L = 1, N
  IF ( L .EQ. I ) CYCLE
  COEF = A(L,K)
  B(L) = B(L) - COEF * B(I)
  DO J = 1, N
  IF ( A(I,J) .EQ. 0. ) CYCLE
  A(L,J) = A(L,J) - COEF * A(I,J)
  END DO !  (J = 1, N)
  END DO !  (L = 1, N)
  END DO !  (I = 1, N)
  DO I = 1, N
  K = 0
  UN = 0.0
  DO J = 1, N
  IF ( A(J,I) .LE. UN ) CYCLE
  K = J
  UN = A(J,I)
  END DO !  (J = 1, N)
  IF ( K .EQ. I ) CYCLE
  TRUC = B(I)
  B(I) = B(K)
  B(K) = TRUC
  DO J = 1, N
  TRUC = A(I,J)
  A(I,J) = A(K,J)
  A(K,J) = TRUC
  END DO !  (J = 1, N)
  END DO !  (I = 1, N)
  RETURN
 99   CONTINUE
  WRITE ( 6, 1 )
  STOP
  END
  SUBROUTINE RIIVEC ( N, AMRT, XINF, XSUP, RII )
!
  DIMENSION XINF(N), XSUP(N), RII(N)
!
  DO 100 J = 1, N
  RII(J) = RIIM ( XINF(J), XSUP(J), AMRT )
 100  CONTINUE
  RETURN
  END
  FUNCTION RIA ( V, VV, GAMA )
  IF ( GAMA .EQ. 0.0 ) GO TO 10
  COEF = 2.01572090207E-03
  SIGA = SIN ( GAMA )
  EXPO = - V * V - VV * VV + 2.0 * V * VV * COS ( GAMA )
  EXPO = EXPO / SIGA**2
  RIA = COEF * EXP ( EXPO ) / SIGA
  RETURN
 10   CONTINUE
  RIA = 0.0
  RETURN
  END
  FUNCTION  RIIA (V, VV ,A ,GAMA )
  IF ( GAMA .EQ. 0.0 ) GOTO 10
  COEF = 2.01572090207E-03
  SIGA = SIN ( GAMA )
  SIGA2 = SIN ( 0.5 * GAMA )
  COGA2 = SQRT ( 1.0 - SIGA2 * SIGA2 )
  R1 = COEF / SIGA
  R2 = EXP ( - ( 0.5 * ( V - VV ) / SIGA2 ) **2 )
  R3 = VOIGT ( A / COGA2, 0.5 * ( V + VV ) / COGA2 )
  RIIA = R1 * R2 * R3
  RETURN
 10   RIIA = 0.0
  RETURN
  END
  FUNCTION RIIM ( X1 , X2 , A )
  IF ( ABS(X2) .GT. ABS(X1) ) GO TO 120
  IF ( X1 .GE. 0.0 ) GO TO 130
  GO TO 140
 120  CONTINUE
  IF ( ABS(X2) .GE. 0.0 ) GO TO 150
  GO TO 160
 130  CONTINUE
  XSUP = X1
  XINF = X2
  GO TO 180
 140  CONTINUE
  XSUP = - X1
  XINF = - X2
  GO TO 180
 150  CONTINUE
  XSUP = X2
  XINF = X1
  GO TO 180
 160  CONTINUE
  XSUP = - X2
  XINF = - X1
 180  CONTINUE
  S = 0.5 * ( XSUP + XINF )
  R = 0.5 * ( XSUP - XINF )
  IF ( R .GE. 4.0 .OR. S .GE. 4.0 ) GO TO 300
 200  CONTINUE
  RIIM = RIIM1 ( XSUP, XINF, A, 10 )
  RETURN
 300  CONTINUE
  IF ( R .GT. 5. ) GO TO 400
  IF ( S .LT. 1. ) GO TO 200
  RIIM = RIIM3 ( XSUP, XINF, A )
  RETURN
 400  CONTINUE
  RIIM = 0.0
  RETURN
  END
  FUNCTION RIIM1 ( V, VV, A, N )
  PARAMETER ( PI=3.141592653589 )
  CC = 8.0 * PI**2
  DX = PI / FLOAT ( N )
  SOM = 0.
  X = - DX * 0.5
  DO 50 I = 1 , N
  X = X + DX
  SOM = SOM + RIIA ( V, VV, A, X ) * SIN ( X )
 50   CONTINUE
  RIIM1 = SOM * CC * DX
  RETURN
  END
  FUNCTION RIIM3 ( XSUP, XINF, A )
  PARAMETER ( PI=3.141592653589 )
  S = 0.5 * ( XSUP + XINF )
  R = 0.5 * ( XSUP - XINF )
  A2 = A * A
  A4 = A2 * A2
  R2 = R * R
  R4 = R2 * R2
  S2 = S * S
  S4 = S2 * S2
  S6 = S4 * S2
  XXX = 0.5 * ERFCA ( XSUP )
  COEF = 1. / SQRT(PI)
  T1 = COEF * EXP(-R2)
  T2 = T1 - R * ERFCA ( R )
  RIIM = XXX
  XXX = 1. - A2/S2 + A4 / S4
  XXX = XXX * A * T2 / ( PI * S2 )
  RIIM = RIIM + XXX
  XXX = 1. - 10. * A2 / ( 3. * S2 )
  XXX = XXX * A / ( 2. * PI * S4 )
  XXX = XXX * ( - T1 + ( 3. + 2. * R2 ) * T2 )
  RIIM = RIIM + XXX
  XXX = A / ( 4. * PI * S6 )
  XXX = XXX * ( -T1*(7.+2.*R2)+(15.+20.*R2+4.*R4)*T2 )
  RIIM3 = RIIM + XXX
  RETURN
  END
  SUBROUTINE PSDEB ( NOMFI )
!
  CHARACTER*9 NOMFI
!
  COMMON /VISU/ XORI, YORI, XL, YL, HL, HC, XMIN, XMAX, YMIN, YMAX &
    , NOFIG, NDX, NDY, LOGX, LXMIN, LXMAX, LOGY, LYMIN, LYMAX &
    , NCX, NCY
  CHARACTER*12 LIG(6)
  COMMON /CADVEC/ NP, LIG
!
 1    FORMAT ( '%!PS-Adobe-1.0' / &
             '/L {lineto} def /M {moveto} def' / &
             '/N {newpath} def /RD {0 360 arc closepath fill} def' / &
             '/P {moveto  0  0  rlineto} def' / &
             '%%BoundingBox:  0  0  570  770' )
!
  NOFIG = 0
  XORI = 20.
  YORI = 20.
  NDX = 4
  NDY = 4
  XMIN = 0.0
  XMAX = 1.0
  LOGX = 0
  LXMIN = 0
  LXMAX = 1
  YMIN = 0.0
  YMAX = 1.0
  LOGY = 0
  LYMIN = 0
  LYMAX = 1
  XL = 150.
  YL = 100.
  HL = 5.
  HC = 5.
  I = 1
  NP = 0
!
  OPEN ( UNIT=88, FILE=NOMFI )
  WRITE ( 88, 1 )
!
  RETURN
  END
  SUBROUTINE PSFIN
!
  COMMON /VISU/ XORI, YORI, XL, YL, HL, HC, XMIN, XMAX, YMIN, YMAX &
    , NOFIG, NDX, NDY, LOGX, LXMIN, LXMAX, LOGY, LYMIN, LYMAX &
    , NCX, NCY
!
 1    FORMAT ( / '%%Pages: ', I3 / '%%EOF' )
!
  WRITE ( 88, 1 ) NOFIG
  CLOSE ( UNIT=88 )
  RETURN
  END
  SUBROUTINE ADVEC ( X, Y, IPEN )
!
 1    FORMAT ( 2(1X,I4), ' M' )
 2    FORMAT ( 2(1X,I4), ' L' )
!
  KX = IFIX ( X/0.35 + 0.5 )
  KY = IFIX ( Y/0.35 + 0.5 )
  IF ( IPEN .EQ. 0 ) WRITE ( 88, 1 ) KX, KY
  IF ( IPEN .EQ. 1 ) WRITE ( 88, 2 ) KX, KY
!
  RETURN
  END
  SUBROUTINE ADVECM ( X, Y, IPEN )
!
  CHARACTER*12 LIG(6)
  COMMON /CADVEC/ NP, LIG
!
 1    FORMAT ( 2(1X,I4), ' M' )
 2    FORMAT ( 2(1X,I4), ' L' )
 3    FORMAT ( 6A12 )
!
  KX = IFIX ( X/0.35 + 0.5 )
  KY = IFIX ( Y/0.35 + 0.5 )
  IF ( NP < 6 ) THEN
  IF ( IPEN .EQ. 0 ) WRITE ( LIG(NP+1), 1 ) KX, KY
  IF ( IPEN .EQ. 1 ) WRITE ( LIG(NP+1), 2 ) KX, KY
  NP = NP + 1
  ELSE
  WRITE ( 88, 3 ) ( LIG(J), J = 1, 6 )
  IF ( IPEN .EQ. 0 ) WRITE ( LIG(1), 1 ) KX, KY
  IF ( IPEN .EQ. 1 ) WRITE ( LIG(1), 2 ) KX, KY
  NP = 1
  END IF
!
  RETURN
  END
  SUBROUTINE FINTRA
!
  CHARACTER*12 LIG(6)
  COMMON /CADVEC/ NP, LIG
!
  IF ( NP > 0 ) THEN
  WRITE ( 88, 1 ) ( LIG(J), J = 1, NP )
 1   FORMAT ( 6A12 )
  NP = 0
  END IF
  WRITE ( 88, 999 )
 999  FORMAT ( ' stroke' )
!
  RETURN
  END
  SUBROUTINE TEXTE ( TEXT, N, XPOS, YPOS, HEIGHT, ANGLE )
  CHARACTER*1 TEXT(N), T1(50)
  KX = IFIX ( XPOS/0.35 + 0.5 )
  KY = IFIX ( YPOS/0.35 + 0.5 )
  WRITE ( 88, 113 ) KX, KY
 113  FORMAT ( 2I5, ' M' )
  IFONT = IFIX ( 4.0 * HEIGHT )
  WRITE ( 88, 115 ) IFONT
 115  FORMAT ( ' /Helvetica    findfont ', i2, ' scalefont setfont' )
  IANG = IFIX ( ANGLE )
  IF ( IANG .NE. 0 ) WRITE ( 88, 122 ) IANG
 122  FORMAT ( 1X, I4, ' rotate' )
  DO 200 J = 1, 50
  T1(J) = ' '
  IF ( J .LE. N ) T1(J) = TEXT(J)
 200  CONTINUE
  WRITE ( 88, 222 ) ( T1(J), J = 1, 50 )
 222  FORMAT ( ' (', 50A1, ') show ' )
  IF ( IANG .NE. 0 ) WRITE ( 88, 122 ) - IANG
!
  RETURN
  END
  SUBROUTINE NOMBRE ( XVAL, XPOS, YPOS, HEIGHT, INUM )
  CALL ADVEC ( XPOS, YPOS, 0 )
  IFONT = IFIX ( 4.0 * HEIGHT )
  WRITE ( 88, 115 ) IFONT
 115  FORMAT ( ' /Helvetica    findfont ', i2, ' scalefont setfont' )
  IF ( INUM .EQ. 0 ) THEN
  IVAL = IFIX ( XVAL+0.5 )
  IF ( XVAL .LT. 0.0 ) IVAL = IFIX ( XVAL-0.5 )
  WRITE ( 88, 200 ) IVAL
 200  FORMAT ( ' (', I5, ') show' )
  END IF
  IF ( INUM .EQ. 1 ) WRITE ( 88, 201 ) XVAL
 201  FORMAT ( ' (', f8.1, ') show' )
  IF ( INUM .EQ. 2 ) WRITE ( 88, 202 ) XVAL
 202  FORMAT ( ' (', f8.2, ') show' )
  IF ( INUM .EQ. 3 ) WRITE ( 88, 203 ) XVAL
 203  FORMAT ( ' (', f10.3, ') show' )
  IF ( INUM .LT. 0 .OR. INUM .GT. 3 ) WRITE ( 88, 222 ) XVAL
 222  FORMAT ( ' (', 1pe10.1, ') show' )
  RETURN
  END
  SUBROUTINE FINFIG
!
  WRITE ( 88, 990 )
 990  FORMAT ( ' showpage' )
!
  RETURN
  END
  SUBROUTINE NVFIGV
!
  COMMON /VISU/ XORI, YORI, XL, YL, HL, HC, XMIN, XMAX, YMIN, YMAX &
    , NOFIG, NDX, NDY, LOGX, LXMIN, LXMAX, LOGY, LYMIN, LYMAX &
    , NCX, NCY
!
 1    FORMAT ( / '%%Page: ', I3 )
 2    FORMAT ( ' 35 120 translate' / &
             '  0.80  0.80 scale' / &
             ' 1 setlinecap 1 setlinejoin 1 setlinewidth' / &
             ' 0.000 0.000 0.000 setrgbcolor' )
!
  NOFIG = NOFIG + 1
  WRITE ( 88, 1 ) NOFIG
  WRITE ( 88, 2 )
!
  RETURN
  END
  SUBROUTINE NVPAG
!
  COMMON /VISU/ XORI, YORI, XL, YL, HL, HC, XMIN, XMAX, YMIN, YMAX &
    , NOFIG, NDX, NDY, LOGX, LXMIN, LXMAX, LOGY, LYMIN, LYMAX &
    , NCX, NCY
!
 1    FORMAT ( / '%%Page: ', I3 )
!
  NOFIG = NOFIG + 1
  WRITE ( 88, 1 ) NOFIG
!
  RETURN
  END
  SUBROUTINE ECHEL3 ( X, XSUP, NDX )
  DIMENSION XVA(8), NDM(8)
  DATA XVA / 1.0, 1.5, 2.0, 3.0, 4.0, 5.0, 6.0, 8.0 /
  DATA NDM / 3, 4, 6, 8, 5, 6, 8, 5 /
  IF ( X .GT. 0.0 ) GO TO 200
  XSUP = 0.0
  NDX = 1
  RETURN
 200  CONTINUE
  XLOG =  LOG10 ( X )
  NLOG = IFIX ( XLOG )
  IF ( XLOG .LT. 0.0 ) NLOG = NLOG - 1
  XPS = 10. ** NLOG
  RAP = X / XPS
  DO 220 II = 1, 8
  I = 9 - II
  IF ( RAP .GE. XVA(I) ) GO TO 240
 220  CONTINUE
 240  CONTINUE
  IF ( I .NE. 8 ) XSUP = XVA(I+1) * XPS
  IF ( I .EQ. 8 ) XSUP = 10. * XPS
  NDX = NDM(I)
  RETURN
  END
  SUBROUTINE TITRE ( TEXT, N )
!
  CHARACTER*1 TEXT(N)
!
  COMMON /VISU/ XORI, YORI, XL, YL, HL, HC, XMIN, XMAX, YMIN, YMAX &
    , NOFIG, NDX, NDY, LOGX, LXMIN, LXMAX, LOGY, LYMIN, LYMAX &
    , NCX, NCY
!
  XPOS = XORI + 0.5 * XL - HL * 0.5 * FLOAT(N-1)
  YPOS = YORI + YL + 2.0 * HL
  HEIGHT = HL
  CALL TEXTE ( TEXT, N, XPOS, YPOS, HEIGHT, 0.0 )
!
  RETURN
  END
  SUBROUTINE TITX ( TEXT, N )
!
  CHARACTER*1 TEXT(N)
!
  COMMON /VISU/ XORI, YORI, XL, YL, HL, HC, XMIN, XMAX, YMIN, YMAX &
    , NOFIG, NDX, NDY, LOGX, LXMIN, LXMAX, LOGY, LYMIN, LYMAX &
    , NCX, NCY
!
  XPOS = XORI + 0.5 * XL - HL * 0.5 * FLOAT(N-1)
  YPOS = YORI - 2.0 * HC - 2.0 * HL
  HEIGHT = HL
  CALL TEXTE ( TEXT, N, XPOS, YPOS, HEIGHT, 0.0 )
!
  RETURN
  END
  SUBROUTINE TITYD ( TEXT, N, XXX )
!
  CHARACTER*1 TEXT(N)
!
  COMMON /VISU/ XORI, YORI, XL, YL, HL, HC, XMIN, XMAX, YMIN, YMAX &
    , NOFIG, NDX, NDY, LOGX, LXMIN, LXMAX, LOGY, LYMIN, LYMAX &
    , NCX, NCY
!
  XPOS = XORI + XXX
  YPOS = YORI + 0.5 * YL - 0.5 * HL * FLOAT(N-1)
  HEIGHT = HL
  CALL TEXTE ( TEXT, N, XPOS, YPOS, HEIGHT, 90. )
!
  RETURN
  END
  SUBROUTINE CADRE ( XORI, YORI, XL, YL, NDX, NDY, HC &
    , XMIN, XMAX, YMIN, YMAX, NCX, NCY )
!
 1    FORMAT ( ' /Helvetica   findfont ', i2,' scalefont setfont' )
 2    FORMAT ( 2I5, ' M' )
 3    FORMAT ( ' (', I2, ') show' )
 4    FORMAT ( ' (*) show' )
 5    FORMAT ( 2I5, ' L' )
!
  CALL ADVEC ( XORI, YORI, 0 )
  CALL ADVEC ( XORI+XL, YORI, 1 )
  CALL ADVEC ( XORI+XL, YORI+YL, 1 )
  CALL ADVEC ( XORI, YORI+YL, 1 )
  CALL ADVEC ( XORI, YORI, 1 )
!
  IF ( NDX .GT. 0 ) THEN
  DO 10 I = 1, NDX+1
  FRAC = FLOAT (I-1) / FLOAT (NDX)
  XPOS = XORI + XL * FRAC
  XVAL = XMIN + ( XMAX - XMIN ) * FRAC
  HEIGHT = HC
  INUM = NCX
  IF ( INUM .GE. 0 ) THEN
  XDNUM = XPOS - 0.5 * HC * FLOAT ( NCX + 4 )
  ELSE
  XDNUM = XPOS - 3. * HC
  END IF
  CALL NOMBRE ( XVAL, XDNUM, YORI-2.0*HC, HEIGHT, INUM )
  CALL ADVEC ( XPOS, YORI, 0 )
  CALL ADVEC ( XPOS, YORI+HC, 1 )
  CALL ADVEC ( XPOS, YORI+YL-HC, 0 )
  CALL ADVEC ( XPOS, YORI+YL, 1 )
 10   CONTINUE
  END IF
  IF ( NDY .GT. 0 ) THEN
  DO 20 I = 1, NDY+1
  FRAC = FLOAT (I-1) / FLOAT (NDY)
  YPOS = YORI + YL * FRAC
  YVAL = YMIN + ( YMAX - YMIN ) * FRAC
  HEIGHT = HC
  INUM = NCY
  XDNUM = XORI - 3.0 * HC - 0.7 * HC * FLOAT(INUM)
  IF ( YVAL .GE. 10.0 ) XDNUM = XDNUM - HC
  IF ( YVAL .GE. 100. ) XDNUM = XDNUM - HC
  IF ( YVAL .LT. 0.0 ) XDNUM = XDNUM - 0.5 * HC
  IF ( YVAL .LE. -10. ) XDNUM = XDNUM - HC
  IF ( YVAL .LE. -100. ) XDNUM = XDNUM - HC
  IF ( INUM .LT. 0 ) XDNUM = XORI - 7.0 * HC
  CALL NOMBRE ( YVAL, XDNUM, YPOS-0.5*HC, HEIGHT, INUM )
  CALL ADVEC ( XORI, YPOS, 0 )
  CALL ADVEC ( XORI+HC, YPOS, 1 )
  CALL ADVEC ( XORI+XL-HC, YPOS, 0 )
  CALL ADVEC ( XORI+XL, YPOS, 1 )
 20   CONTINUE
  END IF
  CALL FINTRA
!
  RETURN
  END
  SUBROUTINE CADLOG ( XORI, YORI, XL, YL, HC, LXMIN, LXMAX, LYMIN &
    , LYMAX )
!
 1    FORMAT ( ' /Helvetica   findfont ', i2,' scalefont setfont' )
 2    FORMAT ( 2I5, ' M' )
 3    FORMAT ( ' (', I2, ') show' )
 4    FORMAT ( ' (*) show' )
 5    FORMAT ( 2I5, ' L' )
!
  CALL ADVEC ( XORI, YORI, 0 )
  CALL ADVEC ( XORI+XL, YORI, 1 )
  CALL ADVEC ( XORI+XL, YORI+YL, 1 )
  CALL ADVEC ( XORI, YORI+YL, 1 )
  CALL ADVEC ( XORI, YORI, 1 )
  NDX = LXMAX - LXMIN
  HCR = 0.7 * HC
  DELTAX = XL / FLOAT(NDX)
  DO 200 I = 1, NDX+1
  FRAC = FLOAT (I-1) / FLOAT (NDX)
  XPOS = XORI + XL * FRAC
  LXVAL = LXMIN + I - 1
  XDNUM = XPOS - 2. * HC
  CALL NOMBRE ( 10., XDNUM, YORI-2.5*HC, HC, 0 )
  CALL NOMBRE ( FLOAT(LXVAL), XDNUM+1.8*HC, YORI-1.3*HC, 0.8*HC, 0 )
  CALL ADVEC ( XPOS, YORI, 0 )
  CALL ADVEC ( XPOS, YORI+HC, 1 )
  CALL ADVEC ( XPOS, YORI+YL-HC, 0 )
  CALL ADVEC ( XPOS, YORI+YL, 1 )
  IF ( I .LE. NDX ) THEN
  DO 150 K = 2, 9
  XKK = XPOS + DELTAX *  LOG10 ( FLOAT(K) )
  CALL ADVEC ( XKK, YORI, 0 )
  CALL ADVEC ( XKK, YORI+HCR, 1 )
  CALL ADVEC ( XKK, YORI+YL-HCR, 0 )
  CALL ADVEC ( XKK, YORI+YL, 1 )
 150  CONTINUE
  END IF
 200  CONTINUE
  NDY = LYMAX - LYMIN
  DELTAY = YL / FLOAT(NDY)
  DO 300 I = 1, NDY+1
  FRAC = FLOAT (I-1) / FLOAT (NDY)
  YPOS = YORI + YL * FRAC
  LYVAL = LYMIN + I - 1
  YDNUM = YPOS - 0.5 * HC
  CALL NOMBRE ( 10., XORI-4.5*HC, YDNUM, HC, 0 )
  CALL NOMBRE ( FLOAT(LYVAL), XORI-2.7*HC, YDNUM+1.2*HC, 0.8*HC, 0 )
  CALL ADVEC ( XORI, YPOS, 0 )
  CALL ADVEC ( XORI+HC, YPOS, 1 )
  CALL ADVEC ( XORI+XL-HC, YPOS, 0 )
  CALL ADVEC ( XORI+XL, YPOS, 1 )
  IF ( I .LE. NDY ) THEN
  DO 250 K = 2, 9
  YKK = YPOS + DELTAY *  LOG10 ( FLOAT(K) )
  CALL ADVEC ( XORI, YKK, 0 )
  CALL ADVEC ( XORI+HCR, YKK, 1 )
  CALL ADVEC ( XORI+XL-HCR, YKK, 0 )
  CALL ADVEC ( XORI+XL, YKK, 1 )
 250  CONTINUE
  END IF
 300  CONTINUE
  CALL FINTRA
!
  RETURN
  END
  SUBROUTINE CADRSP
!
  COMMON /VISU/ XORI, YORI, XL, YL, HL, HC, XMIN, XMAX, YMIN, YMAX &
    , NOFIG, NDX, NDY, LOGX, LXMIN, LXMAX, LOGY, LYMIN, LYMAX &
    , NCX, NCY
!
  IF ( LOGX .EQ. 0 .OR. LOGY .EQ. 0 ) THEN
  CALL CADRE ( XORI, YORI, XL, YL, NDX, NDY, HC &
    , XMIN, XMAX, YMIN, YMAX, NCX, NCY )
  ELSE
  CALL CADLOG ( XORI, YORI, XL, YL, HC, LXMIN, LXMAX, LYMIN, LYMAX )
  END IF
!
  RETURN
  END
  SUBROUTINE CHCADR ( XO, YO, IDX, IDY, XLON, YLON, HLET, HCHIF &
    , NC1, NC2 )
!
  COMMON /VISU/ XORI, YORI, XL, YL, HL, HC, XMIN, XMAX, YMIN, YMAX &
    , NOFIG, NDX, NDY, LOGX, LXMIN, LXMAX, LOGY, LYMIN, LYMAX &
    , NCX, NCY
!
  XORI = XO
  YORI = YO
  NDX = IDX
  NDY = IDY
  XL = XLON
  YL = YLON
  HL = HLET
  HC = HCHIF
  NCX = NC1
  NCY = NC2
!
  RETURN
  END
  SUBROUTINE CHLIMI ( XMI, XMA, LX, LXI, LXA, YMI, YMA, LY, LYI, LYA &
    )
!
  COMMON /VISU/ XORI, YORI, XL, YL, HL, HC, XMIN, XMAX, YMIN, YMAX &
    , NOFIG, NDX, NDY, LOGX, LXMIN, LXMAX, LOGY, LYMIN, LYMAX &
    , NCX, NCY
!
  XMIN = XMI
  XMAX = XMA
  LOGX = LX
  LXMIN = LXI
  LXMAX = LXA
  YMIN = YMI
  YMAX = YMA
  LOGY = LY
  LYMIN = LYI
  LYMAX = LYA
!
  RETURN
  END
  SUBROUTINE COLILI ( NP, X, Y, NT )
!
  COMMON /VISU/ XORI, YORI, XL, YL, HL, HC, XMIN, XMAX, YMIN, YMAX &
    , NOFIG, NDX, NDY, LOGX, LXMIN, LXMAX, LOGY, LYMIN, LYMAX &
    , NCX, NCY
!
  DIMENSION X(NP), Y(NP)
  DIMENSION T1(5), T2(5), T3(5), T4(5)
!
  T1 = (/ 5., 0.5, 6.,  10., 5. /)
  T2 = (/ 2., 3.,  2.,  2., 5.  /)
  T3 = (/ 5., 0.5, 0.5, 10., 5. /)
  T4 = (/ 2., 3.,  2.,  2., 5.  /)
!
  IF ( NT .LE. -1 ) GO TO 100
  IT = MOD ( NT, 6 )
  IF ( IT .EQ. 0 ) THEN
  CALL COUSUC ( NP, X, Y, XORI, YORI, XL, YL, XMIN, XMAX, YMIN, YMAX &
    , LOGX, LOGY, LXMIN, LXMAX, LYMIN, LYMAX )
  ELSE
  CALL COUSUP ( NP, X, Y, T1(IT), T2(IT), T3(IT), T4(IT), XORI, YORI &
    , XL, YL, XMIN, XMAX, YMIN, YMAX, LOGX, LOGY, LXMIN, LXMAX, LYMIN &
    , LYMAX )
  END IF
  RETURN
!
 100  CONTINUE
  WRITE ( 88, 111 )
 111  FORMAT ( ' 2 setlinewidth' )
  CALL COUSUC ( NP, X, Y, XORI, YORI, XL, YL, XMIN, XMAX, YMIN, YMAX &
    , LOGX, LOGY, LXMIN, LXMAX, LYMIN, LYMAX )
  WRITE ( 88, 133 )
 133  FORMAT ( ' 1 setlinewidth' )
  RETURN
!
  END
  SUBROUTINE COUSUP ( NP, X, Y, T1, T2, T3, T4, XORI, YORI, XL, YL &
    , XMIN, XMAX, YMIN, YMAX, LOGX, LOGY, LXMIN, LXMAX, LYMIN, LYMAX )
!
  dimension x(np), y(np), p(4)
!
  tot = t1 + t2 + t3 + t4
  p(1) = t1 / tot
  p(2) = ( t1 + t2 ) / tot
  p(3) = ( t1 + t2 + t3 ) / tot
  p(4) = 1.0
  ip = 0
 100  continue
  ip = ip + 1
  if ( ip .gt. np ) go to 900
  if ( logx .eq. 0 ) then
  xx = xl * ( x(ip) - xmin ) / ( xmax - xmin )
  else
  xx = xl * ( LOG10 ( x(ip) ) - float ( lxmin ) ) / float ( &
          lxmax  - lxmin )
  end if
  if ( logy .eq. 0 ) then
  yy = yl * ( y(ip) - ymin ) / ( ymax - ymin )
  else
  yy = yl * ( LOG10 ( y(ip) ) - float ( lymin ) ) / float ( &
          lymax  - lymin )
  end if
  if ( xx .lt. 0.0 .or. xx .gt. xl .or. yy .lt. 0.0 .or. yy .gt. &
         yl ) go to 100
  pp = 0.0
  iepp = 1
  call advecm ( xori+xx, yori+yy, 0 )
 200  continue
  if ( logx .eq. 0 ) then
  xxn = xl * ( x(ip+1) - xmin ) / ( xmax - xmin )
  else
  xxn = xl * ( LOG10 ( x(ip+1) ) - float ( lxmin ) ) / float ( &
          lxmax  - lxmin )
  end if
  if ( logy .eq. 0 ) then
  yyn = yl * ( y(ip+1) - ymin ) / ( ymax - ymin )
  else
  yyn = yl * ( LOG10 ( y(ip+1) ) - float ( lymin ) ) / float ( &
          lymax  - lymin )
  end if
  if ( xxn .lt. 0.0 .or. xxn .gt. xl .or. yyn .lt. 0.0 .or. yyn .gt. &
         yl ) go to 100
 300  continue
  dx = xxn - xx
  dy = yyn - yy
  ds = sqrt ( dx*dx + dy*dy )
  if ( ds .ne. 0.0 ) then
  u = dx / ds
  v = dy / ds
  end if
  dp = ( p(iepp) - pp ) * tot
  if ( dp .gt. ds ) go to 400
  ipen = 1
  if ( mod ( iepp, 2 ) .eq. 0 ) ipen = 0
  xx = xx + dp * u
  yy = yy + dp * v
  call advecm ( xori+xx, yori+yy, ipen )
  pp = p(iepp)
  iepp = iepp + 1
  if ( iepp .eq. 5 ) then
  iepp = 1
  pp = 0.0
  end if
  go to 300
 400  continue
  xx = xxn
  yy = yyn
  ipen = 1
  if ( mod ( iepp, 2 ) .eq. 0 ) ipen = 0
  call advecm ( xori+xx, yori+yy, ipen )
  pp = pp + ds / tot
  ip = ip + 1
  if ( ip .eq. np ) go to 900
  go to 200
!
 900  CONTINUE
  CALL FINTRA
!
  RETURN
  END
  SUBROUTINE COUSUC ( NP, X, Y, XORI, YORI, XL, YL, XMIN, XMAX &
    , YMIN, YMAX, LOGX, LOGY, LXMIN, LXMAX, LYMIN, LYMAX )
!
  DIMENSION X(NP), Y(NP)
!
  ip1 = 0
  do 200 i = 1, np
  if ( logx .eq. 0 ) then
  xx = xl * ( x(i) - xmin ) / ( xmax - xmin )
  else
  xx = xl * ( LOG10 ( x(i) ) - float ( lxmin ) ) / float ( &
          lxmax  - lxmin )
  end if
  if ( logy .eq. 0 ) then
  yy = yl * ( y(i) - ymin ) / ( ymax - ymin )
  else
  yy = yl * ( LOG10 ( y(i) ) - float ( lymin ) ) / float ( &
          lymax  - lymin )
  end if
  ip2 = 1
  if ( xx .lt. 0.0 .or. xx .gt. xl ) ip2 = 0
  if ( yy .lt. 0.0 ) yy = 0.0
  if ( yy .gt. yl ) yy = yl
  if ( ip2 .eq. 0 ) go to 180
  ipen = 1
  if ( ip1 .eq. 0 ) ipen = 0
  call advecm ( xori+xx, yori+yy, ipen )
 180  continue
  ip1 = ip2
 200  continue
  CALL FINTRA
  RETURN
  END
  SUBROUTINE VISU21L ( NVLI, NP, NC, IOPII, IOPFR, ILOG )
!
  DIMENSION XMU(NC), XLA(NP), Y(NP,NC), YY(NP,NC)
  CHARACTER*45 BUF
!
  DO IFI = 1, NVLI
  READ ( 21, * ) NI, NS, FR0
  AMBDA = 2.997925E18 / FR0
  READ ( 21, * ) ( XMU(J), J = 1, NC )
  READ ( 21, * ) ( XLA(I), I =1, NP )
  DO J = 1, NC
  READ ( 21, * ) ( Y(I,J), I = 1, NP )
  END DO
  IF ( IOPII == 1 ) THEN
  XII = 0.0
  DO I = 2, NP
  XII = XII + ( XLA(I) - XLA(I-1) ) * ( Y(I-1,NC) + Y(I,NC) )
  END DO
  END IF
  IF ( IOPFR == 1 ) THEN
  DO J = 1, NC
  DO I = 1, NP
  Y(I,J) = Y(I,J) * AMBDA / FR0
  END DO
  END DO
  END IF
!
  XMIN = AMINI ( XLA, NP )
  XMAX = AMAXI ( XLA, NP )
  YMAX = Y(1,1)
  YMIN = Y(1,1)
  DO J = 1, NC
  DO I = 1, NP
  YMAX = AMAX1 ( YMAX, Y(I,J) )
  YMIN = AMIN1 ( YMIN, Y(I,J) )
  END DO
  END DO
  XL = 180.
  YL = 180.
  IXMIN = IFIX ( XMIN )
  IXMAX = IFIX ( XMAX + 0.5 )
  XMI = FLOAT ( IXMIN )
  XMA = FLOAT ( IXMAX )
  NDX = IXMAX - IXMIN
  NDX = MAX0 ( NDX, 2 )
!
  IF ( ILOG .EQ. 1 ) THEN
  YMIN = AMAX1 ( YMIN, 1.E-5*YMAX )
  MINY = IFIX ( LOG10(YMIN) )
  IF ( LOG10(YMIN) .LE. 0.0 ) MINY = MINY - 1
  MAXY = IFIX ( LOG10(YMAX) ) + 1
  IF ( LOG10(YMAX) .LE. 0.0 ) MAXY = MAXY - 1
  NDY = MAXY - MINY
  YMI = FLOAT ( MINY )
  YMA = FLOAT ( MAXY )
  DO J = 1, NC
  DO I = 1, NP
  YY(I,J) = LOG10 ( Y(I,J) )
  END DO
  END DO
  CALL NVFIGV
  CALL CHLIMI ( XMI, XMA, 0, 0, 0, YMI, YMA, 0, 0, 0 )
  CALL CHCADR ( 40., 30., NDX, NDY, XL, YL, 5., 4., 1, 1 )
  CALL CADRSP
  CALL TITX ( 'delta-lambda (A)', 16 )
  IF ( IOPFR == 1 ) THEN
  CALL TITYD ( 'log(I_nu)', 9, -28. )
  ELSE
  CALL TITYD ( 'log(I_lambda)', 13, -28. )
  END IF
  DO J = 1, NC
  CALL COLILI ( NP, XLA, YY(1,J), NC-J )
  END DO
!
  ELSE
!
  YMI = 0.0
  CALL ECHEL3 ( YMAX, YMA, NDY )
  CALL NVFIGV
  CALL CHLIMI ( XMI, XMA, 0, 0, 0, YMI, YMA, 0, 0, 0 )
  CALL CHCADR ( 40., 30., NDX, NDY, XL, YL, 5., 4., 1, -2 )
  CALL CADRSP
  CALL TITX ( 'delta-lambda (A)', 16 )
  IF ( IOPFR == 1 ) THEN
  CALL TITYD ( 'I_nu (erg/cm2/s/sr/Hz)', 22, -28. )
  ELSE
  CALL TITYD ( 'I_lambda (erg/cm2/s/sr/A)', 25, -28. )
  END IF
  DO J = 1, NC
  CALL COLILI ( NP, XLA, Y(1,J), NC-J )
  END DO
!
  END IF
!
  IF ( IOPII == 1 ) THEN
  WRITE ( BUF, 411 ) NI, NS, IFIX ( AMBDA ), XII
 411  FORMAT ( ' line', 2I5, ' (', I8, ' A ) , E =', 1PE10.2 )
  WRITE ( 61, 433 ) BUF
 433  FORMAT ( A45 )
  CALL TITRE ( BUF, 45 )
  ELSE
  WRITE ( BUF, 455 ) NI, NS, IFIX ( AMBDA )
 455  FORMAT ( ' line', 2I5, 5X, ' (', I8, ' A ) ' )
  PRINT 477, BUF
 477  FORMAT ( A35 )
  CALL TITRE ( BUF, 35 )
  END IF
!
  CALL FINFIG
  END DO
!
  RETURN
  END
