      PROGRAM HYDR

!        Calcul des raies et continus de l'hydrogene ...
!        + EHS (ou EP) + ES + EI
!        (couches plan-paralleles ou atmospheres)
!
    
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF 


      CALL INIT
      CALL INIMET
      IF ( IVERT .LT. 0 ) THEN
      CALL EXEATM
      ELSE
      CALL EXEPRO
      END IF

      PRINT *, ' FIN NORMALE '
      STOP 1
    END PROGRAM HYDR
      SUBROUTINE INIT

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) & 
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP) 
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


      DATA  PI,HP,CL,BOLT,UMA,EV,ELM  / 3.141592653589, 6.6262E-27 &
     &, 2.997925E10, 1.3806E-16, 1.660E-24, 1.6021E-12, 0.910956E-27 /

      DATA ( XFR(I), I = 1, 20 ) / 0.0, 0.5, 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 /

      C4=2.*HP/CL**2
      C5=2.*(2.*PI*ELM*BOLT/HP**2)**1.5
      C6=EV/BOLT
      FIZERO = 1. / SQRT(PI)
      WLYA = 1300.
      NRAMX = NTAR
      HMA = 1.0
      DO 120 I = 1, NTAR
      IOPRN(I) = 1
      IOPERA(I) = 0
      RXRO(I) = 0.0
      DL1(I) = 0.0
      DL2(I) = 0.0
 120  CONTINUE
      DO 140 I = 1, NTAC
      IOPECO(I) = 0
      RXIK(I) = 0.0
 140  CONTINUE
      RXTR = 0.0
      NK = NN
      IORD = -1
      CSCOEF = 1.0
      IPROM = 0
      IPROF = 0
      IPAL = 0
      IFTOT = 0
      IFLYA = 0
      IFBAA = 0
      ICATA = 0
      IOPRA = 0
      ICCVAL = 0
      IRDVAL = 0
      IMRSPL = 0
!...................  OPTIONS ....................
      ICATA = 2
      ITGMAX = 12
      ICRMAX = 12
      IEHMAX = 100
      RXY = 0.5
      CRITY = 1.E-3
      IOPMRU = 0
      IOPRN(1) = 4
      IOPRN(2) = 3
      IOPFEV = 1
      IVERT = -1
      IOPEHS = 1
      IOPVT = 0
      IOPMIC = 1
      IPROF = 1
      IFTOT = 0
      IFLYA = 1
      IFBAA = 0
      INIDLD = 0
      DLDREF(1) = 0.05
      DLDREF(2) = 0.04
      DLDREF(3) = 0.25
      DLDREF(4) = 0.04
      DLDREF(5) = 0.2
      DLDREF(6) = 0.7
      DLDREF(7) = 0.04
      DLDREF(8) = 0.2
      DLDREF(9) = 0.5
      DLDREF(10) = 1.5
      IOPERA(1) = 1
      IOPERA(2) = 1
      IOPERA(3) = 1
      IOPERA(4) = 1
      IOPERA(5) = 1
      IOPERA(6) = 1
      IOPERA(7) = 1
      IOPERA(8) = 1
      IOPERA(9) = 1
      IOPERA(10) = 1
      DL2(1) = 2.0
      DL2(2) = 1.0
      DL2(3) = 2.0
      DL2(4) = 1.0
      DL2(5) = 2.0
      DL2(6) = 4.0
      DL2(7) = 1.0
      DL2(8) = 2.0
      DL2(9) = 4.0
      DL2(10) = 4.0
      PMU(1) = 0.2
      PMU(2) = 0.6
      PMU(3) = 1.0
      IOPECO(1) = 1
      IOPECO(2) = 0
      IOPECO(3) = 0
      IOPECO(4) = 0
      IOPECO(5) = 0
      IOPCAC = 3
      IOPEAC = 0
      IOPTOC = 0
      IOPATM = 0
      IOPTTC = 0
      IOPPOP = 1
      IOPROB = 0
      IOPREN = 0
      DO 220 I = 1, NTAR
      NTR(I) = I
      ICTR(I) = 1
 220  CONTINUE
      DO 240 I = 1, NTAC
      NTC(I) = ((NN-1)*(NN-2))/2 + I
      ICTC(I) = 3
 240  CONTINUE
      ICTC(1) = 1
      ICTC(2) = 1
      ICTC(3) = 1
      DO 260 I = 1, NTAR
      RXRO(I) = 0.5
 260  CONTINUE
      RXIK(1) = 0.0
      RXTR = 0.0
      IVTR = 1
      IOPTR(1) = 1
      IOPTR(2) = 2
      IOPTR(3) = 2
      IOPTR(4) = 2
      IOPTR(5) = 2
      TROM(1) = 8000.
      TROM(2) = 6000.
      TROM(3) = 6000.
      TROM(4) = 6000.
      TROM(5) = 6000.
!...........  FIN DES OPTIONS  ...................

!              Ecriture des donnees

      PRINT '( 10H IPROF     , I8 )', IPROF
      PRINT '( 10H IPAL      , I8 )', IPAL
      PRINT '( 10H IMRSPL    , I8 )', IMRSPL
      PRINT '( 10H ICCVAL    , I8 )', ICCVAL
      PRINT '( 10H IRDVAL    , I8 )', IRDVAL
      PRINT '( 10H ITGMAX    , I8 )', ITGMAX
      PRINT '( 10H ICRMAX    , I8 )', ICRMAX
      PRINT '( 10H IOPMRU    , I8 )', IOPMRU
      PRINT '( 10H IOPRN     , 10I8 )', IOPRN
      PRINT '( 10H IOPFEV    , I8 )', IOPFEV
      PRINT '( 10H IVERT     , I8 )', IVERT
      PRINT '( 10H INIDLD    , I8 )', INIDLD
      PRINT '( 10H IOPATM    , I8 )', IOPATM
      PRINT '( 10H IOPEAC    , I8 )', IOPEAC
      PRINT '( 10H IOPECO    , 10I8 )', IOPECO
      PRINT '( 10H IOPERA    , 10I8 )', IOPERA
      PRINT '( 10H IOPVT     , I8 )', IOPVT
      PRINT '( 10H IOPMIC    , I8 )', IOPMIC
      PRINT '( 10H IOPPOP    , I8 )', IOPPOP
      PRINT '( 10H IOPREN    , I8 )', IOPREN
      PRINT '( 10H IOPROB    , I8 )', IOPROB
      PRINT '( 10H IOPTOC    , I8 )', IOPTOC
      PRINT '( 10H IOPTTC    , I8 )', IOPTTC
      PRINT '( 10H RXRO      , 10F8.3 )', RXRO
      PRINT '( 10H RXIK      , 10F8.3 )', RXIK
      PRINT '( 10H RXTR      , F8.3 )', RXTR
      IF ( IVERT .GE. 0 ) THEN
      PRINT '( 10H FADI      , 10F8.5 )', FADI
      PRINT '( 10H DL1       , 10F8.3 )', DL1
      PRINT '( 10H DL2       , 10F8.3 )', DL2
      ENDIF

      RETURN
      END
      SUBROUTINE EXEATM

!         Organisation des calculs dans le cas d'une atmosphere
!         stellaire (y compris solaire)

 1    FORMAT ( 23H1 RESUME DES ITERATIONS / )
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP) 
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


      WRITE ( 8, 1)

!              Lecture du modele d'atmosphere

      CALL INIATM3

      CALL INIFEV
      IOPSAV = IOPCAC
      IOPCAC = 0
      CALL JEUXDO
      IOPCAC = IOPSAV
      CALL COLIM3
      CALL INITR3
      CALL PENDULE
      DO 300 ITG = 1, ITGMAX
      NITG = ITG
      CALL HYESEH
      IF ( IOPCAC .EQ. 3 ) CALL ABSCON ( 0 )
      DO 200 IT = 1, NTAR
      IF ( ICTR(IT) .GE. 3 ) GO TO 200
      CALL RPCDEF ( IT, 0 )
 200  CONTINUE
      IF ( IOPFEV .GE. 3 ) THEN
      DO 250 IT = 1, NTAR
      IF ( IOPERA(IT) .EQ. 0 ) GO TO 250
      CALL ECRFEV ( 1, NFR, IT, NZ, FEVK(1,1,IT) )
 250  CONTINUE
      DO 260 IT = 1, NTAC
      IF ( IOPECO(IT) .EQ. 0 ) GO TO 260
      CALL ECRFEV ( 2, NFRC, IT, NZ, FKTC(1,1,IT) )
 260  CONTINUE
      END IF
      CALL ESTR6
      CALL NOVTER
      CALL PENDULE
 300  CONTINUE
      IF ( IOPFEV .GE. 2 ) THEN
      DO 350 IT = 1, NTAR
      IF ( IOPERA(IT) .EQ. 0 ) GO TO 350
      CALL ECRFEV ( 1, NFR, IT, NZ, FEVK(1,1,IT) )
 350  CONTINUE
      DO 360 IT = 1, NTAC
      IF ( IOPECO(IT) .EQ. 0 ) GO TO 360
      CALL ECRFEV ( 2, NFRC, IT, NZ, FKTC(1,1,IT) )
 360  CONTINUE
      END IF
      CALL TESTH6
      IF ( IOPTOC .EQ. 1 ) CALL IMTOCS ( NZ )
!     CALL IMPERA
      CALL CSHYDR ( IFTOT, IFLYA, IFBAA )
      IF ( ICATA .EQ. -1 ) CALL CATF27
      IF ( ICATA .GE. 1 ) CALL CATFIC
      IF ( ICATA .GE. 2 ) CALL IMPIMO ( NZ, Z )
      CALL PENDULE

      RETURN
      END
      SUBROUTINE EXEPRO

!         Organisation des calculs dans le cas des protuberances
!       solaires

 1    FORMAT ( 23H1 RESUME DES ITERATIONS / )
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )


      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP) 
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG & 
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF 

      DIMENSION TMOD(50), PGMOD(50), EPSSR(50), IVTMOD(50)

!              Lecture de la liste des modeles a calculer

      READ ( 3, * ) NMDL
      PRINT 11, NMDL
 11   FORMAT ( '1', 20X, I5, ' modeles a traiter :' / )
      DO 100 K = 1, NMDL
      READ ( 3, * ) TMOD(K), PGMOD(K), EPSSR(K), IVTMOD(K)
      PRINT 12, K, TMOD(K), PGMOD(K), EPSSR(K), IVTMOD(K)
 12   FORMAT ( 1X, I5, '    T =', F7.0, '    P =', F7.3, '    E =' &
     &, F7.0, '    VT =', I3 )
 100  CONTINUE

      WRITE ( 8, 1 )

!          Definition automatique des transitions permises au-dela
!        du niveau 5.

      K = 0
      DO 120 J = 2, NN-1
      DO 120 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
 120  CONTINUE
      DO 140 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
 140  CONTINUE

!              Exceptions pour H-delta et H-epsilon

! 28/07/2015 dépassement de tableau...si on met 20 ou 15, d'autres pbs
!!      ICTR(11) = 1
!!      ICTR(15) = 1

!              Boucle sur les modeles

      DO 500 IMDL = 1, NMDL
      TSLAB = TMOD(IMDL)
      PSLAB = PGMOD(IMDL)
      EPST = EPSSR(IMDL)
      IOPVT = IVTMOD(IMDL)
      CALL INIATM1
      CALL INIFEV
      IOPSAV = IOPCAC
      IOPCAC = 0
      CALL JEUXDO
      IOPCAC = IOPSAV
      IF ( IMDL .EQ. 1 ) CALL SOLINT
      CALL COLIMI
      CALL INITR1
      CALL PENDULE
      DO 300 ITG = 1, ITGMAX
      NITG = ITG
      CALL HYESEI
      IF ( IOPCAC .EQ. 3 ) CALL ABSCON ( 0 )
      DO 200 IT = 1, NTAR
      IF ( ICTR(IT) .GE. 3 ) GO TO 200
      CALL RPCDEF ( IT, 0 )
 200  CONTINUE
      IF ( IOPFEV .GE. 3 ) THEN
      DO 250 IT = 1, NTAR
      IF ( IOPERA(IT) .EQ. 0 ) GO TO 250
      CALL ECRFEV ( 1, NFR, IT, NZ, FEVK(1,1,IT) )
 250  CONTINUE
      DO 260 IT = 1, NTAC
      IF ( IOPECO(IT) .EQ. 0 ) GO TO 260
      CALL ECRFEV ( 2, NFRC, IT, NZ, FKTC(1,1,IT) )
 260  CONTINUE
      END IF
      CALL ESTR6
      CALL NOVTER
      CALL PENDULE
 300  CONTINUE
      IF ( IOPFEV .GE. 2 ) THEN
      DO 350 IT = 1, NTAR
      IF ( IOPERA(IT) .EQ. 0 ) GO TO 350
      CALL ECRFEV ( 1, NFR, IT, NZ, FEVK(1,1,IT) )
 350  CONTINUE
      DO 360 IT = 1, NTAC
      IF ( IOPECO(IT) .EQ. 0 ) GO TO 360
      CALL ECRFEV ( 2, NFRC, IT, NZ, FKTC(1,1,IT) )
 360  CONTINUE
      END IF
      CALL TESTH6
      IF ( IOPTOC .EQ. 1 ) CALL IMTOCS ( NZ )
!     CALL IMPERA
      IF ( IPROM .EQ. 1 ) CALL SORTAB
      IF ( ICATA .GE. 1 ) CALL CATFIC
      IF ( ICATA .GE. 2 ) CALL IMPIMO ( NZ, Z )
      CALL PENDULE
 500  CONTINUE

      RETURN
      END
      SUBROUTINE ABSCON ( IVISU )

!              CALCUL DE L'ABSORPTION CONTINUE AU VOISINAGE DES
!         RAIES ETUDIEES.

      PARAMETER ( NARA=10 )
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &  
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP) 
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


 1    FORMAT ( 1H1,30X, 'ABSORPTION CONTINUE POUR LA RAIE NO. ', I3 &
     &, 10X, 9HLAMBDA = , F10.2, 10H ANGSTROMS  // &
     & 8X,3HTAU,8X,3HCAC,6X,8HRAYLEIGH,6X,3HH2+,7X,3H H-,5X,7HTHOMSON &
     &,6X,1HH,9X,1HC,8X,2HMG,8X,2HAL,8X,2HSI,8X,2HFE / )
 2    FORMAT ( 1X, I3, 2(2X,1PE9.2), 10(1X,0PF9.6) )
 3    FORMAT ( 1X )

      DIMENSION TAUC(NZMX)
      COMMON /ABSCOM/ ARA(NZMX,NARA), THETA(NZMX), HNEUT(NZMX) &
     &, CABA(NZMX), FSCA(NZMX), CABH(NZMX), FSCH(NZMX), CABD(NZMX) &
     &, DTAU(NZMX)

      DO 400 IT = 1, NTAR
      NT = NTR(IT)
      NI = NINF(NT)
      NS = NSUP(NT)
      FREQ = FRN(NS) - FRN(NI)
      AMBDA = 1.E8 * CL / FREQ
      CALL PROFSC ( 1, FREQ, TAUC, SC(1,IT), DCAC(1,IT), CAC(1,IT) )
      DO 200 J = 1, NARA
      DO 200 IZ = 1, NZ
      ARA(IZ,J) = ARA(IZ,J) / CAC(IZ,IT)
 200  CONTINUE
      IF ( IVISU .EQ. 0 ) GO TO 400
      DO 300 IZ = 1, NZ
      IF ( MOD(IZ,50) .EQ. 1 ) WRITE ( 6, 1 ) IT, AMBDA
      IF ( MOD(IZ,10) .EQ. 1 ) WRITE ( 6, 3 )
      WRITE ( 6, 2 ) IZ, TAUC(IZ), CAC(IZ,IT), ( ARA(IZ,J), J=1,NARA )
 300  CONTINUE
 400  CONTINUE
      RETURN
      END
      SUBROUTINE PROFSC ( IOPHBF, FREQ, TAUC, FSC, CSCAT, CABCO )

!              CALCUL DES PROFONDEURS OPTIQUES ( TAUC ), DES FONCTIONS
!         SOURCES CONTINUES ( FSC ) ET DES TAUX DE DIFFUSION PURE
!         ( CSCAT ) POUR UNE FREQUENCE DONNEE ( FREQ )
!         CABCO : COEFFICIENT D/ ABSORPTION CONTINUE
!
!              OPTIONS :
!         IOPHBF = 0 : SUPPRESSION DE LA CONTRIBUTION DE L/ HYDROGENE
!         LIE-LIBRE
!         IOPHBF = 1 : CALCUL COMPLET

      PARAMETER ( NARA=10 )
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      DIMENSION TAUC(1), FSC(1), CSCAT(1), CABCO(1)

      COMMON /ABSCOM/ ARA(NZMX,NARA), THETA(NZMX), HNEUT(NZMX) &
     &, CABA(NZMX), FSCA(NZMX), CABH(NZMX), FSCH(NZMX), CABD(NZMX) &
     &, DTAU(NZMX) 
      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


      FRLM = 1.E8 * CL / WLYA
      DO 120 IZ = 1, NZ
      THETA(IZ) = 5040.4 / TE(IZ)
      HNEUT(IZ) = HNH(IZ) - HN(IZ,NK)
 120  CONTINUE
      DO 200 IZ = 1, NZ
      ARA(IZ,1) = 0.0
      IF ( FREQ .LE. FRLM ) ARA(IZ,1) = DIFRAY ( FREQ, HNEUT(IZ) )
      ARA(IZ,2) = 0.0
      ARA(IZ,3) = CABHM ( FREQ, TE(IZ), HNEUT(IZ), HNE(IZ) )
      ARA(IZ,4) = HNE(IZ) * 6.653E-25
 200  CONTINUE
      IF ( IOPHBF .EQ. 1 ) THEN
      CALL ABSHYD ( NZ, FREQ, TE, HNE, NND, HN, CABH, FSCH )
      ELSE
      DO 220 IZ = 1, NZ
      CABH(IZ) = 0.0
      FSCH(IZ) = 0.0
 220  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) = C4 * FREQ**3 / ( EXP ( HP * FREQ / ( BOLT * TE(IZ) ) ) &
     &           - 1.0 )
 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
      FUNCTION CABHM ( FREQ, T, HNEUT, XNE )

!         Coefficient d'absorption continue par l'ion H-
!       d'apres 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 )

      COMMON /COMHM/ CBF(6), A(6), B(6), C(6), D(6), E(6), F(6), AA(4) &
     & , BB(4), CC(4), DD(4), EE(4), FF(4), AUX(6)

      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 100 J = 1, 6
      FLA = FLA + CBF(J) * COEF**(0.5*FLOAT(J-1))
 100  CONTINUE
      SIG = 1.E-18 * WL**3 * COEF**1.5 * FLA
      CABF = ( 0.75 / T**2.5 ) * EXP ( ALPHA/(WL0*T) ) &
     & * ( 1.0 - EXP ( - ALPHA/(WL*T) ) ) * SIG
      GO TO 500
 400  CONTINUE
      CABF = 0.0
 500  CONTINUE

!                "free-free"

      CAFF = 0.0
      IF ( WL .LT. 0.182 ) GO TO 900
      IF ( WL .GT. 0.3645 ) THEN
      AUX(1) = 0.0
      DO 600 J = 2, 6
      AUX(J) = WL * WL * A(J) + B(J) + ( C(J) + ( D(J) + &
     & ( E(J) + F(J) / WL ) / WL ) / WL ) / WL
 600  CONTINUE
      ELSE
      DO 700 J = 1, 4
      AUX(J) = WL * WL * AA(J) + BB(J) + ( CC(J) + ( DD(J) + &
     & ( EE(J) + FF(J) / WL ) / WL ) / WL ) / WL
 700  CONTINUE
      AUX(5) = 0.0
      AUX(6) = 0.0
      END IF
      DO 800 J = 1, 6
      CAFF = CAFF + AUX(J) * 1.E-29 * (5040./T)**(0.5*FLOAT(J+1))
 800  CONTINUE
 900  CONTINUE
      CABHM = ( CABF + CAFF ) * HNEUT * XNE * BOLT * T

      RETURN
      END
      SUBROUTINE ABSHYD ( NZ, FREQ, T, XNE, NNDH, XNH, CABH, FSCH )

!              Calcul du coefficient d'absorption ( CABH ) et de la
!         fonction source ( FSCH ) associes aux transitions continues
!         de l'hydrogene
!         FREQ = frequence
!         T = temperature
!         XNE = densite electronique
!         NNDH = nombre de niveaux discrets de l'hydrogene
!         XNH(1,...,NNDH+1) = populations des niveaux

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      PARAMETER ( RYD = 2.17875E-11 )

      DIMENSION T(NZ), XNE(NZ), XNH(NZMX,NN), CABH(NZ), FSCH(NZ)
      DIMENSION ETLJC(NZMX), FSCJ(NZMX), CEMH(NZMX)

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA


      HNU = HP * FREQ
      NC = NNDH + 1
      DO 120 IZ = 1, NZ
      CABH(IZ) = 0.0
      CEMH(IZ) = 0.0
 120  CONTINUE
      DO 300 J = 1, NNDH
      XJ2 = FLOAT ( J * J )
      EJK = RYD / XJ2
      IF ( HNU .LT. EJK ) GO TO 300
      POMJ = XJ2 + XJ2
      SEJ = SEPION ( FREQ, J )
      DO 160 IZ = 1, NZ
      CABH(IZ) = CABH(IZ) + XNH(IZ,J) * SEJ
 160  CONTINUE
      DO 200 IZ = 1, NZ
      ETLJC(IZ) = XNE(IZ) * POMJ * EXP ( EJK / ( BOLT * T(IZ) ) ) &
     &            / ( C5 * T(IZ)**1.5 )
      FSCJ(IZ) = C4 * FREQ**3 * EXP ( - HNU / ( BOLT * T(IZ) ) ) &
     &           * XNH(IZ,NC) * ETLJC(IZ) / XNH(IZ,J)
 200  CONTINUE
      DO 220 IZ = 1, NZ
      CEMH(IZ) = CEMH(IZ) + XNH(IZ,J) * SEJ * FSCJ(IZ)
 220  CONTINUE
 300  CONTINUE
      IF ( CABH(1) .NE. 0.0 ) THEN
      DO 400 IZ = 1, NZ
      FSCH(IZ) = CEMH(IZ) / CABH(IZ)
 400  CONTINUE
      ELSE
      DO 420 IZ = 1, NZ
      FSCH(IZ) = 0.0
 420  CONTINUE
      END IF

      RETURN
      END
      SUBROUTINE ABSSIL ( NZ, FREQ, T, XNH, XNE, CAB )

!              ABSORPTION CONTINUE PAR LE SILICIUM ( 8 NIVEAUX )
!        EN E.T.L.

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )


      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA


      DIMENSION T(NZ), XNH(NZ), XNE(NZ), CAB(NZ)

      COMMON /CABSSI/ ABON, NC &
     &, CAT(NZMX), XNT(NZMX), SOM(NZMX), XN(NZMX,9) &
     &, 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 120 IZ = 1, NZ
      CAT(IZ) = BOLT * T(IZ)
      XNT(IZ) = XNH(IZ) * ABON
      XN(IZ,1) = 1.0
      SOM(IZ) = 1.0
 120  CONTINUE
      NM1 = NC - 1
      DO 160 I = 2, NM1
      DFR = FR1 - 1.E4 * CL / WLION(I)
      DO 160 IZ = 1, NZ
      XN(IZ,I) = ( GPS(I) / GPS(1) ) * EXP ( - HP * DFR / CAT(IZ) )
      SOM(IZ) = SOM(IZ) + XN(IZ,I)
 160  CONTINUE
      DO 180 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)
 180  CONTINUE
      DO 200 I = 1, NC
      DO 200 IZ = 1, NZ
      XN(IZ,I) = XN(IZ,I) * XNT(IZ) / SOM(IZ)
 200  CONTINUE
      DO 220 IZ = 1, NZ
      SOM(IZ) = 0.0
 220  CONTINUE
      DO 300 I = 1, NM1
      IF ( WL .GT. WLION(I) ) GO TO 300
      IF ( I .EQ. 1 ) GO TO 240
      SEFF = A(I) * ( WL / WLION(I) ) ** S(I)
      GO TO 260
 240  CONTINUE
      SEFF = A(1)
      IF ( WL .LT. 0.135 ) SEFF = A(1) * ( WL / 0.135 ) ** S(1)
 260  CONTINUE
      DO 280 IZ = 1, NZ
      SOM(IZ) = SOM(IZ) + XN(IZ,I) * SEFF
 280  CONTINUE
 300  CONTINUE
      DO 400 IZ = 1, NZ
      CAB(IZ) = SOM(IZ) * 1.E-18 * ( 1.0 - EXP ( - HP * FREQ / CAT(IZ) ) &
     &          )
 400  CONTINUE

      RETURN
      END
      SUBROUTINE ABSCAR ( NZ, FREQ, T, XNH, XNE, CAB )

!              ABSORPTION CONTINUE PAR LE CARBONE ( E.T.L. )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )


      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA


      DIMENSION T(NZ), XNH(NZ), XNE(NZ), CAB(NZ)

      COMMON /CABSC/ ABON, NC &
     &, CAT(NZMX), XNT(NZMX), SOM(NZMX), XN(NZMX,9)&
     &, 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 120 IZ = 1, NZ
      CAT(IZ) = BOLT * T(IZ)
      XNT(IZ) = XNH(IZ) * ABON
      XN(IZ,1) = 1.0
      SOM(IZ) = 1.0
 120  CONTINUE
      NM1 = NC - 1
      DO 160 I = 2, NM1
      DFR = FR1 - 1.E4 * CL / WLION(I)
      DO 160 IZ = 1, NZ
      XN(IZ,I) = ( GPS(I) / GPS(1) ) * EXP ( - HP * DFR / CAT(IZ) )
      SOM(IZ) = SOM(IZ) + XN(IZ,I)
 160  CONTINUE
      DO 180 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)
 180  CONTINUE
      DO 200 I = 1, NC
      DO 200 IZ = 1, NZ
      XN(IZ,I) = XN(IZ,I) * XNT(IZ) / SOM(IZ)
 200  CONTINUE
      DO 220 IZ = 1, NZ
      SOM(IZ) = 0.0
 220  CONTINUE
      DO 300 I = 1, NM1
      IF ( WL .GT. WLION(I) ) GO TO 300
      SEFF = A(I) * ( WL / WLION(I) ) ** S(I)
      IF ( I .LE. 3 ) SEFF = SEFF - AP(I) * ( WL / WLION(I) ) ** SP(I)
      DO 280 IZ = 1, NZ
      SOM(IZ) = SOM(IZ) + XN(IZ,I) * SEFF
 280  CONTINUE
 300  CONTINUE
      DO 400 IZ = 1, NZ
      CAB(IZ) = SOM(IZ) * 1.E-18 * ( 1.0 - EXP(-HP*FREQ/CAT(IZ)) )
 400  CONTINUE

      RETURN
      END
      SUBROUTINE ABSMAG ( NZ, FREQ, T, XNH, XNE, CAB )

!              ABSORPTION CONTINUE PAR LE MAGNESIUM ( E.T.L. )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )


      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA


      DIMENSION T(NZ), XNH(NZ), XNE(NZ), CAB(NZ)

      COMMON /CABSMG/ ABON, NC &
     &, CAT(NZMX), XNT(NZMX), SOM(NZMX), XN(NZMX,9) &
     &, 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 120 IZ = 1, NZ
      CAT(IZ) = BOLT * T(IZ)
      XNT(IZ) = XNH(IZ) * ABON
      XN(IZ,1) = 1.0
      SOM(IZ) = 1.0
 120  CONTINUE
      NM1 = NC - 1
      DO 160 I = 2, NM1
      DFR = FR1 - 1.E4 * CL / WLION(I)
      DO 160 IZ = 1, NZ
      XN(IZ,I) = ( GPS(I) / GPS(1) ) * EXP ( - HP * DFR / CAT(IZ) )
      SOM(IZ) = SOM(IZ) + XN(IZ,I)
 160  CONTINUE
      DO 180 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)
 180  CONTINUE
      DO 200 I = 1, NC
      DO 200 IZ = 1, NZ
      XN(IZ,I) = XN(IZ,I) * XNT(IZ) / SOM(IZ)
 200  CONTINUE
      DO 220 IZ = 1, NZ
      SOM(IZ) = 0.0
 220  CONTINUE
      DO 300 I = 1, NM1
      IF ( WL .GT. WLION(I) ) GO TO 300
      SEFF = A(I) * ( WL / WLION(I) ) ** S(I)
      IF ( I .EQ. 3 ) SEFF = SEFF - 7.8 * ( WL / WLION(I) ) ** 9.5
      DO 280 IZ = 1, NZ
      SOM(IZ) = SOM(IZ) + XN(IZ,I) * SEFF
 280  CONTINUE
 300  CONTINUE
      DO 400 IZ = 1, NZ
      CAB(IZ) = SOM(IZ) * 1.E-18 * ( 1.0 - EXP(-HP*FREQ/CAT(IZ)) )
 400  CONTINUE

      RETURN
      END
      SUBROUTINE ABSALU ( NZ, FREQ, T, XNH, XNE, CAB )

!              ABSORPTION CONTINUE PAR L' ALUMINIUM ( E.T.L. )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA


      DIMENSION T(NZ), XNH(NZ), XNE(NZ), CAB(NZ)
 
      COMMON /CABSAL/ ABON, NC &
     &, CAT(NZMX), XNT(NZMX), SOM(NZMX), XN(NZMX,9) &
     &, 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 120 IZ = 1, NZ
      CAT(IZ) = BOLT * T(IZ)
      XNT(IZ) = XNH(IZ) * ABON
      XN(IZ,1) = 1.0
      SOM(IZ) = 1.0
 120  CONTINUE
      NM1 = NC - 1
      DO 160 I = 2, NM1
      DFR = FR1 - 1.E4 * CL / WLION(I)
      DO 160 IZ = 1, NZ
      XN(IZ,I) = ( GPS(I) / GPS(1) ) * EXP ( - HP * DFR / CAT(IZ) )
      SOM(IZ) = SOM(IZ) + XN(IZ,I)
 160  CONTINUE
      DO 180 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)
 180  CONTINUE
      DO 200 I = 1, NC
      DO 200 IZ = 1, NZ
      XN(IZ,I) = XN(IZ,I) * XNT(IZ) / SOM(IZ)
 200  CONTINUE
      DO 220 IZ = 1, NZ
      SOM(IZ) = 0.0
 220  CONTINUE
      DO 300 I = 1, NM1
      IF ( WL .GT. WLION(I) ) GO TO 300
      SEFF = A(I) * ( WL / WLION(I) ) ** S(I)
      DO 280 IZ = 1, NZ
      SOM(IZ) = SOM(IZ) + XN(IZ,I) * SEFF
 280  CONTINUE
 300  CONTINUE
      DO 400 IZ = 1, NZ
      CAB(IZ) = SOM(IZ) * 1.E-18 * ( 1.0 - EXP ( - HP * FREQ / CAT(IZ) & 
     &          ) )
 400  CONTINUE

      RETURN
      END
      SUBROUTINE ABSFER ( NZ, FREQ, T, XNH, XNE, CAB )

!              ABSORPTION CONTINUE PAR LE FER ( E.T.L. )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA


      DIMENSION T(NZ), XNH(NZ), XNE(NZ), CAB(NZ)

      COMMON /CABSFE/ ABON, NC &
     &, CAT(NZMX), XNT(NZMX), SOM(NZMX), XN(NZMX,3) & 
     &, 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 120 IZ = 1, NZ
      CAT(IZ) = BOLT * T(IZ)
      XNT(IZ) = XNH(IZ) * ABON
      XN(IZ,1) = 1.0
      SOM(IZ) = 1.0
 120  CONTINUE
      NM1 = NC - 1
      DO 160 I = 2, NM1
      DFR = FR1 - 1.E4 * CL / WLION(I)
      DO 160 IZ = 1, NZ
      XN(IZ,I) = ( GPS(I) / GPS(1) ) * EXP ( - HP * DFR / CAT(IZ) )
      SOM(IZ) = SOM(IZ) + XN(IZ,I)
 160  CONTINUE
      DO 180 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)
 180  CONTINUE
      DO 200 I = 1, NC
      DO 200 IZ = 1, NZ
      XN(IZ,I) = XN(IZ,I) * XNT(IZ) / SOM(IZ)
 200  CONTINUE
      DO 220 IZ = 1, NZ
      SOM(IZ) = 0.0
 220  CONTINUE
      DO 300 I = 1, NM1
      IF ( WL .GT. WLION(I) ) GO TO 300
      SEFF = A(I) * ( WL / WLION(I) ) ** S(I)
      DO 280 IZ = 1, NZ
      SOM(IZ) = SOM(IZ) + XN(IZ,I) * SEFF
 280  CONTINUE
 300  CONTINUE
      DO 400 IZ = 1, NZ
      CAB(IZ) = SOM(IZ) * 1.E-18 * ( 1.0 - EXP (-HP*FREQ/CAT(IZ)) )
 400  CONTINUE

      RETURN
      END
      FUNCTION DIFRAY ( FR, XNH )

!           Diffusion Rayleigh pour H neutre
!     (formule obtenue aux moindres carres a partir de la table
!         de Vernazza)
!     FR  : frequence (Hz)
!     XNH : nombre d'atomes de H neutre par cm3

      PARAMETER ( A0=1.05E-6, A1=0.072747, A2=19.045, A3=92.299 &
     &, A4=245.89 )
      DW = ABS ( 2.997925E14/FR - 0.122 )
      DIFRAY = XNH * 1.E-26 / ( A0 + DW * ( A1 + DW * ( A2 + DW * &
     &        ( A3 + DW * A4 ) ) ) )
      RETURN
      END
      FUNCTION BWIEN ( FR, T )
      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      BWIEN = C4 * FR * FR * FR * EXP ( - HP * FR / ( BOLT * T ) )
      RETURN
      END
      SUBROUTINE CATFIC

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      PARAMETER ( NNDCAT=5, NNCAT=NNDCAT+1 )

 1    FORMAT ( 1X, A8, 1X, 60(1H.) )
 2    FORMAT ( / 1X, 20(1H-), ' DEBUT ftn24 ', 20(1H-) )
 3    FORMAT ( 1X, 20(1H-), '  FIN  ftn24 ', 20(1H-) )
 4    FORMAT ( 1X, 2I10, 2F10.1 )
 5    FORMAT ( 1X, I10 )
 6    FORMAT ( 1X, 4E16.8 )

      WRITE ( 24, 2 )
      WRITE ( 24, 1 ) XMOAT
      WRITE ( 24, 4 ) NZ, IZERO, G, VSINI
      WRITE ( 24, 5 ) NNCAT
      WRITE ( 24, 6 ) ( XM(I), I = 1, NZ )
      WRITE ( 24, 6 ) ( TE(I), I = 1, NZ )
      WRITE ( 24, 6 ) ( VT(I), I = 1, NZ )
      WRITE ( 24, 6 ) ( Z(I), I = 1, NZ )
      WRITE ( 24, 6 ) ( HNH(I), I = 1, NZ )
      WRITE ( 24, 6 ) ( HNE(I), I = 1, NZ )
      DO 200 J = 1, NNDCAT
      WRITE ( 24, 6 ) ( TR(I,J), I = 1, NZ )
 200  CONTINUE
      DO 300 J = 1, NNDCAT
      WRITE ( 24, 6 ) ( HN(I,J), I = 1, NZ )
 300  CONTINUE
      WRITE ( 24, 6 ) ( HN(I,NK), I = 1, NZ )
!      WRITE ( 24, 3 )

      RETURN
      END
      SUBROUTINE CATF27

!        Variante de "CATFIC" adaptee aux problemes d'hydrodynamique
!     (exemple : RLXT)
!     Les parametres sont ecrits sur le fichier 27

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )
 
      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      PARAMETER ( NNDCAT=5, NNCAT=NNDCAT+1 )

 2    FORMAT ( / 1X, 20(1H-), ' DEBUT ftn27 ', 20(1H-) )
 3    FORMAT ( 1X, 20(1H-), '  FIN  ftn27 ', 20(1H-) )
 4    FORMAT ( 1X, I10, 2E16.8 )
 6    FORMAT ( 1X, 4E16.8 )

      WRITE ( 27, 2 )
      WRITE ( 27, 4 ) NZ, XM(IZERO), G
      WRITE ( 27, 6 ) ( XM(I), I = 1, NZ )
      WRITE ( 27, 6 ) ( TE(I), I = 1, NZ )
      WRITE ( 27, 6 ) ( VT(I), I = 1, NZ )
      WRITE ( 27, 6 ) ( Z(I), I = 1, NZ )
      WRITE ( 27, 6 ) ( C1*HNH(I), I = 1, NZ )
      WRITE ( 27, 6 ) ( HNH(I), I = 1, NZ )
      WRITE ( 27, 6 ) ( HNE(I), I = 1, NZ )
      WRITE ( 27, 6 ) ( HN(I,NK), I = 1, NZ )
      WRITE ( 27, 3 )

      RETURN
      END
      SUBROUTINE COHEVA ( NFR, XNE, XN1, T, DFR, COHLA )

!         Calcul du coefficient de coherence, variable avec la
!         frequence, pout la raie Lyman-alpha de l'hydrogene

      DIMENSION DFR(NFR), COHLA(NFR)

!              Elargissement naturel

      GAMNA = 4.7E8

!              Elargissement de resonance
!          (Lortet & Roueff, 1969, A&A 3, 462)
!
      GAMRE = 4.93E-8 * XN1

!              Elargissement Stark
!         (d'apres 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 - &
     &        ALOG ( 4.0*COEFC*COEFC ) )
      GEHOL = 16.76 * XNE / SQRT ( FRCE )
      GIIMP = 3.13E-3 * ( XNE / SQRT ( T ) ) * ( COEFB - &
     &        ALOG ( 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 = ALOG ( DFR(J) )
      XS1 = ALOG ( FRPE )
      XS2 = ALOG ( 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 = ALOG ( DFR(J) )
      XS1 = ALOG ( FRPI )
      XS2 = ALOG ( 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 COHEVAL ( NFR, XNE, XN1, T, GAMAMX, DFR, COHLA )

!     Coefficient de coherence variable pour Lyman-alpha
!     (d'apres Vernazza, Avrett, Loeser 1981, ApJS 45, 635)
!
      PARAMETER ( CLA=2.998E18, WL0=1216. )
      DIMENSION DFR(NFR), COHLA(NFR)

      RN1 = XN1 / 1.E13
      RNE = XNE / 5.E10
      RT = T / 6500.
      ZETA1 = 0.0014 * SQRT ( RNE )
      ZETA2 = 44.5 * RT
      ZETA2P = 0.024 * RT
      DLDF = WL0**2 / CLA

      GNAT = 4.70E8
      GRES = 4.93E5 * RN1
      TRUC = 1.0 - 0.051 * ALOG ( RNE/RT**2 )
      GEIMP = 1.26E6 * TRUC * RNE / SQRT ( RT )
      ETA = 0.071 / TRUC

      DO 200 J = 1, NFR
      DWL = DLDF * DFR(J)
! ... effet Stark pour les electrons
      IF ( DWL .LT. ZETA1 ) GO TO 120
      IF ( DWL .GT. ZETA2 ) GO TO 140
      GO TO 160
 120  CONTINUE
      GSE = GEIMP
      GO TO 180
 140  CONTINUE
      GSE = GEIMP * ETA * SQRT ( ZETA2 / DWL )
      GO TO 180
 160  CONTINUE
      GSE = GEIMP * ( 1.0 + ( ETA - 1.0 ) * ALOG ( DWL/ZETA1 ) / &
     & ALOG ( ZETA2/ZETA1 ) )
 180  CONTINUE
! ... effet Stark pour les protons
      IF ( DWL .LT. ZETA2P ) THEN
      GSP = GEIMP
      ELSE
      GSP = 5.90E5 * RNE / SQRT ( DWL )
      END IF
      GCOL = GRES + GSE + GSP
      COHLA(J) = GNAT / ( GNAT + GCOL )
      COHLA(J) = AMIN1 ( COHLA(J), GAMAMX )
 200  CONTINUE

      RETURN
      END
      SUBROUTINE COLIMI

!              CONDITION A LA LIMITE SUPERIEURE :
!         - COUCHE HORIZONTALE : INTENSITE INCIDENTE NULLE
!         - COUCHE VERTICALE : INTENSITE INCIDENTE EGALE EN MOYENNE
!         A CELLE EMISE PAR LE DISQUE SOLAIRE, MULTIPLIEE PAR UN FACTEUR
!         DE DILUTION COMPRIS ENTRE 0 ET 0.5 ( ENVIRON OMEGA/(4*PI),
!         OMEGA ETANT L'ANGLE SOLIDE SOUS LEQUEL ON VOIT LE SOLEIL ).

!              CONDITION A LA LIMITE INFERIEURE :
!         - COUCHE HORIZONTALE : INTENSITE INCIDENTE EGALE A CELLE
!         EMISE PAR LE DISQUE SOLAIRE, MULTIPLIEE PAR UN FACTEUR DE
!         DILUTION COMPRIS ENTRE 0 ET 1 ( ENVIRON OMEGA/(2*PI) ).
!         - COUCHE VERTICALE : GRADIENT D'INTENSITE NUL AU MILIEU DE
!         LA COUCHE (SYMETRIE).

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA


      DIMENSION FLJ(NFR)
!              Conditions aux limites pour les raies.

      DO 200 IT = 1, NTAR
      IF ( ICTR(IT) .EQ. 5 ) GO TO 190
      DO 120 J = 1, NFR
      FRR(J,IT) = DNDREF(IT) * XFR(J)
 120  CONTINUE
      DO 140 J = 1, NFR
      CALL INTERL ( NFINT(IT), FRFI(1,IT), FINT(1,IT), FRR(J,IT) &
     &            , FLJ(J) )
 140  CONTINUE
      IF ( IVERT .EQ. 0 ) THEN
      DO 160 J = 1, NFR
      FIIR(J,IT) = FADI(IT) * FLJ(J)
      FISR(J,IT) = 0.0
 160  CONTINUE
      ELSE
      DO 180 J = 1, NFR
      FIIR(J,IT) = 0.0
      FISR(J,IT) = FADI(IT) * FLJ(J)
 180  CONTINUE
      END IF
      GO TO 200
 190  CONTINUE
      NT = NTR(IT)
      FR0 = FRN(NSUP(NT)) - FRN(NINF(NT))
      AMBDA = 1.E4 * CL / FR0
      TB = TEMBRI ( AMBDA )
      HJB = C4 * FR0**3 / ( EXP(HP*FR0/(BOLT*TB)) - 1.0 )
      GIOM(IT) = FADI(IT) * HJB
      IF ( IVERT .EQ. 0 ) GIOM(IT) = GIOM(IT) * 0.5
 200  CONTINUE

!              Conditions aux limites pour les continus.

      DO 300 IT = 1, NTAC
      NT = NTC(IT)
      NI = NINF(NT)
      FR0 = FRN(NK) - FRN(NI)
      DO 220 J = 1, NFRC
      FRC(J,IT) = FR0 * XFRC(J)
 220  CONTINUE
      IF ( IVERT .EQ. 0 ) THEN
      DO 240 J = 1, NFRC
      AMBDA = 1.E4 * CL / FRC(J,IT)
      TB = TEMBRI ( AMBDA )
      FIIC(J,IT) = BENU ( FRC(J,IT), TB ) * FADI(NTAR+IT)
      FISC(J,IT) = 0.0
 240  CONTINUE
      ELSE
      DO 260 J = 1, NFRC
      AMBDA = 1.E4 * CL / FRC(J,IT)
      TB = TEMBRI ( AMBDA )
      FIIC(J,IT) = 0.0
      FISC(J,IT) = BENU ( FRC(J,IT), TB ) * FADI(NTAR+IT)
 260  CONTINUE
      END IF
 300  CONTINUE

      RETURN
      END
      SUBROUTINE COLIM3

!              Conditions aux limites pour une atmosphere:
!         - en haut: intensite incidente nulle
!         - en bas: fonction de Planck

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA


!              Conditions aux limites pour les raies.

      DO 200 IT = 1, NTAR
      DO 120 J = 1, NFR
      FRR(J,IT) = DNDREF(IT) * XFR(J)
 120  CONTINUE
      NT = NTR(IT)
      FR0 = FRN(NSUP(NT)) - FRN(NINF(NT))
      HJB = BENU ( FR0, TE(NZ) )
      DO 200 J = 1, NFR
      FIIR(J,IT) = HJB
      FISR(J,IT) = 0.0
 200  CONTINUE

!              Conditions aux limites pour les continus.

      DO 300 IT = 1, NTAC
      NT = NTC(IT)
      NI = NINF(NT)
      FR0 = FRN(NK) - FRN(NI)
      DO 220 J = 1, NFRC
      FRC(J,IT) = FR0 * XFRC(J)
 220  CONTINUE
      DO 240 J = 1, NFRC
      FIIC(J,IT) = BENU ( FRC(J,IT), TE(NZ) )
      FISC(J,IT) = 0.0
 240  CONTINUE
 300  CONTINUE

      RETURN
      END
      SUBROUTINE COMPAC ( EMIN, EMAX )
 1    FORMAT (5X, 7HCONTINU, 2I3, 5X, 6HEMIN =, F10.6, 5X, 6HEMAX =, &
     & F10.6, 5X, 6HEMOY =, F10.6, 5X, 5HEQM =, F10.6 )
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      FN = 1. / FLOAT ( NZ )
      PREC = 0.
      DO 20 ITAC = 1 , NTAC
      IF ( ICTC(ITAC) .GT. 2 ) GO TO 20
      NT = NTC(ITAC)
      NI = NINF(NT)
      EMIN = 1.
      EMAX = -1.
      EMOY = 0.
      EQM = 0.
      DO 30 IZ = 1, 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
      EMOY = EMOY + ER
      EQM = EQM + ER * ER
 30   CONTINUE
      EMOY = EMOY * FN
      EQM = SQRT ( EQM * FN )
!     WRITE ( 8, 1 ) NI, NK, EMIN, EMAX, EMOY, EQM
      IF ( EQM .GT. PREC ) PREC = EQM
 20   CONTINUE
      EQM = PREC
      RETURN
      END
      SUBROUTINE COMPAR ( EMIN1, EMAX1, EMIN2, EMAX2, EMIN3, EMAX3 )
 1    FORMAT ( 5X, 4HRAIE, 2I3, 5X, 6HEMIN =, F10.6, 5X, 6HEMAX =, &
     & F10.6, 5X,6HEMOY =,F10.6,5X,5HEQM =,F10.6,5X,6HEQMR =,F10.6 )
 2    FORMAT ( ' EQM(raies) = ', 10(1X,F10.6) )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) & 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP) 
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      DIMENSION AUX(NTAR)

      FN = 1. / FLOAT(NZ)
      PREC = 0.
      DO 20 IT = 1 , NTAR
      IF ( ICTR(IT) .GT. 2 ) GO TO 20
      NT = NTR(IT)
      NI = NINF(NT)
      NS = NSUP(NT)
      EMIN = 1.
      EMAX = -1.
      EMOY = 0.
      EQM = 0.
      VM = 0.
      DO 30 IZ = 1, NZ
      R1 = BRN(IZ,IT)
      R2 = BRP(IZ,IT)
      ER = R2 - R1
      VM = VM + ABS ( R1 ) + ABS ( R2 )
      IF ( ER .LT. EMIN ) EMIN = ER
      IF ( ER .GT. EMAX ) EMAX = ER
      EMOY = EMOY + ER
      EQM = EQM + ER * ER
 30   CONTINUE
      VM = 0.5 * VM * FN
      EMOY = EMOY * FN
      EQM = SQRT ( EQM * FN )
      AUX(IT) = EQM
      EQMR = EQM / VM
      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
!     WRITE ( 8, 1 ) NI, NS, EMIN, EMAX, EMOY, EQM, EQMR
      IF ( EQMR .GT. PREC ) PREC = EQMR
 20   CONTINUE
      EQMR = PREC
!     WRITE ( 8, 2 ) ( AUX(IT), IT = 1, NTAR )

      RETURN
      END
      SUBROUTINE CSIETA
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG & 
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /TRANC/ NT, FR0, L1, L2, TO(NZMX) & 
     &, CSI0(NZMX), ETA0(NZMX), GIBAR(NZMX), FR(NFRC), WF(NFRC) & 
     &, PHI(NFRC), CNORM & 
     &, RAE(NZMX,NFRC), SAE(NZMX,NFRC), CAE(NZMX,NFRC)

      DIMENSION XXX(NZMX), YYY(NZMX)
      CALL CSIETA1
      IF ( CSCOEF .EQ. 1. ) RETURN
      DO 100 IZ = 1 , NZ
      XXX(IZ) = CSI0(IZ)
      YYY(IZ) = ETA0(IZ)
 100  CONTINUE
      CALL CSIETA2
      C2 = 1. - CSCOEF
      DO 200 IZ = 1 , NZ
      CSI0(IZ) = CSCOEF * XXX(IZ) + C2 * CSI0(IZ)
      ETA0(IZ) = CSCOEF * YYY(IZ) + C2 * ETA0(IZ)
 200  CONTINUE
      RETURN
      END
      SUBROUTINE  CSIETA1
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT 
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) & 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG & 
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF
 
      COMMON /TRANC/ NT, FR0, L1, L2, TO(NZMX) & 
     &, CSI0(NZMX), ETA0(NZMX), GIBAR(NZMX), FR(NFRC), WF(NFRC) & 
     &, PHI(NFRC), CNORM &
     &, RAE(NZMX,NFRC), SAE(NZMX,NFRC), CAE(NZMX,NFRC)

      DIMENSION PJK(500)
      NI = NINF(NT)
      NTP = ITP(NT)
      NTPC = NTP - NTAR
      FR0 = FRN(NK) - 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 / ( UK * C5 * TZ**1.5 )
      PJK(NN) = 0.
      DO 20 J = 1 , NND
      IT = ((NK-1) * (NK-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 , NND
      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 CSIETA2
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &  
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) & 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) & 
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG & 
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /TRANC/ NT, FR0, L1, L2, TO(NZMX) & 
     &, CSI0(NZMX), ETA0(NZMX), GIBAR(NZMX), FR(NFRC), WF(NFRC) & 
     &, PHI(NFRC), CNORM & 
     &, RAE(NZMX,NFRC), SAE(NZMX,NFRC), CAE(NZMX,NFRC)

      DIMENSION P(225),A(196),B(79)
      NI = NINF(NT)
      NTP = ITP(NT)
      NTPC = NTP - NTAR
      FR0 = FRN(NK) - 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 / ( UK * C5 * TZ**1.5 )
      DO 20 IT = 1, NTT
      I = NINF(IT)
      J = NSUP(IT)
      JTP = ITP(IT)
      IJ = NN * ( J - 1 ) + I
      JI = NN * ( I - 1 ) + J
      P(IJ) = CIJ(IZ,IT)
      P(JI) = CJI(IZ,IT)
      IF ( JTP .EQ. 0 ) GO TO 20
      IF ( NSUP(IT) .EQ. NK ) GO TO 150
      P(JI) = P(JI) + AE(JTP) * BRN(IZ,JTP)
      GO TO 20
 150  CONTINUE
      ITAC = JTP - NTAR
      P(IJ) = P(IJ) + RIK(IZ,ITAC)
      P(JI) = P(JI) + RKI(IZ,ITAC)
 20   CONTINUE
      DO 30 I = 1 , NN
      II = NN * ( I - 1 ) + I
      P(II) = 0.
      DO 32 J = 1 , NN
      IF ( I .EQ. J ) GO TO 32
      IJ = NN * ( J - 1 ) + I
      P(II) = P(II) - P(IJ)
 32   CONTINUE
 30   CONTINUE
      DO 40 I = 1 , NND
      DO 42 J = 1 , NND
      IP = J
      IF ( J .GE. NI ) IP = J + 1
      JP = I
      IF ( I .GE. NI ) JP = I + 1
      IJ = NND * ( J - 1 ) + I
      IJP = NN * ( JP - 1 ) + IP
      A(IJ) = P(IJP)
 42   CONTINUE
      NIJP = NN * ( JP - 1 ) + NI
      B(I) = - P(NIJP)
 40   CONTINUE
      CALL INVMAT ( A, NND )
      XIS = - A(NND*NND)
      YIS = 0.
      IF ( NND .LE. 1 ) GO TO 52
      NXX = NND - 1
      DO 50 J = 1 , NXX
      NJ = NND * J
      YIS = YIS + A(NJ) * B(J)
 50   CONTINUE
 52   CONTINUE
      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 ECRIPOP ( IOP )
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
      &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      DIMENSION XXX(NZMX)
 1    FORMAT ( 1H1 )
 2    FORMAT ( 20X, 23HPOPULATIONS DES NIVEAUX / 20X, 23(1H-) / )
 3    FORMAT ( // 30X, 6HNIVEAU, I3 / )
 4    FORMAT ( 10(3X,G10.4) )
 5    FORMAT ( /// 20X, 17HECARTS A L E.T.L. / )
      WRITE ( 6, 1 )
      WRITE ( 6, 2 )
      DO 50 I = 1 , NN
      WRITE ( 6, 3 ) I
      IF ( IOP .EQ. 1 ) WRITE ( 6, 4 ) (HN(IZ,I),IZ=1,NZ)
      IF ( IOP .EQ. 2 ) WRITE ( 6, 4 ) (HNP(IZ,I),IZ=1,NZ)
 50   CONTINUE
      IF ( NTAC .EQ. 0 ) RETURN
      WRITE ( 6, 5 )
      DO 60 I = 1 , NND
      DO 70 IZ = 1, NZ
      T = TE(IZ)
      CAT = BOLT * T
      FREQ = FRN(NK) - FRN(I)
      XX = EXP(HP*FREQ/CAT)
      ETLIS = HNE(IZ) * POM(I) * XX / ( UK * C5 * T**1.5 )
      IF ( IOP .EQ. 1 ) XXX(IZ) = HN(IZ,I) / ( HN(IZ,NK) * ETLIS )
      IF ( IOP .EQ. 2 ) XXX(IZ) = HNP(IZ,I) / ( HNP(IZ,NK) * ETLIS )
 70   CONTINUE
      WRITE ( 6, 3 ) I
      WRITE ( 6, 4 ) (XXX(IZ),IZ=1,NZ)
 60   CONTINUE
      RETURN
      END
      SUBROUTINE ECRITAU ( IOP )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


 1    FORMAT ( 1H1 )
 2    FORMAT ( 20X, 32HTAUX DE TRANSITION COLLISIONNELS / 20X,32(1H-)/)
 3    FORMAT ( // 30X, 4HC ( , I2, 3H , , I2, 2H ) / )
 4    FORMAT ( 10(3X,G10.4) )
 5    FORMAT ( // )
 6    FORMAT ( 20X, 44HTAUX DE TRANSITION RADIATIFS AVANT TRANSFERT / &
     & 20X, 44(1H-) / )
 7    FORMAT ( // 30X, 4HR ( , I2, 3H , , I2, 2H ) / )
 8    FORMAT ( 20X, 44HTAUX DE TRANSITION RADIATIFS APRES TRANSFERT / & 
     & 20X, 44(1H-) / )
 9    FORMAT ( 20X, 27HBILANS RADIATIFS NORMALISES / 20X, 27(1H-) / )
 10   FORMAT ( // 25X, 10HTRANSITION, I3, 10X, 4HNI =, I3, 10X, &
     & 4HNS =, I3 / )
 11   FORMAT ( 40X, 7HANCIENS )
 12   FORMAT ( 40X, 8HNOUVEAUX )

      WRITE ( 6, 1 )
      IF ( IOP ) 20 , 20 , 30
 20   CONTINUE
      WRITE ( 6, 2 )
      DO 22 IT = 1 , NTT
      WRITE ( 6, 3 ) NINF(IT) , NSUP(IT)
      WRITE ( 6, 4 ) ( CIJ(IZ,IT), IZ = 1, NZ )
      WRITE ( 6, 3 ) NSUP(IT) , NINF(IT)
      WRITE ( 6, 4 ) ( CJI(IZ,IT), IZ = 1, NZ )
 22   CONTINUE
      WRITE ( 6, 5 )
      RETURN
 30   CONTINUE
      WRITE ( 6, 9 )
      DO 62 ITAR = 1 , NTAR
      IT = NTR(ITAR)
      WRITE ( 6, 10 ) IT , NINF(IT) , NSUP(IT)
      WRITE ( 6, 11 )
      WRITE ( 6, 4 ) (BRN(IZ,ITAR),IZ=1,NZ)
      WRITE ( 6, 12 )
      WRITE ( 6, 4 ) (BRP(IZ,ITAR),IZ=1,NZ)
 62   CONTINUE
      WRITE ( 6, 5 )
      RETURN
      END
      SUBROUTINE ECRFEV ( NATRA, NF, NT, NZ, FEVK )

!              Ecriture des F. E. V.

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )


      DIMENSION FEVK(NF,NZMX)

 1    FORMAT ( 1H1, ' Facteurs d Eddington pour la raie no.', I3 / )
 2    FORMAT ( 1H1, ' Facteurs d Eddington pour le continu no.', I3 / )
 3    FORMAT ( / 50X, '***  K / J  ***' / )
 4    FORMAT ( 8X, 20('  FR',I2) )
 5    FORMAT ( ' IZ=', I2, 2X, 20F6.3 )

      NFMX = MIN0 ( 20, NF )
      IF ( NATRA .EQ. 1 ) WRITE ( 6, 1 ) NT
      IF ( NATRA .EQ. 2 ) WRITE ( 6, 2 ) NT
      WRITE ( 6, 3 )
      WRITE ( 6, 4 )  ( J, J = 1, NFMX )
      DO 200 I = 1, NZ
      WRITE ( 6, 5 ) I, ( FEVK(J,I), J = 1, NFMX )
 200  CONTINUE

      RETURN
      END
      SUBROUTINE ELCO ( IR, NTR, NINF, NSUP, NZ, T, HNEUT, XNE, DFRCO )

!         ELARGISSEMENT COLLISIONNEL POUR LES RAIES DE L HYDROGENE

      PARAMETER ( PI=3.1415926536, EXPHN=2.65, EXPS=2./3. )

      DIMENSION NTR(1), NINF(1), NSUP(1), T(1), HNEUT(1), XNE(1) & 
     &, DFRCO(1)
      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)

!         Elargissement de resonance et Van der Waals d'apres
!      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

!       Elargissement Stark d'apres 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
      SUBROUTINE EPSBEN

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101  & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      PARAMETER ( NDIMB=NN-1 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &  
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) & 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC)& 
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF 

      COMMON /TRANSF/ NRA, NT, FR0, L1, L2, TO(NZMX) & 
     &, DND(NZMX), AM(NZMX), EPS(NZMX), BEN(NZMX), CAR(NZMX), RF(NZMX) & 
     &, DDC(NZMX), SL(NZMX), GIBAR(NZMX), FR(NFR), R(NFR2) &
     &, PHI(NFR,NZMX), GI(NFR,NZMX), COHE(NZMX)


      DIMENSION P(NN**2,NZMX), A(NDIMB**2,NZMX), B(NDIMB,NZMX) &
     &, U(NZMX), V(NZMX)

      NI = NINF(NT)
      NS = NSUP(NT)
      NTP = ITP(NT)
      GP = POM(NI) / POM(NS)
      FR0 = FRN(NS) - FRN(NI)
      DO 200 IT = 1 ,NTT
      I = NINF(IT)
      J = NSUP(IT)
      IJ = NN * (J-1) + I
      JI = NN * (I-1) + J
      DO 120 IZ = 1, NZ
      P(IJ,IZ) = CIJ(IZ,IT)
      P(JI,IZ) = CJI(IZ,IT)
 120  CONTINUE
      JTP = ITP(IT)
      IF ( JTP .EQ. 0 ) GO TO 180
      IF ( NSUP(IT) .EQ. NK ) GO TO 150
      DO 140 IZ = 1, NZ
      P(JI,IZ) = P(JI,IZ) + AE(JTP) * BRN(IZ,JTP)
 140  CONTINUE
      GO TO 180
 150  CONTINUE
      ITAC = JTP - NTAR
      DO 160 IZ = 1, NZ
      P(IJ,IZ) = P(IJ,IZ) + RIK(IZ,ITAC)
      P(JI,IZ) = P(JI,IZ) + RKI(IZ,ITAC)
 160  CONTINUE
 180  CONTINUE
 200  CONTINUE
      DO 300 I = 1 ,NN
      II = NN * (I-1) + I
      DO 220 IZ = 1, NZ
      P(II,IZ) = 0.0
 220  CONTINUE
      DO 260 J = 1 ,NN
      IF ( I .EQ. J ) GO TO 260
      IJ = NN * (J-1) + I
      DO 240 IZ = 1, NZ
      P(II,IZ) = P(II,IZ) - P(IJ,IZ)
 240  CONTINUE
 260  CONTINUE
 300  CONTINUE
      NM = NN - 1
      DO 400 I = 1, NM
      JP = I
      IF ( I .GE. NS ) JP = I + 1
      JSP = NN * (JP-1) + NS
      DO 320 IZ = 1, NZ
      B(I,IZ) = - P(JSP,IZ)
 320  CONTINUE
      DO 400 J = 1, NM
      IJ = NM * (J-1) + I
      IP = J
      IF ( J .GE. NS ) IP = J + 1
      IJP = NN * (JP-1) + IP
      DO 340 IZ = 1, NZ
      A(IJ,IZ) = P(IJP,IZ)
 340  CONTINUE
 400  CONTINUE
      DO 420 IZ = 1, NZ
      CALL INVMAT ( A(1,IZ), NM )
 420  CONTINUE
      II = NM * ( NI - 1 ) + NI
      DO 440 IZ = 1, NZ
      U(IZ) = - A(II,IZ) * AE(NTP)
      V(IZ) = - A(II,IZ) * CJI(IZ,NT)
 440  CONTINUE
      DO 480 J = 1, NM
      IF ( J .EQ. NI ) GO TO 480
      IJ = NM * ( J - 1 ) + NI
      DO 460 IZ = 1, NZ
      V(IZ) = V(IZ) + A(IJ,IZ) * B(J,IZ)
 460  CONTINUE
 480  CONTINUE
      DO 500 IZ = 1, NZ
      EPS(IZ) = 1.0 / ( 1.0 + U(IZ) / ( V(IZ) - GP ) )
      BEN(IZ) = C4 * FR0**3 / ( V(IZ) / GP - 1.0 )
 500  CONTINUE

      RETURN
      END
      SUBROUTINE EQST ( IOP )

!              Calcul des populations des niveaux conformement a
!         l'equilibre statistique.

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


      DIMENSION P(NN,NN), A(NN,NN), B(NN)

      DO 500 IZ = 1, NZ

      DO 260 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 ) GO TO 260
      IF ( NSUP(IT) .EQ. NK ) GO TO 180
      IF ( IOP .EQ. 1 ) THEN
      P(J,I) = CJI(IZ,IT) + AE(JTP) * BRN(IZ,JTP)
      ELSE
      P(J,I) = CJI(IZ,IT) + AE(JTP) * BRP(IZ,JTP)
      END IF
      GO TO 260
 180  CONTINUE
      ITAC = JTP - NTAR
      IF ( IOP .EQ. 1 ) THEN
      P(I,J) = CIJ(IZ,IT) + RIK(IZ,ITAC)
      ELSE
      P(I,J) = CIJ(IZ,IT) + RIKP(IZ,ITAC)
      END IF
      P(J,I) = CJI(IZ,IT) + RKI(IZ,ITAC)
 260  CONTINUE
      DO 340 I = 1, NN
      P(I,I) = 0.0
      A(I,I) = 0.0
      DO 320 J = 1, NN
      IF ( I .EQ. J ) GO TO 320
      A(I,J) = P(J,I)
      A(I,I) = A(I,I) - P(I,J)
 320  CONTINUE
 340  CONTINUE
      DO 360 J = 1, NN
      A(NN,J) = 1.0
 360  CONTINUE
      CALL INVMAT ( A, NN )
      DO 400 I = 1, NN
      B(I) = A(I,NN) * HNT(IZ)
 400  CONTINUE
! ... correction des populations negatives (dues aux erreurs d'arrondi)
      DO 420 I = 1, NN
      IF ( B(I) .GT. 0.0 ) GO TO 420
      XNUM = 0.0
      XDEN = 0.0
      DO 410 J = 1, NN
      IF ( J .EQ. I ) GO TO 410
      IF ( B(J) .LE. 0.0 ) GO TO 410
      IF ( P(I,J) .LT. 0.0 ) GO TO 410
      IF ( P(J,I) .LT. 0.0 ) GO TO 410
      XNUM = XNUM + B(J) * P(J,I)
      XDEN = XDEN + P(I,J)
 410  CONTINUE
      IF ( XDEN .NE. 0.0 ) THEN
      B(I) = XNUM / XDEN
      ELSE
      B(I) = 0.0
      END IF
 420  CONTINUE
      SOM = 0.0
      DO 430 I = 1, NN
      SOM = SOM + B(I)
 430  CONTINUE
      DO 440 I = 1, NN
      B(I) = HNT(IZ) * B(I) / SOM
 440  CONTINUE
! ...
      IF ( IOP .EQ. 1 ) THEN
      DO 450 I = 1, NN
      HN(IZ,I) = B(I)
 450  CONTINUE
      ELSE
      DO 460 I = 1, NN
      HNP(IZ,I) = B(I)
 460  CONTINUE
      END IF

 500  CONTINUE

      RETURN
      END
      SUBROUTINE ESTR6

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


      IF ( ICRMAX .EQ. 0 ) RETURN
      DO 400 ICR = 1 , ICRMAX
      IF ( IORD .LE. 0 ) GO TO 300
 120  CONTINUE
      CALL EQST ( 1 )
      DO 160 ITAR = 1 , NTAR
      IF ( ICTR(ITAR) .EQ. 1 ) CALL RPRAIE ( ITAR )
      IF ( ICTR(ITAR) .EQ. 5 ) CALL RAOPMI ( ITAR )
 160  CONTINUE
      CALL EQST ( 2 )
      CALL COMPAR ( EMIN1, EMAX1, EMIN2, EMAX2, EMIN3, EMAX3 )
      CALL NOVBRN
      IF ( IORD .LE. 0 ) GO TO 380
 300  CONTINUE
      CALL EQST ( 1 )
      DO 320 ITAC = 1 , NTAC
      IF ( ICTC(ITAC) .GE. 3 ) GO TO 320
      CALL NLTEBF ( ITAC )
 320  CONTINUE
      CALL EQST ( 2 )
      CALL COMPAC ( EMIN, EMAX )
      CALL NOVRIK
      IF ( IORD .LE. 0 ) GO TO 120
 380  CONTINUE
      WRITE ( 8, 399 ) EMIN1, EMAX1, EMIN2, EMAX2, EMIN3, EMAX3, EMIN & 
     &, EMAX
 399  FORMAT ( 8(3X,F12.6 ) )
 400  CONTINUE

      RETURN
      END
      SUBROUTINE EXOATM

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &  
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR)& 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG & 
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA


 1    FORMAT ( 1H1, 9X, 18HETAT ATMOSPHERIQUE , 5X, &
     &  13H( NO. REF. = , A8, 2H ) // )
 2    FORMAT (130H  NO. I    MASSE    I  ALTITUDE   I TEMPERATURE I  VIT &  
     &. MIC.  I DENS. HYD.  I DENS. ELEC. I RAPPORT E/H I  PRESSION   I &
     & DENSITE  )
 3    FORMAT (130H      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(1H-) )
 5    FORMAT ( 1X, I4, 9(3H I , G11.4) )
 6    FORMAT ( 1H1 )

      WRITE ( 6, 1 ) XMOAT
      DO 200 I = 1, NZ
      IF ( MOD(I,50) .NE. 1 ) GO TO 100
      IF ( I .NE. 1 ) WRITE ( 6, 6 )
      WRITE ( 6, 2 )
      WRITE ( 6, 3 )
      WRITE ( 6, 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)
      IF ( IOPMIC .EQ. 0 ) PT = 0.0
      PRES = PA + PE + PT
      DENS = C1 * HNH(I)
      WRITE ( 6, 5 ) I, XM(I), ALT, TE(I), VIM, HNH(I), HNE(I) & 
     &, YION, PRES, DENS
 200  CONTINUE
      RETURN
      END
      SUBROUTINE EXOTCO
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA &  
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG & 
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /TRANC/ NT, FR0, L1, L2, TO(NZMX) &
     &, CSI0(NZMX), ETA0(NZMX), GIBAR(NZMX), FR(NFRC), WF(NFRC) & 
     &, PHI(NFRC), CNORM & 
     &, RAE(NZMX,NFRC), SAE(NZMX,NFRC), CAE(NZMX,NFRC)

      DIMENSION FS(NZMX), BJ(NZMX)
 1    FORMAT ( 1H1 )
 2    FORMAT ( 20X, 22HTRANSITION CONTINUE ( , I2, 3H , , I2, 2H ) )
 3    FORMAT ( 20X, 31(1H-) )
 4    FORMAT ( 10H   LIMITES, 2(10X,I5,5H   ( ,F7.0,5H KM )) )
 5    FORMAT ( // 20X, 30HPROFONDEURS OPTIQUES AU SEUIL / )
 6    FORMAT ( 10(3X,G10.4) )
 7    FORMAT ( // 20X, 4HCSI0 / )
 8    FORMAT ( // 20X, 4HETA0 / )
 9    FORMAT ( // 20X, 18HINTENSITE MOYENNE / )
 10   FORMAT ( // 20X, 24HFONCTION SOURCE AU SEUIL / )
 11   FORMAT (// ' INTENSITES EMERGENTES' // 10X, '   FREQUENCE   ', & 
     & '   LONG. ONDE   ', 3('   I(MU=',F3.1,')   ') / )
 12   FORMAT ( 2X, I6, 4X, E11.3, 4X, F11.2, 3(4X,E11.3) )
 13   FORMAT ( / 25X, 5HSEUIL, F10.1, 11H  ANGSTROMS / )
 14   FORMAT ( // 20X, 35HECARTS A L E. T. L. CORRESPONDANTS / )
      WRITE ( 6, 1 )
      NI = NINF(NT)
      NTP = ITP(NT)
      ITAC = NTP - NTAR
      WRITE ( 6, 2 ) NI , NK
      WRITE ( 6, 3 )
      AMBDA = 1.E8 * CL / FR0
      WRITE ( 6, 13 ) AMBDA
      Z1 = -1.E-5 * Z(L1)
      Z2 = -1.E-5 * Z(L2)
      WRITE ( 6, 4 ) L1 , Z1 , L2 , Z2
      WRITE ( 6, 5 )
      WRITE ( 6, 6 ) (TO(IZ),IZ=1,NZ)
      WRITE ( 6, 7 )
      WRITE ( 6, 6 ) (CSI0(IZ),IZ=1,NZ)
      WRITE ( 6, 8 )
      WRITE ( 6, 6 ) (ETA0(IZ),IZ=1,NZ)
      WRITE ( 6, 9 )
      WRITE ( 6, 6 ) (GIBAR(IZ),IZ=1,NZ)
      DO 50 IZ = 1 , NZ
      FS(IZ) = CSI0(IZ) * GIBAR(IZ) + ETA0(IZ)
 50   CONTINUE
      WRITE ( 6, 10 )
      WRITE ( 6, 6 ) (FS(IZ),IZ=1,NZ)
      WRITE ( 6, 14 )
      DO 200 IZ = 1, NZ
      CAT = BOLT * TE(IZ)
      BBB = C4 * FR0**3 * EXP ( -HP*FR0/CAT )
      BJ(IZ) = BBB / FS(IZ)
 200  CONTINUE
      WRITE ( 6, 6 ) ( BJ(IZ), IZ = 1, NZ )

!         Intensites emergentes

      WRITE ( 6, 11 ) ( PMU(K), K = 1, NMUV )
      DO 300 J = 1, NFRC
      WRITE ( 6, 12 ) J, FR(J), 1.E8*CL/FR(J), ( HIEMC(J,K,ITAC), K = 1 & 
     &, NMUV )
 300  CONTINUE

      RETURN
      END
      SUBROUTINE EXOTDE
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /TRANSF/ NRA, NT, FR0, L1, L2, TO(NZMX) &   
     &, DND(NZMX), AM(NZMX), EPS(NZMX), BEN(NZMX), CAR(NZMX), RF(NZMX) &
     &, DDC(NZMX), SL(NZMX), GIBAR(NZMX), FR(NFR), R(NFR2) & 
     &, PHI(NFR,NZMX), GI(NFR,NZMX), COHE(NZMX)

 1    FORMAT ( 1H1 )
 2    FORMAT ( 20X, 'TRANSFERT DANS LA TRANSITION NUMERO  ', I3 )
 3    FORMAT ( 20X, 40(1H-) // )
 4    FORMAT ( 10H   LIMITES, 2(10X,I5,5H   ( ,F7.0,5H KM ) ) )
 5    FORMAT ( 30X, 8HLAMBDA  , F10.2 // )
 6    FORMAT ( 130H  NO. I PROF. OPT.  I LARG. DOPP. I A (CTE AMOR I   EP &
     &S*      I   BEN*      I  RAPPORT D  I  COEF. DE   I  INTENSITE  I &
     &   BILAN  )
 7    FORMAT (130H      I  INTEGREE   I (ANGSTROMS) I TISSEMENT)  I &
     &        I (C.G.S.)    I ABSORPTION  I  COHERENCE  I   MOYENNE   I &
     & RADIATIF     )
 8    FORMAT ( 1X, 132(1H-) )
 9    FORMAT ( 1X, I4, 9(3H I ,G11.4) )
      WRITE ( 6, 1 )
      WRITE ( 6, 2 ) NT
      WRITE ( 6, 3 )
      AMBDA = 1.E8 * CL / FR0
      WRITE ( 6, 5 ) AMBDA
      Z1 = -1.E-5 * Z(L1)
      Z2 = -1.E-5 * Z(L2)
      WRITE ( 6, 4 ) L1,Z1,L2,Z2
      DO 200 I = 1, NZ
      IF ( MOD(I,50) .NE. 1 ) GO TO 100
      IF ( I .NE. 1 ) WRITE ( 6, 1 )
      WRITE ( 6, 6 )
      WRITE ( 6, 7 )
      WRITE ( 6, 8 )
 100  CONTINUE
      DLD = DND(I) * AMBDA / FR0
      SRCE = EPS(I) * BEN(I) + ( 1. - EPS(I) ) * GIBAR(I)
      BIL = EPS(I) * ( BEN(I) - GIBAR(I) ) / SRCE
      WRITE ( 6, 9 ) I, TO(I), DLD, AM(I), EPS(I), BEN(I), RF(I) & 
     &, COHE(I), GIBAR(I), BIL
 200  CONTINUE
      RETURN
      END
      SUBROUTINE EXPROB

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP) 
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG & 
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


 1    FORMAT ( 1H1 )
 2    FORMAT ( 46H PROBABILITES DE TRANSITION ENTRE LES NIVEAUX , I2, & 
     & 4H ET , I2 / 1X, 53(1H-) / )
 3    FORMAT ( 1X )
 4    FORMAT ( 4H NO., 5X, 4HC/IS, 8X, 4HC/SI,  8X, 4HBRN1, 8X, & 
     &  4HBRN2, 8X, 4HP*IS, 8X, 4HP*SI, 8X, 4HR/IS, 8X, 4HR/SI, 8X, & 
     &  4HP/IS, 8X, 4HP/SI )
 5    FORMAT ( 4H NO., 5X, 4HC/IS, 8X, 4HC/SI, 8X, 4HT/R , 8X, & 
     & 4HR1IS, 8X, 4HR2IS, 8X, 4HR/SI, 8X, 4HP/IS, 8X, 4HP/SI, 7X, & 
     & 6HNI*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 ( 6, 1 )
      WRITE ( 6, 2 ) NI, NS
      IF ( NS .EQ. NK ) GO TO 300

!              ECRITURE DES PROBABILITES DE TRANSITION POUR UNE RAIE

      ITAR = ITP(IT)
      DO 200 IZ = 1, NZ
      IF ( IZ .EQ. 51 ) WRITE ( 6, 1 )
      IF ( MOD ( IZ, 50 ) .EQ. 1 ) WRITE ( 6, 4 )
      IF ( MOD ( IZ, 10 ) .EQ. 1 ) WRITE ( 6, 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 ( 6, 6 ) IZ, CIS, CSI, BRN(IZ,ITAR), BRP(IZ,ITAR), PIS, PSI & 
     &, RIS, RSI, PSIS, PSSI
 200  CONTINUE
      GO TO 500
 300  CONTINUE

!              ECRITURE DES PROBABILITES DE TRANSITION POUR UN CONTINU

      ITAC = ITP(IT) - NTAR
      DO 400 IZ = 1, NZ
      IF ( IZ .EQ. 51 ) WRITE ( 6, 1 )
      IF ( MOD ( IZ, 50 ) .EQ. 1 ) WRITE ( 6, 5 )
      IF ( MOD ( IZ, 10 ) .EQ. 1 ) WRITE ( 6, 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 ( 6, 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 FONSOC ( L, TAUC, SABS, CRDP, GINU, S )

 !              CALCUL DES FONCTIONS SOURCES ( S ) DANS LE CONTINU ET
!         DES INTENSITES MOYENNES ( GINU ) ASSOCIEES, CONNAISSANT :
!         ( 1 ) LES PROFONDEURS OPTIQUES ( TAUC )
!         ( 2 ) LES FONCTIONS SOURCES DES ABSORBANTS, IONS OU
!         ATOMES ( SABS )
!         ( 3 ) LA CONTRIBUTION RELATIVE DE LA DIFFUSION PURE, RAYLEIGH
!         OU THOMSON, AU COEFFICIENT D'ABSORPTION ( CRDP )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      DIMENSION TAUC(L), SABS(L), CRDP(L), GINU(L), S(L)
      DIMENSION D(NZMX), F(NZMX)

      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
      D(1) = C1 / B1
      F(1) = 0.0
      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 = XMU0 / ( TAUC(L) - TAUC(LM1) )
      BL = 1.0 + AL
      EL = SABS(L)
      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 FONSOC ' // )
 2    FORMAT ( 10(3X,1PE10.3) )
      DO 500 I = 1, L
      GINU(I) = SABS(I)
      S(I) = SABS(I)
 500  CONTINUE
      RETURN
      END
      SUBROUTINE HYESEH
        EXTERNAL SECOND
 1    FORMAT (//' NON-CONVERGENCE DANS HYESEH APRES',I5,' ITERATIONS',  10(/10G12.5) // )
 2    FORMAT ( / 24H EQUILIBRE D IONISATION , 10X, 6HEQM = , F10.6 )  
 3    FORMAT ( 3X, 37HEQUILIBRE HYDROSTATIQUE ET IONISATION, 5X & 
     &, 5HIEH =, I3, 5X, 5HTCP =, F7.3, 5X, 7HEZMIN =, G11.3, 5X &  
     &, 7HEZMAX =, G11.3 / ) 

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


      DIMENSION Z0(NZMX)

!              IOPEHS .GT. 0 : RESOLUTION SIMULTANEE DE L'EQUILIBRE
!         HYDROSTATIQUE ET DE L'EQUILIBRE D'IONISATION
!              IOPEHS .EQ. 0 : MATIERE FIGEE. CALCUL DE L'IONISATION
!         SEULEMENT.

      IF ( IOPEHS .LE. 0 ) GO TO 700
      CALL SECOND ( TCP0 )
      IEH = 0
      DO 200  I = 1, NZ
      Y0(I) = 0.5
      Z0(I) = Z(I)
 200  CONTINUE
 300  CONTINUE
      IEH = IEH + 1
      CALL EQHYST
      CALL TXCOLL
      DO 340 IT = 1, NTAC
      CALL INIRIK ( IT, 3 )
 340  CONTINUE
      DO 360 I = 1, NZ
      HNT(I) = HNH(I)
 360  CONTINUE
      CALL EQST ( 1 )
      ICVY = 0
      DO 400 I = 1, NZ
      CALL SAHARA ( 1, TE(I), HNH(I), HN(I,NK), DEL )
      Y1(I) = DEL / HNH(I)
      ECAR = ( Y1(I) - Y0(I) ) / Y0(I)
      IF ( ABS(ECAR) .GT. CRITY ) ICVY = 1
 400  CONTINUE
      IF ( ICVY .EQ. 0 ) GO TO 500
      IF ( IEH .GT. IEHMAX ) GO TO 900
      DO 450 I = 1, NZ
      Y0(I) = Y1(I) * ( 1. - RXY ) + Y0(I) * RXY
 450  CONTINUE
      GO TO 300
 500  CONTINUE
!         SORTIE NORMALE
      EZMIN = 0.
      EZMAX = 0.
      DO 550 I = 1, NZ
      ECAR = 1.E-5 * ( Z0(I) - Z(I) )
      IF ( ECAR .LT. EZMIN ) EZMIN = ECAR
      IF ( ECAR .GT. EZMAX ) EZMAX = ECAR
 550  CONTINUE
      CALL SECOND ( TCP )
      TCP = TCP - TCP0
      WRITE (8,3) IEH, TCP, EZMIN, EZMAX
      RETURN
 700  CONTINUE
      CALL TXCOLL
      DO 720 IT = 1, NTAC
      CALL INIRIK ( IT, 3 )
 720  CONTINUE
      DO 740 I = 1, NZ
      HNT(I) = HNH(I)
      Y0(I) = HNE(I) / HNH(I)
 740  CONTINUE
      CALL EQST ( 1 )
      EQM = 0.0
      DO 760 I = 1, NZ
      CALL SAHARA ( 1, TE(I), HNH(I), HN(I,NK), HNE(I) )
      Y1(I) = HNE(I) / HNH(I)
      ECAR = ( Y1(I) - Y0(I) ) / Y0(I)
      EQM = EQM + ECAR * ECAR
 760  CONTINUE
      EQM = SQRT ( EQM / FLOAT ( NZ ) )
      WRITE ( 8, 2 ) EQM
      RETURN

 900  CONTINUE
!         SORTIE EN CAS DE NON-CONVERGENCE
      PRINT 1, IEH, ( Y0(I), Y1(I), I = 1, NZ )
      STOP
      END
      SUBROUTINE EQHYST
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG & 
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      PARAMETER ( NDEH=10, NDIM=NZMX*NDEH )
      DIMENSION DH(NDIM), TT(NDIM), VV(NDIM), YY(NDIM), ZZ(NDIM)
      DIMENSION DDH(NDIM)

      K = 1
      DH(1) = XM(1) / C1
      TT(1) = TE(1)
      VV(1) = VT(1)
      YY(1) = Y0(1)
      DHB = ALOG ( DH(1) )
      TTB = ALOG ( TE(1) )
      VVB = ALOG ( VT(1) )
      YYB = ALOG ( Y0(1) )
      DO 200 I = 2, NZ
      DHA = DHB
      TTA = TTB
      VVA = VVB
      YYA = YYB
      DHB = ALOG ( XM(I) / C1 )
      TTB = ALOG ( TE(I) )
      VVB = ALOG ( VT(I) )
      YYB = ALOG ( Y0(I) )
      DO 200 J = 1, NDEH
      K = K + 1
      FRAC = FLOAT(J) / FLOAT(NDEH)
      DH(K) = EXP ( DHA + ( DHB - DHA ) * FRAC )
      TT(K) = EXP ( TTA + ( TTB - TTA ) * FRAC )
      VV(K) = EXP ( VVA + ( VVB - VVA ) * FRAC )
      YY(K) = EXP ( YYA + ( YYB - YYA ) * FRAC )
 200  CONTINUE
      MEH = K
      ZZ(1) = 0.
      PMIC = 0.0
      IF ( IOPMIC .EQ. 1 ) PMIC = 0.5 * C1 * VV(1) * VV(1)
      DDH(1) = C1 * G * DH(1) / ( PMIC + ( C2 + YY(1) ) * BOLT * TT(1) )
      DO 300 K = 2, MEH
      PMIC = 0.0
      IF ( IOPMIC .EQ. 1 ) PMIC = 0.5 * C1 * VV(K) * VV(K)
      DDH(K) = C1 * G * DH(K) / ( PMIC + ( C2 + YY(K) ) * BOLT * TT(K) )
      DZDNH = 0.5 / DDH(K-1) + 0.5 / DDH(K)
      ZZ(K) = ZZ(K-1) + DZDNH * ( DH(K) - DH(K-1) )
 300  CONTINUE
      DO 400 I = 1, NZ
      K = 1 + NDEH * ( I - 1 )
      Z(I) = ZZ(K)
      HNH(I) = DDH(K)
      HNE(I) = HNH(I) * Y0(I)
 400  CONTINUE
      ZREF = Z(IZERO)
      DO 450 I = 1, NZ
      Z(I) = Z(I) - ZREF
 450  CONTINUE
      RETURN
      END
      SUBROUTINE HYESEI
        EXTERNAL SECOND
!            Calcul de l'equilibre statistique et de l'equilibre
!       d'ionisation, pour une pression et une temperature donnees.

 1    FORMAT ( '1 NON-CONVERGENCE DANS HYESEI APRES',I5,' ITERATIONS' & 
     &, 10(/10G12.5) // )
 3    FORMAT ( / 23H EQUILIBRE D IONISATION, 10X, 5HIEH =, I3, 5X & 
     &, 5HTCP =, F7.3, 5X, 7HEYMIN =, E10.3, 5X, 7HEYMAX =, E10.3 / )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) & 
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG & 
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA


      DIMENSION DELTAM(NZMX)

      CALL SECOND ( TCP0 )
      IEH = 0
      DO 200  I = 1, NZ
      Y1(I) = Y0(I)
 200  CONTINUE
 300  CONTINUE
      IEH = IEH + 1
      IF ( IOPMIC .NE. 0 ) THEN
      DO 320 I = 1, NZ
      HNH(I) = PSLAB / ( 0.5 * C1 * VT(I)**2 + ( C2 + Y1(I) ) * BOLT &
     & * TE(I) )
      HNE(I) = HNH(I) * Y1(I)
 320  CONTINUE
      ELSE
      DO 321 I = 1, NZ
      HNH(I) = PSLAB / ( ( C2 + Y1(I) ) * BOLT * TE(I) )
      HNE(I) = HNH(I) * Y1(I)
 321  CONTINUE
      END IF

!              CALCUL DES 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

!              CALCUL DES PROBABILITES DE TRANSITION PAR COLLISION

      CALL TXCOLL

      DO 340 IT = 1, NTAC
      CALL INIRIK ( IT, 3 )
 340  CONTINUE
      DO 360 I = 1, NZ
      HNT(I) = HNH(I)
 360  CONTINUE
      CALL EQST ( 1 )
      ICVY = 0
      DO 400 I = 1, NZ
      CALL SAHARA ( 1, TE(I), HNH(I), HN(I,NK), DEL )
      Y2(I) = DEL / HNH(I)
      ECAR = ( Y2(I) - Y1(I) ) / Y1(I)
      IF ( ABS ( ECAR ) .GT. CRITY ) ICVY = 1
 400  CONTINUE
      IF ( ICVY .EQ. 0 ) GO TO 500
      IF ( IEH .GT. IEHMAX ) GO TO 900
      DO 450 I = 1, NZ
      Y1(I) = Y2(I) * ( 1. - RXY ) + Y1(I) * RXY
 450  CONTINUE
      GO TO 300
 500  CONTINUE

!         SORTIE NORMALE

      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
      CALL SECOND ( TCP )
      TCP = TCP - TCP0
      WRITE ( 8, 3 ) IEH, TCP, EYMIN, EYMAX
      RETURN

 900  CONTINUE

!         SORTIE EN CAS DE NON-CONVERGENCE

      PRINT 1, IEH, ( Y0(I), Y1(I), Y2(I), I = 1, NZ )
      STOP
      END
      SUBROUTINE IMPERA

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR)& 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) & 
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      DIMENSION AUX(NZMX)

      PRINT 1
 1    FORMAT ( 1H1, ' PERTES RADIATIVES ' / )
      DO 200 IT = 1, NTAR
      NT = NTR(IT)
      NI = NINF(NT)
      NS = NSUP(NT)
      FR0 = FRN(NS) - FRN(NI)
      PRINT 2, IT, NS, NI, AE(IT)
 2    FORMAT ( / ' Raie no. ', I3, 10X, 'A(', I2,',', I2, ') = ', & 
     &         1PE10.2 / )
      DO 100 IZ = 1, NZ
      AUX(IZ) = HP * FR0 * HN(IZ,NS) * AE(IT) * BRN(IZ,IT)
 100  CONTINUE
      PRINT 3, (AUX(IZ),IZ=1,NZ)
 3    FORMAT ( 10E13.5 )
 200  CONTINUE

      RETURN
      END
      SUBROUTINE IMPIMO ( NZ, Z )

!         Calcul des intensites moyennes pour determiner les taux de
!     photoionisation de divers elements. Les resultats sont
!     imprimes sur "fort.28".

      PARAMETER ( NLA=70, CL=2.997925E10 )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )


      COMMON /CIMPIMO/ XLA(NLA)
      DIMENSION Z(NZMX), GINU(NZMX)
      DIMENSION AUX1(NZMX), AUX2(NZMX), AUX3(NZMX), AUX4(NZMX) & 
     &, CABF(NZMX), CEBF(NZMX), CADP(NZMX), CABR(NZMX), CEMR(NZMX)

      DATA XLA / 200., 250. & 
     &, 300., 400., 500., 508., 600., 700., 800., 821., 900., 910. & 
     &, 911., 912., 913., 1000., 1010., 1020., 1021., 1022. & 
     &, 1023., 1024., 1025., 1026., 1027., 1028., 1029., 1030. & 
     &, 1044., 1100., 1200., 1205., 1210., 1212., 1213., 1214. & 
     &, 1215., 1216., 1217., 1218., 1219., 1220., 1225., 1230. & 
     &, 1250., 1300., 1400., 1420., 1500., 1600., 1700., 1800. & 
     &, 1900., 2000., 2027., 2250., 2500., 2750., 3000., 3500. &
     &, 4000., 4500., 5000., 5500., 6000., 6424., 6500., 7000. &
     &, 7500., 8000. /

      WRITE ( 28, 101 ) NLA, NZ
 101  FORMAT ( 2(1X,I9) )
      DO 200 J = 1, NLA
      WRITE ( 28, 107 ) XLA(J)
 107  FORMAT ( 1X, F9.0 )
      FREQ = 1.E8 * CL / XLA(J)

!         CALCUL DES COEFFICIENTS D'ABSORPTION ET D'EMISSION LIES
!         AUX CONTINUS ET A LA DIFFUSION PURE :
!         CABF, CEBF : CONTINUS ("BOUND-FREE")
!         CADP : C. A. POUR LA DIFFUSION PURE
!         AUX2 = CEBF / CABF
!         AUX3 = CADP / ( CADP + CABF )
!         AUX4 = CADP + CABF

      CALL PROFSC ( 1, FREQ, AUX1, AUX2, AUX3, AUX4 )
      DO 120 IZ = 1, NZ
      CADP(IZ) = AUX3(IZ) * AUX4(IZ)
      CABF(IZ) = AUX4(IZ) - CADP(IZ)
      CEBF(IZ) = CABF(IZ) * AUX2(IZ)
 120  CONTINUE

!              CALCUL DES COEFFICIENTS D'ABSORPTION ( CABR ) ET
!         D'EMISSION ( CEMR ) DUS AUX RAIES DE LYMAN

      CALL SERLYM ( FREQ, CABR, CEMR )

!              CALCUL DES PROFONDEURS OPTIQUES ET DES FONCTIONS SOURCES
!         NECESSAIRES AU CALCUL DES INTENSITES
!         AUX1 : PROFONDEURS OPTIQUES
!         AUX2 : FONCTION SOURCE "CONTINU + RAIES"
!         AUX3 = CADP / ( CABF + CADP + CABR )
!         AUX4 : COEFFICIENT D'ABSORPTION TOTAL

      DO 150 IZ = 1, NZ
      AUX4(IZ) = CABF(IZ) + CADP(IZ) + CABR(IZ)
      AUX3(IZ) = CADP(IZ) / AUX4(IZ)
      AUX2(IZ) = ( CEBF(IZ) + CEMR(IZ) ) / ( CABF(IZ) + CABR(IZ) )
 150  CONTINUE
      AUX1(1) = 0.0
      DO 170 IZ = 2, NZ
      AUX1(IZ) = AUX1(IZ-1) + 0.5 * ( AUX4(IZ-1) + AUX4(IZ) ) * & 
     & ( Z(IZ) - Z(IZ-1) )
 170  CONTINUE
      CALL FONSOC ( NZ, AUX1, AUX2, AUX3, GINU, AUX4 )

      WRITE ( 28, 177 ) ( GINU(IZ), IZ = 1, NZ )
 177  FORMAT ( 5(1X,E15.6) )
 200  CONTINUE

      RETURN
      END
      SUBROUTINE IMTOCS ( NZ )

!              IMTOCS IMPRIME LES PROFONDEURS OPTIQUES CONTINUES, EN
!         FONCTION DE L'ALTITUDE, POUR DIVERSES LONGUEURS D'ONDE.

 1    FORMAT ( 1H1 )
 2    FORMAT ( 20X, 30HPROFONDEURS OPTIQUES CONTINUES // )
 3    FORMAT ( 50X, 31HLONGUEURS D ONDE ( ANGSTROMS ) / 4X, & 
     & 10(4X,F8.0) )
 4    FORMAT ( 1X )
 5    FORMAT ( 1X, I4, 1X, 10(2X,1PE10.3) )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      COMMON /CALFAT/ AMBDA(10), TOC(NZMX,10), FSC(NZMX), CSCAT(NZMX) & 
     &, BIDON(NZMX)

      DATA AMBDA / 5000.0, 910.0, 1000.0, 1215.0, 2000.0, 2800.0, 3640.0 & 
     &, 3950.0, 8200.0, 10000.0 /

      DO 200 J = 1, 10
      FREQ = 1.E8 * CL / AMBDA(J)
      CALL PROFSC ( 1, FREQ, TOC(1,J), FSC, CSCAT, BIDON )
 200  CONTINUE
      DO 400 I = 1, NZ
      IF ( MOD(I,50) .NE. 1 ) GO TO 300
      WRITE ( 6, 1 )
      WRITE ( 6, 2 )
      WRITE ( 6, 3 ) ( AMBDA(J), J = 1, 10 )
 300  CONTINUE
      IF ( MOD(I,10) .EQ. 1 ) WRITE ( 6, 4 )
      WRITE ( 6, 5 ) I, ( TOC(I,J), J = 1, 10 )
 400  CONTINUE
      RETURN
      END
      SUBROUTINE INIATM1

!        Version pour protuberances isothermes

      PARAMETER ( NXMOD=46 )
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) &  
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

 
      COMMON /SORTIE/ VTMOD, DZMOD, XNHC, XNHB, SNHDZ & 
     &, TOCLY, TOCBA, TAUTO(NTAR), SIDFR(NTAR) & 
     &, AMB1(NTAR), AMB2(NTAR), HIFR(NPSOR,NTAR)

      COMMON /CINIAT/ XMOD(NXMOD)

      DATA XMOD & 
     &/ 0.0 & 
     &, 1.E-8, 1.6E-8, 2.5E-8, 4.0E-8, 6.3E-8 & 
     &, 1.E-7, 1.6E-7, 2.5E-7, 4.0E-7, 6.3E-7 &
     &, 1.E-6, 1.6E-6, 2.5E-6, 4.0E-6, 6.3E-6 & 
     &, 1.E-5, 1.6E-5, 2.5E-5, 4.0E-5, 6.3E-5 &
     &, 1.E-4, 1.6E-4, 2.5E-4, 4.0E-4, 6.3E-4 &
     &, 1.E-3, 1.6E-3, 2.5E-3, 4.0E-3, 6.3E-3 &
     &, 1.E-2, 1.6E-2, 2.5E-2, 4.0E-2, 6.3E-2 &
     &, .1, .2, .3, .4, .5, .6, .7, .8, .9, 1.0 /

      NZ = NXMOD
      IF ( NZ .GT. NZMX ) GO TO 900
      DO 120 I = 1, NZ
      Z(I) = XMOD(I) * 0.5E5 * EPST
      TE(I) = TSLAB
 120  CONTINUE

      DO 300 I = 1, NZ
      Y0(I) = 0.5
 300  CONTINUE
      IF ( IOPVT .LT. 0 ) THEN
      DO 320 I = 1, NZ
      VT(I) = 6.E5 + 14.E5 * ALOG10 ( 1.E-4 * TE(I) )
 320  CONTINUE
      ELSE
      DO 340 I = 1, NZ
      VT(I) = 1.E5 * FLOAT ( IOPVT )
 340  CONTINUE
      END IF

      VTMOD = VT(1)

      RETURN

 900  CONTINUE
      PRINT 901, NZ, NZMX
 901  FORMAT ( 1H1 ///// ' Sous-programme INIATM :' / ' La grille des' & 
     &,      ' profondeurs depasse la dimension autorisee :' / ' NZ = ' & 
     &,      I5, 10X, 'NZMX = ', I5 ///// )
      STOP

      END
      SUBROUTINE INIATM3

!         Version pour atmosphere stellaire (y compris solaire)

 1    FORMAT ( A8 )
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) & 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) & 
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP) 
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG & 
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      DIMENSION XMMOD(NZMX), TEMOD(NZMX), VTMOD(NZMX)

      READ ( 3, 1 ) XMOAT
      READ ( 3, * ) ILG, GGG, ILM, VSINI
      IF ( ILG .EQ. 1 ) THEN
      GLOG = GGG
      G = 10.**GGG
      ELSE
      G = GGG
      GLOG = ALOG10 ( G )
      END IF

      I = 0
 100  CONTINUE
      READ ( 3, * ) ZZM, ZZT, ZZV, INDEX
      IF ( INDEX .LT. 0 ) GO TO 200
      I = I + 1
      IF ( ILM .EQ. 1 ) ZZM = 10.**ZZM
      XMMOD(I) = ALOG ( ZZM )
      TEMOD(I) = ALOG ( ZZT )
      VTMOD(I) = ALOG ( 1.E5 * ZZV )
      IF ( INDEX .EQ. 1 ) IZMOD = I
      GO TO 100
 200  CONTINUE
      NZMOD = I
      IDIV = NZMX / NZMOD
      XM(1) = EXP ( XMMOD(1) )
      Z(1) = 0.0
      TE(1) = EXP ( TEMOD(1) )
      VT(1) = EXP ( VTMOD(1) )
      K = 1
      IF ( IZMOD .EQ. 1 ) IZERO = 1
      DO 350 I = 2, NZMOD
      DO 300 J = 1, IDIV
      K = K + 1
      FRAC = FLOAT ( J ) / FLOAT ( IDIV )
      ZZM = XMMOD(I-1) + ( XMMOD(I) - XMMOD(I-1) ) * FRAC
      XM(K) = EXP ( ZZM )
      Z(K) = 0.0
      ZZT = TEMOD(I-1) + ( TEMOD(I) - TEMOD(I-1) ) * FRAC
      TE(K) = EXP ( ZZT )
      ZZV = VTMOD(I-1) + ( VTMOD(I) - VTMOD(I-1) ) * FRAC
      VT(K) = EXP ( ZZV )
 300  CONTINUE
      IF ( IZMOD .EQ. I ) IZERO = K
 350  CONTINUE
      NZ = K

!     Calcul automatique de VT si IOPVT est negatif

      IF ( IOPVT .LT. 0 ) THEN
      DO 400 I = 1, NZ
      VT(I) = 6.E5 + 14.E5 * ALOG10 ( 1.E-4 * TE(I) )
 400  CONTINUE
      END IF

      RETURN
      END
      SUBROUTINE INIATM5

!        Lecture des donnees pour un modele de protu de type Fontenla

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT , IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR)& 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) & 
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC)  & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


      READ ( 3, 1 ) XMOAT, PSLAB, NZ
 1    FORMAT ( A8, E12.5, I7 )
      READ ( 3, * ) ( Z(I), I = 1, NZ )
      READ ( 3, * ) ( TE(I), I = 1, NZ )
      DO 100 J = 1, NN
      READ ( 3, * ) ( HN(I,J), I = 1, NZ )
 100  CONTINUE
      DO 200 I = 1, NZ
      HNE(I) = HN(I,NN)
      HNH(I) = 0.0
      VT(I) = 0.0
      DO 200 J = 1, NN
      HNH(I) = HNH(I) + HN(I,J)
 200  CONTINUE

      RETURN
      END
      SUBROUTINE INIFEV

!         Initialisation des facteurs d'Eddington variables.

      PARAMETER ( COEFK=1./3., COEFL=1./2. )
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA &  
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR)& 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) & 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


      DO 100 IT = 1, NTAR
      DO 100 J = 1, NFR
      DO 100 I = 1, NZ
      FEVK(J,I,IT) = COEFK
      FEVL(J,I,IT) = COEFL
 100  CONTINUE

      DO 200 IT = 1, NTAC
      DO 200 J = 1, NFRC
      DO 200 I = 1, NZ
      FKTC(J,I,IT) = COEFK
      FLTC(J,I,IT) = COEFL
 200  CONTINUE

      RETURN
      END
      SUBROUTINE INIMET
      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*4 NOM

      COMMON /ELEMTS/ NEL, NOM(20), ABON(20), HM(20), NEI(20), PIO(20,4) & 
     &, U(20,5), HNION(5,20)

      DATA NEL / 20 /
      DATA NOM / "HE", "C", "N", "O", "NE", "NA", "MG", "AL", "SI", "P", & 
     & "S", "AR", "K", "CA", "CR", "MN", "FE", "CO", "NI", "H"/
      DATA 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 /
      DATA 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 /
      DATA NEI / 3, 19*2 /
      DATA (PIO(1,J),J=1,2) / 24.58, 58.40 /
      DATA (PIO(I,1),I=2,20) &
     &/ 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 /
      DATA (U(1,J),J=1,3) / 1., 2., 1. /
      DATA (U(2,J),J=1,2) / 9.28, 5.94 /
      DATA (U(3,J),J=1,2) / 4.07, 8.91 /
      DATA (U(4,J),J=1,2) / 8.70, 3.98 /
      DATA (U(5,J),J=1,2) / 1.00, 5.37 /
      DATA (U(6,J),J=1,2) / 2.02, 1.00 /
      DATA (U(7,J),J=1,2) / 1.01, 2.01 /
      DATA (U(8,J),J=1,2) / 5.83, 1.03 /
      DATA (U(9,J),J=1,2) / 9.26, 5.82 /
      DATA (U(10,J),J=1,2) / 4.46, 8.12 /
      DATA (U(11,J),J=1,2) / 8.12, 4.16 /
      DATA (U(12,J),J=1,2) / 1.00, 4.89 /
      DATA (U(13,J),J=1,2) / 2.18, 1.00 /
      DATA (U(14,J),J=1,2) / 1.03, 2.29 /
      DATA (U(15,J),J=1,2) / 10.3, 7.24 /
      DATA (U(16,J),J=1,2) / 6.45, 7.76 /
      DATA (U(17,J),J=1,2) / 24.5, 39.2 /
      DATA (U(18,J),J=1,2) / 31.6, 27.5 /
      DATA (U(19,J),J=1,2) / 28.8, 10.0 /
      DATA (U(20,J),J=1,2) / 2.00, 1.00 /
      C1 = 0.
      C2 = 0.
      DO 50 I = 1 , NEL
      XM = UMA * HM(I)
      X = 10.**(ABON(I)-12.)
      C1 = C1 + XM * X
      C2 = C2 + X
 50   CONTINUE
      RETURN
      END
      SUBROUTINE INIRIK ( ITAC , IOP )

!              INITIALISATION DES PROBABILITES DE PHOTO-IONISATION
!         POUR L'HYDROGENE A PARTIR DES TEMPERATURES DE RAYONNEMENT
 
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      COMMON /TRANC/ NT, FR0, L1, L2, TO(NZMX) &
     &, CSI0(NZMX), ETA0(NZMX), GIBAR(NZMX), FR(NFRC), WF(NFRC) & 
     &, PHI(NFRC), CNORM & 
     &, RAE(NZMX,NFRC), SAE(NZMX,NFRC), CAE(NZMX,NFRC)


      NT = NTC(ITAC)
      NTP = ITP(NT)
      NI = NINF(NT)
      FR0 = FRN(NK) - FRN(NI)
      DO 100 J = 1, NFRC
      FR(J) = FR0 * XFRC(J)
 100  CONTINUE
      CALL COIN ( 1, NFRC, FR, WF )
      CNORM = 0.0
      DO 120 J = 1, NFRC
      WF(J) = WF(J) * SEPION ( FR(J), NI ) / ( HP * FR(J) )
      CNORM = CNORM + WF(J)
 120  CONTINUE
      DO 140 J = 1, NFRC
      WF(J) = WF(J) / CNORM
 140  CONTINUE
      DO 300 I = 1, NZ
      TZ = TE(I)
      DE = HNE(I)
      CAT = BOLT * TZ
      XXX = EXP(HP*FR0/CAT)
      ETLIS = DE * POM(NI) * XXX / ( UK * C5 * TZ**1.5 )
      XX = 0.
      DO 160 J = 1, NFRC
      XX = XX + WF(J) * BWIEN ( FR(J), TZ )
 160  CONTINUE
      RKI(I,ITAC) = 4.0 * PI * ETLIS * CNORM * XX
      XX = 0.0
      DO 180 J = 1, NFRC
      XX = XX + WF(J) * BWIEN ( FR(J), TR(I,ITAC) )
 180  CONTINUE
      RIS = 4.0 * PI * CNORM * XX
      IF ( IOP .EQ. 2 ) GO TO 200
      RIK(I,ITAC) = RIS
 200  CONTINUE
      IF ( IOP .EQ. 1 ) GO TO 300
      RIKP(I,ITAC) = RIS
 300  CONTINUE
      RETURN
      END
      SUBROUTINE INITR1

!         INITIALISATION DES TEMPERATURES DE RAYONNEMENT INTERNES
!         ( TR ) POUR LES CONTINUS DE L'HYDROGENE A PARTIR DES
!         TEMPERATURES DE RAYONNEMENT INCIDENTES ET DES
!         FACTEURS DE DILUTION ( FADI ).

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF 

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      COMMON /TRANC/ NT, FR0, L1, L2, TO(NZMX) & 
     &, CSI0(NZMX), ETA0(NZMX), GIBAR(NZMX), FR(NFRC), WF(NFRC) & 
     &, PHI(NFRC), CNORM & 
     &, RAE(NZMX,NFRC), SAE(NZMX,NFRC), CAE(NZMX,NFRC)


      DO 400 ITAC = 1, NTAC
      NT = NTC(ITAC)
      NI = NINF(NT)
      FR0 = FRN(NK) - FRN(NI)
      DO 100 J = 1, NFRC
      FR(J) = FR0 * XFRC(J)
 100  CONTINUE
      CALL COIN ( 1, NFRC, FR, WF )
      CNORM = 0.0
      DO 120 J = 1, NFRC
      SEP = SEPION ( FR(J), NI )
      WF(J) = WF(J) * SEP / ( HP * FR(J) )
      CNORM = CNORM + WF(J)
 120  CONTINUE
      DO 140 J = 1, NFRC
      WF(J) = WF(J) / CNORM
 140  CONTINUE
      XX = 0.0
      DO 180 J = 1, NFRC
      AMBDA = 1.E4 * CL / FR(J)
      TB = TEMBRI ( AMBDA )
      TRUC = BWIEN ( FR(J), TB )
      XX = XX + WF(J) * TRUC
 180  CONTINUE
      RIK0 = 4.0 * PI * CNORM * XX * FADI(NTAR+ITAC)
      DO 300 IZ = 1, NZ
      RIK(IZ,ITAC) = RIK0
 300  CONTINUE
      CALL TEMPRA ( ITAC, 1 )
 400  CONTINUE

      RETURN
      END
      SUBROUTINE INITR3

!         INITIALISATION DES TEMPERATURES DE RAYONNEMENT INTERNES
!         ( TR ) POUR LES CONTINUS DE L'HYDROGENE

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT 
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN)& 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA
 
      COMMON /TRANC/ NT, FR0, L1, L2, TO(NZMX) &
     &, CSI0(NZMX), ETA0(NZMX), GIBAR(NZMX), FR(NFRC), WF(NFRC) &
     &, PHI(NFRC), CNORM &
     &, RAE(NZMX,NFRC), SAE(NZMX,NFRC), CAE(NZMX,NFRC)


      IF ( NTAC .LE. 0 ) GO TO 550

!              Si IOPTR = 0, on fixe la temperature de rayonnement
!         egale a la temperature electronique locale.
!              SI IOPTR # 0 , ON FIXE LA TEMPERATURE DE RAYONNEMENT
!         CORRESPONDANT A LA PARTIE OPTIQUEMENT MINCE DE L'ATMOSPHERE
!         ( TR = TROM ), ET ON RECHERCHE LE POINT DE JONCTION AVEC LA
!         PARTIE OPTIQUEMENT EPAISSE ( TR = TE ) PAR COMPARAISON DE
!         TROM AVEC LA TEMPERATURE ELECTRONIQUE LOCALE
!         IOPTR = 1 : JONCTION DANS LA CHROMOSPHERE
!         IOPTR = 2 : JONCTION DANS LA PHOTOSPHERE

      DO 540 IT = 1, NTAC
      IF ( IOPTR(IT) .EQ. 0 ) GO TO 520
      IF ( IOPTR(IT) .NE. 1 ) GO TO 460
      DO 440 IZ = 2, NZ
      IF ( TROM(IT) .LE. TE(IZ-1) .AND. TROM(IT) .GE. TE(IZ) ) JONC = IZ &
     & - 1
 440  CONTINUE
 460  CONTINUE
      IF ( IOPTR(IT) .NE. 2 ) GO TO 500
      DO 480 IZ = 2, NZ
      IF ( TROM(IT) .GE. TE(IZ-1) .AND. TROM(IT) .LE.TE(IZ) ) JONC = IZ &
     & - 1
 480  CONTINUE
 500  CONTINUE
      DO 510 IZ = 1, NZ
      TR(IZ,IT) = TROM(IT)
      IF ( IZ .GT. JONC ) TR(IZ,IT) = TE(IZ)
 510  CONTINUE
      GO TO 540
 520  CONTINUE
      DO 530 IZ = 1, NZ
      TR(IZ,IT) = TE(IZ)
 530  CONTINUE
 540  CONTINUE
 550  CONTINUE

      RETURN
      END
      SUBROUTINE JEUXDO

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

 ! modif le 28/07/2015 pour Hollerith
      character X,XX
 ! fin modif

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA


 1    FORMAT ( 1H1 )
 2    FORMAT ( / 10X, 18HNombre de niveaux, 5X, 4HNN =, I3 )
 3    FORMAT (/10X, 28HNombre total de transitions ,5X, 5HNTT =, I3 )
 4    FORMAT ( / 10X, 'Nombre de transitions permises :' / &
      10X, 'a) raies : NTAR =', I4 / 10X, 'b) continus : NTAC =', I3 )
 9    FORMAT ( /// 20X, 22HLISTE DES TRANSITIONS // 10X, 3HNO., 8X, &
      2HNI, 8X, 2HNS, 7X, 3HI/A, 7X, 3HC/R, 6X, 6Hlambda / )
 10   FORMAT ( 2X, 3I10, 2(9X,A1), F10.1 )

!              Donnees atomiques (pour l'hydrogene seulement)

      NND = NN
      IF ( NN .EQ. NK ) NND = NN - 1
      DO 200 JS = 2 , NN
      JSM = JS - 1
      DO 200 JI = 1 , JSM
      IT = ( (JS-1) * (JS-2) ) / 2 + JI
      NINF(IT) = JI
      NSUP(IT) = JS
      ITP(IT) = 0
      DO 120 ITAR = 1, NTAR
      JT = NTR(ITAR)
      IF ( JT .EQ. IT ) ITP(IT) = ITAR
 120  CONTINUE
      DO 140 ITAC = 1, NTAC
      JT = NTC(ITAC)
      IF ( JT .EQ. IT ) ITP(IT) = ITAC + NTAR
 140  CONTINUE
 200  CONTINUE
      UK = 1.0
      TSP(NN) = 109678.76
      DO 220 J = 1, NN-1
      POM(J) = 2.0 * FLOAT ( J * J )
      TSP(J) = TSP(NN) * ( 1.0 - 2.0 / POM(J) )
 220  CONTINUE
      DO 240 J = 1, NN
      FRN(J) = CL * TSP(J)
 240  CONTINUE

!               Probabilites d'emission spontanee

      DO 260 IT = 1, NTAR
      NT = NTR(IT)
      NI = NINF(NT)
      NS = NSUP(NT)
      AE(IT) = AEMS ( NI, NS )
 260  CONTINUE

!          Coefficients d'excitation et d'ionisation par collision

      TAB(1) = 5000.
      TAB(2) = 7000.
      TAB(3) = 10000.
      TAB(4) = 14000.
      TAB(5) = 20000.
      DO 340 K = 1, NTT
      NI = NINF(K)
      NS = NSUP(K)
      EIJ = HP * ( FRN(NS) - FRN(NI) )
      DO 300 ITAB = 1, NTAB
      IF ( NS .EQ. NK ) THEN
      OIS(ITAB,K) = CICHC ( NI, TAB(ITAB) )
      ELSE
      OIS(ITAB,K) = CECH ( NI, NS, TAB(ITAB) )
      END IF
 300  CONTINUE
      DO 320 ITAB = 1, NTAB
      OIS(ITAB,K) = OIS(ITAB,K) * EXP ( EIJ / ( BOLT * TAB(ITAB) ) )
 320  CONTINUE
 340  CONTINUE

!        Si ICCVAL=1, on remplace les coefficients de collision par
!      ceux de l'article VAL 81

      IF ( ICCVAL .EQ. 1 ) THEN
      OIS(1,1) = 2.39E-08
      OIS(1,2) = 6.62E-08
      OIS(1,3) = 4.70E-07
      OIS(1,4) = 2.59E-09
      OIS(1,5) = 8.97E-08
      OIS(1,6) = 3.97E-06
      OIS(1,7) = 1.57E-09
      OIS(1,8) = 3.90E-08
      OIS(1,9) = 5.86E-07
      OIS(1,10) = 1.78E-05
      OIS(2,1) = 2.38E-08
      OIS(2,2) = 5.63E-09
      OIS(2,3) = 5.66E-07
      OIS(2,4) = 2.28E-09
      OIS(2,5) = 9.59E-08
      OIS(2,6) = 4.49E-06
      OIS(2,7) = 1.26E-09
      OIS(2,8) = 3.79E-08
      OIS(2,9) = 6.77E-07
      OIS(2,10) = 1.89E-05
      OIS(3,1) = 2.31E-08
      OIS(3,2) = 5.31E-09
      OIS(3,3) = 6.46E-07
      OIS(3,4) = 2.08E-09
      OIS(3,5) = 1.06E-07
      OIS(3,6) = 4.80E-06
      OIS(3,7) = 1.11E-09
      OIS(3,8) = 3.98E-08
      OIS(3,9) = 7.44E-07
      OIS(3,10) = 1.90E-05
      OIS(4,1) = 2.24E-08
      OIS(4,2) = 5.61E-09
      OIS(4,3) = 7.21E-07
      OIS(4,4) = 2.13E-09
      OIS(4,5) = 1.17E-07
      OIS(4,6) = 4.93E-06
      OIS(4,7) = 1.09E-09
      OIS(4,8) = 4.31E-08
      OIS(4,9) = 7.83E-07
      OIS(4,10) = 1.85E-05
      OIS(5,1) = 2.22E-08
      OIS(5,2) = 6.29E-09
      OIS(5,3) = 7.56E-07
      OIS(5,4) = 2.35E-09
      OIS(5,5) = 1.24E-07
      OIS(5,6) = 4.91E-06
      OIS(5,7) = 1.17E-09
      OIS(5,8) = 4.58E-08
      OIS(5,9) = 7.91E-07
      OIS(5,10) = 1.79E-05

      NNC = (NN-1)*(NN-2)/2
      OIS(1,NNC+1) = 2.82E-09
      OIS(1,NNC+2) = 5.90E-08
      OIS(1,NNC+3) = 2.87E-07
      OIS(1,NNC+4) = 8.59E-07
      OIS(1,NNC+5) = 1.98E-06
      OIS(2,NNC+1) = 3.92E-09
      OIS(2,NNC+2) = 7.59E-08
      OIS(2,NNC+3) = 3.61E-07
      OIS(2,NNC+4) = 1.06E-06
      OIS(2,NNC+5) = 2.39E-06
      OIS(3,NNC+1) = 5.30E-09
      OIS(3,NNC+2) = 9.44E-08
      OIS(3,NNC+3) = 4.40E-07
      OIS(3,NNC+4) = 1.25E-06
      OIS(3,NNC+5) = 2.69E-06
      OIS(4,NNC+1) = 7.21E-09
      OIS(4,NNC+2) = 1.17E-07
      OIS(4,NNC+3) = 5.23E-07
      OIS(4,NNC+4) = 1.40E-06
      OIS(4,NNC+5) = 2.86E-06
      OIS(5,NNC+1) = 9.01E-09
      OIS(5,NNC+2) = 1.34E-07
      OIS(5,NNC+3) = 5.72E-07
      OIS(5,NNC+4) = 1.47E-06
      OIS(5,NNC+5) = 2.90E-06
      END IF

!          Recapitulation des transitions

      WRITE ( 6, 1 )
      WRITE ( 6, 2 ) NN
      WRITE ( 6, 3 ) NTT
      WRITE ( 6, 4 ) NTAR, NTAC
      WRITE ( 6, 9 )
      DO 400 IT = 1,NTT
      NI = NINF(IT)
      NS = NSUP(IT)
! modif le 28/07/2015 Hollerith
!!      X = 1HI
!!      IF ( ITP(IT) .NE. 0 ) X = 1HA
!!      XX = 1HR
!!      IF ( NS .EQ. NK ) XX = 1HC

      X='I'
      if (ITP(IT) .NE. 0) X='A'
      XX='R'
      if (NS .EQ. NK) XX='C'

! fin modif
      ONDE = 1.E8 / ( TSP(NS) - TSP(NI) )
      WRITE ( 6, 10 ) IT, NI, NS, X, XX, ONDE
 400  CONTINUE

!          Jeu de frequences pour les transitions continues (adapte
!       a une decroissance en 1/FR**3 )

      DO 500 J = 1, NFRC
      QJ = FLOAT ( NFRC + 1 - J ) / FLOAT ( NFRC )
      XFRC(J) = 1.0 / SQRT ( QJ )
 500  CONTINUE

      IF ( NTAR .EQ. 0 ) GO TO 600

!              INITIALISATION DES ABSORPTIONS CONTINUES ( COEFFICIENTS
!         D'ABSORPTION ET FONCTIONS SOURCES )
!         IOPCAC = 0 : PAS D'ABSORPTION CONTINUE : CAC ET SC SONT MIS
!         A ZERO
!         IOPCAC = 1 : PAS D'INITIALISATION : CAC ET SC DOIVENT ALORS
!         ETRE SPECIFIES DANS UN AUTRE SOUS-PROGRAMME
!         IOPCAC = 2 : COMME PRECEDEMMENT, SAUF POUR SC : LES VALEURS
!         INITIALEMENT FIXEES A -1.0 SONT REMPLACEES PAR LA FONCTION
!         DE PLANCK CORRESPONDANTE
!         IOPCAC = 3 : CAC ET SC SONT CALCULES PAR LE SOUS-PROGRAMME
!         ABSCON

      GO TO ( 560, 600, 580, 590 ) IOPCAC + 1
 560  CONTINUE
      DO 570 IT = 1, NTAR
      DO 570 IZ = 1, NZ
      CAC(IZ,IT) = 0.0
      SC(IZ,IT) = 0.0
 570  CONTINUE
      GO TO 600
 580  CONTINUE
      DO 581 IT = 1, NTAR
      NT = NTR(IT)
      NI = NINF(NT)
      NS = NSUP(NT)
      FREQ = FRN(NS) - FRN(NI)
      DO 581 IZ = 1, NZ
      IF ( SC(IZ,IT) .EQ. -1.0 ) SC(IZ,IT) = BENU ( FREQ, TE(IZ) )
 581  CONTINUE
      GO TO 600
 590  CONTINUE
      CALL ABSCON ( 1 )
 600  CONTINUE

!             LARGEURS DOPPLER ... CONVERSION DES ANGSTROMS EN HERTZ
!         SI INIDLD = 1, ON PROCEDE A L'INITIALISATION AUTOMATIQUE DES
!         LARGEURS DOPPLER DE REFERENCE(DLDREF).

      DO 650 IT = 1, NTAR
      NT = NTR(IT)
      NI = NINF(NT)
      NS = NSUP(NT)
      FR = FRN(NS) - FRN(NI)
      IF ( INIDLD .NE. 1 ) GO TO 620
      ONDE = 1.E8 / ( TSP(NS) - TSP(NI) )
      HM = HMA * UMA
      VMIC = 1.E5 * VTREF
      DLDREF(IT) = ONDE * SQRT ( VMIC*VMIC + 2.0*BOLT*TEREF/HM ) / CL
 620  CONTINUE
      DNDREF(IT) = FR**2 * DLDREF(IT) * 1.E-8 / CL
 650  CONTINUE

!              Mise a zero des tableaux initiaux

      DO 700 IT = 1, NTAR
      DO 700 IZ = 1, NZ
      BRN(IZ,IT) = 0.0
      BRP(IZ,IT) = 0.0
      CAC(IZ,IT) = 0.0
      SC(IZ,IT) = 0.0
      DCAC(IZ,IT) = 0.0
 700  CONTINUE

      RETURN
      END
      FUNCTION AEMS ( I, J )

!              Coefficient d'Einstein pour l'emission spontanee
!         de l'atome d'hydrogene, d'apres L. C. Johnson (1972)
!              I    : niveau inferieur
!              J    : niveau superieur

      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 - 2 ) 120, 140, 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 )

!              Coefficient d'excitation par collision electronique
!         pour l'atome d'hydrogene, d'apres L. C. Johnson (1972)
!              I    : niveau inferieur
!              J    : niveau superieur
!              TE   : temperature
!         Utilisation:
!              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 - 2 ) 120, 140, 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 ) * EXPN ( 1, Y ) - ( 1./Z + 0.5 ) &
     &     * EXPN ( 1, Z ) )
      T2 = ( B - A * ALOG ( 2. * XI * XI * XM1 ) ) * ( EXPN ( 2, Y ) / Y &
     &     - EXPN ( 2, Z ) / Z )
      CECH = SQRT ( CSE * TE ) * 2. * XI * XI * XM1 * PIA02 * Y * Y * &
     &         ( T1 + T2 )

      RETURN
      END
      FUNCTION CICHJ ( I, TE )

!              Coefficient d'ionisation par collision electronique
!         pour l'atome d'hydrogene, d'apres Johnson (1972, Ap. J.
!         174, 227)
!              I    : niveau inferieur
!              TE   : temperature
!         Utilisation:
!              Cic = Ne * CICHJ(i,T) * exp(-Ei/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 )
      COEF = 32. / ( 3. * SQRT(3.) * PI )
      IF ( I - 2 ) 120, 140, 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
      A = COEF * XI * ( G0 / 3. + G1 / 4. + G2 / 5. )
      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 = ( 2. / 3. ) * XI * XI * ( 5.0 + PBN )
      EIK = RYD / XI**2
      Y = EIK / ( BOLT * TE )
      Z = RN + Y
      T1 = A * ( EXPN ( 1, Y ) / Y - EXPN ( 1, Z ) / Z )
      T2 = ( B - A * ALOG ( 2. * XI * XI ) ) * ( EXPN ( 0, Y ) &
     &  - EXPN ( 0, Z ) - 2. * EXPN ( 1, Y ) + 2. * EXPN ( 1, Z ) &
     &  + EXPN ( 2, Y ) - EXPN ( 2, Z ) )
      CICHJ = SQRT ( CSE * TE ) * 2. * XI * XI * PIA02 * Y * Y * &
     &         ( T1 + T2 )

      RETURN
      END
      FUNCTION CICHC ( I, TE )

!              Coefficient d'ionisation par collision electronique
!         pour l'atome d'hydrogene, d'apres Clark, Abdallah &
!         Mann (1991, Ap. J. 381, 597)
!              I    : niveau inferieur
!              TE   : temperature
!         Utilisation:
!              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 = EXPN ( 1, Y )
      E2Y = EXPN ( 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 EXPN ( M, T )
      IF (T) 1, 20, 30
 30   CONTINUE
      IF ( M .EQ. 0 ) GO TO 200
      IF (T.GT.1.) GO TO 2
      E1 = -.57721566490153 - ALOG (T)
      N = 1
      A = 1.
 10   CONTINUE
      A = -A*T/FLOAT(N)
      B = A/FLOAT (N)
      E1 = E1-B
      IF (N.LE.2)  GOTO  11
      IF(ABS(B).LT.(1.E-14*E1)) GOTO 50
 11   CONTINUE
      N= N+1
      GOTO 10
 2    CONTINUE
      IF(T.LE.670.)  GOTO 3
      EXPN = 0.
      RETURN
 3    CONTINUE
      A0 = .2677737343
      A1 =  8.6347608925
      A2 = 18.0590169730
      A3 =  8.5733287401
      B0 = 3.9584969228
      B1 =  21.0996530827
      B2 = 25.6329561486
      B3 =  9.5733223454
      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
      EXPN = E1
      IF (M.EQ.1) RETURN
      DO 40 I=2,M
      EXPN = (EXP(-T)-T*EXPN)/FLOAT(I-1)
 40   CONTINUE
      RETURN
 20   CONTINUE
      IF (M.LE.1) GOTO 1
      EXPN = 1./FLOAT(M-1)
      RETURN
 200  CONTINUE
      EXPN = EXP(-T) / T
      RETURN
 1    CONTINUE
      PRINT 101
 101  FORMAT ( 1H1 / ' Argument negatif ou nul dans EXPN ' // )
      STOP
      END
      SUBROUTINE NLTEBF ( IT )

!              NLTEBF EFFECTUE LE CALCUL HORS ETL
!         DES CHAMPS DE RAYONNEMENT ET DES PROBABILITES DE TRANSITIONS
!         RADIATIVES POUR LES CONTINUS ( LIE-LIBRE ) DE L'HYDROGENE .
!              CETTE VERSION S'APPLIQUE A UNE COUCHE D'EPAISSEUR FINIE.
!         ELLE TIENT COMPTE DES AUTRES
!         ABSORBANTS QUI AGISSENT DANS LES INTERVALLES
!         SPECTRAUX CONCERNES. ELLE EST ASSOCIEE AU SOUS-PROGRAMME DE
!         TRANSFERT DE RAYONNEMENT TFCFEV.

      PARAMETER ( TOMIN=1.E-3, CRIT=1.E-3 )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC)& 
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /TRANC/ NT, FR0, L1, L2, TO(NZMX) & 
     &, CSI0(NZMX), ETA0(NZMX), GIBAR(NZMX), FR(NFRC), WF(NFRC) & 
     &, PHI(NFRC), CNORM &
     &, RAE(NZMX,NFRC), SAE(NZMX,NFRC), CAE(NZMX,NFRC)


      COMMON /SORTIE/ VTMOD, DZMOD, XNHC, XNHB, SNHDZ & 
     &, TOCLY, TOCBA, TAUTO(NTAR), SIDFR(NTAR) & 
     &, AMB1(NTAR), AMB2(NTAR), HIFR(NPSOR,NTAR)

      DIMENSION BIDON(NZMX), AUX(NFRC,NZMX), TAUNU(NFRC,NZMX)
      DIMENSION TOZ(2*NZMX), SZ(2*NZMX), DTOZ(NZMX)

      NT = NTC(IT)
      NI = NINF(NT)
      FR0 = FRN(NK) - FRN(NI)
      ALP0 = SEPION ( FR0, NI )
      DO 100 J = 1, NFRC
      FR(J) = FRC(J,IT)
      PHI(J) = SEPION ( FR(J), NI ) / ALP0
 100  CONTINUE
      CALL COIN ( 1, NFRC, FR, WF )
      CNORM = 0.0
      DO 120 J = 1, NFRC
      WF(J) = WF(J) * SEPION ( FR(J), NI ) / ( HP * FR(J) )
      CNORM = CNORM + WF(J)
 120  CONTINUE
      DO 140 J = 1, NFRC
      WF(J) = WF(J) / CNORM
 140  CONTINUE
      DO 180 I = 1, NZ
      ETLIS = HNE(I) * POM(NI) * EXP ( HP * FR0 / ( BOLT * TE(I) ) ) / &
     & ( UK * 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
      TO(1) = 0.
      CA = HN(1,NI) * ALP0
      L1 = 1
      DO 200 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
 200  CONTINUE
      L2 = NZ
      IF ( IVERT .EQ. 1 ) GO TO 230
      DO 220 I = 2, NZ
      IZ = NZ - I + 1
      IF ( TO(NZ)-TO(IZ) .LT. TOMIN ) L2 = IZ
 220  CONTINUE
 230  CONTINUE

      IF ( IVERT .EQ. 1 ) THEN
      IF ( NI .EQ. 1 ) TOCLY = 2.0 * TO(NZ)
      IF ( NI .EQ. 2 ) TOCBA = 2.0 * TO(NZ)
      END IF

      DO 240 J = 1, NFRC
      CALL PROFSC ( 0, FR(J), BIDON, SAE(1,J), CAE(1,J), RAE(1,J) )
      DO 240 I = 1, NZ
      RAE(I,J) = RAE(I,J) / ( ALP0 * HN(I,NI) )
 240  CONTINUE
      DO 260 J = 1, NFRC
      TAUNU(J,1) = 0.0
 260  CONTINUE
      DO 280 IZ = 2, NZ
      DO 280 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) ) )
 280  CONTINUE

      IF ( TO(NZ) .GE. EOLIM ) THEN
 300  CONTINUE
      CALL TFCFEV ( NZ, 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 320 IZ = 1, NZ
      DO 320 J = 1, NFRC
      AUX(J,IZ) = FKTC(J,IZ,IT)
 320  CONTINUE
      CALL NOVFEV ( NZ, NFRC, 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 340 IZ = 1, NZ
      DO 340 J = 1, NFRC
      EMAX = AMAX1 ( EMAX, ABS(AUX(J,IZ)-FKTC(J,IZ,IT)) )
 340  CONTINUE
!     WRITE ( 8, 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 400 I = 1, NZ
      RIKP(I,IT) = 4.0 * PI * CNORM * GIBAR(I)
 400  CONTINUE

!             Cas optiquement mince

      ELSE
      CALL TFCOM ( NZ, FRC(1,IT), PHI, RAE, CAE, SAE, CSI0, ETA0 & 
     &, FIIC(1,IT), FISC(1,IT), WF, TE, GIBAR, STC(1,1,IT) )
      DO 440 I = 1, NZ
      GIBAR(I) = RIK(I,IT) / ( 4.0 * PI * CNORM )
      RIKP(I,IT) = RIK(I,IT)
 440  CONTINUE
      END IF

!              Calcul des intensites emergentes

      IF ( IOPECO(IT) .EQ. 0 ) RETURN
      DO 600 J = 1, NFRC
      NZCC = NZ
      DO 500 IZ = 1, NZ
      TOZ(IZ) = TAUNU(J,IZ)
      SZ(IZ) = STC(J,IZ,IT)
 500  CONTINUE
      HIL = FIIC(J,IT)
      IF ( IVERT .EQ. 1 ) THEN
      NZCC = 2 * NZ - 1
      DO 520 IZ = 1, NZ-1
      DTOZ(IZ) = TOZ(IZ+1) - TOZ(IZ)
 520  CONTINUE
      DO 540 IZ = NZ+1, NZCC
      TOZ(IZ) = TOZ(IZ-1) + DTOZ(2*NZ-IZ)
      SZ(IZ) = SZ(2*NZ-IZ)
 540  CONTINUE
      HIL = 0.0
      END IF
      DO 560 K = 1, NMUV
      CALL TRALA ( NZCC, TOZ, SZ, HIL, PMU(K), HIEMC(J,K,IT) )
 560  CONTINUE
 600  CONTINUE

      RETURN
      END
      SUBROUTINE NOVBRN
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR)& 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR)& 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) & 
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      DO 200 J = 1, NTAR
      RA = RXRO(J)
      RB = 1.0 - RA
      DO 150 I = 1, NZ
      BRN(I,J) = RA * BRN(I,J) + RB * BRP(I,J)
 150  CONTINUE
 200  CONTINUE
      RETURN
      END
      SUBROUTINE NOVFEV ( NZ, NF, L1, L2, IVERT, TAU, FIINF, FISUP & 
     &,                   S, FEVK, FEVL )

!              Calcul des nouveaux facteurs d'Eddington a partir
!         des fonctions sources pour une couche d'epaisseur finie.
!         (Valable pour les raies comme pour les continus).

!!      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
! modif le 28/07/2015
! call CALL COEFQG ( NMU, 0.0, 1.0, HMU, H ), il faut que HMU soit de taille 5
        PARAMETER ( NZMX=100, NFR=20, NMU=5, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )


      DIMENSION TAU(NF,NZMX), FIINF(NF), FISUP(NF), S(NF,NZMX) & 
     &, FEVK(NF,NZMX), FEVL(NF,NZMX)
      DIMENSION HMU(NMU), H(NMU), A(NMU*NFR,NZMX), B(NMU*NFR,NZMX) & 
     &,         C(NMU*NFR,NZMX), E(NMU*NFR,NZMX), D(NMU*NFR,NZMX) &
     &,         F(NMU*NFR,NZMX), Y(NMU*NFR,NZMX)

      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 140 IA = 1, NMU
      DO 140 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)
 140  CONTINUE
      GO TO 300

 150  CONTINUE
      IF ( I .EQ. L2 ) GO TO 250

!              Profondeurs intermediaires

      DO 210 IA = 1, NMU
      DO 210 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)
 210  CONTINUE
      GO TO 300

 250  CONTINUE
      DO 260 IA = 1, NMU
      DO 260 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
 260  CONTINUE
 300  CONTINUE

!              Resolution du systeme tridiagonal

      DO 320 J = 1, NFM
      D(J,L1) = C(J,L1) / B(J,L1)
      F(J,L1) = E(J,L1) / B(J,L1)
 320  CONTINUE
      DO 340 I = L1+1, L2-1
      DO 340 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) )
 340  CONTINUE
      DO 360 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) )
 360  CONTINUE
      DO 380 I = L2-1, L1, -1
      DO 380 J = 1, NFM
      Y(J,I) = D(J,I) * Y(J,I+1) + F(J,I)
 380  CONTINUE

!              Calcul des F. E. V.

      DO 420 IB = 1, NF
      DO 420 I = L1, L2
      A(IB,I) = 0.0
      B(IB,I) = 0.0
      C(IB,I) = 0.0
 420  CONTINUE
      DO 440 IA = 1, NMU
      DO 440 IB = 1, NF
      DO 440 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)
 440  CONTINUE
      DO 500 IB = 1, NF
      DO 500 I = L1, L2
      FEVL(IB,I) = B(IB,I) / A(IB,I)
      FEVK(IB,I) = C(IB,I) / A(IB,I)
 500  CONTINUE
      DO 600 IZ = 1, NZ
      IF ( IZ .LT. L1 ) THEN
      DO 520 IB = 1, NF
      FEVK(IB,IZ) = FEVK(IB,L1)
      FEVL(IB,IZ) = FEVL(IB,L1)
 520  CONTINUE
      END IF
      IF ( IZ .GT. L2 ) THEN
      DO 540 IB = 1, NF
      FEVK(IB,IZ) = FEVK(IB,L2)
      FEVL(IB,IZ) = FEVL(IB,L2)
 540  CONTINUE
      END IF
 600  CONTINUE

      RETURN
      END
      SUBROUTINE NOVRIK
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR)& 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP) 
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      DO 100 ITAC = 1 , NTAC
      IF ( ICTC(ITAC) .GT. 2 ) GO TO 100
      R1 = RXIK ( ITAC )
      R2 = 1.0 - R1
      DO 80 I = 1, NZ
      RIK1 = RIK(I,ITAC)
      RIK2 = RIKP(I,ITAC)
      IF ( RIK2 .LT. 0. ) RIK2 = 0.
      RIK(I,ITAC) = R1 * RIK1 + R2 * RIK2
 80   CONTINUE
 100  CONTINUE
      RETURN
      END
      SUBROUTINE NOVTER

!              Mise a jour des temperatures de rayonnement dans les
!         transitions continues pour l'iteration ( ITG ) suivante

 1    FORMAT ( '1ITERATION NO. ', I3 / &
     & ' MISE A JOUR DES TEMPERATURES DE RAYONNEMENT POUR LA ' &
     & I3, 'EME TRANSITION CONTINUE' )
 2    FORMAT ( // 20X, 17HVALEURS INITIALES / )
 3    FORMAT ( // 20X, 37HSOLUTIONS DE L EQUATION DE TRANSFERT / )
 4    FORMAT ( // 20X, 'ECARTS' / )
 5    FORMAT ( 10(2X,G11.4) )
 6    FORMAT ( / ' Iteration ', I3, ' , Continu ', I3, ' : Ecarts sur' & 
     & , ' les T. R. ' )
 7    FORMAT ( 1X, 10F7.0 )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      DIMENSION TRZERO(NZMX)

      DO 160 IT = 1, NTAC
      IF ( ICTC(IT) .GE. 3 ) GO TO 160
      IF ( IVTR .EQ. 1 ) WRITE ( 6, 6 ) NITG, IT
      IF ( IVTR .EQ. 2 ) WRITE ( 6, 1 ) NITG, IT
      DO 120 I = 1, NZ
      TRZERO(I) = TR(I,IT)
 120  CONTINUE
      IF ( IVTR .EQ. 2 ) WRITE ( 6, 2 )
      IF ( IVTR .EQ. 2 ) WRITE ( 6, 5 ) ( TRZERO(I), I = 1, NZ )
      CALL TEMPRA ( IT, 2 )
      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 140 I = 1, NZ
      TR(I,IT) = RXTR * TRZERO(I) + ( 1. - RXTR ) * TR(I,IT)
 140  CONTINUE
 160  CONTINUE
      RETURN
      END
      SUBROUTINE PENDULE
        EXTERNAL SECOND
      CALL SECOND ( TCP )
      WRITE ( 8, 1 ) TCP
 1    FORMAT ( / 1X, 40(1H-), 5X, 'TCP = ', F10.3, 5X, 40(1H-) / )

      RETURN
      END
      SUBROUTINE PROEM1

!            Calcul du profil emergent en incidence normale.
!         Version sans impression; les profils calcules sont stockes
!         dans le common /SORTIE/ (pour la version avec courbes sur
!         listing, voir "P1").

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP) 
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF
 
      COMMON /TRANSF/ NRA, NT, FR0, L1, L2, TO(NZMX) & 
     &, DND(NZMX), AM(NZMX), EPS(NZMX), BEN(NZMX), CAR(NZMX), RF(NZMX) & 
     &, DDC(NZMX), SL(NZMX), GIBAR(NZMX), FR(NFR), R(NFR2) & 
     &, PHI(NFR,NZMX), GI(NFR,NZMX), COHE(NZMX)


      COMMON /SORTIE/ VTMOD, DZMOD, XNHC, XNHB, SNHDZ & 
     &, TOCLY, TOCBA, TAUTO(NTAR), SIDFR(NTAR) & 
     &, AMB1(NTAR), AMB2(NTAR), HIFR(NPSOR,NTAR)

      DIMENSION XX(NPSOR), YY(NPSOR), CQI(NPSOR)

      AMBDA = CL / FR0
      DO 40 IP = 1, NPSOR
      DLA = DL1(NRA) + ( DL2(NRA) - DL1(NRA) ) * FLOAT(IP-1) / & 
           FLOAT(NPSOR-1)
      FREQ = CL / ( AMBDA + 1.E-8 * DLA )
      XX(IP) = DLA
      CALL INTEME ( 1.0, FREQ-FR0, YY(IP) )
 40   CONTINUE
      DO 130 IP = 1, NPSOR
      XX(IP) = CL / ( AMBDA + 1.E-8 * XX(IP) ) - FR0
 130  CONTINUE
      CALL COIN ( 1, NPSOR, XX, CQI )
      XIINT = 0.0
      DO 135 IP = 1, NPSOR
      XIINT = XIINT + YY(IP) * CQI(IP)
 135  CONTINUE
      XIINT = ABS ( XIINT * 2.0 )

      AMB1(NRA) = 1.E8 * AMBDA + DL1(NRA)
      AMB2(NRA) = 1.E8 * AMBDA + DL2(NRA)
      SIDFR(NRA) = XIINT
      DO 200 IP = 1, NPSOR
      HIFR(IP,NRA) = YY(IP)
 200  CONTINUE

      RETURN
      END
      SUBROUTINE PROEM2

!            Calcul du profil emergent pour plusieurs incidences
!            avec ecriture des resultats sur le fichier 21.

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC)  & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /TRANSF/ NRA, NT, FR0, L1, L2, TO(NZMX) & 
     &, DND(NZMX), AM(NZMX), EPS(NZMX), BEN(NZMX), CAR(NZMX), RF(NZMX) & 
     &, DDC(NZMX), SL(NZMX), GIBAR(NZMX), FR(NFR), R(NFR2) &
     &, PHI(NFR,NZMX), GI(NFR,NZMX), COHE(NZMX)


      DIMENSION XX(NPSOR), YY(NPSOR,NMUV)

      AMBDA = CL / FR0
      DO 40 IP = 1, NPSOR
      DLA = DL1(NRA) + ( DL2(NRA) - DL1(NRA) ) * FLOAT(IP-1) / & 
     &      FLOAT(NPSOR-1)
      FREQ = CL / ( AMBDA + 1.E-8 * DLA )
      XX(IP) = DLA
      DO 40 IC = 1, NMUV
      CALL INTEME ( PMU(IC), FREQ-FR0, YY(IP,IC) )
 40   CONTINUE
      WRITE ( 21, 107 ) NRA, FR0, NPSOR, NMUV
 107  FORMAT ( I10, 2X, E16.7, 2X, 2I10 )
      WRITE ( 21, 108 ) ( PMU(IC), IC = 1, NMUV )
 108  FORMAT ( 6E12.3 )
      WRITE ( 21, 108 ) ( XX(IP), IP = 1, NPSOR )
      DO 120 IC = 1, NMUV
      WRITE ( 21, 108 ) ( YY(IP,IC), IP = 1, NPSOR )
 120  CONTINUE

      RETURN
      END
      SUBROUTINE PROEM3

!            Calcul des intensites emergentes pour Paletou
!            avec ecriture des resultats sur le fichier 25.

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP) 
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


      DIMENSION TOZ(NZMX), SZ(NZMX), AUX1(NZMX), AUX2(NZMX), AUX3(NZMX)
      DIMENSION XX(NFR), YY(NFR,NMUV)

      DO 200 IR = 1, 10
      NT = NTR(IR)
      NI = NINF(NT)
      NS = NSUP(NT)
      FR0 = FRN(NS) - FRN(NI)
      AMBDA = 1.E8 * CL / FR0
      DO 150 J = 1, NFR
      DFR = FRR(J,IR)
      ALA = 1.E8 * CL / ( FR0 + DFR )
      DLA = ABS ( ALA - AMBDA )
      XX(J) = DLA
      TOZ(1) = 0.0
      SZ(1) = STR(J,1,IR)
      DO 120 IZ = 2, NZ
      TOZ(IZ) = TOZ(IZ-1) + 0.5 * ( CAC(IZ-1,IR) + CAC(IZ,IR) + & 
     & CARR(IZ-1,IR) * PHIR(J,IZ-1,IR) + CARR(IZ,IR) * PHIR(J,IZ,IR) ) * & 
     & ( Z(IZ) - Z(IZ-1) )
      SZ(IZ) = STR(J,IZ,IR)
 120  CONTINUE
      HIL = SZ(NZ)
      DO 150 IC = 1, NMUV
      CALL TRALA ( NZ, TOZ, SZ, HIL, PMU(IC), YY(J,IC) )
 150  CONTINUE
      WRITE ( 25, 157 ) NI, NS, AMBDA
 157  FORMAT ( / ' raie ', 2I5, 10X, 'lambda', F10.2 )
      WRITE ( 25, 158 ) ( PMU(IC), IC = 1, NMUV )
 158  FORMAT ( 10X, ' mu = ', 3F12.2 )
      DO 180 J = 1, NFR
      WRITE ( 25, 177 ) XX(J), ( YY(J,IC), IC = 1, NMUV )
 177  FORMAT ( 1X, F12.3, 3E14.4 )
 180  CONTINUE
 200  CONTINUE

      DO 400 IT = 1, 5
      NT = NTC(IT)
      NI = NINF(NT)
      FR0 = FRN(NK) - FRN(NI)
      AMBDA = 1.E8 * CL / FR0
      DO 300 J = 1, NFRC
      FREQ = FRC(J,IT)
      XX(J) = 1.E8 * CL / FREQ
      CALL PROFSC ( 1, FREQ, TOZ, AUX1, AUX2, AUX3 )
      CALL FONSOC ( NZ, TOZ, AUX1, AUX2, AUX3, SZ )
      HIL = BENU ( FREQ, TE(NZ) )
      DO 300 IC = 1, NMUV
      CALL TRALA ( NZ, TOZ, SZ, HIL, PMU(IC), YY(J,IC) )
 300  CONTINUE
      WRITE ( 25, 333 ) NI, AMBDA
 333  FORMAT ( / ' continu ', I5, 10X, 'lambda', F10.2 )
      WRITE ( 25, 158 ) ( PMU(IC), IC = 1, NMUV )
      DO 400 J = 1, NFRC
      WRITE ( 25, 177 ) XX(J), ( YY(J,IC), IC = 1, NMUV )
 400  CONTINUE

      RETURN
      END
      SUBROUTINE RAOPMI ( ITAR )

!               Raies optiquement minces : traitement simplifie
!         lorsque ICTR(ITAR) = 5

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA


      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 RPRAIE ( ITAR )

      PARAMETER ( TOMIN=1.E-3, CRIT=1.E-3 )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &  
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     & , FIZERO, WLYA

      COMMON /TRANSF/ NRA, NT, FR0, L1, L2, TO(NZMX) & 
     &, DND(NZMX), AM(NZMX), EPS(NZMX), BEN(NZMX), CAR(NZMX), RF(NZMX) & 
     &, DDC(NZMX), SL(NZMX), GIBAR(NZMX), FR(NFR), R(NFR2) &
     &, PHI(NFR,NZMX), GI(NFR,NZMX), COHE(NZMX)


      COMMON /SORTIE/ VTMOD, DZMOD, XNHC, XNHB, SNHDZ & 
     &, TOCLY, TOCBA, TAUTO(NTAR), SIDFR(NTAR) & 
     &, AMB1(NTAR), AMB2(NTAR), HIFR(NPSOR,NTAR)
      COMMON /CSLYM/ ILYM, SLYMA(NFR,NZMX), SLYMB(NFR,NZMX)

      DIMENSION AUX(NFR,NZMX), TAUNU(NFR,NZMX)

      NRA = ITAR
      NT = NTR(ITAR)
      NI = NINF(NT)
      NS = NSUP(NT)
      FR0 = FRN(NS) - FRN(NI)

      DO 110 IZ = 1, NZ
      DND(IZ) = DNDR(IZ,ITAR)
      AM(IZ) = AMR(IZ,ITAR)
      COHE(IZ) = COHER(IZ,ITAR)
 110  CONTINUE
      DO 120 IB = 1, NFR
      FR(IB) = FRR(IB,ITAR)
 120  CONTINUE
      DO 130 IZ = 1, NZ
      DO 130 IB = 1, NFR
      PHI(IB,IZ) = PHIR(IB,IZ,ITAR)
 130  CONTINUE

      BSI = AE(ITAR) / ( C4 * FR0**3 )
      BIS = BSI * POM(NS) / POM(NI)
      COEF = HP * FR0 / ( 4. * PI )
      DO 135 IZ = 1, NZ
      CAR(IZ) = COEF * ( HN(IZ,NI) * BIS - HN(IZ,NS) * BSI ) / DND(IZ)
      RF(IZ) = CAC(IZ,ITAR) / CAR(IZ)
      DDC(IZ) = DCAC(IZ,ITAR)
      CARR(IZ,ITAR) = CAR(IZ)
 135  CONTINUE
      DO 140 IB = 1, NFR
      TAUNU(IB,1) = 0.0
 140  CONTINUE
      TO(1) = 0.0
      L1 = 1
      DO 150 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 145 IB = 1, NFR
      TAUNU(IB,IZ) = TAUNU(IB,IZ-1) + DTO * 0.5 * ( PHI(IB,IZ) + & 
     &               PHI(IB,IZ-1) + RF(IZ) + RF(IZ-1) )
 145  CONTINUE
 150  CONTINUE
      L2 = NZ
      IF ( IVERT .EQ. 1 ) GO TO 180
      DO 160 I = 2, NZ
      IZ = NZ - I + 1
      IF ( TO(NZ)-TO(IZ) .LT. TOMIN ) L2 = IZ
 160  CONTINUE
 180  CONTINUE

      IF ( IVERT .EQ. 1 ) TAUTO(ITAR) = 2.0 * TAUNU(1,NZ)

      CALL EPSBEN
      DO 350 ITFEV = 1, 5
      ILYM = NRA
      CALL TFRFEV ( NZ, L1, L2, IVERT, FR, PHI, RF, TO, DDC, SC(1,ITAR) & 
     &,    EPS, BEN, FIIR(1,ITAR), FISR(1,ITAR), RDMAT(1,1,ITAR) & 
     &,    FEVK(1,1,ITAR), FEVL(1,1,ITAR), GI, GIBAR, STR(1,1,ITAR) )
      IF ( IOPFEV .EQ. 0 ) GO TO 380
      DO 300 IZ = 1, NZ
      DO 300 IB = 1, NFR
      AUX(IB,IZ) = FEVK(IB,IZ,ITAR)
 300  CONTINUE
      CALL NOVFEV ( NZ, NFR, L1, L2, IVERT, TAUNU, FIIR(1,ITAR) &
     &, FISR(1,ITAR), STR(1,1,ITAR), FEVK(1,1,ITAR), FEVL(1,1,ITAR) )
      EMAX = 0.0
      DO 320 IZ = 1, NZ
      DO 320 IB = 1, NFR
      EMAX = AMAX1 ( EMAX, ABS(AUX(IB,IZ)-FEVK(IB,IZ,ITAR)) )
 320  CONTINUE
      IF ( IOPFEV .GE. 2 ) WRITE ( 8, 321 ) ITFEV, ITAR, EMAX
 321  FORMAT ( 10X, 'C.F.E.', I3, 10X, 'Raie no.', I4, 10X, 'Emax =' & 
     &, F10.5 )
      IF ( EMAX .LE. CRIT ) GO TO 380
 350  CONTINUE
 380  CONTINUE
      DO 400 IZ = 1, NZ
      SRCE = EPS(IZ) * BEN(IZ) + ( 1. - EPS(IZ) ) * GIBAR(IZ)
      BRP(IZ,ITAR) = EPS(IZ) * ( BEN(IZ) - GIBAR(IZ) ) / SRCE
 400  CONTINUE

      RETURN
      END
      SUBROUTINE SAHARA ( IOP, T, HNH, HNP, HNE )
      DIMENSION HNT(20), F(20,4)
      character*4 NOM

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA


      COMMON /ELEMTS/ NEL, NOM(20), ABON(20), HM(20), NEI(20), PIO(20,4) & 
     &, U(20,5), HNION(5,20)

      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
 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
 200  CONTINUE
      HNE=HMIN+(HMAX-HMIN)*X
      HNPE=HNP
      DO 210 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
 210  CONTINUE
      FX=(HNPE-HNE)/HMAX
      IF(INDEX-2) 110,120,130
 300  CONTINUE
      HNE=HNPE
      DO 310 I = 1 , NELU
      HNION(1,I) = 1.0
      SOM = 1.0
      DO 320 J=2,5
      HNION(J,I) = HNION(J-1,I) * F(I,J-1) / HNE
      SOM = SOM + HNION(J,I)
 320  CONTINUE
      DO 330 J=1,5
      HNION(J,I) = HNT(I) * HNION(J,I) / SOM
 330  CONTINUE
 310  CONTINUE
      RETURN
      END
      FUNCTION SEPION ( FR, NI )

!              CALCUL DE LA SECTION EFFICACE DE PHOTO-IONISATION POUR
!         L/ HYDROGENE A LA FREQUENCE FR, A PARTIR DU NIVEAU NI

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &  
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


      FR0 = FRN(NK) - FRN(NI)

!           Facteurs de Gaunt d'apres Gingerich

      W = 2.997925E15 / FR
      IF ( NI .GE. 7 ) GO TO 7
      GO TO ( 1, 2, 3, 4, 5, 6, 7 ) NI
    1 GAUNT=0.9916+(9.068E-3-0.2524*W)*W
      GO TO 100
    2 GAUNT=1.105+(-7.922E-02+4.536E-3*W)*W
      GO TO 100
    3 GAUNT=1.101+(-3.290E-2+1.152E-3*W)*W
      GO TO 100
    4 GAUNT=1.101+(-1.923E-2+5.110E-4*W)*W
      GO TO 100
    5 GAUNT=1.102+(-0.01304+2.638E-4*W)*W
      GO TO 100
    6 GAUNT=1.0986+(-0.00902+1.367E-4*W)*W
      GO TO 100
    7 GAUNT=1.
 100  CONTINUE
      SEPION = 7.906E-18 * FLOAT(NI) * GAUNT * ( FR0 / FR ) ** 3
      RETURN
      END
      SUBROUTINE SOLINT

!              Definition des intensites emises par le disque solaire
!         dans les differentes raies, servant a etablir les conditions
!         aux limites pour la resolution des equations de transfert

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP) 
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA


!              Raies d'ordre inferieur ou egal a 10 :
!         lecture des intensites sur des fichiers exterieurs.

      DO 300 K = 1, 8
      READ ( 4, * ) IT
      READ ( 4, * ) NFINT(IT), COEF
      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

!              Lyman -gamma et -delta :
!         On suppose que ces raies ont des profils identiques a celui
!         de lyman-beta. Les rapports des intensites integrees sont
!         deduits des observations.

      NFINT(4) = NFINT(2)
      NFINT(7) = NFINT(2)
      DO 400 I = 1, NFINT(2)
      FRFI(I,4) = FRFI(I,2)
      FRFI(I,7) = FRFI(I,2)
      FINT(I,4) = FINT(I,2) * 0.230
      FINT(I,7) = FINT(I,2) * 0.112
 400  CONTINUE

!              Raies d'indice superieur a 10 : on utilise la table
!         des temperatures de brillance.

      IF ( NRAMX .LE. 10 ) RETURN
      DO 600 IT = 11, NRAMX
      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 = C4 * FR0**3 / ( EXP(HP*FR0/(BOLT*TB)) - 1.0 )
      FINT(1,IT) = HJB
      FINT(2,IT) = HJB
 600  CONTINUE

      RETURN
      END
      SUBROUTINE SORTAB

!              Sortie des tableaux de resultats sur fort.11
!                 (couche verticale uniquement).

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC)& 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR)& 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC)&
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


      COMMON /SORTIE/ VTMOD, DZMOD, XNHC, XNHB, SNHDZ & 
     &, TOCLY, TOCBA, TAUTO(NTAR), SIDFR(NTAR) & 
     &, AMB1(NTAR), AMB2(NTAR), HIFR(NPSOR,NTAR)

   1  FORMAT ( 1X, 70(1HD) )
   2  FORMAT ( 1X, 5I14 )
   3  FORMAT ( 1X, 5E14.6 )
   4  FORMAT ( 1X, 70(1HF) )

      IF ( IVERT .NE. 1 ) RETURN
      TOTM = 2.0 * ABS ( XM(NZ) - XM(1) )
      DZMOD = 2.0 * ABS ( Z(NZ) - Z(1) )
      XNHC = HNH(NZ)
      XNHB = HNH(1)
      SNHDZ = 0.0
      DO 120 I = 2, NZ
      SNHDZ = SNHDZ + ( HNH(I-1) + HNH(I) ) * ABS ( Z(I) - Z(I-1) )
 120  CONTINUE

      WRITE ( 11, 1 )
! ... Donnees generales
      WRITE ( 11, 2 ) NZ, NFRC
      WRITE ( 11, 3 ) TSLAB, PSLAB, DZMOD, VTMOD, TOTM, XNHC, XNHB &
     &,               SNHDZ, TOCLY, TOCBA 
! ... Altitudes
      WRITE ( 11, 3 ) ( Z(IZ), IZ = 1, NZ )
! ... Densites electroniques
      WRITE ( 11, 3 ) ( HNE(IZ), IZ = 1, NZ )
      NRAS = 0
      DO 140 I = 1, NTAR
      IF ( IOPERA(I) .EQ. 1 ) NRAS = NRAS + 1
 140  CONTINUE
! ... Principaux profils de raies
      WRITE ( 11, 2 ) NRAS
      DO 210 I = 1, NTAR
      IF ( IOPERA(I) .EQ. 0 ) GO TO 210
      WRITE ( 11, 2 ) I
      WRITE ( 11, 3 ) AMB1(I), AMB2(I)
      WRITE ( 11, 3 ) TAUTO(I), SIDFR(I)
      WRITE ( 11, 3 ) ( HIFR(J,I), J = 1, NPSOR )
 210  CONTINUE
! ... Fonctions sources pour H-alpha
      WRITE ( 11, 3 ) ( STR(1,IZ,3), IZ = 1, NZ )
! ... Profil du continu de Lyman
      WRITE ( 11, 3 ) ( FRC(J,1), J = 1, NFRC )
      WRITE ( 11, 3 ) ( HIEMC(J,1,1), J = 1, NFRC )
      WRITE ( 11, 4 )

      RETURN
      END
      FUNCTION TEMBRI ( AMBDA )

!              Temperature de brillance pour le flux solaire (disque
!         integre) a la longueur d'onde AMBDA (microns).

      PARAMETER ( N = 45 )
      COMMON /CTEMBR/ WL(N), TB(N)

      DATA 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.0911 &
     &,       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. /
      DATA 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 TEMPRA ( ITAC, IOP )

!              TEMPRA calcule les temperatures de rayonnement
!         correspondant a des taux de photoionisation donnes

 1    FORMAT ( /// 20X, 19HERREUR DANS TEMPRA / 15X, &
     & 17HPROFONDEUR NO    , I3 / 15X, 27HTAUX DE PHOTOIO NISATION    , & 
     & G12.5 / 15X, 24HNOMBRE D ITERATIONS :   , I4 /// )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) & 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /TRANC/ NT, FR0, L1, L2, TO(NZMX) &
     &, CSI0(NZMX), ETA0(NZMX), GIBAR(NZMX), FR(NFRC), WF(NFRC) &
     &, PHI(NFRC), CNORM &
     &, RAE(NZMX,NFRC), SAE(NZMX,NFRC), CAE(NZMX,NFRC)


      NT = NTC(ITAC)
      NI = NINF(NT)
      FR0 = FRN(NK) - FRN(NI)
      ALP0 = SEPION ( FR0, NI )
      DO 120 J = 1, NFRC
      FR(J) = FR0 * XFRC(J)
      PHI(J) = SEPION ( FR(J), NI ) / ALP0
 120  CONTINUE
      CALL COIN ( 1, NFRC, FR, WF )
      CNORM = 0.0
      DO 140 J = 1, NFRC
      WF(J) = WF(J) * SEPION ( FR(J), NI ) / ( HP * FR(J) )
      CNORM = CNORM + WF(J)
 140  CONTINUE
      DO 160 J = 1, NFRC
      WF(J) = WF(J) / CNORM
 160  CONTINUE
      DO 300 IZ = 1, NZ
      IF ( IOP .EQ. 1 ) RIS = RIK(IZ,ITAC)
      IF ( IOP .EQ. 2 ) RIS = RIKP(IZ,ITAC)
      IF ( RIS .LE. 0. ) GO TO 900
      GIB = RIS / ( 4.0 * PI * CNORM )
      NIT = 0
      TMIN = 0.
      TMAX = TE(IZ)
 180  CONTINUE
      GIMAX = GIBMOY ( TMAX )
      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 )
      PREC = ABS ( ( FTRAY - GIB ) / ( FTRAY + GIB ) )
      IF ( PREC .LT. 1.E-6 ) GO TO 260
      IF ( FTRAY - GIB ) 220, 260, 240
 220  CONTINUE
      TMIN = TRAY
      GO TO 200
 240  CONTINUE
      TMAX = TRAY
      GO TO 200
 260  CONTINUE
      TR(IZ,ITAC) = TRAY
 300  CONTINUE
      RETURN
 900  CONTINUE
      PRINT 1, IZ, RIS, NIT
      STOP
      END
      FUNCTION GIBMOY ( TR )
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      COMMON /TRANC/ NT, FR0, L1, L2, TO(NZMX) & 
     &, CSI0(NZMX), ETA0(NZMX), GIBAR(NZMX), FR(NFRC), WF(NFRC) & 
     &, PHI(NFRC), CNORM & 
     &, RAE(NZMX,NFRC), SAE(NZMX,NFRC), CAE(NZMX,NFRC)

      XX = 0.
      CAT = BOLT * TR
      DO 200 J = 1, NFRC
      XX = XX + WF(J) * FR(J)**3 * EXP ( - HP * FR(J) / CAT )
 200  CONTINUE
      GIBMOY = C4 * XX
      RETURN
      END
      SUBROUTINE TESTH6
 1    FORMAT ( / 20X, 19H*** TEST GLOBAL *** / )
      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT 
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      WRITE (8,1)
      IF ( IOPATM .GT. 0 ) CALL EXOATM
      IF ( IOPCAC .EQ. 3 ) CALL ABSCON ( IOPEAC )
      IF ( IOPTTC .GT. 0 ) CALL ECRITAU ( 0 )
      CALL EQST ( 1 )
      IF ( IOPPOP .GT. 0 ) CALL ECRIPOP ( 1 )
      DO 200 ITAR = 1 , NTAR
      IF ( ICTR(ITAR) .GE. 3 ) GO TO 200
      CALL RPCDEF ( ITAR, IOPREN )
      CALL RPRAIE ( ITAR )
      IF ( IOPERA(ITAR) .EQ. 0 ) GO TO 200
      IF ( IOPRA .EQ. 1 ) CALL EXOTDE
      IF ( IPROM .EQ. 1 ) CALL PROEM1
      IF ( IPROF .GE. 1 ) CALL PROEM2
 200  CONTINUE
      DO 300 ITAC = 1 , NTAC
      IF ( ICTC(ITAC) .GE. 3 ) GO TO 300
      CALL NLTEBF ( ITAC )
      IF ( IOPECO(ITAC) .GT. 0 ) CALL EXOTCO
 300  CONTINUE
      IF ( IOPROB .GT. 0 ) CALL EXPROB
      IF ( IPAL .EQ. 1 ) CALL PROEM3
      CALL EQST ( 2 )
      CALL COMPAR ( EMIN1, EMAX1, EMIN2, EMAX2, EMIN3, EMAX3 )
      CALL COMPAC ( EMIN, EMAX )
      WRITE ( 8, 399 ) EMIN1, EMAX1, EMIN2, EMAX2, EMIN3, EMAX3, EMIN &
     &, EMAX
 399  FORMAT ( 8(3X,F12.6) )

      RETURN
      END
      SUBROUTINE TFCFEV ( NZ, L1, L2, IVERT, FR, PHI, TAU, RAE, CAE & 
     &, SAE, CSI0, ETA0, FIINF, FISUP, WF, TE, FEVK, FEVL, GIBAR, S )

!             LE SOUS-PROGRAMME TFCFEV RESOUT LES EQUATIONS DU TRANSFERT
!         DE RAYONNEMENT POUR UNE TRANSITION CONTINUE, EN TENANT
!         COMPTE DES ABSORBANTS EXTERNES. IL UTILISE LA METHODE DES
!         DIFFERENCES FINIES AVEC DES FACTEURS D'EDDINGTON VARIABLES.

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA


      DIMENSION FR(NFRC), PHI(NFRC), TAU(NFRC,NZMX), RAE(NZMX,NFRC) & 
     &, CAE(NZMX,NFRC), SAE(NZMX,NFRC), CSI0(NZMX), ETA0(NZMX) & 
     &, FIINF(NFRC), FISUP(NFRC), WF(NFRC), TE(NZMX) &
     &, FEVK(NFRC,NZMX), FEVL(NFRC,NZMX), GIBAR(NZMX), S(NFRC,NZMX)
      DIMENSION GI(NFRC,NZMX), CSI(NFRC,NZMX), ETA(NFRC,NZMX) & 
     &, D(NFRC,NFRC,NZMX), F(NFRC,NZMX), A(NFRC), B(NFRC,NFRC), C(NFRC) &
     &, E(NFRC), AUXM(NFRC,NFRC), AUXV(NFRC), DTOM(NFRC), DTOP(NFRC) &
     &, DTO(NFRC)

      DO 150 IZ = 1, NZ
      DO 150 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)
 150  CONTINUE

      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 210 J = 1, NFRC
      DTOP(J) = TAU(J,IZ+1) - TAU(J,IZ)
 210  CONTINUE
      DO 220 K = 1, NFRC
      DO 220 J = 1, NFRC
      B(J,K) = - 0.5 * DTOP(J) * PHI(J) * CSI(J,IZ) * WF(K) / & 
     &         ( PHI(J) + RAE(IZ,J) )
 220  CONTINUE
      DO 240 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)
 240  CONTINUE
      CALL INVMAT ( B, NFRC )
      DO 260 K = 1, NFRC
      DO 260 J = 1, NFRC
      D(J,K,L1) = B(J,K) * C(K)
 260  CONTINUE
      CALL PROMAV ( B, E, F(1,L1), NFRC )
      GO TO 500

 300  CONTINUE
      DO 320 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) )
 320  CONTINUE
      DO 340 K = 1, NFRC
      DO 340 J = 1, NFRC
      B(J,K) = - DTO(J) * PHI(J) * CSI(J,IZ) * WF(K) / ( PHI(J) + & 
     &         RAE(IZ,J) )
 340  CONTINUE
      DO 360 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) )
 360  CONTINUE
      GO TO 480

 400  CONTINUE
      DO 420 J = 1, NFRC
      DTOM(J) = TAU(J,L2) - TAU(J,L2-1)
 420  CONTINUE
      DO 440 K = 1, NFRC
      DO 440 J = 1, NFRC
      B(J,K) = - 0.5 * DTOM(J) * PHI(J) * CSI(J,IZ) * WF(K) / & 
     &        ( PHI(J) + RAE(IZ,J) )
 440  CONTINUE
      DO 450 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) )
 450  CONTINUE
      IF ( IVERT .NE. 1 ) THEN
      DO 460 J = 1, NFRC
      B(J,J) = B(J,J) + FEVL(J,IZ)
      E(J) = E(J) + 0.5 * FIINF(J)
 460  CONTINUE
      END IF

 480  CONTINUE
      DO 485 K = 1, NFRC
      DO 485 J = 1, NFRC
      AUXM(J,K) = B(J,K) - A(J) * D(J,K,IZ-1)
 485  CONTINUE
      CALL INVMAT ( AUXM, NFRC )
      DO 490 K = 1, NFRC
      DO 490 J = 1, NFRC
      D(J,K,IZ) = AUXM(J,K) * C(K)
 490  CONTINUE
      DO 495 J = 1, NFRC
      AUXV(J) = E(J) + A(J) * F(J,IZ-1)
 495  CONTINUE
      CALL PROMAV ( AUXM, AUXV, F(1,IZ), NFRC )
 500  CONTINUE

      DO 560 IZ = L2, L1, -1
      IF ( IZ .EQ. L2 ) THEN
      DO 520 J = 1, NFRC
      GI(J,IZ) = F(J,IZ)
 520  CONTINUE
      ELSE
      CALL PROMAV ( D(1,1,IZ), GI(1,IZ+1), AUXV, NFRC )
      DO 540 J = 1, NFRC
      GI(J,IZ) = AUXV(J) + F(J,IZ)
 540  CONTINUE
      END IF
 560  CONTINUE
      DO 580 IZ = L1, L2
      GIBAR(IZ) = 0.0
 580  CONTINUE
      DO 600 J = 1, NFRC
      DO 600 IZ = L1, L2
      GIBAR(IZ) = GIBAR(IZ) + WF(J) * GI(J,IZ)
 600  CONTINUE

      DO 700 IZ = 1, NZ
      IF ( IZ .LT. L1 ) THEN
      GIBAR(IZ) = GIBAR(L1)
      DO 620 J = 1, NFRC
      GI(J,IZ) = GI(J,L1)
 620  CONTINUE
      END IF
      IF ( IZ .GT. L2 ) THEN
      GIBAR(IZ) = GIBAR(L2)
      DO 640 J = 1, NFRC
      GI(J,IZ) = GI(J,L2)
 640  CONTINUE
      END IF
 700  CONTINUE

!              Calcul des fonctions sources

      DO 800 IZ = 1, NZ
      DO 800 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) )
 800  CONTINUE

      RETURN
      END
      SUBROUTINE TFCOM ( NZ, FR, PHI, RAE, CAE, SAE, CSI0, ETA0 & 
     &, FIINF, FISUP, WF, TE, GIBAR, S )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA


      DIMENSION FR(NFRC), PHI(NFRC), RAE(NZMX,NFRC) & 
     &, CAE(NZMX,NFRC), SAE(NZMX,NFRC), CSI0(NZMX), ETA0(NZMX) & 
     &, FIINF(NFRC), FISUP(NFRC), WF(NFRC), TE(NZMX) &
     &, GIBAR(NZMX), S(NFRC,NZMX)
      DIMENSION GI(NFRC,NZMX), CSI(NFRC,NZMX), ETA(NFRC,NZMX) & 
     &, AUXV(NFRC)

      DO 150 IZ = 1, NZ
      DO 150 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)
 150  CONTINUE

      GIBAR(1) = 0.0
      DO 700 J = 1, NFRC
      GI(J,1) = 0.5 * ( FIINF(J) + FISUP(J) )
      GIBAR(1) = GIBAR(1) + WF(J) * GI(J,1)
 700  CONTINUE
      DO 750 IZ = 2, NZ
      GIBAR(IZ) = GIBAR(1)
      DO 750 J = 1, NFRC
      GI(J,IZ) = GI(J,1)
 750  CONTINUE

!              Calcul des fonctions sources

      DO 800 IZ = 1, NZ
      DO 800 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) )
 800  CONTINUE

      RETURN
      END
      SUBROUTINE TFRFEV ( NZ, L1, L2, IVERT, FR, PHI, RF, TO, DDC & 
     &, SC, EPS, BEN, FIINF, FISUP, RDMAT, FEVK, FEVL, GI, GIBAR, S )

!              Resolution des equations de transfert pour une raie
!         par la methode des differences finies (Feautrier) avec
!         utilisation des facteurs d'Eddington variables :
!         - Couche plan-parallele d'epaisseur finie
!         - 3 options : atmosphere (IVERT=-1)
!                       couche horizontale (IVERT=0)
!                       demi-couche verticale (IVERT=1)
!         - absorption continue
!         - redistribution partielle en frequence

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )


      COMMON /CSLYM/ ILYM, SLYMA(NFR,NZMX), SLYMB(NFR,NZMX) 
      DIMENSION FR(NFR), PHI(NFR,NZMX), RF(NZMX), TO(NZMX) & 
     &, DDC(NZMX), SC(NZMX), EPS(NZMX), BEN(NZMX), FIINF(NFR) &
     &, FISUP(NFR), RDMAT(NFR2,NZMX), FEVK(NFR,NZMX), FEVL(NFR,NZMX) &
     &, GI(NFR,NZMX), GIBAR(NZMX), S(NFR,NZMX)
      DIMENSION HF(NFR), D(NFR,NFR,NZMX), F(NFR,NZMX), A(NFR) & 
     &, B(NFR,NFR), C(NFR), E(NFR), AUXM(NFR,NFR), AUXV(NFR) &
     &, DTO(NFR,NZMX), DTOM(NFR,NZMX), DTOP(NFR,NZMX)

      CALL COIN ( 1, NFR, FR, HF )

      IF ( TO(NZ) .LT. EOLIM ) GO TO 600

      DO 110 J = 1, NFR
      DO 100 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)
 100  CONTINUE
      DO 110 I = L1+1, L2-1
      DTO(J,I) = 0.5 * ( DTOM(J,I) + DTOP(J,I) )
 110  CONTINUE

      DO 300 I = L1, L2
      IF ( I .GT. L1 ) GO TO 200

      DO 120 K = 1, NFR
      DO 120 J = 1, NFR
      B(J,K) = 0.5 * DTOP(J,I) * ( EPS(I) - 1.0 ) * RDMAT(NFR*K-NFR+J,I) & 
     &         / ( PHI(J,I) + RF(I) )
 120  CONTINUE
      DO 130 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) )
 130  CONTINUE
      CALL INVMAT ( B, NFR )
      DO 140 K = 1, NFR
      DO 140 J = 1, NFR
      D(J,K,L1) = B(J,K) * C(K)
 140  CONTINUE
      CALL PROMAV ( B, E, F(1,L1), NFR )
      GO TO 300

 200  CONTINUE
      IF ( I .EQ. L2 ) GO TO 250

      DO 210 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) )
 210  CONTINUE
      DO 220 K = 1, NFR
      DO 220 J = 1, NFR
      B(J,K) = ( EPS(I) - 1.0 ) * DTO(J,I) * RDMAT(NFR*K-NFR+J,I) / & 
     &         ( RF(I) + PHI(J,I) )
 220  CONTINUE
      DO 230 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) )
 230  CONTINUE
      GO TO 290

 250  CONTINUE
      DO 260 K = 1, NFR
      DO 260 J = 1, NFR
      B(J,K) = 0.5 * DTOM(J,I) * ( EPS(I) - 1.0 ) * RDMAT(NFR*K-NFR+J,I) & 
     &         / ( PHI(J,I) + RF(I) )
 260  CONTINUE
      DO 270 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) )
 270  CONTINUE
      IF ( IVERT .NE. 1 ) THEN
      DO 280 J = 1, NFR
      B(J,J) = B(J,J) + FEVL(J,I)
      E(J) = E(J) + 0.5 * FIINF(J)
 280  CONTINUE
      END IF
 290  CONTINUE
      DO 292 K = 1, NFR
      DO 292 J = 1, NFR
      AUXM(J,K) = B(J,K) - A(J) * D(J,K,I-1)
 292  CONTINUE
      CALL INVMAT ( AUXM, NFR )
      DO 294 K = 1, NFR
      DO 294 J = 1, NFR
      D(J,K,I) = AUXM(J,K) * C(K)
 294  CONTINUE
      DO 296 J = 1, NFR
      AUXV(J) = E(J) + A(J) * F(J,I-1)
 296  CONTINUE
      CALL PROMAV ( AUXM, AUXV, F(1,I), NFR )
 300  CONTINUE

      DO 400 II = L1 , L2
      I = L1 + L2 - II
      IF ( I .EQ. L2 ) THEN
      DO 320 J = 1, NFR
      GI(J,I) = F(J,I)
 320  CONTINUE
      ELSE
      CALL PROMAV ( D(1,1,I), GI(1,I+1), AUXV, NFR )
      DO 330 J = 1, NFR
      GI(J,I) = AUXV(J) + F(J,I)
 330  CONTINUE
      END IF
      GIBAR(I) = 0.0
      SOM = 0.0
      DO 350 J = 1, NFR
      COEF = HF(J) * PHI(J,I)
      GIBAR(I) = GIBAR(I) + COEF * GI(J,I)
      SOM = SOM + COEF
 350  CONTINUE
      GIBAR(I) = GIBAR(I) / SOM
 400  CONTINUE

      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 440 J = 1, NFR
      GI(J,I) = GI(J,L1)
 440  CONTINUE
      GO TO 500
 460  CONTINUE
      GIBAR(I) = GIBAR(L2)
      DO 480 J = 1, NFR
      GI(J,I) = GI(J,L2)
 480  CONTINUE
 500  CONTINUE
      GO TO 800

!              CAS OU LA COUCHE EST OPTIQUEMENT MINCE POUR LA RAIE
!         CONSIDEREE. L'INTENSITE MOYENNE EST OBTENUE EN FAISANT LA
!         MOYENNE DES INTENSITES INCIDENTES SUR LES DEUX FACES.

 600  CONTINUE
      DO 640 I = 1, NZ
      GIBAR(I) = 0.0
      SOM = 0.0
      DO 620 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
 620  CONTINUE
      GIBAR(I) = GIBAR(I) / SOM
 640  CONTINUE

!              Calcul des fonctions-sources

 800  CONTINUE
      DO 820 I = 1, NZ
      CALL PROMAV ( RDMAT(1,I), GI(1,I), S(1,I), NFR )
 820  CONTINUE
      IF ( ILYM .EQ. 1 ) THEN
      DO 827 J = 1, NFR
      DO 827 I = 1, NZ
      SLYMA(J,I) = EPS(I) * BEN(I) + ( 1.0 - EPS(I) ) * S(J,I) / &
     & PHI(J,I)
 827  CONTINUE
      END IF
      IF ( ILYM .EQ. 2 ) THEN
      DO 833 J = 1, NFR
      DO 833 I = 1, NZ
      SLYMB(J,I) = EPS(I) * BEN(I) + ( 1.0 - EPS(I) ) * S(J,I) / & 
     & PHI(J,I)
 833  CONTINUE
      END IF
      DO 840 J = 1, NFR
      DO 840 I = 1, NZ
      S(J,I) = ( RF(I) * ( 1.0 - DDC(I) ) * SC(I) + PHI(J,I) * EPS(I) & 
     &         * BEN(I) + RF(I) * DDC(I) * GI(J,I) + ( 1.0 - EPS(I) ) &
     &         * S(J,I) ) / ( PHI(J,I) + RF(I) )
 840  CONTINUE

      RETURN
      END
      FUNCTION TMPRAY ( B, FREQ )

!               TMPRAY CALCULE LA TEMPERATURE DE RAYONNEMENT
!         CORRESPONDANT A L'INTENSITE B ( EN ERG/S/CM2/SR/HZ ) ET
!         A LA FREQUENCE FREQ

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      XXX = 1. + C4 * FREQ**3 / B
      TMPRAY = HP * FREQ / ( BOLT * ALOG(XXX) )
      RETURN
      END
      SUBROUTINE TRALA ( N, TO, S, HIL, PMU, HI )
      DIMENSION TO(1) , S(1)
      XI = -TO(1) / PMU
      IF ( XI .LT. -100. ) GO TO 50
      XI = EXP ( XI )
      SI = S(1)
      IF ( N - 1 ) 70 , 60 , 10
 10   CONTINUE
      DXI = 1. - XI
      HI = DXI * SI
      DO 20 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
 20   CONTINUE
!         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 (//' PROFONDEURS OPTIQUES INCORRECTES A L ENTREE DE TRALA' & 
     & / 10(3X,G10.4) // )
      STOP

 70   CONTINUE
      PRINT 2, N
 2    FORMAT ( // ' VALEUR DE N INCORRECTE DANS TRALA :  N =', I5 // )
      STOP

      END
      SUBROUTINE TXCOLL

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )


      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA


      DIMENSION AUX1(NZMX), AUX2(NZMX)

      DO 600 IT = 1, NTT
      NI = NINF(IT)
      NS = NSUP(IT)
      FREQ = FRN(NS) - FRN(NI)
      DO 100 IZ = 1, NZ
      CALL INTERL ( NTAB, TAB, OIS(1,IT), TE(IZ), AUX1(IZ) )
 100  CONTINUE
      DO 200 IZ = 1, NZ
      AUX2(IZ) = EXP ( HP * FREQ / ( BOLT * TE(IZ) ) )
      CIJ(IZ,IT) = HNE(IZ) * AUX1(IZ) / AUX2(IZ)
 200  CONTINUE
      IF ( NS .NE. NK ) THEN
      DO 300 IZ = 1, NZ
      AUX2(IZ) = AUX2(IZ) * POM(NI) / POM(NS)
 300  CONTINUE
      ELSE
      DO 400 IZ = 1, NZ
      AUX2(IZ) = HNE(IZ) * POM(NI) * AUX2(IZ) / ( UK * C5 * TE(IZ)**1.5 & 
     & )
 400  CONTINUE
      END IF
      DO 500 IZ = 1, NZ
      CJI(IZ,IT) = CIJ(IZ,IT) * AUX2(IZ)
 500  CONTINUE
 600  CONTINUE

      RETURN
      END
      FUNCTION BENU (FR,T)

      H = 6.6262E-27
      C = 2.997925E10
      HK = 1.3806E-16

      A = H*FR/(HK*T)
      IF (A.GT.740.) GOTO 10
      BENU = 2.*H*FR**3/(C*C*(EXP(A)-1.))
      RETURN
 10   BENU = 0.
      RETURN
      END
      FUNCTION ERFCA ( X )

! FONCTION APPROCHANT ERFC ( X ) A MIEUX QUE 1.E-3 PRES

      PARAMETER ( A1=.254829592, A2=-.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.
      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
      SUBROUTINE COEFQG ( N , A , B , T , H )
      DIMENSION T(5),H(5)
      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 250 I = 1 , N
      T(I) = VM + DL * T(I)
      H(I) = DL * H(I)
 250  CONTINUE
      RETURN
      END
      SUBROUTINE COIN ( IOP, KMAX, V, H )

      DIMENSION V(KMAX), H(KMAX)

      DO 110 K = 2, KMAX-1
      H(K) = 0.5 * ( V(K+1) - V(K-1) )
 110  CONTINUE
      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

      DIMENSION XT(N), YT(N)

      COMMON / CINTER / 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, P, Q )
      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 )

!     Interpolation par spline (memes arguments que INTERL)

      PARAMETER ( NMAX=1024 )
      DIMENSION X1(N1), Y1(N1), HM(NMAX), P(NMAX), Q(NMAX)

      IF ( N1 .GT. NMAX ) GO TO 900
      CALL SPLDEF ( N1, X1, Y1, HM, P, Q )
      CALL SPLUSE ( N1, X1, Y1, HM, X2, Y2 )
      RETURN

 900  CONTINUE
      PRINT 999, N1, NMAX
 999  FORMAT ( // ' Arret dans SPLINT' / ' N1 =', I5, 5X, 'NMAX =', I5 & 
     &  // )
      STOP

      END
      SUBROUTINE CSHYDR ( IFTOT, IFLYA, IFBAA )

!           Calcul du spectre de l'hydrogene.
!           Options :
!           IFTOT = 1 : de 1000 a 8000 AA (resolution: 10 AA)
!           IFTOT = 2 : de 0.1 a 4.1 microns (echelle logarithmique)
!           IFLYA = 1 : region de Lyman-alpha (1212.5 -> 1218.5 AA)
!           IFBAA = 1 : region de H-alpha (6480 -> 6650 AA)
!
!      WRITE ( 22, 101 )
 101  FORMAT ( / 1X, 20(1H-), ' DEBUT ftn22 ', 20(1H-) )
      IF  ( IFTOT .GE. 1 ) THEN
      WRITE ( 22, 111 )
 111  FORMAT ( '########## SPECTRE VISIBLE ET ULTRAVIOLET ##########' )
      WLMIN = 1000.
      WLRES = 10.
      NFRFL = 701
      IF ( IFTOT .EQ. 2 ) THEN
      WLRES = 41000.
      NFRFL = -1000
      END IF
      CALL CALIAH ( WLMIN, WLRES, NFRFL )
      END IF
      IF ( IFLYA .GE. 1 ) THEN
!      WRITE ( 22, 122 )
 122  FORMAT ( '########## REGION DE LYMAN-ALPHA ##########' )
      WLMIN = 1212.5
      WLRES = 0.01
      NFRFL = 601
      CALL CALIAH ( WLMIN, WLRES, NFRFL )
      END IF
      IF ( IFBAA .GE. 1 ) THEN
      WRITE ( 22, 133 )
 133  FORMAT ( '########## REGION DE H-ALPHA ##########' )
      WLMIN = 6480.
      WLRES = 0.2
      NFRFL = 851
      CALL CALIAH ( WLMIN, WLRES, NFRFL )
      END IF
!      WRITE ( 22, 199 )
 199  FORMAT ( 1X, 20(1H-), '  FIN  ftn22 ', 20(1H-) )

      RETURN
      END
      SUBROUTINE CALIAH ( WLMIN, WLRES, NFRFLU )

!              Calcul des intensites absolues dans une partie du
!         spectre de l'hydrogene
!
!         WLMIN : plus petite longueur d'onde (Angstroms)
!         WLRES : pas en longueur d'onde (Angstroms)
!         NFRFL : nombre de points ( <= NDIM )
!         si NFRFLU > 0 , NFRFL = NFRFLU
!         si NFRFLU < 0  [  NFRFL = - NFRFLU
!                        [  echelle log avec max = WLRES
!
      PARAMETER ( NDIM=1001, NMUF=10 )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF


      DIMENSION XMU(NMUF), WMU(NMUF), FRFL(NDIM), XINT(NDIM,NMUF) & 
     &, AUX1(NZMX), AUX2(NZMX), AUX3(NZMX), AUX4(NZMX) &
     &, CABF(NZMX), CEBF(NZMX), CADP(NZMX), CABR(NZMX), CEMR(NZMX) & 
     &, STL(NZMX)

 10   FORMAT ( 1X, I10 )
 11   FORMAT ( 5(1X,E15.6) )

!              FORMULE DE QUADRATURE EN DIRECTION POUR LE CALCUL DU
!         FLUX EMERGENT
!
!         F = 2 * PI * SOMME DE 0 A 1 DE I(MU) * MU * DMU
!           = SIGMA DE J = 1 A NMUF DE WMU(J) * I ( MU(J) )
!
      DO 110 J = 1, NMUF
      XMU(J) = ( FLOAT(J) - 0.5 ) / FLOAT ( NMUF )
      WMU(J) = 1.0 / FLOAT(NMUF)
 110  CONTINUE
      DO 120 J = 1, NMUF
      WMU(J) = WMU(J) * 2.0 * PI * XMU(J)
 120  CONTINUE

!              CALCUL DES FREQUENCES ( FRSUP ), POIDS STATISTIQUES
!         ( PSUP ) ET POPULATIONS ( XNSUP ) DES NIVEAUX SUPPLEMENTAIRES
!         DE L'ATOME D'HYDROGENE.

      DO 200 J = 1, NNSUP
      JNIV = NND + J
      FRJC = FRN(NK) / FLOAT ( JNIV * JNIV )
      FRSUP(J) = FRN(NK) - FRJC
      PSUP(J) = 2.0 * FLOAT ( JNIV * JNIV )
      HNUSK = HP * FRJC / BOLT
      DO 200 IZ = 1, NZ
      XNSUP(IZ,J) = HN(IZ,NK) * HNE(IZ) * PSUP(J) * EXP ( HNUSK / &
     & TE(IZ) ) / ( UK * C5 * TE(IZ)**1.5 )
 200  CONTINUE

!              CALCUL DES FREQUENCES DE LA GRILLE.

      IF ( NFRFLU .GT. 0 ) THEN
      NFRFL = NFRFLU
      DO 260 K = 1, NFRFL
      FRFL(K) = 1.E8 * CL / ( WLMIN + WLRES * FLOAT ( NFRFL - K ) )
 260  CONTINUE
      ELSE
      NFRFL = - NFRFLU
      FMIN = ALOG ( 1.E8 * CL / WLRES )
      FMAX = ALOG ( 1.E8 * CL / WLMIN )
      DO 270 K = 1, NFRFL
      FRFL(K) = EXP ( FMIN + (FMAX-FMIN) * FLOAT(K-1) / FLOAT(NFRFL-1) )
 270  CONTINUE
      END IF

      IF ( NFRFL .GT. NDIM ) GO TO 900

!              DEBUT DU CALCUL DES FLUX : BOUCLE GENERALE SUR LES
!         FREQUENCES.

      DO 600 K = 1, NFRFL
      FREQ = FRFL(K)

!              CALCUL DES COEFFICIENTS D'ABSORPTION ET D'EMISSION LIES
!         AUX CONTINUS ET A LA DIFFUSION PURE :
!         CABF, CEBF : CONTINUS ("BOUND-FREE")
!         CADP : C. A. POUR LA DIFFUSION PURE
!         AUX2 = CEBF / CABF
!         AUX3 = CADP / ( CADP + CABF )
!         AUX4 = CADP + CABF

      CALL PROFSC ( 1, FREQ, AUX1, AUX2, AUX3, AUX4 )
      DO 320 IZ = 1, NZ
      CADP(IZ) = AUX3(IZ) * AUX4(IZ)
      CABF(IZ) = AUX4(IZ) - CADP(IZ)
      CEBF(IZ) = CABF(IZ) * AUX2(IZ)
 320  CONTINUE

!              CALCUL DES COEFFICIENTS D'ABSORPTION ( CABR ) ET
!         D'EMISSION ( CEMR ) DUS AUX RAIES DE L'HYDROGENE : SERIES
!         DE LYMAN, BALMER ET PASCHEN

      CALL SERLYM ( FREQ, CABR, CEMR )
      CALL SERBAL ( FREQ, AUX1, AUX2 )
      CALL SERPAS ( FREQ, AUX3, AUX4 )
      DO 360 IZ = 1, NZ
      CABR(IZ) = CABR(IZ) + AUX1(IZ) + AUX3(IZ)
      CEMR(IZ) = CEMR(IZ) + AUX2(IZ) + AUX4(IZ)
 360  CONTINUE

!              CALCUL DES PROFONDEURS OPTIQUES ET DES FONCTIONS SOURCES
!         NECESSAIRES AU CALCUL DES INTENSITES EMERGENTES.
!         AUX1 : PROFONDEURS OPTIQUES
!         AUX2 : FONCTION SOURCE "CONTINU + RAIES"
!         AUX3 = CADP / ( CABF + CADP + CABR )
!         AUX4 : COEFFICIENT D'ABSORPTION TOTAL, PUIS INTENSITE MOYENNE
!         STL  : FONCTION SOURCE TOTALE

      DO 400 IZ = 1, NZ
      AUX4(IZ) = CABF(IZ) + CADP(IZ) + CABR(IZ)
      AUX3(IZ) = CADP(IZ) / AUX4(IZ)
      AUX2(IZ) = ( CEBF(IZ) + CEMR(IZ) ) / ( CABF(IZ) + CABR(IZ) )
 400  CONTINUE
      AUX1(1) = 0.0
      DO 420 IZ = 2, NZ
      AUX1(IZ) = AUX1(IZ-1) + 0.5 * ( AUX4(IZ-1) + AUX4(IZ) ) * &
     & ( Z(IZ) - Z(IZ-1) )
 420  CONTINUE
      CALL FONSOC ( NZ, AUX1, AUX2, AUX3, AUX4, STL )

!              CALCUL DES INTENSITES EMERGENTES

      HIL = BENU ( FREQ, TE(NZ) )
      DO 500 IMU = 1, NMUF
      CALL TRALA ( NZ, AUX1, STL, HIL, XMU(IMU), XINT(K,IMU) )
 500  CONTINUE
 600  CONTINUE

      WRITE ( 22, 611 ) NFRFL, NMUF
 611  FORMAT ( 2(1X,I9) )
      WRITE ( 22, 11 ) ( XMU(I), WMU(I),I = 1, NMUF )
      WRITE ( 22, 11 ) ( FRFL(K), K = 1, NFRFL )
      DO 620 I = 1, NMUF
      WRITE ( 22, 11 ) ( XINT(K,I), K = 1, NFRFL )
 620  CONTINUE
      RETURN

 900  CONTINUE
      PRINT 999, NFRFL, NDIM
 999  FORMAT ( /// ' ARRET DANS CALIAH' / ' NFRFL =', I5, 5X, ' NDIM =' & 
     &, I5 / )
      STOP
      END
      SUBROUTINE SERLYM ( FREQ, CAB, CEM )

!              CALCUL DES COEFFICIENTS D'ABSORPTION ( CAB ) ET
!         D'EMISSION ( CEM ) DUS AUX RAIES DE LA SERIE DE LYMAN, POUR
!         LA FREQUENCE FREQ.

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR)  &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CSLYM/ ILYM, SLYMA(NFR,NZMX), SLYMB(NFR,NZMX)

      DIMENSION CAB(NZMX), CEM(NZMX), AUX1(NZMX), AUX2(NZMX)

      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 VOIVEC ( NZ, AMR(1,1), AUX1, AUX2 )
      DO 440 IZ = 1, NZ
      CALL INTERL ( NFR, FRR(1,1), SLYMA(1,IZ), 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 VOIVEC ( NZ, AMR(1,2), AUX1, AUX2 )
      DO 540 IZ = 1, NZ
      CALL INTERL ( NFR, FRR(1,2), SLYMB(1,IZ), 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
      SUBROUTINE SERBAL ( FREQ, CAB, CEM )

!              CALCUL DES COEFFICIENTS D'ABSORPTION ( CAB ) ET
!         D'EMISSION ( CEM ) DUS AUX RAIES DE LA SERIE DE BALMER, POUR
!         LA FREQUENCE FREQ.

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 & 
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 & 
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT & 
     &, IOPMIC, IFTOT, IFLYA, IFBAA & 
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX & 
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) & 
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) & 
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) & 
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) & 
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) & 
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) & 
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) & 
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) & 
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) & 
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) & 
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) & 
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP & 
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA & 
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA & 
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG & 
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN & 
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) & 
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) & 
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) & 
     &, DFRCO(NZMX), HNT(NZMX) & 
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) & 
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) & 
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) & 
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) & 
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG & 
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      PARAMETER ( NBRB=38 )

      DIMENSION CAB(NZMX), CEM(NZMX)

      COMMON /CSERBA/ INIT, FRA1, FRA2, FRB1, FRB2, FRC1, FRC2 &
     &, EXSTA, AUX1(NZMX), AUX2(NZMX), AUX3(NZMX) &
     &, FCR(NBRB), AJI(NBRB), GAMN(NBRB), CSTA(NBRB) &
     &, CACR(NZMX,NBRB), SR(NZMX,NBRB), DNDB(NZMX,NBRB), DFRS(NZMX,NBRB)

      DATA INIT / 0 /
      DATA AJI / 4.41E7, 8.42E6, 2.53E6, 9.73E5, 4.39E5, 2.22E5, 1.22E5 & 
     &, 7.12E4, 4.40E4, 2.83E4, 1.89E4, 1.30E4, 9.2E3, 6.7E3, 4.9E3 & 
     &, 3.7E3, 2.8E3, 2.2E3, 1.7E3, 1.3E3, 1.1E3, 8.7E2, 7.1E2, 5.8E2 &
     &, 4.8E2, 4.0E2, 3.4E2, 2.8E2 &
     &, 242., 206., 177., 152., 132., 114., 100., 87., 77., 67. /
      DATA GAMN / 5.7E8, 5.0E8, 36*4.8E8 /
      DATA FRA1 / 4.4E14 /, FRA2 / 4.7E14 /
      DATA FRB1 / 6.0E14 /, FRB2 / 6.4E14 /
      DATA FRC1 / 6.7E14 /, FRC2 / 8.5E14 /

      IF ( INIT .EQ. 1 ) GO TO 300

!              INITIALISATION :
!
!         NBRB : NOMBRE DE RAIES DE LA SERIE DE BALMER
!         FCR  : FREQUENCE CENTRALE DE CHAQUE RAIE
!        AJI  : PROBABILITE D'EMISSION SPONTANEE PAR UNITE DE TEMPS
!         GAMN : CONSTANTE D'ELARGISSEMENT NATUREL
!         CSTA : COEFFICIENT POUR LE CALCUL APPROCHE DE L'ELARGISSEMENT
!                STARK ( CF. SUTTON, 1978 )
!         CACR : COEFFICIENT D'ABSORPTION AU CENTRE
!         SR   : FONCTION SOURCE
!         DNDB : LARGEUR DOPPLER
!         DFRS : DEMI-LARGEUR STARK

      DO 120 IR = 1, NBRB
      NS = IR + 2
      IF ( NS .LE. NND ) FCR(IR) = FRN(NS) - FRN(2)
      IF ( NS .GT. NND ) FCR(IR) = FRSUP(NS-NND) - FRN(2)
      CSTA(IR) = 0.60 * ( FLOAT(NS*NS) - 4.0 )
 120  CONTINUE
      CSTA(1) = CSTA(1) * 0.642
      EXSTA = 2.0 / 3.0
      HM = HMA * UMA
      DO 140 IZ = 1, NZ
      AUX1(IZ) = SQRT ( 2.0 * BOLT * TE(IZ) / HM + VT(IZ)**2 ) / CL
 140  CONTINUE
      DO 160 IR = 1, NBRB
      DO 160 IZ = 1, NZ
      DNDB(IZ,IR) = FCR(IR) * AUX1(IZ)
      DFRS(IZ,IR) = CSTA(IR) * HNE(IZ)**EXSTA
 160  CONTINUE
      DO 240 IR = 1, NBRB
      NS = IR + 2
      TRUC = C4 * FCR(IR)**3
      BJI = AJI(IR) / TRUC
      COEF = FIZERO * HP * FCR(IR) / ( 4.0 * PI )
      IF ( NS .GT. NND ) GO TO 200
      BIJ = BJI * POM(NS) / POM(2)
      DO 180 IZ = 1, NZ
      CACR(IZ,IR) = COEF * ( HN(IZ,2) * BIJ - HN(IZ,NS) * BJI ) / &
     & DNDB(IZ,IR)
      SR(IZ,IR) = TRUC / ( HN(IZ,2) * POM(NS) / ( HN(IZ,NS) * POM(2) ) &
     & - 1.0 )
 180  CONTINUE
      GO TO 240
 200  CONTINUE
      BIJ = BJI * PSUP(NS-NND) / POM(2)
      DO 220 IZ = 1, NZ
      CACR(IZ,IR) = COEF * ( HN(IZ,2) * BIJ - XNSUP(IZ,NS-NND) * BJI ) &
     & / DNDB(IZ,IR)
      SR(IZ,IR) = TRUC / ( HN(IZ,2) * PSUP(NS-NND) / ( XNSUP(IZ,NS-NND) &
     & * POM(2) ) - 1.0 )
 220  CONTINUE
 240  CONTINUE
      INIT = 1
 300  CONTINUE

!              DEBUT DU CALCUL DES COEFFICIENTS D'ABSORPTION ET
!         D'EMISSION

      DO 320 IZ = 1, NZ
      CAB(IZ) = 0.0
      CEM(IZ) = 0.0
 320  CONTINUE
      IF ( FREQ .LT. FRA1 .OR. FREQ .GT. FRC2 ) RETURN
      IF ( FREQ .LT. FRA2 ) GO TO 400
      IF ( FREQ .GT. FRB1 .AND. FREQ .LT. FRB2 ) GO TO 500
      IF ( FREQ .GT. FRC1 ) GO TO 600
      RETURN
 400  CONTINUE

!              REGION DE LA RAIE H - ALPHA

      DFR = ABS ( FREQ - FCR(1) )
      DO 420 IZ = 1, NZ
      AUX1(IZ) = DFR / DNDB(IZ,1)
      AUX3(IZ) = ( GAMN(1) / ( 4.0 * PI ) & 
     &         + DFR / SQRT ( ( 1.0 + DFR / DFRS(IZ,1) ) ** 2.5 - 1.0 ) &
     &        ) / DNDB(IZ,1)
 420  CONTINUE
      CALL VOIVEC ( NZ, AUX3, AUX1, AUX2 )
      DO 440 IZ = 1, NZ
      CAB(IZ) = CACR(IZ,1) * AUX2(IZ)
      CEM(IZ) = CAB(IZ) * SR(IZ,1)
 440  CONTINUE
      RETURN
 500  CONTINUE

!              REGION DE LA RAIE H - BETA

      DFR = ABS ( FREQ - FCR(2) )
      DO 520 IZ = 1, NZ
      AUX1(IZ) = DFR / DNDB(IZ,2)
      AUX3(IZ) = ( GAMN(2) / ( 4.0 * PI ) & 
     &         + DFR / SQRT ( ( 1.0 + DFR / DFRS(IZ,2) ) ** 2.5 - 1.0 ) &
     &         ) / DNDB(IZ,2)
 520  CONTINUE
      CALL VOIVEC ( NZ, AUX3, AUX1, AUX2 )
      DO 540 IZ = 1, NZ
      CAB(IZ) = CACR(IZ,2) * AUX2(IZ)
      CEM(IZ) = CAB(IZ) * SR(IZ,2)
 540  CONTINUE
      RETURN
 600  CONTINUE

!              REGION DES RAIES DE BALMER D'ORDRE ELEVE

      DO 680 IR = 3, NBRB
      DFR = ABS ( FREQ - FCR(IR) )
      DO 620 IZ = 1, NZ
      AUX1(IZ) = DFR / DNDB(IZ,IR)
      AUX3(IZ) = ( GAMN(IR) / ( 4.0 * PI ) &
     &         + DFR / SQRT ( ( 1.0 + DFR / DFRS(IZ,IR) ) ** 2.5 - 1.0 ) &
     &         ) / DNDB(IZ,IR )
 620  CONTINUE
      CALL VOIVEC ( NZ, AUX3, AUX1, AUX2 )
      DO 640 IZ = 1, NZ
      AUX2(IZ)  = AUX2(IZ) * CACR(IZ,IR)
      CAB(IZ) = CAB(IZ) + AUX2(IZ)
      CEM(IZ) = CEM(IZ) + AUX2(IZ) * SR(IZ,IR)
 640  CONTINUE
 680  CONTINUE
      RETURN
      END
      SUBROUTINE SERPAS ( FREQ, CAB, CEM )

!              CALCUL DES COEFFICIENTS D'ABSORPTION ( CAB ) ET
!         D'EMISSION ( CEM ) DUS AUX RAIES DE LA SERIE DE PASCHEN, POUR
!         LA FREQUENCE FREQ.

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA 

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      PARAMETER ( NBRP=17 )

      DIMENSION CAB(NZMX), CEM(NZMX)

      COMMON /CSERPA/ INIT, FR1, FR2, AUX1(NZMX), AUX2(NZMX) & 
     &, FCR(NBRP), AJI(NBRP), GAMN(NBRP) &
     &, CACR(NZMX,NBRP), SR(NZMX,NBRP), DNDP(NZMX,NBRP), AMP(NZMX,NBRP)

      DATA INIT / 0 /
      DATA AJI / 8.99E6, 2.20E6, 7.78E5, 3.36E5, 1.65E5, 8.91E4, 5.16E4 & 
     &, 3.16E4, 2.02E4, 1.34E4, 9.2E3, 6.5E3, 4.7E3, 3.4E3, 2.6E3 &
     &, 2.0E3, 1.5E3 /
      DATA GAMN / 1.30E8, 1.11E8, 1.05E8, 1.02E8, 13*1.0E8 /
      DATA FR1 / 1.5E14 /, FR2 / 4.E14 /

      IF ( INIT .EQ. 1 ) GO TO 300

!              INITIALISATION :

!         NBRP : NOMBRE DE RAIES DE LA SERIE DE PASCHEN
!         FCR  : FREQUENCE CENTRALE DE CHAQUE RAIE
!         AJI  : PROBABILITE D'EMISSION SPONTANEE PAR UNITE DE TEMPS
!         GAMN : CONSTANTE D'ELARGISSEMENT NATUREL
!         CACR : COEFFICIENT D'ABSORPTION AU CENTRE
!         SR   : FONCTION SOURCE
!         DNDP : LARGEUR DOPPLER
!         AMP  : FACTEUR D'AMORTISSEMENT

      DO 120 IR = 1, NBRP
      NS = IR + 3
      IF ( NS .LE. NND ) FCR(IR) = FRN(NS) - FRN(3)
      IF ( NS .GT. NND ) FCR(IR) = FRSUP(NS-NND) - FRN(3)
 120  CONTINUE
      HM = HMA * UMA
      DO 140 IZ = 1, NZ
      AUX1(IZ) = SQRT ( 2.0 * BOLT * TE(IZ) / HM + VT(IZ)**2 ) / CL
 140  CONTINUE
      DO 160 IR = 1, NBRP
      DO 160 IZ = 1, NZ
      DNDP(IZ,IR) = FCR(IR) * AUX1(IZ)
      AMP(IZ,IR) = GAMN(IR) / ( 4.0 * PI * DNDP(IZ,IR) )
 160  CONTINUE
      DO 240 IR = 1, NBRP
      NS = IR + 3
      TRUC = C4 * FCR(IR)**3
      BJI = AJI(IR) / TRUC
      COEF = FIZERO * HP * FCR(IR) / ( 4.0 * PI )
      IF ( NS .GT. NND ) GO TO 200
      BIJ = BJI * POM(NS) / POM(3)
      DO 180 IZ = 1, NZ
      CACR(IZ,IR) = COEF * ( HN(IZ,3) * BIJ - HN(IZ,NS) * BJI ) / &
     & DNDP(IZ,IR)
      SR(IZ,IR) = TRUC / ( HN(IZ,3) * POM(NS) / ( HN(IZ,NS) * POM(3) ) &
     & - 1.0 )
 180  CONTINUE
      GO TO 240
 200  CONTINUE
      BIJ = BJI * PSUP(NS-NND) / POM(3)
      DO 220 IZ = 1, NZ
      CACR(IZ,IR) = COEF * ( HN(IZ,3) * BIJ - XNSUP(IZ,NS-NND) * BJI ) &
     & / DNDP(IZ,IR)
      SR(IZ,IR) = TRUC / ( HN(IZ,3) * PSUP(NS-NND) / ( XNSUP(IZ,NS-NND) &
     & * POM(3) ) - 1.0 )
 220  CONTINUE
 240  CONTINUE
      INIT = 1
 300  CONTINUE

!              DEBUT DU CALCUL DES COEFFICIENTS D'ABSORPTION ET
!        D'EMISSION

      DO 320 IZ = 1, NZ
      CAB(IZ) = 0.0
      CEM(IZ) = 0.0
 320  CONTINUE
      IF ( FREQ .LT. FR1 .OR. FREQ .GT. FR2 ) RETURN

      DO 680 IR = 1, NBRP
      DFR = ABS ( FREQ - FCR(IR) )
      DO 620 IZ = 1, NZ
      AUX1(IZ) = DFR / DNDP(IZ,IR)
 620  CONTINUE
      CALL VOIVEC ( NZ, AMP(1,IR), AUX1, AUX2 )
      DO 640 IZ = 1, NZ
      AUX2(IZ)  = AUX2(IZ) * CACR(IZ,IR)
      CAB(IZ) = CAB(IZ) + AUX2(IZ)
      CEM(IZ) = CEM(IZ) + AUX2(IZ) * SR(IZ,IR)
 640  CONTINUE
 680  CONTINUE

      RETURN
      END
      SUBROUTINE SECOND ( T )
      real(kind=4) :: tcp4
      CALL CPU_TIME ( tcp4 )
      T = tcp4
      RETURN
      END
      SUBROUTINE INTEME ( RMU, FRL, HI )

!        Calcul des intensites emergentes

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 &
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 & 
     &, FIZERO, WLYA

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /TRANSF/ NRA, NT, FR0, L1, L2, TO(NZMX) & 
     &, DND(NZMX), AM(NZMX), EPS(NZMX), BEN(NZMX), CAR(NZMX), RF(NZMX) & 
     &, DDC(NZMX), SL(NZMX), GIBAR(NZMX), FR(NFR), R(NFR2) &
     &, PHI(NFR,NZMX), GI(NFR,NZMX), COHE(NZMX)


      DIMENSION TOZ(2*NZMX), SZ(2*NZMX), HAV(NZMX), PHIZM(NZMX) &
     &,         VVV(NZMX)

      FRA = ABS ( FRL )

      DO 120 IZ = 1, NZ
      IF ( IPROF .EQ. 2 ) THEN
      CALL SPLINT ( NFR, FR, STR(1,IZ,NRA), FRA, SZ(IZ) )
      ELSE
      CALL INTERL ( NFR, FR, STR(1,IZ,NRA), FRA, SZ(IZ) )
      END IF
 120  CONTINUE
      DO 140 IZ = 1, NZ
      VVV(IZ) = FRA / DND(IZ)
      HAV(IZ) = VOIGT ( AM(IZ), VVV(IZ) )
 140  CONTINUE
!CNV.. CALL VOIVEC ( NZ, AM, VVV, HAV )
      COEF = 0.5 * FIZERO
      DO 160 IZ = 2, NZ
      PHIZM(IZ) = COEF * HAV(IZ) + COEF * HAV(IZ-1) + 0.5 * RF(IZ) + &
     & 0.5 * RF(IZ-1)
 160  CONTINUE
      TOZ(1) = 0.0
      DO 180 IZ = 2, NZ
      TOZ(IZ) = TOZ(IZ-1) + ( TO(IZ) - TO(IZ-1) ) * PHIZM(IZ)
 180  CONTINUE
      IF ( IVERT .EQ. 1 ) GO TO 200

!       IVERT = 0  : couche horizontale eclairee par le bas
!       IVERT = -1 : atmosphere semi-infinie (thermalisation)

      IF ( IVERT .EQ. 0 ) THEN
      IF ( IPROF .EQ. 2 ) THEN
      CALL SPLINT ( NFINT(NRA), FRFI(1,NRA), FINT(1,NRA), FRA, HIL )
      ELSE
      CALL INTERL ( NFINT(NRA), FRFI(1,NRA), FINT(1,NRA), FRA, HIL )
      END IF
      ELSE
      HIL = SZ(NZ)
      END IF
      CALL TRALA ( NZ , TOZ , SZ , HIL , RMU , HI )
      RETURN

!  IVERT = 1 : COUCHE FINIE VERTICALE : ON CALCULE L'INTENSITE EMISE
!         DANS LE CAS D'UNE OBSERVATION A L'EXTERIEUR DU BORD
!         SOLAIRE. POUR CELA, ON RECONSTITUE LA COUCHE COMPLETE,
!         SYMETRIQUE, A PARTIR DE LA DEMI-COUCHE.

 200  CONTINUE
      NZM = NZ - 1
      NZCC = NZ + NZM
      DO 300 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)
 300  CONTINUE
      HIL = 0.0
      CALL TRALA ( NZCC, TOZ, SZ, HIL, RMU, HI )
      RETURN

      END
      SUBROUTINE MARALA ( L, PHI, AMRT, X, R, COHE, XNORM )

!              CALCUL D'UNE MATRICE DE REDISTRIBUTION.
!
!      VERSION PARTICULIERE POUR LA RAIE LYMAN-ALPHA DE L'HYDROGENE.
!      ON UTILISE UNE GRILLE DE FREQUENCE UNILATERALE (ATMOSPHERE
!     STATIQUE) ET UNE REPRESENTATION LINEAIRE DE L'INTENSITE
!     MOYENNE.
!        (version non vectorielle)

      PARAMETER ( KMAX=1000, DXMAX=0.2, LMAX=20, XBL=3.0 )

      DIMENSION PHI(L), X(L), COHE(L), XNORM(L), R(1)
      DIMENSION Y(KMAX), RR(KMAX), NDY(LMAX), KFJ(LMAX)

!         DECOUPAGE DES INTERVALLES POUR L'INTEGRATION DE R

      IF ( L .GT. LMAX ) GO TO 900
      K = 0
      LM = L - 1
      DO 120 I = 1, LM
      NDY(I) = IFIX ( ( X(I+1) - X(I) ) / DXMAX ) + 1
 120  CONTINUE
      NDY(L) = IFIX ( XBL / DXMAX ) + 1
      DO 150 I = 1, L
      NXX = NDY ( I )
      DO 140 ISD = 1, NXX
      K = K + 1
      IF ( K .GT. KMAX ) GO TO 900
      IF ( ISD .EQ. 1 ) GO TO 130
      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)
      GO TO 140
 130  CONTINUE
      Y(K) = X(I)
      KFJ(I) = K
 140  CONTINUE
 150  CONTINUE
      NY = K + 1
      IF ( NY .GT. KMAX ) GO TO 900
      Y(NY) = X(L) + XBL

!      DIFFUSION COHERENTE DANS LE REFERENTIEL DE L'ATOME

      DO 300 I = 1, L
      DO 180 K = 1 , NY
      XINF = AMIN1 ( X(I), Y(K) )
      XSUP = AMAX1 ( X(I), Y(K) )
      RR(K) = RIIM ( XINF, XSUP, AMRT ) + RIIM ( -XINF, XSUP, AMRT )
 180  CONTINUE
      DO 300 J = 1 , L
      IJ = L * ( J - 1 ) + I
      R(IJ) = 0.
      IF ( J .EQ. 1 ) GO TO 220

!        INTEGRATION DE X(J-1) A X(J)

      K1 = KFJ(J-1)
      MK = NDY(J-1)
      K2 = K1 + MK
      DO 210 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)
 210  CONTINUE
 220  CONTINUE

!         INTEGRATION DE X(J) A X(J+1)

      K1 = KFJ(J)
      MK = NDY(J)
      K2 = K1 + MK
      DO 230 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)
 230  CONTINUE
 300  CONTINUE

      CALL COIN ( 1 , L , X , Y )
      DO 350 I = 1, L
      DO 350 J = 1, L
      IJ = L * ( J - 1 ) + I
      R(IJ) = COHE(J) * R(IJ) + ( 1.0 - COHE(J) ) * PHI(I) * PHI(J) * &
     & Y(J) * 2.0
 350  CONTINUE

!         RENORMALISATION DE LA MATRICE R

      DO 600 I = 1, L
      Y(I) = 0.
      DO 550 J = 1, L
      IJ = L * ( J - 1 ) + I
      Y(I) = Y(I) + R(IJ)
 550  CONTINUE
      XNORM(I) = Y(I) / PHI(I)
 600  CONTINUE
      DO 650 I = 1, L
      DO 650 J = 1 , L
      IJ = L * ( J - 1 ) + I
      R(IJ) = R(IJ) / XNORM(I)
 650  CONTINUE
      RETURN

 900  CONTINUE
      PRINT 999, L, LMAX, K, KMAX
 999  FORMAT ( /// ' ARRET DANS MARALA' / ' L =', I5, 5X, ' LMAX =', I5 &
     & / ' K =', I5, 5X, ' KMAX =', I5 / )
      STOP
      END
      SUBROUTINE MAREDI ( L, PHI, AMRT, X, R, COHE, XNORM )

!            CALCUL D UNE MATRICE DE REDISTRIBUTION.

!     CAS D'UNE RAIE DE RESONANCE AVEC COEFFICIENT DE COHERENCE
!     INDEPENDANT DE LA FREQUENCE.
!     REPARTITION DE FREQUENCES UNILATERALE (ATMOSPHERE STATIQUE).
!     REPRESENTATION LINEAIRE DE L'INTENSITE MOYENNE.
!     (version non-vectorielle)

      PARAMETER ( KMAX=1000, DXMAX=0.2, LMAX=20, XBL=3.0 )

      DIMENSION PHI(L), X(L), R(1)
      DIMENSION XNORM(L)
      DIMENSION Y(KMAX), RR(KMAX), NDY(LMAX), KFJ(LMAX)

      IF ( L .GT. LMAX ) GO TO 900
      IF ( COHE .EQ. 0. ) GO TO 400

!         DECOUPAGE DES INTERVALLES POUR L'INTEGRATION DE R

      K = 0
      LM = L - 1
      DO 120 I = 1, LM
      NDY(I) = IFIX ( ( X(I+1) - X(I) ) / DXMAX ) + 1
 120  CONTINUE
      NDY(L) = IFIX ( XBL / DXMAX ) + 1
      DO 150 I = 1, L
      NXX = NDY ( I )
      DO 140 ISD = 1, NXX
      K = K + 1
      IF ( K .GT. KMAX ) GO TO 900
      IF ( ISD .EQ. 1 ) GO TO 130
      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)
      GO TO 140
 130  CONTINUE
      Y(K) = X(I)
      KFJ(I) = K
 140  CONTINUE
 150  CONTINUE
      NY = K + 1
      IF ( NY .GT. KMAX ) GO TO 900
      Y(NY) = X(L) + XBL

!      DIFFUSION COHERENTE DANS LE REFERENTIEL DE L'ATOME

      DO 300 I = 1, L
      DO 180 K = 1 , NY
      XINF = AMIN1 ( X(I), Y(K) )
      XSUP = AMAX1 ( X(I), Y(K) )
      RR(K) = RIIM ( XINF, XSUP, AMRT ) + RIIM ( -XINF, XSUP, AMRT )
 180  CONTINUE
      DO 300 J = 1 , L
      IJ = L * ( J - 1 ) + I
      R(IJ) = 0.
      IF ( J .EQ. 1 ) GO TO 220

!         INTEGRATION DE X(J-1) A X(J)

      K1 = KFJ(J-1)
      MK = NDY(J-1)
      K2 = K1 + MK
      DO 210 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)
 210  CONTINUE
 220  CONTINUE

!         INTEGRATION DE X(J) A X(J+1)

      K1 = KFJ(J)
      MK = NDY(J)
      K2 = K1 + MK
      DO 230 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)
 230  CONTINUE
 300  CONTINUE

      IF ( COHE .EQ. 1. ) GO TO 500
      CALL COIN ( 1 , L , X , Y )
      DO 350 I = 1, L
      DO 350 J = 1, L
      IJ = L * ( J - 1 ) + I
      R(IJ) = COHE * R(IJ) + ( 1. - COHE ) * PHI(I) * PHI(J) * Y(J) * 2.
 350  CONTINUE
      GO TO 500
 400  CONTINUE

!         CAS DE LA DIFFUSION TOTALEMENT INCOHERENTE

      CALL COIN ( 1 , L , X , Y )
      DO 450 I = 1, L
      DO 450 J = 1, L
      IJ = L * ( J - 1 ) + I
      R(IJ) = PHI(I) * PHI(J) * Y(J) * 2.
 450  CONTINUE
 500  CONTINUE

!         RENORMALISATION DE LA MATRICE R

      DO 600 I = 1, L
      Y(I) = 0.
      DO 550 J = 1, L
      IJ = L * ( J - 1 ) + I
      Y(I) = Y(I) + R(IJ)
 550  CONTINUE
      XNORM(I) = Y(I) / PHI(I)
 600  CONTINUE
      DO 650 I = 1, L
      DO 650 J = 1 , L
      IJ = L * ( J - 1 ) + I
      R(IJ) = R(IJ) / XNORM(I)
 650  CONTINUE
      RETURN

 900  CONTINUE
      PRINT 999, L, LMAX, K, KMAX
 999  FORMAT ( /// ' ARRET DANS MAREDI' / ' L =', I5, 5X, ' LMAX =', I5 &
     & / ' K =', I5, 5X, ' KMAX =', I5 / )
      STOP
      END
      SUBROUTINE RPCDEF ( ITAR, IVISU )

!         IOP = 1     REDISTRIBUTION COMPLETE
!         IOP = 2     REDISTRIBUTION SELON RIIA
!         IOP = 3     REDISTRIBUTION PONDEREE

 1    FORMAT ( 1H1 )
 2    FORMAT ( 49H COEFFICIENTS DE RENORMALISATION POUR LA RAIE NO. , &
     & I3 )
 3    FORMAT ( 1X )
 4    FORMAT ( 1X, I3, 1X, 25F5.2 )
 5    FORMAT ( 43H COEFFICIENTS DE COHERENCE POUR LYMAN-ALPHA )
 6    FORMAT ( 1X, I3, 1X, 20F6.4 )
 7    FORMAT ( 15X, 14HREDISTRIBUTION, 10X, 10HNO. RAIE :, I3, 10X &
     &, 5HTCP =, F8.3 )

      PARAMETER ( NZMX=100, NFR=20, NMU=3, NFR2=NFR*NFR, NPSOR=101 &
     &, NMUV=3, NFRC=10, EOLIM=0.1 & 
     &, NN=21, NTT=(NN*(NN-1))/2, NTAB=5 &
     &, NRAMR=10, NTAC=5, NTAR=NRAMR, NNSUP=20 )

      CHARACTER*8 XMOAT
      COMMON /UGEN/ XMOAT, NZ, IZERO, PSLAB, TSLAB, IVERT, IOPVT &
     &, IOPMIC, IFTOT, IFLYA, IFBAA &
     &, IOPMRU, EPST, IPROM, IPROF, IPAL, VSINI, G, GLOG, NRAMX &
     &, NFINT(NTAR), FRFI(201,NTAR), FINT(201,NTAR), FADI(NTAR+NTAC) &
     &, XM(NZMX), Z(NZMX), TE(NZMX), VT(NZMX), HNH(NZMX), HNE(NZMX) &
     &, Y0(NZMX), Y1(NZMX), Y2(NZMX), GIOM(NTAR), XFRC(NFRC) &
     &, XFR(NFR), INIDLD, DNDREF(NTAR), DLDREF(NTAR) &
     &, FEVK(NFR,NZMX,NTAR), FEVL(NFR,NZMX,NTAR), STR(NFR,NZMX,NTAR) &
     &, FKTC(NFRC,NZMX,NTAC), FLTC(NFRC,NZMX,NTAC) &
     &, STC(NFRC,NZMX,NTAC), FRR(NFR,NTAR), FRC(NFRC,NTAC) &
     &, COHER(NZMX,NRAMR), DNDR(NZMX,NRAMR), AMR(NZMX,NRAMR) &
     &, CARR(NZMX,NTAR), PHIR(NFR,NZMX,NRAMR), RDMAT(NFR2,NZMX,NRAMR) &
     &, HIEMC(NFRC,NMUV,NTAC), FIIR(NFR,NTAR) &
     &, FISR(NFR,NTAR), FIIC(NFRC,NTAC), FISC(NFRC,NTAC) &
     &, FRSUP(NNSUP), PSUP(NNSUP), XNSUP(NZMX,NNSUP)
      COMMON /UGEN2/ ITGMAX, IEHMAX, RXY, CRITY, TCP0, TCP &
     &, ICRMAX, CSCOEF, IORD, RXRO(NTAR), RXIK(NTAC), IOPEHS, ICATA &
     &, IOPRN(NTAR), IOPERA(NTAR), IOPECO(NTAC), IOPRA &
     &, DL1(NTAR), DL2(NTAR), PMU(NMUV), RXTR, IVTR, NITG &
     &, IOPCAC, IOPEAC, IOPTOC, IOPATM, IOPTTC, IOPPOP, IOPROB, IOPREN &
     &, IOPFEV, NK, NTR(NTAR), NTC(NTAC), ICTR(NTAR), ICTC(NTAC) &
     &, NND, NINF(NTT), NSUP(NTT), ITP(NTT), HMA, AE(NTAR) &
     &, TSP(NN), FRN(NN), POM(NN-1), UK, TAB(NTAB), OIS(NTAB,NTT) &
     &, DFRCO(NZMX), HNT(NZMX) &
     &, CAC(NZMX,NTAR), DCAC(NZMX,NTAR), SC(NZMX,NTAR) &
     &, BRN(NZMX,NTAR), BRP(NZMX,NTAR), IOPTR(NTAC), TROM(NTAC) &
     &, TR(NZMX,NTAC), RIK(NZMX,NTAC), RIKP(NZMX,NTAC) &
     &, RKI(NZMX,NTAC), HN(NZMX,NN), HNP(NZMX,NN) &
     &, CIJ(NZMX,NTT), CJI(NZMX,NTT), ELEMT, IODEG &
     &, ICCVAL, IRDVAL, GAMAMX, IMRSPL, TEREF, VTREF

      COMMON /CNST/ PI, HP, CL, BOLT, UMA, EV, ELM, C4, C1, C2, C5, C6 &
     &, FIZERO, WLYA

      COMMON /TRANSF/ NRA, NT, FR0, L1, L2, TO(NZMX) &
     &, DND(NZMX), AM(NZMX), EPS(NZMX), BEN(NZMX), CAR(NZMX), RF(NZMX) &
     &, DDC(NZMX), SL(NZMX), GIBAR(NZMX), FR(NFR), R(NFR2) &
     &, PHI(NFR,NZMX), GI(NFR,NZMX), COHE(NZMX)


      DIMENSION VV(NFR), FI(NFR), COHLA(NFR), XNORM(NFR), AMV(NFR) &
     &,         AUX(50)

      IOP = IOPRN ( ITAR )
      IF ( IOP .EQ. 0 ) RETURN
      HM = HMA * UMA
      NRA = ITAR
      NT = NTR(ITAR)
      NI = NINF(NT)
      NS = NSUP(NT)
      FR0 = FRN(NS) - FRN(NI)

!              Calcul de la constante d elargissement

      GAMA=0.
      NIM=NI-1
      NSM=NS-1
      IF ( NI .EQ. 1 ) GO TO 120
      DO 110 I=1,NIM
      IT=I+((NI-1)*(NI-2))/2
      ITX = ITP(IT)
      IF ( ITX .EQ. 0 ) GO TO 110
      GAMA = GAMA + AE(ITX)
 110  CONTINUE
 120  DO 130 I=1,NSM
      IT=I+((NS-1)*(NS-2))/2
      ITX = ITP(IT)
      IF ( ITX .EQ. 0 ) GO TO 130
      GAMA = GAMA + AE(ITX)
 130  CONTINUE
      DFRNA = GAMA / ( 4. * PI )
      CALL ELCO ( ITAR, NTR, NINF, NSUP, NZ, TE, HN, HNE, DFRCO )
      IF ( IOPMRU .EQ. 1 ) THEN
      NZ1 = NZ / 2 + 1
      NZ2 = NZ1
      ELSE
      NZ1 = 1
      NZ2 = NZ
      END IF
      DO 140 IZ = NZ1, NZ2
      DND(IZ) = (FR0/CL) * SQRT ( VT(IZ)**2 + 2.*BOLT*TE(IZ)/HM )
      ELA = DFRNA + DFRCO(IZ)
      COHE(IZ) = AE(ITAR) / ( 4.0 * PI * ELA )
      AM(IZ) = ELA / DND(IZ)
      IF ( IOP .EQ. 1 ) COHE(IZ) = 0.
      IF ( IOP .EQ. 2 ) COHE(IZ) = 1.
 140  CONTINUE
      DO 170 JF=1,NFR
      FR(JF) = FRR(JF,ITAR)
 170  CONTINUE
      DO 250 IZ = NZ1, NZ2
      DO 220 IB = 1 , NFR
      VV(IB) = FR(IB) / DND(IZ)
      AMV(IB) = AM(IZ)
      AUX(IB) = VOIGT ( AMV(IB), VV(IB) )
 220  CONTINUE
!CNV.. CALL VOIVEC ( NFR, AMV, VV, AUX )
      DO 240 IB = 1, NFR
      PHI(IB,IZ) = FIZERO * AUX(IB)
 240  CONTINUE
 250  CONTINUE

      IF ( IOPMRU .NE. 1 ) THEN
      DO 252 IZ = 1, NZ
      DNDR(IZ,ITAR) = DND(IZ)
      AMR(IZ,ITAR) = AM(IZ)
      COHER(IZ,ITAR) = COHE(IZ)
 252  CONTINUE
      DO 254 IZ = 1, NZ
      DO 254 IB = 1, NFR
      PHIR(IB,IZ,ITAR) = PHI(IB,IZ)
 254  CONTINUE
      ELSE
      DO 256 IZ = 1, NZ
      DNDR(IZ,ITAR) = DND(NZ1)
      AMR(IZ,ITAR) = AM(NZ1)
      COHER(IZ,ITAR) = COHE(NZ1)
 256  CONTINUE
      DO 258 IZ = 1, NZ
      DO 258 IB = 1, NFR
      PHIR(IB,IZ,ITAR) = PHI(IB,NZ1)
 258  CONTINUE
      END IF

      IF ( IVISU .EQ. 1 ) WRITE ( 6, 1 )
      IF ( IVISU .EQ. 1 ) WRITE ( 6, 2 ) ITAR
!     CALL SECOND ( TCP0 )
      DO 400 IZ = NZ1, NZ2
      DO 260 IB = 1, NFR
      FI(IB) = PHI(IB,IZ)
      VV(IB) = FR(IB) / DND(IZ)
 260  CONTINUE
      IF ( ITAR .EQ. 1 .AND. IOPRN(1) .EQ. 4 ) GO TO 300
      CALL MAREDI ( NFR, FI, AM(IZ), VV, R, COHE(IZ), XNORM )
      GO TO 320
 300  CONTINUE

!              Traitement particulier de Lyman-alpha ( hydrogene ) :
!         parametre d'elargissement dependant de la frequence

      IF ( IRDVAL .EQ. 1 ) THEN
      CALL COHEVAL ( NFR, HNE(IZ), HN(IZ,1), TE(IZ), GAMAMX, FR &
     &, COHLA )
      ELSE
      CALL COHEVA ( NFR, HNE(IZ), HN(IZ,1), TE(IZ), FR, COHLA )
      END IF
      CALL MARALA ( NFR, FI, AM(IZ), VV, R, COHLA, XNORM )
 320  CONTINUE
      IF ( IOPMRU .NE. 1 ) THEN
      DO 340 J = 1, NFR2
      RDMAT(J,IZ,ITAR) = R(J)
 340  CONTINUE
      END IF
      IF ( IVISU .NE. 1 ) GO TO 400
      IF ( IZ .EQ. 51 ) WRITE ( 6, 1 )
      IF ( MOD ( IZ, 10 ) .EQ. 1 ) WRITE ( 6, 3 )
      WRITE ( 6, 4 ) IZ, ( XNORM(J), J = 1, NFR )
 400  CONTINUE
      IF ( IOPMRU .EQ. 1 ) THEN
      DO 440 IZ = 1, NZ
      DO 440 J = 1, NFR2
      RDMAT(J,IZ,ITAR) = R(J)
 440  CONTINUE
      END IF
!     CALL SECOND ( TCP )
!     TCP = TCP - TCP0
!     WRITE ( 8, 7 ) NRA, TCP

      IF ( IVISU .NE. 1 .OR. IOP .NE. 4 ) RETURN
      WRITE ( 6, 1 )
      WRITE ( 6, 5 )
      DO 500 IZ = NZ1, NZ2
      IF ( IZ .EQ. 51 ) WRITE ( 6, 1 )
      IF ( MOD(IZ,10) .EQ. 1 ) WRITE ( 6, 3 )
      IF ( IRDVAL .EQ. 1 ) THEN
      CALL COHEVAL ( NFR, HNE(IZ), HN(IZ,1), TE(IZ), GAMAMX, FR &
     &, COHLA )
      ELSE
      CALL COHEVA ( NFR, HNE(IZ), HN(IZ,1), TE(IZ), FR, COHLA )
      END IF
      WRITE ( 6, 6 ) IZ, ( COHLA(J), J = 1, NFR )
 500  CONTINUE

      RETURN
      END
      SUBROUTINE PROMAV ( A, B, C, N )

!            PRODUIT D'UNE MATRICE CARREE PAR UN VECTEUR :
!       C(I) = SIGMA DE J = 1 A N DE A(I,J) * B(J)

      DIMENSION A(1), B(1), C(1)

      DO 100 I = 1, N
      C(I) = 0.0
      DO 100 J = 1, N
      C(I) = C(I) + A(N*J-N+I) * B(J)
 100  CONTINUE

      RETURN
      END
      SUBROUTINE INVMAT ( A, N )
!            Inversion de matrice sans calcul du determinant

      PARAMETER ( NMAX=256 )
      DIMENSION A(1), L(NMAX), M(NMAX)

 2    FORMAT ( 40H1 MATRICE SINGULIERE DETECTEE PAR INVMAT // )

      IF ( N .GT. NMAX ) GO TO 900
      NK = - N
      DO 80 K = 1 , N
      NK = NK + N
      L(K) = K
      M(K) = K
      KK = NK + K
      BIGA = A(KK)
      DO 20 J = K , N
      IZ = N * ( J - 1 )
      DO 20 I = K , N
      IJ = IZ + I
 10   IF ( ABS(BIGA) - ABS(A(IJ)) )  15 , 20 , 20
 15   BIGA = A(IJ)
      L(K) = I
      M(K) = J
 20   CONTINUE
      J = L(K)
      IF ( J - K ) 35 , 35 , 25
 25   KI = K - N
      DO 30 I = 1 , N
      KI = KI + N
      HOLD = - A(KI)
      JI = KI - K + J
      A(KI) = A(JI)
 30   A(JI) = HOLD
 35   I = M(K)
      IF ( I - K )   45 , 45 , 38
 38   JP = N * ( I - 1 )
      DO 40 J = 1 , N
      JK = NK + J
      JI = JP + J
      HOLD = - A(JK)
      A(JK) = A(JI)
 40   A(JI) = HOLD
 45   IF ( BIGA )  48 , 46 , 48
 46   CONTINUE
      PRINT 2
      STOP

 48   DO 55 I = 1 , N
      IF ( I - K )  50 , 55 , 50
 50   IK = NK + I
      A(IK) = - A(IK) / BIGA
 55   CONTINUE
      DO 65 I = 1 , N
      IK = NK + I
      HOLD = A(IK)
      IJ = I - N
      DO 65 J = 1 , N
      IJ = IJ + N
      IF ( I - K ) 60 , 65 , 60
 60   IF ( J - K ) 62 , 65 , 62
 62   KJ = IJ - I + K
      A(IJ) = HOLD * A(KJ) + A(IJ)
 65   CONTINUE
      KJ = K - N
      DO 75 J = 1 , N
      KJ = KJ + N
      IF (J-K) 70 , 75 , 70
 70   A(KJ) = A(KJ) / BIGA
 75   CONTINUE
      A(KK) = 1. / BIGA
 80   CONTINUE
      K = N
 100  K = K - 1
      IF ( K ) 150 , 150 , 105
 105  I = L(K)
      IF ( I - K ) 120 , 120 , 108
 108  JQ = N * ( K - 1 )
      JR = N * (I - 1 )
      DO 110 J = 1 , N
      JK = JQ + J
      HOLD = A(JK)
      JI = JR + J
      A(JK) = - A(JI)
 110  A(JI) = HOLD
 120  J = M ( K )
      IF ( J - K ) 100 , 100 , 125
 125  KI = K - N
      DO 130 I = 1 , N
      KI = KI + N
      HOLD = A(KI)
      JI = KI - K + J
      A(KI) = - A(JI)
 130  A(JI) = HOLD
      GO TO 100
 150  CONTINUE
      RETURN

 900  CONTINUE
      PRINT 999, N, NMAX
 999  FORMAT ( /// ' ARRET DANS INVMAT' / ' N =', I5, 5X, ' NMAX =', I5 &
     & / )
      STOP
      END
      FUNCTION RIA (V,VV,GAMA)
      IF (GAMA.EQ.0.) GOTO 10
      COEF = 2.01572090207E-03
      SIGA = SIN (GAMA)
      EXPO = -V*V-VV*VV+2.*V*VV*COS(GAMA)
      EXPO = EXPO / SIGA**2
      RIA = COEF*EXP(EXPO)/SIGA
      RETURN
 10   CONTINUE
      RIA = 0.
      RETURN
      END
      FUNCTION  RIIA (V,VV,A,GAMA)
      IF (GAMA.EQ.0.) GOTO 10
      COEF = 2.01572090207E-03
      SIGA = SIN (GAMA)
      SIGA2 = SIN (.5*GAMA)
      COGA2 = SQRT (1.-SIGA2*SIGA2)
      R1 = COEF/SIGA
      R2 = EXP (-(.5*(V-VV)/SIGA2)**2)
      R3 = VOIGT ( A / COGA2, 0.5 * ( V + VV ) / COGA2 )
      RIIA = R1*R2*R3
      RETURN
 10   RIIA = 0.
      RETURN
      END
      FUNCTION RIIM ( X1 , X2 , A )
      IF ( ABS(X2) .GT. ABS(X1) ) GO TO 120
      IF ( X1 .GE. 0. ) GO TO 130
      GO TO 140
 120  CONTINUE
      IF ( ABS(X2) .GE. 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. .OR. S .GE. 4. ) 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.
      RETURN
      END
      FUNCTION RIIM1 ( V , VV , A , N )
      PARAMETER ( PI = 3.141592653589 )
      CC = 8. * 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
      FUNCTION VOIGT ( A, V )

!        Calcul de la fonction de Voigt par la methode de 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*0.5642236))))/ &
     & (16.4955+T*(38.82363+T*(39.27121+T*(21.69274+T*(6.699398+T)))))
      RETURN
! *** REGION IV
3     U=T*T
      W4=CEXP(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 VOIVEC ( N, A, V, H )

!         Version de remplacement (non vectorielle)

      DIMENSION A(N), V(N), H(N)

      DO 100 I = 1, N
      H(I) = VOIGT ( A(I), V(I) )
 100  CONTINUE

      RETURN
      END
