      SUBROUTINE OPAC(ICALL)
C
C  GIVES STANDARD AND BACKGROUND OPACITIES
C
C  XNORM : STANDARD OPACITY, UNIT CM**2 PER CM**3
C  XCONT : CONTINUUM OPACITY, RELATIVE TO STANDARD OPACITY
C  TOTN  : TOTAL POPULATION DENSITY OF ATOM
C
C  ROUTINES OPINIT AND ABSKO ARE TO BE FOUND IN OPACITY PACKAGE
C
C  BACKGROUND SOURCE FUNCTIONS ARE  INITIALIZED WITH THE ASSUMPTION
C  J=0 FOR THE SCATTERING. CONTINUA CALCULATED IN DETAIL ARE NOT
C  INCLUDED IN THE BACKGROUND OPACITY
C
C:
C: OPAC   88-01-21  MODIFICATIONS: (MATS CARLSSON)
C:        THIS IS A VERSION USING THE UPPSALA BACKGROUND OPACITY PACKAGE
C:        MODIFIED FOR THE INCLUSION OF NON-LTE EFFECTS
C:
C:        90-12-28  MODIFICATIONS: (MATS CARLSSON)
C:        INITIALIZING JNY, XCONT, SCAT AND SC (NDEP+1:MDEP)
C:        TO ZERO TO ENABLE I/O OF WHOLE ARRAY
C:
C:        91-02-04  MODIFICATIONS: (MATS CARLSSON)
C:        RECORD LENGTH OF JNY CHANGED TO MDEP TO SPEED UP I/O
C:
C:        95-08-21  MODIFICATIONS: (MATS CARLSSON)
C:        WARNING MESSAGE TO JOBLOG IF ABUNDANCE AFFECTED BY MOLECULES
C:        OR IF ABUNDANCE IS TAKEN FROM FILE ABUND AND NOT EQUAL TO
C:        VALUE IN FILE ATOM
C:
C:        00-03-27  MODIFICATIONS: (MATS CARLSSON)
C:        ABND.LT.-90 CAUSES FILE WITH ABUNDANCES AS FUNCTION OF DEPTH
C:        TO BE READ IN ATMOS AND INTERPOLATED INTO ABNDK
C:
C:        02-01-16  MODIFICATIONS: (REMO COLLET)
C:        ADDED ROUTINES TO INCLUDE BACKGROUND LINE OPACITIES
C:
C:        04-04-22  MODIFICATIONS: (MATS CARLSSON)
C:        CORRECTED ERROR IN ABMIN, ABMAX PRINTOUT TO JOBLOG
C:
C:        06-01-18  MODIFICATIONS: (MATS CARLSSON)
C:        EXCLUDE LINE OPACITIES FROM ABSLIN IF IWIDE.EQ.0
C:
C:        11-02-14 MODIFICATIONS: (KARIN LIND)
C:        ADDED NEW FORMAT FOR ABSMET FILE 
C:      
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'CATOM'
      INCLUDE 'CATMOS'
      INCLUDE 'CATMO2'
      INCLUDE 'CSLINE'
      INCLUDE 'CCONST'
      INCLUDE 'CINPUT'
      INCLUDE 'CLU'
      INCLUDE 'C3D'
C
      COMMON/CABNDK/ ABNDK(MDEP)
C
C     02-01-16 MODIFICATIONS (RC)
C     INCLUDED 'COSM3','OSMPAR' ... DEFINED MAXNU, LFLAG ...
      INCLUDE 'OSMPAR'
      INCLUDE 'COSM3'
      INTEGER MAXNU, LFLAG
C     (RC)
C
      INCLUDE 'PARAMO'
      COMMON/CA2/ABKOF(NABDIM),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP,NABKOF
      INCLUDE 'CALIN'

C     03-02-19 MODIFICATIONS (RC)
C     MAXNU AND LFLAG ARE INSERTED IN A COMMON BLOCK /CBRULS/
      COMMON/CBRULS/ LFLAG

      CHARACTER*20 ABNAME,LVNAMEI,LVNAMEJ
      COMMON/CNAME/ ABNAME(MKOMP),LVNAMEI(MKOMP),LVNAMEJ(MKOMP)
C
C*
C* 88-06-20 ADDITION (P. JUDGE): GET UNIT NUMBERS TO DELETE LARGE WORK FILES
      COMMON/CFIL/IREAT,INLATB
C* 88-06-20 END
C*

C
      LOGICAL HLTE
      REAL(8) NHYD,NPIN
      COMMON/CIN/ NHYD(MT,5),NPIN(MT),HLTE
C
      COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT),
     * TOTCH(MT),TOTCO(MT),TOTCN(MT),
     * TOTC(MT),TOTNIT(MT),TOTO(MT),
     * BHYD(MT,5),GRPH,TOTOH(MT)

CCC  00-09-12 TOTOH ADDED
C
C   KL 11-02-14 PGC communicated through COPBID
      COMMON /COPBID/ PGC(MT),ROC(MT),XMYC(MT),EJONC(MT),
     * XNENHC(MT),PROV(20,MT)
C
      COMMON/CABSB/ ABSLTE(MT),KMPEXC
      REAL(8) PE(MT),ABSK(MT),SPRID(MT)
C
      CHARACTER*4 ELEMID
      LOGICAL LABUND
      logical fcall
      save fcall
      data fcall/.true./
C
C  INITIALIZE JNY,XCONT,SCAT,SC (NDEP+1:MDEP) TO ZERO
      DO 5 K=NDEP+1,MDEP
        JNY(K)=0.0
        XCONT(K)=0.0
        SC(K)=0.0
        SCAT(K)=0.0
    5 CONTINUE
C
C  INITIALIZE OPACITY ROUTINES AND JNY
C
C  KL added call to OPINIT if ATOM2 is run 23-03-11
C
      IF(ICALL.EQ.0) THEN
        if(fcall.or.IATOM2.eq.1) then
          CALL OPINIT
          fcall=.false.
        endif
        IF(.NOT.L3D) CALL MOPEN(LJNY,'JNY',MDEP,'UNKNOWN')
        DO 10 K=1,NDEP
          JNY(K)=0.0
          TOTH(K)=0.0
   10   CONTINUE
        IREC=0
        DO 30 KR=1,NRAD
          DO 20 NY=1,NQ(KR)
            IREC=IREC+1
            CALL WRITEJ(IREC)
   20     CONTINUE
   30   CONTINUE
C
C  READ RHO,TOTN,XNORM,BH FROM FILE INIT IF IOPAC=0
        IF(IOPAC.EQ.0) THEN
          IF(L3D) CALL STOP('OPAC: NO SUPPORT FOR IOPAC=0')
          CALL MOPEN(LOPC,'OPC',0,'OLD')
          CALL MOPEN(LINIT,'INIT',0,'OLD')
          READ(LINIT) (RHO(K),K=1,NDEP),(TOTN(K),K=1,NDEP),(XNORM(K),
     *     K=1,NDEP),((BH(I,K),I=1,5),K=1,NDEP)
          CALL CLOSE(LINIT)
          RETURN
        ELSE
          IF(.NOT.L3D) CALL MOPEN(LOPC,'OPC',0,'UNKNOWN')
        ENDIF
      ENDIF
      CALL MCTIME('OPAC  ',0,0,1)
C
C  SET KMPEXC TO 0 (INDICATES WHICH ABSORBER TO EXCLUDE)
C
      KMPEXC=0
C
C  FILL HYDROGEN POPULATIONS IN ARRAYS NHYD AND NPIN
C  FILL ELECTRON PRESSURES IN ARRAY PE
C
      HLTE=NH(1,1).EQ.0.0
      IF(.NOT.HLTE) THEN
        DO 150 I=1,5
          DO 110 K=1,NDEP
            NHYD(K,I)=NH(I,K)
  110     CONTINUE
  150   CONTINUE
        DO 160 K=1,NDEP
          NPIN(K)=NH(6,K)
  160   CONTINUE
      ENDIF
      DO 190 K=1,NDEP
        PE(K)=NE(K)*BK*TEMP(K)
  190 CONTINUE
      IF(IWOPAC.NE.0) THEN
        WRITE(LOUT,'(A)') 'LINE OPACITY TREATMENT:'
        WRITE(LJOBLO,'(A)') 'LINE OPACITY TREATMENT:'
        WRITE(LOUT,'(A,I2)') 'IOSMET=',IOSMET
        WRITE(LJOBLO,'(A,I2)') 'IOSMET=',IOSMET
        IF(IOSMET.EQ.0) THEN
          WRITE(LOUT,'(A)') ' NO LINE OPACITIES'
          WRITE(LJOBLO,'(A)') ' NO LINE OPACITIES'
        ELSE IF(IOSMET.EQ.1) THEN
          WRITE(LOUT,'(A)') ' OPACITY SAMPLING NEW FORMAT'
          WRITE(LJOBLO,'(A)') ' OPACITY SAMPLING NEW FORMAT'
          WRITE(LOUT,'(A,1P,E10.2,0P)') ' EOSMET=',EOSMET
          WRITE(LJOBLO,'(A,1P,E10.2,0P)') ' EOSMET=',EOSMET
        ELSE IF(IOSMET.EQ.-1) THEN
          WRITE(LOUT,'(A)') ' OPACITY SAMPLING OLD FORMAT'
          WRITE(LJOBLO,'(A)') ' OPACITY SAMPLING OLD FORMAT'
          WRITE(LOUT,'(A,1P,E10.2,0P)') ' EOSMET=',EOSMET
          WRITE(LJOBLO,'(A,1P,E10.2,0P)') ' EOSMET=',EOSMET
        ELSE IF(IOSMET.EQ.2) THEN
          WRITE(LOUT,'(A)') ' JO BRULS RECIPY'
          WRITE(LJOBLO,'(A)') ' JO BRULS RECIPY'
        ELSE IF(IOSMET.EQ.3) THEN
          WRITE(LOUT,'(A)') ' OPACITY SAMPLING, OSMET=0 FOR XL<1500'
          WRITE(LJOBLO,'(A)') ' OPACITY SAMPLING, OSMET=0 FOR XL<1500'
          WRITE(LOUT,'(A,1P,E10.2,0P)') ' EOSMET=',EOSMET
          WRITE(LJOBLO,'(A,1P,E10.2,0P)') ' EOSMET=',EOSMET
        ENDIF
      ENDIF
C
C  CALCULATE STANDARD OPACITY, POPULATIONS, DENSITIES
C  NOTE THAT ALL OPACITIES FROM ABSKO ARE IN PER GRAM
C  CONVERSION TO PER CM**3 FOR XNORM IS DONE AT END OF ROUTINE
C
C  STORE NLL IN NLL0, SET TO ZERO TO AVOID LINE OPACITIES TO BE INCLUDED
C
      NLL0=NLL
      CALL ABSKO(2,NDEP,TEMP,PE,1,1,ABSK,SPRID)
      DO 200 K=1,NDEP
        XNORM(K)=ABSK(K)+SPRID(K)
  200 CONTINUE
C
C  11-02-14 KL STORE ATMOS VARIABLE PG
      DO 201 K=1,NDEP
        PG(K)=PGC(K)
  201 CONTINUE      
C
C  STORE DEPARTURE COEFFICIENTS AND RE-STORE HYDROGEN POPULATIONS
C  (IF H-POPULATIONS ARE 0 ON INPUT THE LTE VALUES ARE RETURNED AND
C  MUST BE STORED IN NH)
C
      IF(HLTE) THEN
        DO 380 I=1,5
          DO 360 K=1,NDEP
            NH(I,K)=NHYD(K,I)
  360     CONTINUE
  380   CONTINUE
        DO 390 K=1,NDEP
          NH(6,K)=NPIN(K)
  390   CONTINUE
      ENDIF
      DO 410 I=1,5
        DO 400 K=1,NDEP
          BH(I,K)=BHYD(K,I)
  400   CONTINUE
  410 CONTINUE
C
C  STORE DENSITIES AND TOTAL POPULATION DENSITIES OF ATOM
C  NOTE THAT IF ATOM IS HYDROGEN, SOME OF TOTH MIGHT BE IN
C  THE FORM OF MOLECULES
C  THIS IS ALSO THE CASE IF ATOM IS CARBON, NITROGEN OR OXYGEN
C  ATOM STUDIED IS DETERMINED BY LOOKING AT FIRST WORD IN
C  ATOMID
C
      DO 500 K=1,NDEP
        RHO(K)=TOTH(K)*GRPH
  500 CONTINUE
      CALL GETWRD(ATOMID,1,K1,K2)
      ELEMID=ATOMID(K1:K2)
      IF(ELEMID.EQ.'H') THEN
        DO 510 K=1,NDEP
          TOTN(K)=TOTHI(K)+NH(6,K)
  510   CONTINUE
        LABUND=.TRUE.
      ELSE IF(ELEMID.EQ.'C') THEN
        DO 520 K=1,NDEP
          TOTN(K)=TOTC(K)
  520   CONTINUE
        LABUND=.TRUE.
      ELSE IF(ELEMID.EQ.'N') THEN
        DO 530 K=1,NDEP
          TOTN(K)=TOTNIT(K)
  530   CONTINUE
        LABUND=.TRUE.
      ELSE IF(ELEMID.EQ.'O') THEN
        DO 540 K=1,NDEP
          TOTN(K)=TOTO(K)
  540   CONTINUE
        LABUND=.TRUE.
      ELSE IF(ELEMID.EQ.'CH') THEN
        DO 550 K=1,NDEP
          TOTN(K)=TOTCH(K)
  550   CONTINUE
        LABUND=.TRUE.
      ELSE IF(ELEMID.EQ.'CO') THEN
        DO 560 K=1,NDEP
          TOTN(K)=TOTCO(K)
  560   CONTINUE
        LABUND=.TRUE.
      ELSE IF(ELEMID.EQ.'CN') THEN
        DO 570 K=1,NDEP
          TOTN(K)=TOTCN(K)
  570   CONTINUE
        LABUND=.TRUE.

CCC 00-09-12 TOTOH ADDED

      ELSE IF(ELEMID.EQ.'OH') THEN      
        DO 571 K=1,NDEP
          TOTN(K)=TOTOH(K)
  571   CONTINUE
        LABUND=.TRUE.

      ELSE IF(ABND.GT.-90.0) THEN
        DO 580 K=1,NDEP
          TOTN(K)=10.0**(ABND-12.0)*TOTH(K)
  580   CONTINUE
        LABUND=.FALSE.
      ELSE
        DO 585 K=1,NDEP
          TOTN(K)=ABNDK(K)*TOTH(K)
  585   CONTINUE
        LABUND=.FALSE.
      ENDIF
c      write(*,*) ' writing CH abundance to file CH'
c      call mopen(LCH,'CH',1,'new')
c      write(lch,*) totch
c      call close(LCH)
C
C  CHECK MAX AND MIN ABUNDANCE AND EQUIVALENCE BETWEEN 
C  ABUNDANCE IN FILES ABUND AND ATOM
C
      IF(LABUND) THEN
        ABATOM=10.0**(ABND-12.0)
        ABMAX=TOTN(1)/TOTH(1)
        ABMIN=ABMAX
        DO 590 K=2,NDEP
          ABMAX=MAX(ABMAX,TOTN(K)/TOTH(K))
          ABMIN=MIN(ABMIN,TOTN(K)/TOTH(K))
  590   CONTINUE
        IF(ABMAX.NE.ABMIN .OR. ABMAX.NE.ABATOM) THEN
          WRITE(LJOBLO,595) ABATOM,ABMIN,ABMAX
  595     FORMAT('OPAC: ABUNDANCE FROM FILE ATOM=',1P,E10.2/
     *     ' ABUNDANCE TAKEN FROM FILE ABUND WITH MOLECULES CONSIDERED'/
     *     ' MIN AND MAX ABUNDANCE:',2E12.2,0P)
        ENDIF
      ENDIF
C
C  CALCULATE BACKGROUND OPACITIES AT OTHER WAVELENGTHS
C
      JP=2
      CALL REWIND(LOPC)
C     03-01-21 MODIFICATIONS (RC)
C     11-02-41 MODIFICATIONS (KL) 
C     IOSMET VARIABLE INTRODUCED IN ORDER TO  

      IF(IOSMET.EQ.1 .OR. IOSMET.EQ.-1 .OR. IOSMET.EQ.3) THEN
C     02-01-16 MODIFICATIONS (RC)
C     MAXNU NUMBER OF WAVELENGTH POINTS READ BY SUBROUTINE OSMET
        MAXNU = 1
        CALL OSMET(MAXNU)
      ENDIF
C     (RC)
      INLTEB=0
      DO 800 KR=1,NRAD
        IF(.NOT.IWIDE(KR)) THEN
          NLL=0
          CALL ABSKO(0,NDEP,TEMP,PE,1,JP,ABSK,SPRID)
          JP=JP+1
          DO 600 K=1,NDEP
            XCONT(K)=(ABSK(K)+SPRID(K))/XNORM(K)
            SC(K)=ABSLTE(K)/(ABSK(K)+SPRID(K))*BP(K,KR)
            SCAT(K)=SPRID(K)/(ABSK(K)+SPRID(K))
  600     CONTINUE
          DO 610 NY=1,NQ(KR)
            CALL WRITEX
  610     CONTINUE
        ELSE
          NLL=NLL0
C
C  FOR CONTINUA IN DETAIL. CHECK TO SEE IF ANY BACKGROUND ABSORBER
C  SHOULD BE EXCLUDED
C
          DO 650 L=2,NKOMP-6
            IF(LVNAMEI(L).EQ.LABEL(IRAD(KR)) .AND.
     *         LVNAMEJ(L).EQ.LABEL(JRAD(KR))) THEN
              INLTEB=INLTEB+1
              KMPEXC=L
              IF(INLTEB.EQ.1 .AND. (IWOPAC.NE.0 .OR. IWARN.GE.1)) THEN
                WRITE(LJOBLO,620)
  620           FORMAT('FOLLOWING BACKGROUND ABSORBERS EXCLUDED:'//
     *                '   KR',2X,'LOWER LEVEL',11X,'UPPER LEVEL')
              ENDIF
              IF(IWOPAC.NE.0 .OR. IWARN.GE.1) THEN
                WRITE(LJOBLO,'(I5,2X,A,2X,A)') KR,LVNAMEI(L),LVNAMEJ(L)
              ENDIF
            ENDIF
  650     CONTINUE
          KT=KTRANS(KR)

C     03-01-21 MODIFICATIONS (RC)
C     ADDED CONDITION FOR THE IOSMET VARIABLE
C     02-01-16 MODIFICATIONS (RC)
C     BACKGROUND LINE OPACITIES ADDED WHEN A BACKGROUND TRANSITION
C     IS CONSIDERED (KR .GT. NLINE);  LFLAG =1

C     03-02-20 MODIFICATIONS (RC)
C     IF IOSMET .EQ. 2 THEN LFLAG =2 AND MULTIPLICATION FACTORS
C     A LA BRULS ET AL. 1992 ARE INTRODUCED
          LFLAG = 0
C   KL TEST to add bb background to bb transitions:       
C          IF (IOSMET.EQ.1 .OR. IOSMET.EQ.-1.OR. IOSMET.EQ.3) THEN           
          IF (KR.GT.NLINE .AND. (IOSMET.EQ.1 .OR.IOSMET.EQ.-1
     *     .OR. IOSMET.EQ.3)) THEN           
             LFLAG=1
          ENDIF
          IF (KR .GT. NLINE .AND. IOSMET .EQ. 2) THEN
             LFLAG = 2
          ENDIF     
C     (RC)
C          
          DO 750 NY=1,NQ(KR)
            WAVE=CC/FRQ(NY,KT)*1.E8
            CALL ABSKO(0,NDEP,TEMP,PE,1,JP,ABSK,SPRID)
            JP=JP+1
C
C     02-01-16 MODIFICATIONS (RC)
C     OSLINE:  IF LFLAG=1  INTERPOLATES BACKGROUND OPACITIES FROM
C     OSMET AT THE FREQUENCY   FRQ(NY,KT)  FOR ALL THE DEPTH POINTS
C     AND STORE THE INTERPOLATED OPACITIES IN THE ARRAY LINOP(K)
C     IF LFLAG = 0 THEN NOTHING IS ADDED (LINOP(K)=0)
            IF(IOSMET.EQ.3) THEN
              IF(WAVE.LT.1520.D0) THEN
                LFLAG=0
              ELSE
                LFLAG=1
              ENDIF
            ENDIF
            IF(IOSMET.NE.0) CALL OSLINE(FRQ(NY,KT), MAXNU, LFLAG)

            DO 700 K=1,NDEP

C     INSTEAD OF SUMMING SEPARATELY ABSK, SPRID AND LINOP 
C     ( XCONT(K)=(ABSK(K)+SPRID(K)+LINOP(K))/XNORM(K) ),
C     LINOP  IS FIRST ADDED TO  ABSK AND SPRID
C     SCATTERING ALBEDO IS EPSLN
C
C      EPSLN==NE(K)/(C+NE(K))
C      WHERE CONSTANT C IS SQRT(T)/(20.6*(WAVE*1.E-8)^3*P) AND
C      P IS VAN REGEMORTER P FUNCTION. ASSUME NEUTRALS
C      ABSK(K)=ABSK(K)+LINOP(K)*EPSLN
C      SPRID(K)=SPRID(K)+LINOP(K)*(1.-EPSLN)
C      ABSLTE(K) = ABSLTE(K) + LINOP(K)*EPSLN
C      XCONT(K)=(ABSK(K)+SPRID(K))/XNORM(K)
C
C     (MODIFICATION, 02-03-27)

C
C     LINE OPACITIES (LINOP) ADDED TO BACKGROUND OPACITIES
C     IF LFLAG IS NOT 1 (IOSMET .NOT. 1) THEN LINOP(*) = 0
              IF(IOSMET.NE.0) THEN
                BETA=HH*CC*1.E8/WAVE/BK/TEMP(K)
                ECNST1=SQRT(TEMP(K))/(20.6D0*(WAVE*1.D-8)**3)
                ECNST=ECNST1*(EOSMET/PSEMI(2,BETA)+
     *           (1.0D0-EOSMET)/PSEMI(1,BETA))
                EPSLN=NE(K)/(ECNST+NE(K))
                EPSLN=1.D0
                ABSK(K)   = ABSK(K)  + LINOP(K)*EPSLN
                ABSLTE(K) = ABSLTE(K)+ LINOP(K)*EPSLN
                SPRID(K) = SPRID(K)+LINOP(K)*(1.D0-EPSLN)
              ENDIF

              XCONT(K)=(ABSK(K)+SPRID(K))/XNORM(K)
              SC(K) = ABSLTE(K)/(ABSK(K)+SPRID(K))*
     *         PLANCK(FRQ(NY,KT),TEMP(K))
              SCAT(K)=SPRID(K)/(ABSK(K)+SPRID(K))
C     (RC)

  700       CONTINUE
            CALL WRITEX
            IF(IWOPAC.NE.0 .AND. KMPEXC.NE.0) THEN
              L=KMPEXC
              WRITE(LOUT,620)
              WRITE(LOUT,'(I5,2X,A,2X,A)') KR,LVNAMEI(L),LVNAMEJ(L)
            ENDIF
  750     CONTINUE
        ENDIF
        KMPEXC=0
  800 CONTINUE
C
C  CONVERT XNORM TO CM**2 PER CM**3
C
      DO 900 K=1,NDEP
        XNORM(K)=XNORM(K)*RHO(K)
  900 CONTINUE
C
C  OUTPUT TO FILE INIT
C
      IF(ICALL.EQ.0 .AND. .NOT.L3D) THEN
        CALL MOPEN(LINIT,'INIT',0,'UNKNOWN')
        WRITE(LINIT) (RHO(K),K=1,NDEP),(TOTN(K),K=1,NDEP),(XNORM(K),
     *   K=1,NDEP),((BH(I,K),I=1,5),K=1,NDEP)
        CALL CLOSE(LINIT)
      ENDIF
C
      CALL MCTIME('OPAC  ',0,1,1)
      RETURN
      END
C
C***********************************************************************
C
      SUBROUTINE TABINI(W,LOOPMX)
C
C  INITIALIZES OPACITY PACKAGE FOR OPCTAB PROGRAM
C
      INCLUDE 'PREC'
      INCLUDE 'PARAMO'
      REAL(8) W(LOOPMX)
C
      COMMON/CA2/ABKOF(NABDIM),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP,NABKOF
C
      COMMON/UTPUT/ IREAD, IWRIT
C
      COMMON/CFIL/IREAT,INLATB
C
      COMMON/COUTR/ NTO,NTPO(MT),IWOPTN
C
      COMMON/CXLSET/NSET,NL(MSET),XL(ML,MSET)
C
      COMMON/CBMET/ BMET(MT,MKOMP-23),BMETP(MT,MKOMP-23),
     *       FRCION(MEL,MJ,MT),ZNLTE(MEL,MJ,MT)
      COMMON/CBMET2/ ANMET(MT,MKOMP-23)
C
      CHARACTER*20 ABNAME,LVNAMEI,LVNAMEJ
      COMMON/CNAME/ ABNAME(MKOMP),LVNAMEI(MKOMP),LVNAMEJ(MKOMP)
      SAVE ICALL
      DATA ICALL/0/
C
      ICALL=ICALL+1
C
C  OPEN ABSORPTION DATA INPUT FILE AND TEMPORARY FILES
C  ASSIGN OUTPUT TO OUT FILE
C
      IF(ICALL.EQ.1) THEN
        CALL MOPEN(IREAD,'ABSDAT',1,'OLD')
        CALL MOPEN(IWRIT,'OUT',1,'NEW')
        IREAT=IREAD
      ELSE
        REWIND IREAD
      ENDIF
C
C  FILL WAVELENGTH ARRAY
C
      NSET=1
      DO 200 L=1,LOOPMX
        XL(L,1)=W(L)
  200 CONTINUE
      NL(1)=LOOPMX
C
      IOUTS=0
      CALL INJON(IOUTS)
      CALL INABS(IOUTS)
C
C  FILL ARRAY WITH INDICES WHERE PRINTOUT IS WANTED
C
      NTO=0
C
C  INITIALIZE BMET AND BMETP ARRAYS TO 1.0
C
      DO 500 KOMP=17,MKOMP-7
        DO 400 K=1,MT
          BMET(K,KOMP-16)=1.0
          BMETP(K,KOMP-16)=1.0
          ANMET(K,KOMP-16)=-1.0
  400   CONTINUE
  500 CONTINUE
C
      END
C
C********************************************************************
C
      SUBROUTINE INJON(IOUTS)
C
C
C        THIS ROUTINE READS DATA NECESSARY FOR THE COMPUTATION OF IONIZATION
C        EQUILIBRIA ETC. (IN SUBR. JON).
C        1. NEL= THE NUMBER OF CHEMICAL ELEMENTS CONSIDERED.
C           A=   THE RATIO OF THE NUMBER OF HYDROGEN NUCLEI TO THE NUMBER OF
C                NUCLEI OF METALLIC ELEMENTS.
C           NMET=THE NUMBER OF METALLIC ELEMENTS IN THE LIST OF CHEMICAL
C                ELEMENTS CONSIDERED. THE LAST NMET ELEMENTS OF THE LIST ARE
C                CONSIDERED TO BE METALLIC, FOR THE CALCULATION OF THE
C                QUANTITY A (DEFINED ABOVE).
C        2. CEL  IS THE ARRAY WHICH WILL CONTAIN THE SYMBOLS FOR THE CHEMICAL
C                ELEMENTS CONSIDERED.
C           ABUND IS THE ARRAY WHICH WILL CONTAIN THE PREVAILING ABUNDANCES OF
C                THE CHEMICAL ELEMENTS CONSIDERED AT INPUT. THESE ABUNDANCES
C                ARE EXPRESSED ON A LOGARITHMIC SCALE (BASE 10) AND NEED NOT BE
C                NORMALIZED. THE ABUNDANCES ARE MODIFIED IN THIS SUBROUTINE
C                SO THAT THE RIGHT VALUE OF A (DEFINED ABOVE) IS OBTAINED.
C        3. AI   IS THE ARRAY WHICH WILL CONTAIN THE ATOMIC WEIGHTS OF THE
C                ELEMENTS CONSIDERED.
C        4. DATA FOR THE COMPUTATION OF THE PARTITION FUNCTIONS IS READ NEXT.
C           NJ(I)= THE NUMBER OF STAGES OF IONIZATION CONSIDERED FOR ELEMENT I.
C         FOR EACH STAGE OF IONIZATION JA THE FOLLOWING QUANTITIES ARE READ
C           G0(JA)=THE STATISTICAL WEIGHT OF THE GROUND LEVEL,
C           NK(JA)=THE NUMBER OF ELECTRON CONFIGURATIONS CONSIDERED.
C         FOR EACH ELECTRON CONFIGURATION JB THE FOLLOWING QUANTITIES ARE READ
C           XION(JB)=THE IONIZATION ENERGY IN ELECTRON VOLTS,
C           G2(JB)=THE STATISTICAL WEIGHT (2L+1)*(2J+1)
C           XL(JB)=THE LOWEST QUANTUM NUMBER OF THE ASYMPTOTIC (HYDROGENIC) PART
C                OF THE PARTITION FUNCTION,
C           NL(JB)=THE NUMBER OF TERMS IN THE (APPROXIMATE) EXPRESSION FOR THE
C                'MIDDLE PART' OF THE PARTITION FUNCTION ('QPRIME').
C           ALFA IS AN ARRAY WHICH WILL CONTAIN THE 'STATISTICAL WEIGHTS' OF
C                THE (APPROXIMATE) EXPRESSIONS FOR THE 'MIDDLE PARTS' OF THE
C                PARTITION FUNCTIONS.
C           GAMMA IS AN ARRAY CONTAINING THE CORRESPONDING 'EXCITATION
C                POTENTIALS' (EXPRESSED IN ELECTRON VOLTS).
C         FOR THE METHOD USED SEE TRAVING ET AL., ABH. HAMB. VIII, I (1966).
C        5. ELEMENTS AND STAGES OF IONIZATION THAT SHOULD BE DISREGARDED ARE
C           INDICATED BY IELEM(I)=0 FOR ELEMENT I AND BY ION(I,J)=0 FOR
C           IONIZATION STAGE J. OTHERWISE INDICATORS SHOULD BE = 1.
C        6. NQFIX IS THE NUMBER OF PARTITION FUNCTIONS THAT SHOULD BE CONSTANT.
C                THE VALUES ARE READ INTO THE VECTOR PARCO AND AN INDICATION IS
C                MADE IN IQFIX.  IQFIX(I,J)=0 MEANS THAT THE PARTITION FUNCTION
C                FOR ELEMENT I, STAGE OF IONIZATION J, IS CONSIDERED TO BE
C                CONSTANT.
C           NQTEMP IS THE NUMBER OF PARTITION FUNCTIONS  THAT SHOULD BE
C                PRESSURE-INDEPENDENT AND INTERPOLATED IN T. VALUES OF FOUR
C                TEMPERATURES (TPARF, THE SAME FOR ALL ELEMENTS) AND
C                CORRESPONDING PARTITION FUNCTIONS (PARF) ARE READ. IQFIX(I,J)=1
C                MEANS THAT A PRESSURE-INDEPENDENT PARTITION FUNCTION FOR INTER-
C                POLATION IN T IS GIVEN.
C        7. IFISH IS A PARAMETER FOR THE CHOICE OF THE ASYMPTOTIC PARTITION
C                FUNCTION. IFISH=0 MEANS THAT THE ASYMPTOTIC PART WILL BE EVALU-
C                ATED FOLLOWING BASCHEK ET AL., ABH. HAMB. VIII,26 (1966). IFISH
C                =1 MEANS THAT IT WILL BE EVALUATED FOLLOWING FISCHEL AND SPARKS
C                ASTROPHYS. J. 164, 356 (1971).
C        8. TMOLIM IS THE HIGHER TEMPERATURE LIMIT BEYOND WHICH MOLECULES WILL
C                NOT BE CONSIDERED
C
C        MOREOVER SOME INITIATING WORK IS DONE FOR SUBR. JON. UNLOGARITHMIC
C        ABUNDANCES ARE NORMALIZED ON HYDROGEN, XMY AND SUMH (DEFINED BELOW)
C        ARE COMPUTED AND SOME FURTHER QUANTITIES ARE EVALUATED AT THE END.
C        A DETAILED PRINTOUT IS GIVEN IF IOUTS IS EQUAL TO ONE. AFTER INJON
C        HAS BEEN CALLED ONCE, A NEW DETAILED PRINTOUT IS OBTAINED IF
C        INJON IS CALLED WITH IOUTS GREATER THAN ONE.
C
C        DIMENSIONS NECESSARY
C        ABUND(NEL),AI(NEL),ALFA(LMAX),ANJON(NEL,MAX(NJ)),FL2(5),F1Q(3),F2Q(2),
C        GAMMA(LMAX),G0(JMAX),G2(KMAX),H(5),CEL(NEL),IELEM(NEL),
C        ION(NEL,MAX(NJ)),IQFIX(NEL,MAX(NJ)),JAMEM(NEL,MAX(NJ)),JBBEG(JMAX),
C        JCBEG(JMAX),NJ(NEL),NK(JMAX),NL(KMAX),PARCO(JMAX),PARF(4*JMAX),
C        PARPP(4),PARPT(4),PARQ(4*JMAX),PART(NEL,MAX(NJ)),SHXIJ(5),TPARF(4),
C        XION(KMAX),XIONG(NEL,MAX(NJ)),XL(KMAX)
C        THE DIMENSIONS ARE LOWER LIMITS
C        JMAX IS THE TOTAL NUMBER OF STAGES OF IONIZATION, INCLUDING NEUTRAL
C             ATOMS.
C        KMAX IS THE TOTAL NUMBER OF ELECTRON CONFIGURATIONS.
C        LMAX IS THE TOTAL NUMBER OF TERMS IN THE (APPROXIMATE) EXPRESSIONS
C             FOR THE MIDDLE PART OF THE PARTITION FUNCTIONS ('QPRIME'),
C             ACCORDING TO TRAVING ET AL., CITED ABOVE.
C        NEL  IS THE NUMBER OF CHEMICAL ELEMENTS.
C        NJ(I) IS THE NUMBER OF STAGES OF IONIZATION, INCLUDING THE NEUTRAL
C             STAGE, FOR ELEMENT I.
C
C:
C: INJON  87-10-16  MODIFICATIONS: (MATS CARLSSON):
C:        ABUNDANCES ARE READ FROM FILE 'ABUND' WHERE THEY ARE GIVEN
C:        EITHER RELATIVE TO HYDROGEN A(H)=1.0 OR ON A LOGARITHMIC SCALE
C:        A(H)=12.0. THE FORMAT IS (ID,ABUNDANCE)  (A3,E15.0). THE ID
C:        SHOULD CORRESPOND TO THE ID IN THE ABSDAT FILE
C:        GRPH, SUMABN AND SUMMY ARE STORED FOR USE IN MULTI ROUTINES
C:
C:        88-04-25 MODIFICATIONS (PHILIP JUDGE)
C:        INPUT CORONAL APPROXIMATION IONIZATION FRACTIONS FROM 
C:        SHULL AND VAN STEENBERG (1982)- SEE ROUTINES CORONA AND RCORON
C:
C:        89-03-24  MODIFICATIONS (MATS CARLSSON)
C:        FORMATION OF MOLECULES WAS NOT TAKEN INTO ACCOUNT WHEN CALCULATING
C:        XNENH AND OPACITIES. THIS HAS BEEN CORRECTED. TOTAL NUMBER 
C:        ABUNDANCES OF ATOMS AFTER MOLECULE FORMATION HAS BEEN TAKEN INTO
C:        ACCOUNT ARE STORED IN NEW VARIABLE ABUNDM
C:
C:        92-07-05  MODIFICATIONS (MATS CARLSSON)
C:        POTENTIAL PROBLEM WITH OVERINDEXING IN 
C:        READ(LABUND,310,END=320) CELIN(I),ABIN(I)
C:        CORRECTED
C:
C:        92-07-20  MODIFICATIONS (MATS CARLSSON)
C:        INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS
C:
      INCLUDE 'PREC'
      INCLUDE 'C3D'
      INCLUDE 'PARAMO'
      DIMENSION AI(MEL),F1Q(3),F2Q(2),PARF(4*MJMAX),PARPP(4),PARPT(4)
      DIMENSION JAMEM(MEL,MJ)
C
      COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4),
     *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL
      CHARACTER*3 CEL
      COMMON/CC1/CEL(MEL)
C
      COMMON/CI9/AI
C
      COMMON/CI3/ALFA(MLMAX),GAMMA(MLMAX),G0(MJMAX),G2(MKMAX),
     * XION(MKMAX),XL(MKMAX),JBBEG(MJMAX),JCBEG(MJMAX),NK(MJMAX),
     * NL(MKMAX),IFISH
C
      COMMON/CI4/ IELEM(MEL),ION(MEL,MJ),TMOLIM,MOLH
C
      COMMON/CI5/ABUND(MEL),ANJON(MEL,MJ),H(5),PART(MEL,MJ),DXI,
     * F1,F2,F3,F4,F5,XKHM,XMH,XMY
C
      COMMON/CI6/TP,IQFIX(MEL,MJ),NQTEMP
C
      COMMON/UTPUT/ IREAD, IWRIT
C*
C* 87-05-30, 87-10-16, 89-03-24, 92-07-20  MODIFICATIONS START
C
      COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT),
     * TOTCH(MT),TOTCO(MT),TOTCN(MT),
     * TOTC(MT),TOTNIT(MT),TOTO(MT),
     * BHYD(MT,5),GRPH,TOTOH(MT)

CCC 00-09-12 TOTOH ADDED

      COMMON/ELMSUM/ SUMABN,SUMMY,NELM,NELME
      DIMENSION ABIN(MEL)
      CHARACTER*3 CELIN(MEL),CELIN0
      COMMON/CABNDM/ ABUNDM(MEL)
C* 87-05-30, 87-10-16, 89-03-24, 92-07-20  MODIFICATIONS END
C
        IF(IOUTS.GT.1) GO TO 25
C
C        READING OF THE ABUNDANCES AND THEIR ASSOCIATED QUANTITIES
C        **** 1 ****
C
      READ(IREAD,100) NEL,A,NMET
C* 92-07-20 MODIFICATIONS START
      READ(IREAD,110)(CEL(I),I=1,NEL)
      DO 50 I=1,NEL
        CALL LJUST(CEL(I))
   50 CONTINUE
C*
C* 87-05-30 MODIFICATIONS START
C* MAKE POSSIBLE  INPUT OF MULTI ABUNDANCE FILE
C* 92-07-20 MODIFIED IEL.. TO CEL..
      IF(L3D) THEN
        CALL MOPEN(LABUND,'ABUND',1,'OLD')
      ELSE
        CALL MOPEN(LABUND,'DUMS5',1,'NEW')
        CALL CSTRI2(LDUMS2,LABUND,'ABUND')
      ENDIF
      I=1
  300 CONTINUE
        READ(LABUND,310,END=320) CELIN0,ABIN0
        IF(I.GT.MEL)
     *    CALL STOP('INJON: TOO MANY ELEMENTS IN ABUNDANCE FILE')
  310   FORMAT(A3,E15.0)
        CELIN(I)=CELIN0
        ABIN(I)=ABIN0
        I=I+1
      GOTO 300
  320 CONTINUE
      CALL CLOSE(LABUND)
      NELIN=I-1
      DO 370 I=1,NEL
        ABUND(I)=0.0
        DO 330 M=1,NELIN
          IF(CEL(I).EQ.CELIN(M)) THEN
            ABUND(I)=ABIN(M)
          ENDIF
  330   CONTINUE
  370 CONTINUE
      IF(ABUND(1).EQ.1.0) THEN
        DO 380 I=1,NEL
          ABUND(I)=LOG10(ABUND(I))+12.0
  380   CONTINUE
      ENDIF
C*
C* 87-05-30, 92-07-20 MODIFICATIONS END
C
C        **** 3 ****
C
      READ(IREAD,102)(AI(I),I=1,NEL)
      NU=NEL
      SUM=0.
      SUMM=0.
      FAKT=1.
C
C        THE ABUNDANCES ARE CONVERTED FROM A LOGARITHMIC SCALE TO A DIRECT
C        SCALE, AND ARE THEN NORMALIZED ON HYDROGEN. XMY=GRAMS OF STELLAR MATTER
C        /GRAMS OF HYDROGEN. SUMH=NUMBER OF OTHER NUCLEI/NUMBER OF HYDROGEN
C        NUCLEI.
C        SUMM=NUMBER OF NUCLEI OTHER THAN H, C, N, O / NUMBER OF HYDROGEN NUCLEI
C
      IF(NMET.LE.0)GO TO 22
      NU=NEL-NMET+1
      DO1 I=NU,NEL
      ABUND(I)=10.**ABUND(I)
    1 SUM=ABUND(I)+SUM
C
      FAKT=SUM*A/10.**ABUND(1)
      NU=NU-1
   22 DO2 I=1,NU
      ABUND(I)=10.**ABUND(I)*FAKT
    2 SUM=SUM+ABUND(I)
      XMY=0.
      AHA=ABUND(1)
      DO3 I=1,NEL
      ABUND(I)=ABUND(I)/AHA
      SUMM=SUMM+ABUND(I)
    3 XMY=XMY+ABUND(I)*AI(I)
      XMY=XMY/AI(1)
      SUMH=SUM/AHA-1.
      SUMM=SUMM-ABUND(1)-ABUND(3)-ABUND(4)-ABUND(5)
C*
C* 89-03-24 START
C  STORE ABUNDANCES IN ABUNDM
C
      DO 390 I=1,NEL
        ABUNDM(I)=ABUND(I)
  390 CONTINUE
C
C* 89-03-24 END
C*
C
C        **** 4 ****
C
C        READING OF DATA FOR THE PARTITION FUNCTIONS.
C        FOR THE SYMBOLS, SEE ABOVE.
C
      READ(IREAD,103)(NJ(I),I=1,NEL)
      JA=1
      JB=1
      JC1=1
      DO11 I=1,NEL
      NJP=NJ(I)
      DO11 J=1,NJP
      JAMEM(I,J)=JA
      JBBEG(JA)=JB
      JCBEG(JA)=JC1
C        JBBEG AND JCBEG ARE INDICATORS USED BY FUNCTION QTRAV
C
      READ(IREAD,104)G0(JA),NK(JA)
      NKP=NK(JA)
      IQFIX(I,J)=2
C        IQFIX(I,J)=2 MEANS THAT A 'FULL' PARTITION FUNCTION SHOULD BE
C        COMPUTED. THIS MAY BE CHANGED UNDER **** 7 ****.
C
      JA=JA+1
      IF(JA.GT.MJMAX) CALL STOP('INJON: JA.GT.MJMAX')
      DO11 K=1,NKP
      READ(IREAD,105)XION(JB),G2(JB),XL(JB),NL(JB)
      IF(K.GT.1)GO TO 9
      XIONG(I,J)=XION(JB)
C        XIONG IS THE IONIZATION ENERGY IN ELECTRON VOLTS FOR THE GROUND STATE,
C        USED IN THE COMPUTATION OF IONIZATION EQUILIBRIA IN
C        SUBROUTINE  JON.
C
    9 CONTINUE
      JC2=NL(JB)+JC1-1
      JBM=JB
      JB=JB+1
      IF(JB.GT.MKMAX) CALL STOP('INJON: JB.GT.MKMAX')
      IF(NL(JBM).LE.0)GO TO 10
      READ(IREAD,106)(GAMMA(L),ALFA(L),L=JC1,JC2)
   10 JC1=JC2+1
   11 CONTINUE
C
C        **** 5 ****
C
C        READING OF THE INDICATORS OF THE ELEMENTS AND THE STAGES OF IONIZATION
C        TO BE DISREGARDED.
      DO12 I=1,NEL
      NJP=NJ(I)
      READ(IREAD,107)IELEM(I),(ION(I,J),J=1,NJP)
   12 CONTINUE
C
C        **** 6 ****
C
C        SPECIFICATION OF THOSE PARTITION FUNCTIONS GIVEN AS CONSTANTS.
C        INDICATION IN IQFIX.
      READ(IREAD,103)NQFIX
      IF(NQFIX.LE.0)GO TO 15
   13 DO14 I=1,NQFIX
      READ(IREAD,109)I1,J1,PARCOP
      JA=JAMEM(I1,J1)
      PARCO(JA)=PARCOP
   14 IQFIX(I1,J1)=0
   15 CONTINUE
C
C        SPECIFICATION OF THOSE PARTITION FUNCTIONS TO BE INTERPOLATED IN T.
C        INDICATION IN IQFIX.
      READ(IREAD,103)NQTEMP
      IF(NQTEMP.EQ.0)GO TO 20
      READ(IREAD,101)TPARF
      DO17 I=1,NQTEMP
      READ(IREAD,109)I1,J1,(PARPP(K),K=1,4)
      IQFIX(I1,J1)=1
C
C        PREPARATION FOR INTERPOLATION OF PARTITION FUNCTIONS IN T (CONCLUDED
C        IN SUBROUTINE  JON).
      DO16 K=1,3
   16 F1Q(K)=(PARPP(K+1)-PARPP(K))/(TPARF(K+1)-TPARF(K))
      DO161 K=1,2
  161 F2Q(K)=(F1Q(K+1)-F1Q(K))/(TPARF(K+2)-TPARF(K))
      F3Q=(F2Q(2)-F2Q(1))/(TPARF(4)-TPARF(1))
      PARPT(1)=PARPP(1)
      PARPT(2)=F1Q(1)
      PARPT(3)=F2Q(1)
      PARPT(4)=F3Q
      JA=JAMEM(I1,J1)
      DO17 K=1,4
      JK=(JA-1)*4+K
      PARQ(JK)=PARPT(K)
   17 PARF(JK)=PARPP(K)
C        PARQ IS IN COMMON/CI1/ AND IS USED IN SUBROUTINE  JON. PARF IS JUST
C        USED BELOW.
C
   20 CONTINUE
C
C        **** 7, 8 ****
C
C        THE PARAMETERS IFISH AND TMOLIM. INITIATING WORK FOR SUBROUTINE
C        JON.
C        WHEN MOLH IS GREATER THAN ZERO THE MOLECULAR FORMATION WILL BE COMPUTED
C        IN SUBR. MOLEQ (ONLY H2 AND H2+), ELSE MORE COMPLETE MOLECULAR
C        FORMATION WILL BE EVALUATED IN SUBR. MOL.
C
      READ(IREAD,100)IFISH
      READ(IREAD,4528) TMOLIM,MOLH
 4528 FORMAT(F10.0,I5)
C*
C*  88-04-25 MODIFICATIONS (PHILIP JUDGE)
C*  READ CORONAL ION BALANCE DATA:
C*
      CALL RCORON(IREAD)
C*  END 88-04-25 MODIFICATIONS
C*
      DO21 J=1,5
      FLJ=J
      FL2(J)=31.321*FLJ*FLJ
   21 SHXIJ(J)=SQRT(13.595*FLJ)
C
C        EEV=THE ELECTRON VOLT (EXPRESSED IN TERMS OF ERGS)
C        XMH=THE MASS OF THE HYDROGEN ATOM (EXPRESSED IN GRAMS)
C        XKBOL=BOLTZMANN'S CONSTANT (EXPRESSED IN ERGS PER DEGREE KELVIN)
      EEV=1.602095E-12
      XMH=1.67339E-24
      XKBOL=1.38053E-16
      ENAMN=EEV/(XMH*XMY)
C
C* 87-10-16 MODIFICATIONS START
C* STORE GRPH, SUMABN AND SUMMY FOR COMMUNICATION WITH MULTI PROGRAMS
      GRPH=XMY*XMH
      SUMMY=XMY/(1.0+SUMH)*1.008
      SUMABN=SUMH
C* 87-10-16 MODIFICATIONS END
C*
      TP=0.
C        TP IS THE TEMPERATURE AT THE 'PRECEDING' CALL OF JON.
C
C        **** PRINT-OUT ****
C
      IF(IOUTS.LE.0)GO TO 40
   25 CONTINUE
      WRITE(IWRIT,201)
      WRITE(IWRIT,202)
      WRITE(IWRIT,203)
      DO33 I=1,NEL
      NJP=NJ(I)
C* 92-07-20 MODIFICATIONS START. CHANGED IEL(I) TO CEL(I)(1:2)
      WRITE(IWRIT,204)CEL(I)(1:2),ABUND(I),IELEM(I),(ION(I,J),
     * IQFIX(I,J),J=1,NJP)
   33 CONTINUE
      WRITE(IWRIT,207)
      WRITE(IWRIT,208)
      IF(IFISH.EQ.1)WRITE(IWRIT,211)
      IF(IFISH.EQ.0)WRITE(IWRIT,210)
      IF(NQTEMP.GT.0.OR.NQFIX.GT.0)WRITE(IWRIT,214)
      IF(NQTEMP.GT.0)WRITE(IWRIT,209)TPARF
      JA=1
      DO32 I=1,NEL
      NJP=NJ(I)
      DO32 J=1,NJP
      JP=J-1
      IF(IQFIX(I,J).EQ.0)WRITE(IWRIT,205)CEL(I)(1:2),JP,PARCO(JA)
      JK1=(JA-1)*4+1
      JK2=(JA-1)*4+4
      IF(IQFIX(I,J).EQ.1)WRITE(IWRIT,206)CEL(I)(1:2),JP,
     * (PARF(JK),JK=JK1,JK2)
C* 92-07-20 MODIFICATIONS END
   32 JA=JA+1
      IF(NQTEMP.GT.0)WRITE(IWRIT,215)
      WRITE(IWRIT,212)TMOLIM
      IF(MOLH.LE.0) WRITE(IWRIT,216)
      IF(MOLH.GT.0) WRITE(IWRIT,217)
      WRITE(IWRIT,213)XMY,SUMH
   40 CONTINUE
      RETURN
C
  100 FORMAT(I10,F10.4,I10)
  101 FORMAT(6F10.4)
  102 FORMAT(6F10.4)
  103 FORMAT(12I5)
  104 FORMAT(F5.0,I5)
  105 FORMAT(F6.3,F4.0,F5.1,I5)
  106 FORMAT(4(F10.3,F10.4))
  107 FORMAT(I10,5I5)
  108 FORMAT(2F10.4)
  109 FORMAT(2I5,4F10.4)
  110 FORMAT(30A3)
  201 FORMAT(1H1,'D A T A  F R O M  S U B R O U T I N E  I N J O N')
  202 FORMAT(1H0,30X,1HI,14X,2HII,13X,3HIII,12X,2HIV)
  203 FORMAT(1H ,'    ABUNDANCE   IELEM      ION   PF       ION   PF
     *   ION   PF       ION   PF')
  204 FORMAT(1H ,A2,E12.4,I5,5X,5(I5,I5,5X))
  205 FORMAT(1H ,A2,', STAGE OF IONIZATION=',I2,' PARTITION FUNCTION (CO
     *NSTANT)=',F10.3)
  206 FORMAT(1H ,A2,', STAGE OF IONIZATION=',I2,' PART.FUNC. (T-DEP.) ='
     *,4F10.3)
  207 FORMAT(1H0,'IELEM AND ION = 1 OR 0 MEANS ELEMENT AND IONIZATION
     *STAGE SHOULD BE CONSIDERED OR DISREGARDED RESP.')
  208 FORMAT(1H0,'PF=2 FULL PART. FUNC., =1 PART. FUNC. TO BE INTERPOLAT
     *ED IN T, =0 CONSTANT PART. FUNC.')
  209 FORMAT(1H ,'T-DEPENDENT PARTITION FUNCTIONS GIVEN FOR T =  ',4F10.
     *0)
  210 FORMAT(1H ,'ASYMPTOTIC PARTS OF PART. FUNC. FOLLOWING BASCHEK ET A
     *L. 1966')
  211 FORMAT(1H ,'ASYMPTOTIC PARTS OF PART. FUNC. FOLLOWING FISCHEL AND
     *SPARKS 1971')
  212 FORMAT(1H0,'MOLECULES CONSIDERED BELOW T=',F7.0,' DEGREES KELVIN')
  213 FORMAT(1H0,'XMY=GRAMS STELLAR MATTER/GRAMS OF HYDROGEN=',F7.4,5X,
     *'SUMH=NUMBER OF OTHER ATOMS/NUMBER OF H=',F8.5)
  214 FORMAT(1H0,'PARTITION FUNCTIONS SUPPLIED BY THE USER')
  215 FORMAT(1H ,'IF T OUTSIDE RANGE FOR INTERPOLATIONS DETAILED PART. F
     *UNCTIONS ARE COMPUTED')
  216 FORMAT(1H0,'MOLECULES CONSIDERED:  H2, H2+, H2O, OH, CH, CO, CN, C
     *2, N2, O2, NO, NH')
  217 FORMAT(1H0,'MOLECULES CONSIDERED:  H2, H2+')
      END
C
C **************************************************************************
C
      SUBROUTINE CSTRI2(IUNIT,LDUMS2,FILE)
C
C  STRIPS COMMENT LINES (LINES WITH * IN POSITION 1) FROM INPUT FILE
C  UNIT IUNIT. THE FILE IS OPENED AND THE NON-COMMENT LINES ARE
C  WRITTEN TO UNIT LDUMS2
C
      INCLUDE 'PREC'
      CHARACTER*164 TEXT
      CHARACTER*(*) FILE
C
      CALL MOPEN(IUNIT,FILE,1,'OLD')
      CALL REWIND(LDUMS2)
  100 CONTINUE
        READ(IUNIT,200,END=900) TEXT
        IF(TEXT(1:1).NE.'*') WRITE(LDUMS2,200) TEXT
  200   FORMAT(A)
      GOTO 100
C
  900 CONTINUE
      CALL REWIND(LDUMS2)
      CALL CLOSE(IUNIT)
      RETURN
      END
C
C***********************************************************************
C
      SUBROUTINE INABS(IOUTS)
C
C        THIS ROUTINE  READS ABSORPTION COEFFICIENT TABLES AND INTER/EXTRA-
C        POLATES THEM TO OUR WAVELENGTHS GIVEN IN XL. THE INTERPOLATION IS
C        PERFORMED SEPARATELY FOR EACH WAVELENGTH SET.
C
C        NKOMP IS THE NUMBER OF COMPONENTS IN THE FULL TABLE.
C        NEXTL SHOULD BE GREATER THAN ZERO IF A PRINT-OUT IS WANTED ON EXTRA-
C              POLATION IN WAVELENGTH,
C        NUTZL IF PRINT-OUT IS WANTED WHEN WE PUT THE COEFFICIENT =0 OUTSIDE THE
C              WAVELENGTH REGION OF THE TABLES.
C        NEXTT AND NUTZL ARE THE CORRESPONDING QUANTITIES ON INTERPOLATION IN
C              T, MADE IN SUBROUTINE TABS.
C        NULL  SHOULD BE GREATER THAN ZERO IF A PRINT-OUT IS WANTED (FROM SUB-
C              ROUTINE ABSKO) WHEN A COEFFICIENT IS FOUND TO BE LESS THAN ZERO
C              ON INTERPOLATION IN T AND THEREFORE PUT EQUAL TO ZERO.
C
C        FOR EACH COMPONENT THE FOLLOWING PARAMETERS MUST BE SPECIFIED
C        ABNAME IS THE NAME OF, OR A SYMBOL FOR, THE ABSORPTION MECHANISM.
C        SOURCE INDICATES THE SOURCE OR REFERENCE OF THE DATA
C        1. PARAMETERS FOR THE WAVELENGTH INTERPOLATION.
C          ILOGL SHOULD BE GREATER THAN ZERO IF INTERPOLATION IN WAVELENGTH IS
C                TO BE PERFORMED ON THE LOGARITHMIC ABSORPTION COEFFICIENTS
C                (WITH SUBSEQUENT EXPONENTIATION OF THE RESULTS - HERE IF ILOGT
C                IS EQUAL TO ZERO OR IN SUBROUTINE ABSKO IF ILOGT IS GREATER
C                THAN ZERO). OTHERWISE INTERPOLATION IN WAVELENGTH IS MADE
C                DIRECTLY ON THE ABSORPTION COEFFICIENTS THEMSELVES.
C          KVADL SHOULD BE GREATER THAN ZERO IF QUADRATIC INTERPOLATION IN
C                WAVELENGTH IS WANTED. OTHERWISE INTERPOLATION WILL BE LINEAR.
C          MINEX SHOULD BE GT 0 IF LINEAR EXTRAPOLATION (INSTEAD OF PUTTING THE
C                COEFFICIENT = 0) IS WANTED TOWARDS SHORTER WAVELENGTHS.
C          MAXEX, CORRESPONDING TOWARDS LONGER WAVELENGTHS.
C          NLATB IS THE NUMBER OF WAVELENGTH POINTS OF THE ABSORPTION COEFFI-
C                CIENT TABLE TO BE READ.
C          XLATB ARE THOSE WAVELENGTHS. THEY SHOULD BE GIVEN IN INCREASING ORDER
C        2. PARAMETERS FOR THE TEMPERATURE INTERPOLATION.
C          ILOGT, KVADT, MINET, MAXET AND NTETB ARE THE T-INTERPOLATION
C                ANALOGUES TO ILOGL-NLATB.
C          ITETA IS PUT GREATER THAN ZERO WHEN TETA VALUES (TETA=5040./T) ARE
C                GIVEN IN XTET INSTEAD OF TEMPERATURES.
C          XTET ARE THE TEMPERATURE (TETA) VALUES OF THE ABSORPTION
C                COEFFICIENT TABLE TO BE READ. THE XTET VALUES SHOULD BE GIVEN
C                IN INCREASING ORDER AND EQUIDISTANTLY, HOWEVER (IELMAX-1)
C                CHANGES OF THE INTERVAL ARE ALLOWED. THE PROGRAM CHECKS THAT
C                THIS NUMBER IS NOT EXCEEDED.
C        XKAP IS THE ABSORPTION COEFFICIENT TABLE FOR THE ACTUAL COMPONENT. THE
C                WAVELENGTHS INCREASES MORE RAPIDLY THAN T (TETA).
C
C        THE TABLES FOR  T E M P E R A T U R E - I N D E P E N D E N T
C        C O M P O N E N T S  S H O U L D  B E  P U T  F I R S T .
C           THE RESULTING TABLE IS PUT IN ABKOF. HERE T (TETA) INCREASES MORE
C        RAPIDLY THAN XLA, WHICH INCREASES MORE RAPIDLY THAN KOMP. IF THE RESULT
C        OF THE INTERPOLATION IS ZERO FOR A CERTAIN XLA(J) AND KOMP, THIS IS NOT
C        PUT IN ABKOF. INSTEAD A NOTE IS MADE IN KOMPLA (KOMPLA(NLB*(KOMP-
C        1)+J) IS PUT EQUAL TO ZERO). OTHERWISE THE KOMPLA VALUE TELLS WHERE IN
C        ABKOF THE TABLE FOR THE COMPONENT KOMP AND THE WAVELENGTH J BEGINS.
C
C        A DETAILED PRINT-OUT IS GIVEN IF IOUTS IS GREATER THAN ZERO.
C
C
C        DIMENSIONS NECESSARY
C        ABKOF(NABDIM),ABNAME(NKOMP),DELT(NKOMP,IELMAX),IDEL(NKOMP),
C        IDISKV(MAX(NLATB)),ILOGTA(NKOMP),ISVIT(NKOMP),ITETA(NKOMP)
C        KOMPLA(MAX(NL)*NKOMP),KVADT(NKOMP),MAXET(NKOMP),MINET(NKOMP),
C        NL(NSET),NTAET(NKOMP),NTM(NKOMP,IELMAX),SOURCE(NKOMP),
C        TBOLT(NKOMP,IELMAX),XKAP(MAX(NLATB),MAX(NTETB)),XL(MAX(NL),NSET),
C        XLA(MAX(NL)),XLA3(MAX(NL)),XLATB(MAX(NLATB)),XTET(MAX(NTETB)),
C        XTETP(MAX(NTETB))
C
C        THE DIMENSIONS ARE LOWER LIMITS
C        IELMAX IS THE MAXIMUM NUMBER OF DIFFERENT T INTERVALS (GIVEN BELOW) IN
C               ANY ABSORPTION COEFFICIENT TABLE.
C        NABDIM IS THE DIMENSION OF THE ABKOF ARRAY (GIVEN BELOW).
C        NKOMP IS THE NUMBER OF 'COMPONENTS', I.E. EQUAL TO THE NUMBER OF
C               DIFFERENT ABSORPTION COEFFICIENT TABLES TO BE READ.
C        NL(I)  IS THE NUMBER OF WAVELENGTHS IN THE WAVELENGTH SET I.
C        NLATB(KOMP) IS THE NUMBER OF WAVELENGTH POINTS IN THE TABLE TO BE READ
C               FOR THE COMPONENT KOMP.
C        NSET   IS THE NUMBER OF WAVELENGTH SETS.
C        NTETB  IS THE NUMBER OF TEMPERATURE POINTS IN THE TABLE FOR THE COM-
C               PONENT BEING CONSIDERED.
C
C:
C: INABS  87-05-30  MODIFICATIONS: (MATS CARLSSON)
C:        ABNAME AND SOURCE CHANGED FROM DOUBLE PRECISION TO 
C:        CHARACTER*20
C:        FORMATS 105 AND 211 CHANGED ACCORDINGLY
C:        ABNAME CONTAINED IN COMMON BLOCK /CNAME/
C:
C:        POSSIBILITY OF INPUT DATA WITH PHOTOIONIZATION CROSSECTIONS
C:        GIVEN LEVEL BY LEVEL. THIS IS INDICATED WITH THE CHARACTER /
C:        AS THE FIRST CHARACTER IN ABNAME. IN THAT CASE AN EXTRA LINE
C:        IS READ (FREE FORMAT) CONTAINING IONIZATION STAGE (1=NEUTRAL),
C:        EXCITATION ENERGY IN CM-1 AND THE STATISTICAL WEIGHT OF THE
C:        LEVEL. THE ELEMENT NAME IS FOUND BY EXTRACTING THE TEXT
C:        BETWEEN / AND THE FIRST BLANK IN ABNAME. THIS NAME IS COMPARED
C:        WITH ARRAY CEL READ BY INJON TO FIND ELEMENT NUMBER THE
C:        INFORMATION IS STORED IN COMMON BLOCK /CLEVD/. THE COMPARISON
C:        IS CARRIED OUT IN ROUTINE  ELMCMP 
C:
C:        90-11-08  MODIFICATIONS: (MATS CARLSSON)
C:        ABNAME CHANGED TO NOT INCLUDE LEADING /
C:
C:        03-06-23  MODIFICATIONS: (MATS CARLSSON)
C:        ADDED SUPPORT FOR VARIABLE NUMBER OF DIGITS FOR NLATB, NTETB
C:        FORMAT FOUND IN OPINIT AND TRANSFERRED IN INLATB IN CFIL
C:
C:        03-08-12  MODIFICATIONS: (MATS CARLSSON)
C:        ADDED BOUNDS CHECK
C:
C:        07-07-30  MODIFICATIONS: (MATS CARLSSON)
C:        LVNAMEJ IS SET TO 'H CONT' IF FIRST CHARACTER IS NOT /
C:        THIS AVOIDS COUNTING BF OPACITY TWICE FOR HYDROGEN, AN ERROR
C:        INTRODUCED WITH EARLIER VERSIONS OF 2.3
C:
C:        07-12-28  MODIFICATIONS: (MATS CARLSSON)
C:        SCRATCH FILES DUMO1 AND DUMO2 NOT USED
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAMO'
      DIMENSION IDISKV(MLATB),XLATB(MLATB),XTET(MTETB),
     *NTAET(MKOMP),XKAP(MLATB,MTETB),XTETP(MTETB)
C
      COMMON/UTPUT/ IREAD, IWRIT
C
      COMMON/CA1/DELT(MKOMP,MELMAX),TBOT(MKOMP,MELMAX),IDEL(MKOMP),
     * ISVIT(MKOMP),ITETA(MKOMP),KVADT(MKOMP),MAXET(MKOMP),
     * MINET(MKOMP),NTM(MKOMP,MELMAX),NEXTT,NUTZT
C
      COMMON/CA2/ABKOF(NABDIM),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP,NABKOF
C
      COMMON/CA3/ILOGTA(MKOMP),NULL
C
      COMMON/CA5/AB(MKOMP),FAKT(MKOMP),PE(MT),T(MT),XLA(ML),XLA3(ML),RO,
     *SUMABS,SUMSCA,VIKTR,ISET,NLB
C
      COMMON/CFIL/IREAT,INLATB
C
      COMMON/CXLSET/NSET,NL(MSET),XL(ML,MSET)
C
      CHARACTER*20 ABNAME,LVNAMEI,LVNAMEJ
      CHARACTER*65 TEXT
      COMMON/CNAME/ ABNAME(MKOMP),LVNAMEI(MKOMP),LVNAMEJ(MKOMP)
C
      COMMON/CLEVD/ IONL(MKOMP),CHIL(MKOMP),G2L(MKOMP),IELL(MKOMP)
      CHARACTER*20 SOURCE(MKOMP)
      CHARACTER*40 F102
      SAVE SMALL
      DATA SMALL/1.E-37/
C
C        IELMAX IS THE MAXIMUM NUMBER OF DIFFERENT T INTERVALS IN THE XKAP-
C        TABLE. THE DIMENSIONS OF TBOT, DELT AND NTM ARE AFFECTED BY THIS NUMBER
      IELMAX=2
      DO705 L=1,30
  705 XTETP(L)=0.
      IF(IOUTS.GT.0)WRITE(IWRIT,229)
C
     
      READ(IREAT,101)NKOMP,NEXTL,NUTZL,NEXTT,NUTZT,NULL
      IF(NKOMP.GT.MKOMP) THEN
        CALL STOP('INABS: NKOMP GT MKOMP')
      ENDIF
C
      KOMPR=0
c
      iset=1
      NLB=NL(ISET)
      DO1 J=1,NLB
      XLA(J)=XL(J,ISET)
    1 XLA3(J)=XLA(J)**3
      INDEX=1
C
C        LOOP OVER COMPONENTS STARTS (THE 'FIRST KOMP-LOOP')
      DO720 KOMP=1,NKOMP
C*90-11-08 START OF MODIFICATION
      READ(IREAT,105) TEXT
      CALL LJUST(TEXT)
      IF(TEXT(1:1).EQ.'/') THEN
        ABNAME(KOMP)=TEXT(2:21)
        LVNAMEI(KOMP)=TEXT(2:21)
        LVNAMEJ(KOMP)=TEXT(24:43)
        SOURCE(KOMP)=TEXT(46:65)
        CALL LJUST(ABNAME(KOMP))
        READ(IREAT,*) IONL(KOMP),CHIL(KOMP),G2L(KOMP)
        CALL ELMCMP(KOMP)
      ELSE
        ABNAME(KOMP)=TEXT(1:20)
        LVNAMEJ(KOMP)='H CONT'
        SOURCE(KOMP)=TEXT(21:40)
      ENDIF
      LVNAMEI(KOMP)=ABNAME(KOMP)
C*90-11-08 END OF MODIFICATION
      WRITE(F102,102) INLATB
      READ(IREAT,F102)ILOGL,KVADL,MINEX,MAXEX,NLATB
      IF(NLATB.GT.MLATB) CALL STOP('INABS: NLATB.GT.MLATB')
      READ(IREAT,103)(XLATB(J),J=1,NLATB)
C
C        WE FIND THE DISCONTINUITIES IN WAVELENGTH
C        A DISCONTINUITY IN A TABLE IS DEFINED BY TWO WAVELENGTH POINTS
C        WITHIN LESS THAN TWO ANGSTROEMS.
      IDISK=0
      IDISKV(1)=0
      DO700 J=2,NLATB
      IDISKV(J)=0
      IF((XLATB(J)-XLATB(J-1)).GE.2.)GO TO 700
      IDISKV(J-1)=1
      IDISKV(J)=1
      IDISK=1
  700 CONTINUE
C
C        CONTINUE READING
      READ(IREAT,F102)ILOGT,KVADT(KOMP),MINET(KOMP),MAXET(KOMP),NTETB,
     * ITETA(KOMP)
      IF(NTETB.GT.MTETB) CALL STOP('INABS: NTETB.GT.MTETB')
      ILOGTA(KOMP)=ILOGT
      IF(NTETB.GT.1)GO TO 702
  701 KOMPR=KOMPR+1
      GO TO 703
  702 READ(IREAT,103)(XTET(L),L=1,NTETB)
C
C        FINALLY THE ABSORPTION COEFFICIENT TABLE IS READ
  703 DO 704 K=1,NTETB
  704 READ(IREAT,104)(XKAP(JJ,K),JJ=1,NLATB)
C
C        WE TAKE THE LOGARITHMS BEFORE THE WAVELENGTH INTERPOLATION
C        IF ILOGL IS GREATER THAN ZERO.
      IF(ILOGL.LT.1)GO TO 712
  710 DO 711 K=1,NTETB
      DO 711 JJ=1,NLATB
      IF(XKAP(JJ,K).GT.0.)GO TO 711
C
C        A COEFFICIENT FOR WHICH THE LOGARITHM SHOULD BE TAKEN IS ZERO
C      WRITE(IWRIT,207)KOMP,JJ,K,XKAP(JJ,K),SMALL
      XKAP(JJ,K)=SMALL
  711 XKAP(JJ,K)=LOG(XKAP(JJ,K))
  712 CONTINUE
C
C        PREPARATION OF THE T-INTERPOLATION IN SUBROUTINE TABS
C
C        WE FIND OUT WHETHER ISVIT(KOMP) CAN BE CHOSEN GREATER THAN ZERO. THIS
C        IS THE CASE IF THE T SCALE AND MAXET, MINET AND KVADT ARE IDENTICAL
C        WITH THOSE OF THE PREVIOUS COMPONENT. IF ISVIT IS GREATER THAN ZERO,
C        THE TIME SPENT IN SUBR. TABS WILL BE DECREASED.
      ISVIT(KOMP)=0
      IF(NTETB.LE.1)GO TO 719
      DO 721 L=1,NTETB
      IF(XTET(L).NE.XTETP(L))GO TO 722
  721 CONTINUE
      IF(NTETB.NE.NTETBP)GO TO 722
      IF(MAXET(KOMP).NE.MAXETP) GO TO 722
      IF(MINET(KOMP).NE.MINETP) GO TO 722
      IF(KVADT(KOMP).NE.KVADTP)GO TO 722
      ISVIT(KOMP)=1
  722 CONTINUE
C
C        WE REMEMBER TEMPERATURES ETC. FOR NEXT COMPONENT
      DO723 L=1,NTETB
  723 XTETP(L)=XTET(L)
      NTETBP=NTETB
      MAXETP=MAXET(KOMP)
      MINETP=MINET(KOMP)
      KVADTP=KVADT(KOMP)
C
C        WE FIND THE INTERVALS IN THE T (TETA) SCALE
      TBOT(KOMP,1)=XTET(1)
      DELT(KOMP,1)=XTET(2)-XTET(1)
      NTM(KOMP,1)=1
      IDEL(KOMP)=1
      IF(NTETB.EQ.2)GO TO 719
C
      J=1
      LF=1
      DO714 L=3,NTETB
      DIFF=XTET(L)-XTET(L-1)
      IF(ABS(1.-DIFF/DELT(KOMP,J)).LT.1.E-4)GO TO 714
      J=J+1
      IF(J.GT.IELMAX)GO TO 715
      TBOT(KOMP,J)=XTET(L-1)
      DELT(KOMP,J)=DIFF
      NTM(KOMP,J-1)=LF
      LF=0
  714 LF=LF+1
      NTM(KOMP,J)=LF
      IDEL(KOMP)=J
      GO TO 719
C        TOO MANY DIFFERENT INTERVALS IN THE T-TABLE FOR THIS COMPONENT
  715 WRITE(IWRIT,203)KOMP,IELMAX
      WRITE(IWRIT,206)(XTET(L),L=1,NTETB)
      STOP
C
  719 NTAET(KOMP)=NTETB
C        **** PRINT-OUT ****
      IF(IOUTS.LE.0)GO TO 7
      WRITE(IWRIT,211)KOMP,ABNAME(KOMP),SOURCE(KOMP)
      WRITE(IWRIT,212)
      WRITE(IWRIT,213)XLATB(1),XLATB(NLATB)
      IF(MINEX.EQ.0)WRITE(IWRIT,214)
      IF(MINEX.GT.0)WRITE(IWRIT,215)
      IF(KVADL.EQ.0)WRITE(IWRIT,216)
      IF(KVADL.GT.0)WRITE(IWRIT,217)
      IF(ILOGL.EQ.0)WRITE(IWRIT,218)
      IF(ILOGL.GT.0)WRITE(IWRIT,219)
      IF(MAXEX.EQ.0)WRITE(IWRIT,220)
      IF(MAXEX.GT.0)WRITE(IWRIT,221)
      IF(IDISK.GT.0)WRITE(IWRIT,222)
      IF(NTETB-1)8,8,9
    8 WRITE(IWRIT,230)
      GO TO 7
    9 CONTINUE
      WRITE(IWRIT,223)
      WRITE(IWRIT,213)XTET(1),XTET(NTETB)
      IF(MINET(KOMP).EQ.0)WRITE(IWRIT,214)
      IF(MINET(KOMP).GT.0)WRITE(IWRIT,215)
      IF(KVADT(KOMP).EQ.0)WRITE(IWRIT,216)
      IF(KVADT(KOMP).GT.0)WRITE(IWRIT,217)
      IF(ILOGTA(KOMP).EQ.0)WRITE(IWRIT,218)
      IF(ILOGTA(KOMP).GT.0)WRITE(IWRIT,219)
      IF(MAXET(KOMP).EQ.0)WRITE(IWRIT,220)
      IF(MAXET(KOMP).GT.0)WRITE(IWRIT,221)
      IF(ISVIT(KOMP).GT.0)WRITE(IWRIT,224)
      WRITE(IWRIT,231)
    7 CONTINUE
C
C        WE BUILD THE ABKOF ARRAY. INTERPOLATION IN WAVELENGTH.
C
      JI=1
      LAMBI=1
C
C        LOOP OVER WAVELENGTHS ('THE J-LOOP') STARTS
      DO60 J=1,NLB
C*    BUG FIX (BG 950331):
C*    LAMBI=1
C        SEARCHING IN WAVELENGTH
      IU=NLB*(KOMP-1)+J
      KOMPLA(IU)=INDEX
      DO24 JJ=1,NLATB
      IHELP=JJ
      IF(XLA(J)-XLATB(JJ))25,24,24
   24 LAMBI=JJ
   25 CONTINUE
      IF(IHELP-1)45,45,26
   26 IF(KVADL)33,33,27
   33 IF(NLATB-LAMBI-1)41,31,31
   27 IF(NLATB-LAMBI-1)41,28,29
C
C        QUADRATIC INTERPOLATION
   28 LAMBI=LAMBI-1
   29 CONTINUE
C        ARE DISCONTINUITIES PRESENT
      IF(IDISK.LE.0)GO TO 299
      IF(IDISKV(LAMBI+1).LE.0)GO TO 299
      IF(XLA(J).GT.XLATB(LAMBI+1))GO TO 292
  291 IF(IDISKV(LAMBI).GT.0)GO TO 31
      IF(LAMBI.EQ.1)GO TO 31
      LAMBI=LAMBI-1
      GO TO 299
  292 LAMBI=LAMBI+1
      IF(IDISKV(LAMBI+1).GT.0)GO TO 31
      IF(LAMBI+1.EQ.NLATB)GO TO 31
  299 CONTINUE
      DXX1=XLA(J)-XLATB(LAMBI)
      DXX2=XLA(J)-XLATB(LAMBI+1)
      DXX3=XLA(J)-XLATB(LAMBI+2)
      DX21=XLATB(LAMBI+1)-XLATB(LAMBI)
      DX32=XLATB(LAMBI+2)-XLATB(LAMBI+1)
      DX31=XLATB(LAMBI+2)-XLATB(LAMBI)
      A1=DXX2*DXX3/(DX21*DX31)
      A2=DXX1*DXX3/(DX21*DX32)
      A3=DXX1*DXX2/(DX31*DX32)
C
      DO30 K=1,NTETB
      ABKOF(INDEX)=A1*XKAP(LAMBI,K)-A2*XKAP(LAMBI+1,K)+A3*XKAP(LAMBI+2,K
     *)
   30 INDEX=INDEX+1
      GO TO 59
C
C        LINEAR INTER- AND EXTRAPOLATION
   31 A2=(XLA(J)-XLATB(LAMBI))/(XLATB(LAMBI+1)-XLATB(LAMBI))
      A1=1.-A2
      DO32 K=1,NTETB
      ABKOF(INDEX)=A1*XKAP(LAMBI,K)+A2*XKAP(LAMBI+1,K)
   32 INDEX=INDEX+1
      GO TO 59
C
C        TOO GREAT A WAVELENGTH - OUTSIDE THE TABLE
   41 IF(MAXEX)50,50,42
   42 LAMBI=LAMBI-1
      IF(NEXTL.GT.0)WRITE(IWRIT,201) KOMP,XLA(J)
      GO TO 31
C
C        TOO SMALL A WAVELENGTH - OUTSIDE THE TABLE
   45 IF(MINEX)50,50,46
   46 IF(NEXTL.GT.0)WRITE(IWRIT,201)KOMP,XLA(J)
      GO TO 31
C
C        ABS. COEFF. IS PUT = ZERO
   50 KOMPLA(IU)=0
      IF(NUTZL.GT.0)WRITE(IWRIT,202)KOMP,XLA(J)
      GO TO 60
C
   59 IF(ILOGL.LT.1)GO TO 592
      IF(ILOGT.GT.0)GO TO 60
C
C        LOGARITHMIC INTERPOLATION ONLY IN WAVELENGTH
      LIP=INDEX-NTETB
      LAP=INDEX-1
      DO 591 LL=LIP,LAP
  591 ABKOF(LL)=EXP(ABKOF(LL))
C
  592 CONTINUE
C
      IF(ILOGT.LE.0)GO TO 60
C        WE TAKE THE LOGARITHM BEFORE THE T INTERPOLATION IF ILOGT GT 0
      LIP=INDEX-NTETB
      LAP=INDEX-1
      DO593 LL=LIP,LAP
      IF(ABKOF(LL).GT.0.)GO TO 593
C
C        IMPOSSIBLE TO TAKE THE LOGARITHM OF A NEGATIVE COEFFICIENT
      LUS=LL-LIP+1
      WRITE(IWRIT,208)LL,ABKOF(LL),KOMP,J,ISET,LUS,SMALL
      ABKOF(LL)=SMALL
  593 ABKOF(LL)=LOG(ABKOF(LL))
   60 CONTINUE
  720 CONTINUE
C        END OF 'THE J-LOOP'
C        END OF 'THE SECOND KOMP-LOOP'
C
      KOMPS=KOMPR+1
      NABKOF=INDEX-1
      NKOMPL=IU
C        CHECK DIMENSION OF ABKOF
      IF(IOUTS.GT.0) WRITE(IWRIT,204)NABKOF,ISET
      IF(NABKOF.LE.NABDIM)GO TO 70
C        TOO SMALL DIMENSION FOR ABKOF
      WRITE(IWRIT,205)NABDIM,nabkof
      CALL STOP('INABS: NABKOF.GT.NABDIM (SEE OUT FILE FOR VALUES)')
   70 CONTINUE
C
C        END OF 'THE ISET-LOOP'
C
C
C*  
C*  89-03-11  MODIFICATIONS (PHILIP JUDGE)
C*  CLOSE THE ABSDAT FILE:
C* 
      CALL CLOSE(IREAT)
C*
C*  89-03-11  END MODIFICATIONS (PHILIP JUDGE)
C*
      IF(IOUTS.LE.0) GOTO 74
C
C        **** PRINT-OUT ****
C        ON WAVELENGTH SETS AND FILES
      WRITE(IWRIT,225)IREAT
      WRITE(IWRIT,226)
      DO73 M=1,NSET
      NP=NL(M)
      WRITE(IWRIT,228)(XL(J,M),J=1,NP)
   73 CONTINUE
   74 CONTINUE
      WRITE(IWRIT,232)
  101 FORMAT(7X,I3,5(9X,I1))
  102 FORMAT('(4(9X,I1),8X,I',I2,',9X,I1)')
  103 FORMAT(6F10.0)
  104 FORMAT(6E10.3)
  105 FORMAT(2A)
  201 FORMAT(' EXTRAPOLATION FOR COMPONENT',I5,5X,'AND WAVELENGTH=',F10.
     *3,5X,'***INABS***')
  202 FORMAT(' ABS.COEFF. PUT =0 AT WAVELENGTH-INTER/EXTRAPOLATION FOR
     *COMPONENT',I5,5X,'AND WAVELENGTH=',F10.3,5X,'***INABS***')
  203 FORMAT(' TOO MANY DIFFERENT INTERVALS IN THE T-(TETA-)TABLE FOR CO
     *MPONENT ',I5,5X,'MAX IS',I5,5X,'***INABS***')
  204 FORMAT(' NECESSARY DIMENSION FOR ABKOF=',I5,5X,'IN SET',I5,5X,'***
     *INABS***')
  205 FORMAT(' DIMENSION ALLOWED =',I7,5X,'TOO SMALL     ***INABS***',
     ,   'wanted is ',i9)
  206 FORMAT(6H XTET=,10E12.4)
  207 FORMAT(' INABS: KOMP=',I3,' XKAP(',I2,',',I2,')=',E12.5,' PUT = ',
     * 1P,E7.0,' BEFORE LOG HAS BEEN TAKEN.')
  208 FORMAT(' ABKOF(',I4,')=',E12.5,' FOR COMPONENT ',I3,' WAVELENGTH',
     *I3,' SET ',I2,' XTET NR ',I2,' ABKOF PUT=',1P,E17.0,'***INABS***')
  211 FORMAT('0**********  COMPONENT NO',I3,', ',A,' SOURCE  ',A,'
     ***********')
  212 FORMAT('0     I N T E R P O L A T I O N  I N  W A V E L E N G T H'
     *)
  213 FORMAT(1H ,15X,F10.2,25X,F10.2)
  214 FORMAT(1H+,'   KAPPA=0   - ')
  215 FORMAT(1H+,' LIN. EXTRAP.- ')
  216 FORMAT(1H+,25X,' -LIN. INT. ')
  217 FORMAT(1H+,25X,' -QUAD. INT.')
  218 FORMAT(1H+,37X,'  KAPPA    - ')
  219 FORMAT(1H+,37X,' LOG(KAPPA)- ')
  220 FORMAT(1H+,60X,' -   KAPPA=0')
  221 FORMAT(1H+,60X,' -LIN. EXTRAP.')
  222 FORMAT(1H0,' DISCONTINUITIES PRESENT.')
  223 FORMAT('0     I N T E R P O L A T I O N  I N  T  ( T E T A )')
  224 FORMAT('0 T SCALE ETC. IDENTICAL WITH PRECEEDING COMPONENT')
  225 FORMAT(1H0,'F I L E S  U S E D  B Y  T H E  A B S - B L O C K'//'
     * INITIAL FILE ',I3,', PRELIMINARY FILE',I3)
  226 FORMAT(1H0,'SET           WAVELENGTHS',81X,'FILE')
  227 FORMAT (1H ,I2,105X,I2)
  228 FORMAT(1H ,5X,10F10.2)
  229 FORMAT(1H1,'D A T A  F R O M  S U B R O U T I N E  I N A B S')
  230 FORMAT(1H0,'     N O  T-  ( T E T A - ) D E P E N D E N C E')
  231 FORMAT(1H0)
  232 FORMAT(1H1)
      RETURN
      END
C
C **************************************************************************
C
      SUBROUTINE ELMCMP(KOMP)
C
C  FINDS ELEMENT NUMBER CORRESPONDING TO ABSORPTION COMPONENT
C  ABNAME(KOMP). THIS IS DONE BY COMPARING THE FIRST TWO LETTERS
C  IN ABNAME WITH THE ARRAY CEL READ BY INJON
C
C  1987-05-21  MATS CARLSSON
C:
C: ELMCMP 90-11-08  MODIFICATIONS: (MATS CARLSSON)
C:        ABNAME CHANGED TO NOT INCLUDE LEADING /
C:
C:        92-07-20  MODIFICATIONS (MATS CARLSSON)
C:        INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAMO'
C
      COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4),
     *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL
      CHARACTER*3 CEL
      COMMON/CC1/CEL(MEL)
C
      CHARACTER*20 ABNAME,LVNAMEI,LVNAMEJ
      COMMON/CNAME/ ABNAME(MKOMP),LVNAMEI(MKOMP),LVNAMEJ(MKOMP)
C
      COMMON/CLEVD/ IONL(MKOMP),CHIL(MKOMP),G2L(MKOMP),IELL(MKOMP)
C
      COMMON /CLU/ LINPUT,LATOM,LATOM2,LATMOS,LDSCAL,LABUND,LOUT,
     * LTIME,LRSTRT,LDSCA2,LWMAT,LNIIT,LDUMS,LDUMI,LDUMC,LOPC,
     * LJNY,LINIT,LPHI,LJOBLO,LATHSE
C
      CHARACTER*20 TEXT
C
      TEXT=ABNAME(KOMP)
      CALL LJUST(TEXT)
      DO 200 I=1,NEL
        IF(TEXT(1:2).EQ.CEL(I)(1:2)) GOTO 300
  200 CONTINUE
      WRITE(LJOBLO,210) TEXT(1:2)
  210 FORMAT(' ELMCMP: ELEMENT ',A,' NOT FOUND')
      CALL STOP(' ')
C
  300 CONTINUE

      IELL(KOMP)=I
C
      END
C
C **************************************************************************
C
      SUBROUTINE ABSKO(NEWT,NT,TSKAL,PESKAL,ISETA,J,ABSK,SPRID)
C
C        THE ROUTINE ADMINISTERS THE COMPUTATION OF ABSORPTION
C        COEFFICIENTS. IT CALLS THE ROUTINES, GIVING THE PROPER THERMO-
C        DYNAMIC INFORMATION ( J O N ) , THE DETAILS OF THE ABSORPTION
C        MECHANISMS ( D E T A B S ) AND THE FACTORS FOR THE INTERPOLATION
C        IN T  ( T A B S ) . IT CHOOSES (IF NECESSARY READS) THE RIGHT SET
C        OF ABSORPTION-COEFFICIENT DATA (ISETA), STATEMENT NO. 5 AND MAKES
C        THE INTERPOLATION IN T, STATEMENTS NOS. 10-18, AND THE SUMMATION
C        OF A ROSSELAND MEAN, IF INDICATED BY J = 0, STATEMENTS NOS. 25-28.
C
C        NEWT SHOULD BE GT 1 THE FIRST TIME THIS ROUTINE IS USED,
C                       EQ 1 WHEN A NEW SET OF T-PE IS USED,
C                       EQ 0 OTHERWISE.
C
C        NT IS THE NUMBER OF T-PE POINTS. THE TEMPERATURES T SHOULD BE EX-
C        PRESSED IN DEGREES KELVIN, THE ELECTRON PRESSURES PE IN DYNES PER CM2.
C        ISETA IS THE WAVELENGTH-SET NUMBER, J THE WAVELENGTH NUMBER IN THAT
C        SET. J EQUAL TO ZERO INDICATES THAT A ROSSELAND MEAN IS WANTED.
C        THIS MEAN IS COMPUTED USING THE WAVELENGTH POINTS OF THE ACTUAL
C        SET (ISETA) AND THE QUADRATURE WEIGHTS GIVEN IN ROSW.
C        IN ABSK AND SPRID THE ABSORPTION AND SCATTERING COEFFICIENTS PER GRAM
C        OF STELLAR MATTER ARE STORED.
C
C        DIMENSIONS NECESSARY
C        AB(NKOMP),ABSK(1),FAKT(NKOMP),FAKTP(5000),NTPO(NTO),PE(NT),PESKAL(1),
C        ROSW(MAX(NL)),SPRID(1),SUMW(NT),T(NT),TSKAL(1),XLA(MAX(NL)),
C        XLA3(MAX(NL))
C        THE DIMENSIONS ARE LOWER LIMITS.
C        DIMENSIONS OF ARRAYS IN COMMONS /CA2/,/CA3/ AND /CFIL/ ARE COMMENTED
C        ON IN SUBROUTINE INABS, THOSE OF ARRAYS IN COMMON /CA4/ IN SUBROUTINE
C        TABS.
C        NKOMP IS THE NUMBER OF 'COMPONENTS'
C        NL(I) IS THE NUMBER OF WAVELENGTHS IN WAVELENGTH SET I
C        NT IS THE NUMBER OF T-PE POINTS SUPPLIED IN TSKAL AND PESKAL
C        NTO IS THE NUMBER OF POINTS IN THOSE SCALES FOR WHICH A DETAILED
C              PRINT-OUT IS WANTED.
C
C:
C: ABSKO  87-05-30  MODIFICATIONS: (MATS CARLSSON)
C:        NTP IS INCLUDED IN THE ARGUMENT-LIST TO JON TO MAKE NON-LTE
C:        INCLUSION AND INTERFACE TO MULTI PROGRAM EASIER
C:
C:        92-11-27  MODIFICATIONS: (MATS CARLSSON)
C:        SAVE STATEMENT ADDED
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAMO'
      DIMENSION TSKAL(NT),PESKAL(NT),ABSK(NT),SPRID(NT)
      DIMENSION FAKTP(MKOMPT*MT)
      DIMENSION SUMW(MT)
C
      COMMON/UTPUT/ IREAD, IWRIT
C
      COMMON/CA2/ABKOF(NABDIM),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP,NABKOF
C
      COMMON/CA3/ILOGTA(MKOMP),NULL
C
      COMMON/CA4/AFAK(KFADIM),NOFAK(IFADIM),NPLATS(IFADIM)
C
      COMMON/CA5/AB(MKOMP),FAKT(MKOMP),PE(MT),T(MT),XLA(ML),XLA3(ML),RO,
     *SUMABS,SUMSCA,VIKTR,ISET,NLB
C
      COMMON/CFIL/IREAT,INLATB
C
      COMMON/COUTR/ NTO,NTPO(MT),IWOPTN
C
      COMMON/CROS/ROSW(ML)
C
      SAVE
C
      ISET=ISETA
      IF(NEWT.GT.1)ISETP=-1
      IF(NEWT.EQ.0)GO TO 6
C
C        FACTORS ONLY DEPENDENT ON T-PE
C
      CALL TABS(NT,TSKAL)
      IFAK=1
      KFAK=1
      JP=0
      KP=1
C
C        LOOP OVER THE T-PE POINTS ('THE FIRST NTP-LOOP')
      DO4 NTP=1,NT
      T(NTP)=TSKAL(NTP)
      PE(NTP)=PESKAL(NTP)
C        IS PRINT-OUT WANTED FOR T-PE POINT NO. NTP
      IOUTR=0
      IF(KP.GT.NTO)GO TO 3
      IF(NTP.EQ.NTPO(KP))GO TO 1
      GO TO 3
    1 IOUTR=1
      KP=KP+1
    3 CONTINUE
C
      CALL JON(NTP,T(NTP),PE(NTP),1,PG,RO,DUM,IOUTR)
      CALL DETABS(J,0,NTP,IOUTR)
C
C        WE STORE THE FAKT ARRAY, MADE IN JON-DETABS IN LONGER ARRAYS NAMELY
C                  IN AFAK FOR TEMPERATURE-INDEPENDENT COMPONENTS
C                  IN FAKTP FOR TEMPERATURE-DEPENDENT ONES
      DO2 KOMP=1,KOMPR
      AFAK(KFAK)=FAKT(KOMP)
    2 KFAK=KFAK+1
      DO4 KOMP=KOMPS,NKOMP
c      print*,IFAK,KOMP,KOMPS,KOMPR
      FAKTP(IFAK)=FAKT(KOMP)
      KFAK=KFAK+NOFAK(IFAK)
    4 IFAK=IFAK+1
C        END OF 'THE FIRST NTP-LOOP'
C
C        ROSSELAND MEAN OR NOT
    6 IF(J.GT.0)GO TO 9
    7 J1=1
      J2=NLB
      DO8 NTP=1,NT
      SUMW(NTP)=0.
    8 ABSK(NTP)=0.
      GO TO 10
    9 J1=J
      J2=J
C
C        INTERPOLATION IN T
C        LOOP OVER ALL THE WAVELENGTHS IN A POSSIBLE ROSSELAND MEAN. THIS
C        LOOP ENDS IN STATEMENT NO. 26
   10 DO26 JP=J1,J2
      KFAK=1
      IFAK=1
      KP=1
C
C        LOOP OVER THE T-PE POINTS ('THE SECOND NTP-LOOP')
      DO26 NTP=1,NT
C
C        IS PRINT-OUT WANTED FOR T-PE POINT NO. NTP
      IOUTR=0
      IF(KP.GT.NTO)GO TO 93
      IF(NTP.EQ.NTPO(KP))GO TO 92
      GO TO 93
   92 IOUTR=1
      KP=KP+1
      IF(KP.EQ.2)IOUTR=2
   93 CONTINUE
      IU=JP
C
C        COMPONENTS WITH ABSORPTION COEFFICIENTS INDEPENDENT OF THE
C        TEMPERATURE
C
      DO14 KOMP=1,KOMPR
      IF(KOMPLA(IU).LE.0)GO TO 12
C        THE VECTOR KOMPLA IS DETERMINED IN SUBROUTINE INABS.
C        KOMPLA GREATER THAN ZERO GIVES THE INDEX IN ABKOF, WHERE THE TABLE FOR
C        THIS COMPONENT AND WAVELENGTH BEGINS.
C        KOMPLA LESS THAN OR EQUAL TO ZERO INDICATES THAT THE ACTUAL ABSORPTION
C        COEFFICIENT FOR THIS COMPONENT AND WAVELENGTH IS ZERO, AS FOUND IN SUB-
C        ROUTINE INABS.
C
   11 INDEX=KOMPLA(IU)
      AB(KOMP)=AFAK(KFAK)*ABKOF(INDEX)
      GO TO 13
   12 AB(KOMP)=0.
   13 KFAK=KFAK+1
   14 IU=IU+NLB
C
C        COMPONENTS WITH T-DEPENDENT ABSORPTION COEFFICIENTS
      DO19 KOMP=KOMPS,NKOMP
      NOP=NOFAK(IFAK)
      IF(NOP.EQ.0)GO TO 17
      IF(KOMPLA(IU).LE.0)GO TO 17
   15 INDEX=NPLATS(IFAK)-1+KOMPLA(IU)
C        THE VECTOR NPLATS IS DETERMINED BY SUBROUTINE TABS. IT GIVES THE ARRAY
C        INDEX OF THE TEMPERATURE AT WHICH THE INTERPOLATION IN ABKOF
C        BEGINS. NOFAK, GIVING INFORMATION ON THE T-INTERPOLATION AND
C        POSSIBLY INDICATING THAT AB=0 (NOFAK=0) IS ALSO DETERMINED BY TABS.
C
C        INTERPOLATION
      DELSUM=0.
      DO16 NP=1,NOP
      DELSUM=DELSUM+AFAK(KFAK)*ABKOF(INDEX)
      KFAK=KFAK+1
   16 INDEX=INDEX+1
C
C        HAS THE INTERPOLATION BEEN MADE ON THE LOGARITHM
      IF(ILOGTA(KOMP).GT.0)DELSUM=EXP(DELSUM)
C        MULTIPLICATION BY FACTOR FROM JON-DETABS
      DELSUM=DELSUM*FAKTP(IFAK)
      IF(DELSUM.GE.0)GO TO 162
C
C        A NEGATIVE INTERPOLATION RESULT
  161 IF(NULL.GT.0)WRITE(IWRIT,200)KOMP,DELSUM,JP,ISET,T(NTP)
  200 FORMAT(4H AB(,I4,11H) NEGATIVE=,E12.4,5X,17HFOR WAVELENGTH NO,I5,
     *5X,6HSET NO,I5,5X,2HT=,F10.4,'  AND THEREFORE PUT =0 ***ABSKO***')
      AB(KOMP)=0.
      GO TO 18
  162 AB(KOMP)=DELSUM
      GO TO 18
   17 AB(KOMP)=0.
      KFAK=KFAK+NOP
   18 IU=IU+NLB
   19 IFAK=IFAK+1
C
C        WE MULTIPLY BY WAVELENGTH-DEPENDENT  FACTORS AND ADD UP. THIS IS
C        DONE IN DETABS.
      CALL DETABS(J,JP,NTP,IOUTR)
C
      IF(J.LE.0)GO TO 25
   24 ABSK(NTP)=SUMABS
      SPRID(NTP)=SUMSCA
      GO TO 26
C
C        SUMMATION TO GET A ROSSELAND MEAN
   25 ABSK(NTP)=ABSK(NTP)+ROSW(JP)/(VIKTR*(SUMABS+SUMSCA))
      SUMW(NTP)=SUMW(NTP)+ROSW(JP) /VIKTR
   26 CONTINUE
C
C        END OF 'THE SECOND NTP-LOOP'
C
      IF(J.GT.0)GO TO 29
   27 DO28 NTP=1,NT
      SPRID(NTP)=0.
   28 ABSK(NTP)=SUMW(NTP)/ABSK(NTP)
C
   29 CONTINUE
      RETURN
      END
C
C ***************************************************************************
C
      SUBROUTINE TABS(NT,T)
C
C        THIS ROUTINE COMPUTES  FACTORS FOR INTERPOLATION IN T (TETA IF
C        ITETA(KOMP) IS GREATER THAN ZERO) IN THE ABKOF TABLE, INITIATED BY
C        SUBROUTINE INABS. CONCERNING THE OTHER CONTROL INTEGERS, SEE INABS.
C        THE RESULTING FACTORS ARE PUT IN AFAK. THE NUMBER OF FACTORS FOR
C        THE COMPONENT KOMP AT TEMPERATURE T(NTP) IS GIVEN IN
C        NOFAK((NKOMP-KOMPR)*(NTP-1)+KOMP-KOMPR). HERE KOMPR IS THE NUMBER
C        OF COMPONENTS WITH T-INDEP. COEFFICIENTS. NOFAK=0 MEANS THAT THE
C        ABSORPTION COEFFICIENT SHOULD BE =0. NPLATS (INDEX AS FOR NOFAK)
C        GIVES THE ARRAY INDEX OF THE TEMPERATURE POINT AT WHICH THE
C        INTERPOLATION IN ABKOF SHOULD START.
C
C        NT=NUMBER OF TEMPERATURES
C        T= ARRAY OF TEMPERATURES
C
C        DIMENSIONS NECESSARY
C        AFAK(KFADIM),NOFAK(IFADIM),NPLATS(IFADIM),T(1)
C        THE DIMENSIONS ARE LOWER LIMITS. DIMENSIONS OF ARRAYS IN COMMONS /CA1/
C        AND /CA2/ ARE COMMENTED ON IN SUBROUTINE INABS.
C        IFADIM SHOULD BE AT LEAST =(NKOMP-KOMPR)*NT, WHERE NKOMP IS THE NUMBER
C               OF COMPONENTS, KOMPR THE NUMBER OF TEMPERATURE-INDEPENDENT
C               COMPONENTS AND NT THE NUMBER OF TEMPERATURE POINTS (IN THE PARA
C               METER LIST).
C        KFADIM SHOULD BE AT LEAST =KOMPR*NT+(NKOMP-KOMPR)*NT*NUM, WHERE NUM IS
C               BETWEEN 2 AND 3 AND DEPENDENT ON THE TYPE OF TEMPERATURE
C               INTERPOLATION USED.
C
C
      INCLUDE 'PREC'
      INCLUDE 'PARAMO'
      DIMENSION T(NT)
C
      COMMON/UTPUT/ IREAD, IWRIT
C
      COMMON/CA1/DELT(MKOMP,MELMAX),TBOT(MKOMP,MELMAX),IDEL(MKOMP),
     * ISVIT(MKOMP),ITETA(MKOMP),KVADT(MKOMP),MAXET(MKOMP),
     * MINET(MKOMP),NTM(MKOMP,MELMAX),NEXTT,NUTZT
C
      COMMON/CA2/ABKOF(NABDIM),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP,NABKOF
C
      COMMON/CA4/AFAK(KFADIM),NOFAK(IFADIM),NPLATS(IFADIM)
C
C      IFADIM=500
C      KFADIM=4500000
      IFAK=1
      KFAK=1
      NSVIT=1
C        THIS IS JUST A DUMMY STATEMENT TO GIVE NSVIT A FORMAL VALUE
C
      DO81 NTP=1,NT
      TP=T(NTP)
      KFAK=KFAK+KOMPR
      DO81 KOMP=KOMPS,NKOMP
      IF(ISVIT(KOMP).GT.0)GO TO (51,61,70),NSVIT
      IF(ITETA(KOMP).LE.0)GO TO 2
    1 TS=5040./T(NTP)
      GO TO 3
    2 TS=T(NTP)
C
C        SEARCHING
    3 IF((TS-TBOT(KOMP,1)).GE.0.)GO TO 10
      IF(MINET(KOMP).LE.0)GO TO 70
C
C        EXTRAPOLATION DOWNWARDS
      IF(NEXTT.GT.0)WRITE(IWRIT,200)TS,KOMP
      INTA=1
      AP=(TS-TBOT(KOMP,1))/DELT(KOMP,1)
      IP=0
      GO TO 60
C
C        SEARCHING CONTINUES
   10 INTAP=1
      IDP=IDEL(KOMP)
      DO11 I=1,IDP
      AP=(TS-TBOT(KOMP,I))/DELT(KOMP,I)
      IP=INT(AP)
      INTA=IP+INTAP
      INAP=NTM(KOMP,I)-1+INTAP
      IF(INTA.LE.INAP) GO TO 20
   11 INTAP=INAP+1
      IF(MAXET(KOMP).LE.0)GO TO 70
C
C        EXTRAPOLATION DOWNWARDS
      IF(NEXTT.GT.0)WRITE(IWRIT,200)TS,KOMP
      INTA=INAP
      IP=NTM(KOMP,IDP)-1
      GO TO 60
C
   20 IF(KVADT(KOMP).LE.0)GO TO 60
C
C        QUADRATIC INTERPOLATION
   21 IF(INTA.LT.INAP)GO TO 50
      INTA=INTA-1
      IP=IP-1
C
   50 DXX1=AP-FLOAT(IP)
      DXX2=DXX1-1.
      DXX3=DXX1-2.
      A1=DXX2*DXX3*0.5
      A2=-DXX1*DXX3
      A3=DXX1*DXX2*0.5
   51 AFAK(KFAK)=A1
      AFAK(KFAK+1)=A2
      AFAK(KFAK+2)=A3
      NPLATS(IFAK)=INTA
      NOFAK(IFAK)=3
      IFAK=IFAK+1
      KFAK=KFAK+3
      NSVIT=1
      GO TO 80
C
C        LINEAR INTER/EXTRAPOLATION
   60 A2=AP-FLOAT(IP)
      A1=1.-A2
   61 AFAK(KFAK)=A1
      AFAK(KFAK+1)=A2
      NPLATS(IFAK)=INTA
      NOFAK(IFAK)=2
      IFAK=IFAK+1
      KFAK=KFAK+2
      NSVIT=2
      GO TO 80
C
C        OUTSIDE TABLE. ABS.COEFF. SHOULD BE = 0
   70 IF(NUTZT.GT.0)WRITE(IWRIT,201)TS,KOMP
      NOFAK(IFAK)=0
      IFAK=IFAK+1
      NSVIT=3
C
   80 CONTINUE
      IF(KFAK.GT.KFADIM)GO TO 90
      IF(IFAK.GT.IFADIM)GO TO 91
   81 CONTINUE
C
      GO TO 92
   90 WRITE(IWRIT,202)KFAK,KFADIM,NT
      STOP
   91 WRITE(IWRIT,203)IFAK,IFADIM,NT
      STOP
   92 CONTINUE
C
  200 FORMAT(33H EXTRAPOLATION IN TABS, T (TETA)=,E12.5,5X,12HCOMPONENT
     *NO,I5)
  201 FORMAT(24H ZERO IN TABS, T (TETA)=,E12.5,5X,12HCOMPONENT NO,I5)
  202 FORMAT(6H KFAK=,I5,5X,11H GT KFADIM=,I5,5X,12HIN TABS, NT=,I5)
  203 FORMAT(6H IFAK=,I5,5X,11H GT IFADIM=,I5,5X,12HIN TABS, NT=,I5)
      RETURN
      END
C
C **********************************************************************
C
      SUBROUTINE JON(NTP,T,PE,IEPRO,PG,RO,E,IOUTR)
C
C
C        THIS ROUTINE COMPUTES IONIZATION EQUILIBRIA FOR A GIVEN TEMPERATURE (T,
C        EXPRESSED IN DEGREES KELVIN) AND A GIVEN ELECTRON PRESSURE (PE, IN
C        DYNES PER CM2). THE FRACTIONS OF IONIZATION ARE PUT IN THE ANJON VECTOR
C        AND THE PARTITION FUNCTIONS ARE PUT IN PART. IF IEPRO IS GREATER THAN
C        ZERO, THE GAS PRESSURE (PG,IN DYNES PER CM2), DENSITY (RO, IN GRAMS
C        PER CM3) AND INNER ENERGY (E, IN ERGS PER GRAM) ARE ALSO EVALUATED.
C        N O T E . RADIATION PRESSURE IS NOT INCLUDED IN E.
C
C        THE ENERGIES OF IONIZATION ARE REDUCED BY DXI, FOLLOWING BASCHEK ET
C        AL., ABH. HAMB. VIII, 26 EQ. (10). THESE REDUCTIONS ARE ALSO MADE IN
C        THE COMPUTATION OF E.
C        THE ENERGY OF DISSOCIATION FOR H- HAS BEEN REDUCED BY 2*DXI, FOLLOWING
C        TARAFDAR AND VARDYA, THIRD HARV. SMITHS. CONF., PAGE 143. THE FORMATION
C        OF MOLECULES IS CONSIDERED FOR T LESS THAN TMOLIM.
C
C        IF IOUTR IS GREATER THAN ZERO, A DETAILED PRINT-OUT WILL BE GIVEN.
C
C
C        THE FUNCTION  QTRAV AND SUBROUTINE MOLEQ ARE CALLED.
C        THEY CALL QAS AND MOLFYS RESPECTIVELY.
C
C        DIMENSIONS NECESSARY
C        A(5),DQ(4),F(MAX(NJ)),PFAK(MAX(NJ)),RFAK(JMAX)
C        DIMENSIONS OF ARRAYS IN COMMONS /CI1/,/CI4/,/CI5/ AND /CI6/ ARE
C        COMMENTED ON IN SUBROUTINE INJON.
C        JMAX IS THE TOTAL NUMBER OF STAGES OF IONIZATION, INCLUDING NEUTRAL
C             ATOMS.
C        NJ(I) IS THE NUMBER OF STAGES OF IONIZATION, INCLUDING THE NEUTRAL
C             STAGE, FOR ELEMENT I.
C:
C: JON    87-05-30  MODIFICATIONS: (MATS CARLSSON)
C:        NTP IS INCLUDED IN THE ARGUMENT-LIST TO JON TO MAKE NON-LTE
C:        INCLUSION AND INTERFACE TO MULTI PROGRAM EASIER (ALSO
C:        AFFECTS ABSKO)
C:
C:        COMMON BLOCKS HYDCOM, CIN, CXNENH AND COPBID INCLUDED FOR
C:        COMMUNICATION WITH MULTI AND WITH DETABS
C:
C:        ACTUAL HYDROGEN POPULATIONS ADDED UP AND ''LTE'' POPULATIONS
C:        CALCULATED USING ACTUAL PROTON DENSITY AND SAHA RELATION
C:
C:        87-10-20  MODIFICATIONS: (MATS CARLSSON)
C:        NON-LTE OPTION FOR MOLECULES ADDED. NE/NHT IS THEN FIXED
C:
C:        88-01-18  MODIFICATIONS: (MATS CARLSSON)
C:        NON-LTE OPTION FOR IONIZATION FRACTIONS ADDED
C:
C:        88-01-30  MODIFICATIONS: (MATS CARLSSON)
C:        DOUBLE PRECISION USED WHEN CALCULATING THE IONIZATION 
C:        FRACTIONS TO AVOID OVERFLOW/UNDERFLOW AT HIGH TEMPERATURES
C:
C:        CALCULATION OF TOTAL NUMBER DENSITIES OF C, N, O, CH, CO, CN
C:        ADDED. THESE AND NH2 TRANSFERED IN COUT
C:
C:        88-04-23  MODIFICATIONS (PHILIP JUDGE)
C:        CORONAL APPROXIMATION CALCULATIONS USED FOR LOW GAS PRESSURES AND HIGH
C:        TEMPERATURES IN ORDER THAT INAPPROPRIATE ION FRACTIONS IN LTE ARE NOT
C:        USED
C:
C:        89-03-24  MODIFICATIONS (MATS CARLSSON)
C:        FORMATION OF MOLECULES WAS NOT TAKEN INTO ACCOUNT WHEN CALCULATING
C:        XNENH AND OPACITIES. THIS HAS BEEN CORRECTED. TOTAL NUMBER 
C:        ABUNDANCES OF ATOMS AFTER MOLECULE FORMATION HAS BEEN TAKEN INTO
C:        ACCOUNT ARE STORED IN NEW VARIABLE ABUNDM
C:
C:        PRINTOUT HAS BEEN CHANGED. IONIZATION FRACTIONS FOR HYDROGEN ARE
C:        NOW THE NON-LTE VALUES. ABUNDANCES ARE THE ABUNDANCES TAKING
C:        FORMATION OF MOLECULES INTO ACCOUNT
C:
C:        92-08-10  MODIFICATIONS (MATS CARLSSON)
C:        INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS
C:
C:        92-11-27  MODIFICATIONS: (MATS CARLSSON)
C:        SAVE STATEMENT ADDED
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAMO'
      DIMENSION DQ(4),F(MJ),PFAK(MJ),RFAK(MJMAX)
      DIMENSION PRESMO(13)
C
      COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4),
     *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL
      CHARACTER*3 CEL
      COMMON/CC1/CEL(MEL)
C
      COMMON/CI4/ IELEM(MEL),ION(MEL,MJ),TMOLIM,MOLH
C
      COMMON/CI5/ABUND(MEL),ANJON(MEL,MJ),H(5),PART(MEL,MJ),DXI,
     * F1,F2,F3,F4,F5,XKHM,XMH,XMY
C
      COMMON/CI6/TP,IQFIX(MEL,MJ),NQTEMP
C
      COMMON/CI7/A(5),PFISH,ITP
C
      COMMON/UTPUT/ IREAD, IWRIT
      COMMON/RABELL/XXRHO(40),XYRHO
C
      COMMON/CI8/YYPG,YYRHO,YYE
      COMMON/CMOL/PK(13),FH,FC,FN,FO,FE,FHE,FCE,FNE,FOE,EH
      COMMON/CARC3/F1P,F3P,F4P,F5P,HNIC,PRESMO
C*
C* MODIFICATIONS START
C
      COMMON/COUTR/ NTO,NTPO(MT),IWOPTN
      REAL(8) NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE
      COMMON/HYDCOM/NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE
C
      LOGICAL HLTE
      REAL(8) NHYD,NPIN
      COMMON/CIN/ NHYD(MT,5),NPIN(MT),HLTE
      COMMON /CXNENH/ XNENH
C
      COMMON /COPBID/ PGC(MT),ROC(MT),XMYC(MT),EJONC(MT),
     * XNENHC(MT),PROV(20,MT)
C
      COMMON/CBMET/ BMET(MT,MKOMP-23),BMETP(MT,MKOMP-23),
     *       FRCION(MEL,MJ,MT),ZNLTE(MEL,MJ,MT)
      COMMON/CBMET2/ ANMET(MT,MKOMP-23)
C
      COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT),
     * TOTCH(MT),TOTCO(MT),TOTCN(MT),
     * TOTC(MT),TOTNIT(MT),TOTO(MT),
     * BHYD(MT,5),GRPH,TOTOH(MT)

CCC  00-09-12 TOTOH ADDED

C*  89-03-24 START
      COMMON/CABNDM/ ABUNDM(MEL)
C*  89-03-24 END
C*
C*  89-03-07   MODIFICATION (PHILIP JUDGE)
C*             CORONAL IONIZATION DATA ADDED
      PARAMETER (MCOR=30)
      INTEGER NCOR,IONCOR(MCOR)
      DOUBLE PRECISION ARADC(MCOR),XRADC(MCOR),ADIC(MCOR),T0C(MCOR),
     * BDIC(MCOR),T1C(MCOR),ACOLC(MCOR),TCOLC(MCOR),TECOR,DECOR
      COMMON /CCORON/ TECOR,DECOR,
     * ARADC,XRADC,ADIC,T0C,BDIC,T1C,ACOLC,TCOLC,NCOR,IONCOR
      CHARACTER*3 CCOR
      COMMON /CCCOR/ CCOR(MCOR)
      INCLUDE 'CCONST'
C*  89-03-07   END 
C*             

C     
      REAL(8) NE
      DOUBLE PRECISION FIL
      REAL(8) NC,NN,NO,NCH,NCO,NCN,NOH
      LOGICAL MASKWR
C**
C** 88-04-16  PGJ ADDITION      
C** TEMPORARY VARIABLE TO STORE LTE IONIZATION FRACTIONS OF NON-LTE
C** ABSORBERS
C*  CHARACTER VARIABLES FOR PRINTOUT
      CHARACTER *10 CANJON(MJ),CPART(MJ)
      REAL(8) FTEMP(MT,MJ)
      SAVE
C** END PGJ ADDITION
C* MODIFICATIONS END
C*
C        STATEMENT FUNCTION FOR 10.**
      EXP10(X)=EXP(2.302585*X)
C
      ITP=1
C
C        IS T=THE TEMPERATURE OF THE PRECEDING CALL
      IF(ABS((T-TP)/T).LT.1.E-8)GO TO 53
   51 ITP=0
C
C        SOME QUANTITIES, ONLY DEPENDENT ON T
      TETA=5040./T
      TETA25=1.202E9/(TETA*TETA*SQRT(TETA))
      DO52 J=1,5
   52 A(J)=FL2(J)*TETA
C        A=ALFA(BASCHEK ET AL., CITED ABOVE)
C
      IF(NQTEMP.EQ.0)GO TO 53
C
C        PREPARATION FOR INTERPOLATION OF PARTITION FUNCTIONS IN T
      DQ(1)=1.
      DQ(2)=T-TPARF(1)
      DQ(3)=DQ(2)*(T-TPARF(2))
      DQ(4)=      DQ(3)*(T-TPARF(3))
C
C        SOME QUANTITIES ALSO DEPENDENT ON PE
C        THE PFAK FACTORS ARE USED IN THE SAHA EQUATION. H(J) IS THE
C        QUANTUM NUMBER OF THE CUT OF THE PARTITION FUNCTIONS (ACCORDING
C        TO BASCHEK ET AL., CITED ABOVE) FOR J-1 TIMES IONIZED ATOMS. H IS
C        USED IN QAS.
C
C        XNEL= THE ELECTRON (NUMBER) DENSITY (PER CM3)
C        PFISH= P(FISCHEL AND SPARKS, ASTROPHYS. J. 164, 359 (1971)) IS USED IN
C        FUNCTION QAS.
C
   53 DXI=4.98E-4*TETA*SQRT(PE)
      DUM=TETA25/PE
      DIM=EXP10(DXI*TETA)
      PFAK(1)=DIM*DUM
      SQDXI=1./SQRT(DXI)
      H(1)=SHXIJ(1)*SQDXI
      DO54 J=2,5
      PFAK(J)=PFAK(J-1)*DIM
   54 H(J)=SHXIJ(J)*SQDXI
      XNEL=PE/(XKBOL*T)
      PFISH=4.2E3/XNEL**0.166666667
C
C        PARTITION FUNCTIONS AND IONIZATION EQUILIBRIA
C
      XNECNO=0.
      XNENH=0.
      EJON=0.
      JA=1
C
C        BEGINNING OF LOOP OVER ELEMENTS ('THE I-LOOP').
      DO24 I=1,NEL
      NJP=NJ(I)
C
C        SHOULD ELEMENT NO. I BE CONSIDERED
      IF(IELEM(I).GT.0)GO TO 9
      DO 55 J=1,NJP
      ANJON(I,J)=0.
      PART(I,J)=0.
   55 CONTINUE
      GO TO 23
C
C        BEGINNING OF LOOP OVER STAGES OF IONIZATION ('THE J-LOOP')
    9 DO19 J=1,NJP
      JM1=J-1
C
C        SHOULD STAGE OF IONIZATION NO. J BE CONSIDERED
      IF(ION(I,J).GT.0)GO TO 10
      ANJON(I,J)=0.
      PART(I,J)=0.
      GO TO 18
C
C        WHICH KIND OF PARTITION FUNCTION SHOULD BE COMPUTED
C
C*
C*  88-04-25  ADDITION (PHILIP JUDGE)
C*  IF THE TEMPERATURES AND PRESSURES LOOK 'CORONAL', AND THE DATA IS NOT
C*  COMPUTED IN DETAIL IN FILE 'BMET',  AND THE ELEMENT IS NOT HYDROGEN,
C*  THEN COMPUTE THE  CORONAL LIMIT IONIZATION FRACTIONS
C*
C*  PARAMETERS TECOR AND DECOR  ARE USED TO SPECIFY THE CORONAL 
C*  APPROXIMATION-  THEY ARE READ IN ROUTINE  INJON
C*
C*  ADD IN PARTITION FUNCTIONS = CONSTANT (UNITY HERE)
C*
C*
C*  92-07-20 MODIFICATION  IEL CHANGED TO CEL
   10          IF (T  .GT.  TECOR  .AND.  PE/BK/T  .LT. DECOR 
     *             .AND.  FRCION(I,J,NTP) .LT. 0.E0 
     *             .AND. CEL(I) .NE. 'H  ') THEN
                 CALL CORONA(CEL(I),J,T,PE,FCORON)
                 IF (FCORON .LT. 0.E0)GOTO 101
                 F(J)=FCORON
                 PART(I,J)=1.E0
                 PART(I,J+1)=1.E0
                 GOTO 19                         
              END IF
  101         IF (IQFIX(I,J)-1) 14,11,13
C*  END PGJ ADDITION
C*
   11 IF(T.LT.TPARF(1).OR.T.GT.TPARF(4))GO TO 13
      PARTP=PART(I,J)
      IF(ITP.GT.0)GO TO 15
C
C        PARTITION FUNCTIONS TO BE INTERPOLATED IN T
      JPARF=(JA-1)*4+1
      PARTP=0.
      DO12 IP=1,4
      PARTP=PARTP+PARQ(JPARF)*DQ(IP)
   12 JPARF=JPARF+1
      GO TO 15
C
C        PARTITION FUNCTIONS FOLLOWING TRAVING ET AL., ABH. HAMB. VIII, 1 (1966)
   13 PARTP=QTRAV(TETA,H(J),J,JA)
      GO TO 15
C
C        THE PARTITION FUNCTION IS CONSTANT
   14 PARTP=PARCO(JA)
C*
C* PGJ MODIFICATIONS START 
C* USE FRCION AS A FLAG THAT MULTI COMPUTED DATA EXISTS FOR ZNLTE
C*
   15         CONTINUE
              IF(FRCION(I,J,NTP).GE.0.0) PARTP = ZNLTE(I,J,NTP)
              IF(J .EQ. NJP) THEN
                IF(FRCION(I,JM1,NTP) .GE. 0.0) PARTP = ZNLTE(I,J,NTP)
              END IF
              PART(I,J) = PARTP
C*
C* PGJ MODIFICATIONS END
C*
C
C        IONIZATION EQUILIBRIA AND TOTAL NUMBER OF ELECTRONS
C
      IF(J.LE.1)GO TO 19
      IF(ITP.GT.0)GO TO 17
      RFAK(JA)=EXP10(-XIONG(I,JM1)*TETA)
   17 F(JM1)=PFAK(JM1)*RFAK(JA)*PARTP/PART(I,J-1)
C*
C* MODIFICATIONS START
C** PGJ ADDED NEW VARIABLE FTEMP TO STORE LTE POPULATIONS TEMPORARILY
              IF(FRCION(I,JM1,NTP).GE.0.0) THEN
                FTEMP(I,JM1)=F(JM1)
                F(JM1) = FRCION(I,JM1,NTP)
              ENDIF
C** PGJ MODIFICATIONS END
C* MODIFICATIONS END
C*
      GO TO 19
   18 IF(J.GT.1)F(JM1)=0.
   19 JA=JA+1
C        END OF 'THE J-LOOP'
C
      FIL=1.
      DO20 J=2,NJP
      LL=NJP-J+1
   20 FIL=1.+F(LL)*FIL
C*
C* 88-01-30  MODIFICATIONS START
      FIL=1./FIL
      ANJON(I,1)=FIL
      XNEN=0.
      DO21 J=2,NJP
      JM1=J-1
      FIL=FIL*F(JM1)
      ANJON(I,J)=FIL
C* 88-01-30  MODIFICATIONS END
C*
      IF(I.LE.1)GO TO 24
      FLJM1=JM1
   21 XNEN=ANJON(I,J)*FLJM1+XNEN
      IF(I.GT.2.AND.I.LT.6) XNECNO=XNECNO+XNEN*ABUND(I)
C*
C* 89-03-24 START
C* STORE CONTRIBUTION FROM C, N, O IN XNENC, XNENN, XNENO TO BE 
C* MULTIPLIED BY ABUNDM AFTER THE MOLECULE FORMATION PART
C*
      IF(I.EQ.3) THEN 
        XNENC=XNEN
      ELSE IF(I.EQ.4) THEN
        XNENN=XNEN
      ELSE IF(I.EQ.5) THEN
        XNENO=XNEN
      ENDIF
C* 89-03-24 END
      XNENH=XNEN*ABUND(I)+XNENH
C        XNENH=NUMBER OF ELECTRONS FROM ELEMENTS OTHER THAN HYDROGEN (Q IN
C        MIHALAS, METH. COMP. PHYS. 7, 1 (1967), EQ. (35))
C        XNECNO=NUMBER OF ELECTRONS FROM ELEMENTS OTHER THAN H, C, N, O
C
C
C        COMPUTATION OF THE ENERGY OF IONIZATION (EJON). HYDROGEN IS NOT
C        INCLUDED.
C
      XERG=0.
C        XERG= THE ENERGY OF IONIZATION PER ATOM (IN ELECTRON VOLTS)
C
      DO22 J=2,NJP
      JM1=J-1
      FLJM1=JM1
   22 XERG=ANJON(I,J)*(XIONG(I,JM1)-DXI*FLJM1)+XERG
      EJON=XERG*ABUND(I)+EJON
      GO TO 24
   23 JA=JA+NJP
   24 CONTINUE
C        END OF 'THE I-LOOP'
C
C
      XNECNO=XNENH-XNECNO
      TP=T
      IF(IEPRO.LE.0)GO TO 71
C
C        COMP. OF PRESSURE, DENSITY AND INNER ENERGY
C
      XIH=XIONG(1,1)-DXI
      XIHM=0.754-2.*DXI
C        XIH AND XIHM ARE THE ENERGIES OF IONIZATION FOR H AND H- RESPECTIVELY
C        (IN ELECTRON VOLTS).
C
      XKHM=TETA25*2.*EXP10(-TETA*XIHM)
C        XKHM = THE 'DISSOCIATION CONSTANT' FOR H-.
C
      IF(T.GT.TMOLIM)GO TO 42
C*
C* 87-10-20 MODIFICATIONS START
      NE=PE/(XKBOL*T)
      IF(HLTE) THEN
        HJONH=ANJON(1,2)/ANJON(1,1)
      ELSE
        NH=0.0
        NHLTE=NPIN(NTP)*ANJON(1,1)/ANJON(1,2)
        DO 35 N=1,5
          NH=NH+NHYD(NTP,N)
   35   CONTINUE
        NP=NPIN(NTP)
        HJONH=NP/NH
        CALL MOLFYS(T,XKH2,XKH2P,DEH2,DEH2P)
        NH2=NH*NH/XKH2*XKBOL*T
        NH2P=NH*NP/XKH2P*XKBOL*T
        NHMIN=NH*NE/XKHM*XKBOL*T
        NHT=NH+NP+NHMIN+2.*(NH2+NH2P)
        FE=NE/NHT
      ENDIF
      IF(MOLH.LE.0) GOTO 45
C
C        FORMATION OF MOLECULES. ONLY H2 AND H2+
   41 CONTINUE
      IF(HLTE) THEN
        CALL MOLEQ(T,PE,HJONH,XIH,XKHM,XIHM,XNENH,F1,F2,F3,F4,F5,FE,
     *   FSUM,EH)
        NHT=NE*FE
        NH=F1*NHT
        NP=F2*NHT
        NHMIN=F3*NHT
        NH2P=F4*NHT
        NH2=F5*NHT
      ELSE
        F1=NH/NHT
        F2=NP/NHT
        F3=NHMIN/NHT
        F4=NH2P/NHT
        F5=NH2/NHT
      ENDIF
C* 87-10-20 MODIFICATIONS END
C*
      FEPE=PE/FE
      F1P=F1*FEPE
      F3P=F3*FEPE
      F4P=F4*FEPE
      F5P=F5*FEPE
      GO TO 43
C        FORMATION OF MOLECULES COMPOSED OF H,C,N,O
   45 IF(ANJON(3,1).LE.0..OR.ANJON(4,1).LE.0..OR.ANJON(5,1).LE.0.)
     * GOTO 41
      HJONC=ANJON(3,2)/ANJON(3,1)
      HJONN=ANJON(4,2)/ANJON(4,1)
      HJONO=ANJON(5,2)/ANJON(5,1)
      ABUC=ABUND(3)/ABUND(1)
      ABUN=ABUND(4)/ABUND(1)
      ABUO=ABUND(5)/ABUND(1)
      CALL MOL(T,PE,HJONH,HJONC,HJONN,HJONO,ABUC,ABUO,ABUN,XIH,XKHM,XIHM
     *,XNECNO,F1,F2,F3,F4,F5)
      SUMPMO=0.
      PRESMO(1)=FHE*PK(1)
      PRESMO(2)=FHE*FHE*PK(2)
      PRESMO(3)=FHE*FHE*HJONH*PK(3)
      PRESMO(4)=FHE*FHE*FOE*PK(4)
      PRESMO(5)=FHE*FOE*PK(5)
      PRESMO(6)=FHE*FCE*PK(6)
      PRESMO(7)=FCE*FOE*PK(7)
      PRESMO(8)=FCE*FNE*PK(8)
      PRESMO(9)=FCE*FCE*PK(9)
      PRESMO(10)=FNE*FNE*PK(10)
      PRESMO(11)=FOE*FOE*PK(11)
      PRESMO(12)=FNE*FOE*PK(12)
      PRESMO(13)=FNE*FHE*PK(13)
      DO 30 I=1,13
      PRESMO(I)=PRESMO(I)*PE
   30 SUMPMO=SUMPMO+PRESMO(I)
      SUMPA=PE*(FHE+FCE+FNE+FOE)
      SUMPI=PE*(FHE*HJONH+FCE*HJONC+FNE*HJONN+FOE*HJONO)
      HNIC=PE*FHE
      HPNIC=HNIC*HJONH
      PG=PE+SUMPMO+SUMPA+SUMPI+PE*SUMM/FE
C*
C* 87-10-20 MODIFICATIONS START
C* 88-01-30
      TKINV=1./(XKBOL*T)
      NH=HNIC*TKINV
      NP=HPNIC*TKINV
      NHLTE=NP*ANJON(1,1)/ANJON(1,2)
      NHMIN=PRESMO(1)*TKINV
      NH2=PRESMO(2)*TKINV
      NH2P=PRESMO(3)*TKINV
      NHT=NH+NP+NHMIN+2.*(NH2+NH2P)
      NC=(1.+HJONC)*FC*NHT
      NN=(1.+HJONN)*FN*NHT
      NO=(1.+HJONO)*FO*NHT

CCC  00-09-12 NOH ADDED

      NOH=PRESMO(5)*TKINV
      NCH=PRESMO(6)*TKINV
      NCO=PRESMO(7)*TKINV
      NCN=PRESMO(8)*TKINV
      GOTO 46
C* 87-10-20 MODIFICATIONS END
C* 88-01-30
C
C        NO MOLECULES
   42 CONTINUE
C*
C* 87-05-30 MODIFICATIONS START
      NE=PE/(XKBOL*T)
      IF(HLTE) THEN
        FE=XNENH+ANJON(1,2)
        NHT=NE/FE
        NP=ANJON(1,2)*NHT
        NH=ANJON(1,1)*NHT
        NHLTE=NH
      ELSE
        NHLTE=NPIN(NTP)*ANJON(1,1)/ANJON(1,2)
        NH=0.0
        DO 422 N=1,5
          NH=NH+NHYD(NTP,N)
  422   CONTINUE
        NP=NPIN(NTP)
        NHT=NH+NP
        FE=NE/NHT
      ENDIF
      NHMIN=NH*NE/XKHM*XKBOL*T
      NH2=0.0
      NH2P=0.0
      F2=NP/NHT
      F1=NH/NHT
C* 87-05-30 MODIFICATIONS END
C*
      F3=0.
      F4=0.
      F5=0.
      FSUM=1.
      EH=-XIH*F1
   43 PG=PE*(1.+(FSUM+SUMH)/FE)
   46 RO=PE*XMH*XMY/(XKBOL*FE*T)
       XYRHO=RO
      E=1.5*PG/RO+(EH+EJON)*ENAMN
      YYPG=PG
      YYRHO=RO
      YYE=E
C
C* 88-01-30 MODIFICATIONS START
      IF(T.GT.TMOLIM .OR. MOLH.GT.0) THEN
        NC=ABUND(3)/ABUND(1)*NHT
        NN=ABUND(4)/ABUND(1)*NHT
        NO=ABUND(5)/ABUND(1)*NHT
        NCH=0.0
        NCO=0.0
        NCN=0.0

C  00-09-12 NOH 
        NOH=0.0
      ENDIF
C* 87-07-29 MODIFICATIONS START
C* 88-01-30
C* STORE DEPTH-DEPENDENT VARIABLES FOR TRANSFER IN COMMON
C* BLOCKS COPBID AND COUT
      PGC(NTP)=PG
      ROC(NTP)=RO
      XMYC(NTP)=XMY*NHT/PG*XKBOL*T
      EJONC(NTP)=EJON*EEV
      XNENHC(NTP)=XNENH
      TOTHI(NTP)=NH
      TOTH(NTP)=NHT
      TOTH2(NTP)=NH2
      TOTC(NTP)=NC
      TOTNIT(NTP)=NN
      TOTO(NTP)=NO

CCC  00-09-12 NOH ADDED       

      TOTOH(NTP)=NOH
      TOTCH(NTP)=NCH
      TOTCO(NTP)=NCO
      TOTCN(NTP)=NCN
C* 87-07-29, 88-01-30 MODIFICATIONS END
C* 89-03-24 START
      ABUNDM(1)=(NH+NP)/NHT
      ABUNDM(3)=NC/NHT
      ABUNDM(4)=NN/NHT
      ABUNDM(5)=NO/NHT
      XNENH=XNECNO+ABUNDM(3)*XNENC+ABUNDM(4)*XNENN+ABUNDM(5)*XNENO
C* 89-03-24 END
C*
C
      IF(IOUTR.LE.0)GO TO 71
C
C        **** PRINT-OUT ****
C
C*
C* 87-11-02  MODIFICATIONS:
C* 1P E-FORMAT,
C* IWOPTN GOVERNS PRINTOUT, BINARY SWITCHES:
C*   1 OPACITY CONTRIBUTIONS
C*   2 PARTIAL PRESSURES
C*   4 IONIZATION FRACTIONS, PARTITION FUNCTIONS
C*
      IF(.NOT.MASKWR(IWOPTN,1) .AND. .NOT.MASKWR(IWOPTN,2)) GOTO 71
      WRITE(IWRIT,204)T,PE,PG,RO,E
      IF(MASKWR(IWOPTN,2)) THEN
        WRITE(IWRIT,201)
        WRITE(IWRIT,202)
        DO93 I=1,NEL
          NJP=NJ(I)
C*
C* PGJ ALTERATION: WRITE BLANKS INSTEAD OF ZEROS
C* 89-03-24 MC ALTERATION: WRITE NON-LTE IONIZATION FOR HYDROGEN
          DO 303 J=1,NJP
            WRITE(CPART(J)(1:10),FMT='(1P,E10.3)')PART(I,J)
            IF(I.GT.1) THEN
              ANJONW=ANJON(I,J)
            ELSE IF(J.EQ.1) THEN
              ANJONW=NH/(NH+NP)
            ELSE
              ANJONW=NP/(NH+NP)
            ENDIF
            IF(ANJONW .LT. 1.E-4)THEN
              WRITE(CANJON(J)(2:8),FMT='(1P,E7.1)') ANJONW
              CANJON(J)(1:1)=' '
            ELSE
              WRITE(CANJON(J)(1:8),FMT='(F8.4)') ANJONW
            ENDIF
  303     CONTINUE
          DO 3031 J=NJP+1,4
            CANJON(J)(1:8) = '        '
            CPART(J)(1:10) = '          '
 3031     CONTINUE
          WRITE (IWRIT,FMT=203) CEL(I)(1:2),ABUNDM(I),
     *        (CANJON(J)(1:8),J=1,4),(CPART(J),J=1,4)
C* END PGJ,MC ALTERATIONS
C*
   93   CONTINUE
      ENDIF
      IF(T.GT.TMOLIM .OR. .NOT.MASKWR(IWOPTN,1))GO TO 44
      IF(MOLH.LE.0)GOTO 47
      WRITE(IWRIT,205)F1P,F3P,F5P,F4P
      GO TO 71
   47 CONTINUE
      WRITE(IWRIT,208)HNIC,(PRESMO(I),I=1,13)
      GOTO 71
   44 WRITE(IWRIT,206)
C
   71 CONTINUE
C*
C* PGJ- HAVING USED NON-LTE POPULATIONS AND PARTITION FUNCTIONS FROM 
C* MULTI WE NOW RE-ASSIGN LTE ION FRACTIONS FOR THE COMPUTATION OF THE
C* DETAILED OPACITIES IN ROUTINE  ABSKO
C
      DO 241 I = 1,NEL
          NJP = NJ(I)
          FIL = 1.
          INLTE=0     
          DO 2021 J = 2,NJP
              JM1 = J - 1
              IF (FRCION(I,JM1,NTP).LT.0.0) GOTO 2021
              LL = NJP - J + 1
              FIL = 1. + FTEMP(I,LL)*FIL
              INLTE=1
 2021     CONTINUE
          IF(INLTE .EQ. 0) GOTO 241
          ANJON(I,1) = 1. / FIL
          DO 211 J = 2,NJP
              JM1 = J - 1
              ANJON(I,J) = ANJON(I,JM1)*FTEMP(I,JM1)
  211     CONTINUE
  241 CONTINUE
C** END PGJ ADDITION
C** 
      RETURN
  201 FORMAT(1H0,'ELEMENT  ABUNDANCE  IONIZATION FRACTIONS',17X,
     *'PARTITION FUNCTIONS')
  202 FORMAT(1H ,23X,1HI,7X,2HII,6X,3HIII,5X,2HIV,12X,1HI,9X,2HII,8X,
     *3HIII,7X,2HIV)
  203 FORMAT (6H      ,A2,1P,E12.4,4A8,5X,4A10)
  204 FORMAT(3H0T=,F7.1,5X,3HPE=,1P,E12.4,5X,3HPG=,E12.4,5X,3HRO=,E12.4,
     *5X,2HE=,E12.4)
  205 FORMAT(1H0,'PARTIAL PRESSURES'/4X,'H',8X,'H-',7X,'H2',7X,'H2+'/1X,
     *4(1PE9.2))
  206 FORMAT(1H0,'NO MOLECULES CONSIDERED')
  207 FORMAT(1H+,56X,1P,4E10.3)
  208 FORMAT(1H0,'PARTIAL PRESSURES'/4X,'H',8X,'H-',7X,'H2',7X,'H2+',6X,
     *'H2O',6X,'OH',7X,'CH',7X,'CO',7X,'CN',7X,'C2',7X,'N2',7X,'O2',7X,
     *'NO',7X,'NH'/1X,14(1PE9.2))
      END
C
C***********************************************************************
C
      FUNCTION QTRAV(TETA,HP,J,JA)
C
C        HERE THE PARTITION FUNCTIONS ACCORDING TO TRAVING ET AL., ABH. HAMB.
C        STERNW. VIII, 1 (1966) ARE COMPUTED. THE SYMBOLS ARE GIVEN
C        IN THE COMMENTS AT THE BEGINNING OF SUBROUTINE INJON.
C        FUNCTION QAS IS CALLED.
C
C        DIMENSIONS NECESSARY
C        A(5),ASDE(KMAX),H(5),QPRIM(KMAX)
C        KMAX IS THE TOTAL NUMBER OF ELECTRON CONFIGURATIONS.
C        DIMENSIONS OF ARRAYS IN COMMON /CI3/ ARE COMMENTED ON IN SUBROUTINE
C        INJON.
C
C: QTRAV  92-11-27  MODIFICATIONS: (MATS CARLSSON)
C:        SAVE STATEMENT ADDED
C:
      INCLUDE 'PREC'
      PARAMETER (MEL=21,MJMAX=180,MKMAX=180,MLMAX=800,MJ=5)
      DIMENSION ASDE(MKMAX),QPRIM(MKMAX)
C
      COMMON/CI3/ALFA(MLMAX),GAMMA(MLMAX),G0(MJMAX),G2(MKMAX),
     * XION(MKMAX),XL(MKMAX),JBBEG(MJMAX),JCBEG(MJMAX),NK(MJMAX),
     * NL(MKMAX),IFISH
C
      COMMON/CI7/A(5),PFISH,ITP
C
      SAVE
C
C
C        STATEMENT FUNCTION FOR 10.**
      EXP10(X)=EXP(2.302585*X)
C
      FLJ=J
      JB=JBBEG(JA)
      JC1=JCBEG(JA)
      NKP=NK(JA)
      QSUM=0.
C
C        WE START THE LOOP OVER DIFFERENT ELECTRON CONFIGURATIONS ('THE K-LOOP'
      DO5 K=1,NKP
      JC2=NL(JB)+JC1-1
C
C        IS TETA=PRECEDING TETA
      IF(ITP.GT.0)GO TO 4
      PRA=XION(JB)*TETA
      IF(PRA.LT.12.)GO TO 1
      ASDE(JB)=0.
      GO TO 2
    1 ASDE(JB)=G2(JB)*EXP10(-PRA)
C
    2 QPRIM(JB)=0.
      IF(NL(JB).LE.0)GO TO 4
      DO3 L=JC1,JC2
      PRE=GAMMA(L)*TETA
      IF(PRE.GT.12.)GO TO 3
      QPRIM(JB)=QPRIM(JB)+ALFA(L)*EXP10(-PRE)
    3 CONTINUE
    4 JC1=JC2+1
      QSUM=QPRIM(JB)+ASDE(JB)*QAS(HP,XL(JB),A(J),FLJ,PFISH,IFISH)
     *             +QSUM
    5 JB=JB+1
C        END OF 'THE K-LOOP'
      QTRAV=G0(JA)+QSUM
C
      RETURN
      END
      FUNCTION QAS(H,XL,A,Z,PFISH,IFISH)
C
C        THIS ROUTINE COMPUTES THE ASYMPTOTIC PARTS OF THE PARTITION
C        FUNCTIONS FOLLOWING
C           BASCHEK ET AL., ABH. HAMB. VIII, 26 (1966) IF IFISH = 0
C           FISCHEL AND SPARKS, AP. J. 164, 359 (1971) IF IFISH = 1
C           (APPROXIMATING THE ZETA FUNCTIONS BY INTEGRALS).
C
C        XL=QUANTUM NUMBER FOR THE FIRST LEVEL OF THE ASYMPTOTIC PART
C        H=QUANTUM NUMBER OF THE CUT (FOR IFISH=0)
C        A=DZ(FISCHEL AND SPARKS)=ALFA(BASCHEK ET AL.)
C        PFISH=P(FISCHEL AND SPARKS), ONLY NECESSARY IF IFISH = 1
C
C
C
      INCLUDE 'PREC'
      COMMON/UTPUT/ IREAD, IWRIT
C
      QAS=0.0
      IF(IFISH.LT.0) RETURN
C
C        WHICH TYPE
      IF(IFISH.GT.0)GO TO 1
C
C        BASCHEK ET AL.
      QAS=0.333333*(H*(H+1.)*(H+0.5)-XL*(XL+1.)*(XL+0.5)) +
     *                       A*(H-XL)+0.5*A*A*(H-XL)/(H*XL)
      RETURN
C
C        FISCHEL AND SPARKS
    1 P=PFISH*Z
C
C        FISCHEL AND SPARKS, EQ. (26)
      P2=P*P
      P3=P2*P
      IF(P.LE.XL)GO TO 2
      XLM1=XL-1.
      R2=XLM1*XLM1
      R3=R2*XLM1
      QAS=1.3333333*P3+0.5*P2+0.16666667*P+1.33333333*A*P-0.4*A*A/P-
     *0.33333333*R3-0.5*R2-0.16666667*XLM1-A*XLM1+0.5*A*A/XL
      RETURN
C
C        FISCHEL AND SPARKS, EQ. (27)
    2 AXL2=A/(XL*XL)
      QAS=P3*P/XL*(1.+AXL2*(0.33333333+0.1*AXL2))
      RETURN
      END
      SUBROUTINE MOLEQ(T,PE,G2,XIH,XKHM,XIHM,XNENH,F1,F2,F3,F4,F5,FE,
     *                 FSUM,EH)
C
C        THIS ROUTINE COMPUTES DISSOCIATION EQUILIBRIA FOR THE MOLECULES
C        H2 AND H2+ WITH H+, H AND H- CONSIDERED. IT MAINLY FOLLOWS MIHALAS,
C        METH. COMP. PHYS. 7, 1 (1967).
C
C        THE INNER ENERGY OF THE HYDROGEN GAS, EH, IS ALSO EVALUATED.
C
C        XIH=THE IONIZATION ENERGY OF HYDROGEN
C        XKHM=THE 'DISSOCIATION CONSTANT' OF H-
C        XIHM=THE 'DISSOCIATION ENERGY' OF H-.
C        XNENH=THE NUMBER OF ELECTRONS PER UNIT VOLUME FROM ELEMENTS OTHER THAN
C        HYDROGEN (Q IN MIHALAS'S ARTICLE)
C        G2,F1,F2 ETC. SEE REF.
C        DOUBLE PRECISION NECESSARY FOR RELATIVELY LOW PRESSURES.
C
C
C                   
      INCLUDE 'PREC'
      COMMON/UTPUT/ IREAD, IWRIT
      DOUBLE PRECISION G3,G4,G5,A,E,B,C,D,C1,C2,C3,CAM,F1D,F2D,F3D,F4D,
     *F5D,FED,FSUMD,ROOT
C
C        CALL MOLFYS FOR PHYSICAL DATA
      CALL MOLFYS(T,XKH2,XKH2P,DEH2,DEH2P)
C
C        CALCULATION OF THE EQUILIBRIUM
      G3=PE/XKHM
      G4=PE/XKH2P
      G5=PE/XKH2
      A=1.+G2+G3
      E=G2*G4/G5
      B=2.*(1.+E)
      C=G5
      D=G2-G3
      C1=C*B*B+A*D*B-E*A*A
      C2=2.*A*E-D*B+A*B*XNENH
      C3=-(E+B*XNENH)
      CAM=C2/(2.*C1)
      ROOT=DSQRT(CAM*CAM-C3/C1)
      F1D=-CAM+ROOT
      IF(F1D.GT.1.E0)F1D=-CAM-ROOT
      F5D=(1.E0-A*F1D)/B
      F4D=E*F5D
      F3D=G3*F1D
      F2D=G2*F1D
      FED=F2D-F3D+F4D+XNENH
      FSUMD=F1D+F2D+F3D+F4D+F5D
      F1=F1D
      F2=F2D
      F3=F3D
      F4=F4D
      F5=F5D
      FE=FED
      FSUM=FSUMD
C
C        CALCULATION OF THE ENERGIES
      EH2=(-2.*XIH+DEH2)*F5
      EH2P=(-XIH+DEH2P)*F4
      EHM=-(XIHM+XIH)*F3
      EHJ=-XIH*F1
      EH=EHJ+EHM+EH2+EH2P
    1 CONTINUE
      RETURN
      END
      SUBROUTINE MOLFYS(T,XKH2,XKH2P,DEH2,DEH2P)
C
C        THIS ROUTINE GIVES DISSOCIATION CONSTANTS XKH2 (=N(H I)*N(H I)/N(H2) )
C        AND XKH2P (=N(H I)*N(H II)/N(H2+)), EXPRESSED IN NUMBER PER CM3, AND
C        THE SUM OF DISSOCIATION, ROTATION AND VIBRATION ENERGIES, DEH2 AND
C        DEH2P FOR H2 AND H2+, RESPECTIVELY (EXPRESSED IN ERGS PER MOLECULE).
C        THE DATA ARE FROM VARDYA, M.N.R.A.S. 129, 205 (1965) AND EARLIER
C        REFERENCES. THE DISSOCIATION CONSTANT FOR H2 IS FROM TSUJI,
C        ASTRON. ASTROPHYS. 1973.
C
      INCLUDE 'PREC'
      DIMENSION A1(5),A2(4),B1(5),B2(5),TE(5)
      DATA A1/12.739,-5.1172,1.2572E-1,-1.4149E-2,6.3021E-4/,
     *A2/11.20699 ,-2.794276 ,-0.079196   ,0.024790   /,
     *B1/2.6757,-1.4772,0.60602,-0.12427,0.009750/,
     *B2/2.9216,-2.0036,1.7231,-0.82685,0.15253/
      TEX=5040./T
      TE(1)=1.
      DO1 K=1,4
    1 TE(K+1)=TE(K)*TEX
      XKH2=0.
      XKH2P=0.
      DEH2=0.
      DEH2P=0.
      DO2 K=1,4
      XKH2=A1(K)*TE(K)+XKH2
      XKH2P=A2(K)*TE(K)+XKH2P
      DEH2=B1(K)*TE(K)+DEH2
    2 DEH2P=B2(K)*TE(K)+DEH2P
      XKH2=A1(5)*TE(5)+XKH2
      DEH2=(B1(5)*TE(5)+DEH2)*8.617E-5*T-4.476
      DEH2P=(B2(5)*TE(5)+DEH2P)*8.617E-5*T-2.648
      XKH2=10.**XKH2
      XKH2P=10.**XKH2P
      RETURN
      END
C
C **************************************************************************
C
      SUBROUTINE MOL(T,PE,G2,GC,GN,GO,ABUC,ABUO,ABUN,XIH,XKHM,XIHM,XNEN,
     *F1,F2,F3,F4,F5)
C
C        THIS ROUTINE COMPUTES DISSOCIATION EQUILIBRIA FOR THE MOLECULES H2,H2+,
C        H2O,OH,CH,CO,CN,C2,O2,N2,NH AND NO WITH H,H-,H+,C,C+,O,O+,N,N+ CON-
C        SIDERED, USING A NEWTON-RAPHSON SCHEME. SOME FEATURES COME FROM THE
C        MONSTER AND FROM MIHALAS, METH. COMP. PHYS. 7,1.
C
C        G2=N(HII)/N(HI), GC=N(CII)/N(CI) ETC.
C        ABUC= THE NUMBER OF CARBON NUCLEI PER HYDROGEN NUCLEUS, ABUO AND ABUN
C        ARE THE CORRESPONDING VALUES FOR OXYGEN AND NITROGEN.
C        XIH = THE IONIZATION ENERGY OF HYDROGEN
C        XIHM= THE 'DISSOCIATION ENERGY' OF H-
C        XKHM= THE 'DISSOCIATION CONSTANT' OF H-
C        XNEN= THE NUMBER OF ELECTRONS PER UNIT VOLUME FROM ELEMENTS OTHER THAN
C        HYDROGEN, CARBON, OXYGEN AND NITROGEN.
C
C        THE SUBSCRIPT IN AKD(I) ETC. HAS THE FOLLOWING MEANING
C        I=1 H-, 2 H2, 3 H2+, 4 H2O, 5 OH, 6 CH, 7 CO, 8 CN, 9 C2, 10 N2,
C         11 O2, 12 NO, 13 NH
C
C        THIS ROUTINE CALLS MOLMAT AND AINV2
C        THE DATA FOR COMPUTING THE DISSOCIATION CONSTANTS ARE FROM TSUJI
C        (ASTRON. ASTROPHYS.  23,411 (1973))
C
C        THE ROUTINE GIVES FH, FC, FO, FN, FE. FH=P(HI)/PH, FC=P(CI)/PH ETC.,
C        WHERE PH=NH*KT (NH IS THE NUMBER OF HYDROGEN NUCLEI PER CM3).
C
C:
C: MOL    87-10-20  MODIFICATIONS: (MATS CARLSSON)
C:        NON-LTE OPTION ADDED. FE IS THEN FIXED TO BE NE/NHT AND
C:        THE CHARGE CONSERVATION EQUATION IS NOT USED.
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAMO'
      LOGICAL HLTE
      REAL(8) NHYD,NPIN
      COMMON/CIN/ NHYD(MT,5),NPIN(MT),HLTE
      REAL(8) NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE
      COMMON/HYDCOM/NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE
      REAL(8) NE
      DOUBLE PRECISION AKA(12),AK1(12),AK2(12),AK3(12),AK4(12),AKD(13),
     *PK(13),TH,WKH,WKC,WKN,WKO,FH,FC,
     *FN,FO,FE,CAM,ROOT,QN,QNN,A(6,6),F(6),D(6),FHP,FCP,FOP,FNP,FEP
     *,S,R,B,BK
      DIMENSION B1(5),B2(5),DIS(10)
      COMMON/CMOL/PPK(13),FFH,FFC,FFN,FFO,FFE,FHE,FCE,FNE,FOE,EH
      DATA B1/2.6757,1.4772,0.60602,0.12427,0.00975/,
     *B2/2.9216,2.0036,1.7231,0.82685,0.15253/,
     *DIS/9.50,4.38,3.47,11.11,7.90,6.12,9.76,5.12,6.51,3.21/
      DATA AKA/12.739E0,11.206998E0,25.420E0,12.371E0,12.135E0,13.820E0,
     *12.805E0,12.804E0,13.590E0,13.228E0,12.831E0,12.033E0/
      DATA AK1/5.1172E0,2.7942767E0,10.522E0,5.0578E0,4.0760E0,11.795E0,
     *8.2793E0,6.5178E0,10.585E0,5.5181E0,7.1964E0,3.8435E0/
      DATA AK2/1.2572E-1,-7.9196803E-2,1.6939E-1,1.3822E-1,1.2768E-1,
     *1.7217E-1,6.4162E-2,9.7719E-2,2.2067E-1,6.9935E-2,1.7349E-1,
     &1.3629E-1/
      DATA AK3/1.4149E-2,-2.4790744E-2,1.8368E-2,1.6547E-2,1.5473E-2,
     *2.2888E-2,7.3627E-3,1.2739E-2,2.9997E-2,8.1511E-3,2.3065E-2,
     *1.6643E-2/
      DATA AK4/6.3021E-4,0.E0,8.1730E-4,7.7224E-4,7.2661E-4,1.1349E-3,
     *3.4666E-4,6.2603E-4,1.4993E-3,3.7970E-4,1.1380E-3,7.8691E-4/
C*
C* 87-10-20 MODIFICATIONS START
C
      DATA XKBOL/1.380662E-16/
C* 87-10-20 MODIFICATIONS END
C*
C
C        COMPUTATION OF DISSOCIATION CONSTANTS (AKD) AND PE/K(AB) (PK).
      TH=5040.E0/T
      AKD(1)=XKHM
      PK(1)=PE/XKHM
      DO 4 J=2,13
      M=J-1
      AKD(J)=10.E0**(AKA(M)-(AK1(M)-(AK2(M)-(AK3(M)-AK4(M)*TH)*TH)*TH)*
     *TH)
    4 PK(J)=PE/AKD(J)
      PK(4)=PE*PK(4)
C
C        COMPUTATION OF STARTING VALUES FOR FH,FC ETC.
C
      WKH=1.E0+G2+PK(1)
      WKC=1.E0+GC
      WKO=1.E0+GO
      WKN=1.E0+GN
C*
C* 87-10-20 MODIFICATIONS START
      IF(HLTE) THEN
        FE=XNEN
      ELSE
        NE=PE/(XKBOL*T)
        FE=NE/NHT
      ENDIF
C* 87-10-20 MODIFICATIONS END
C*
      CAM=FE*(1.E0+G2+PK(1))/(2.E0*PK(2))
      ROOT=DSQRT(DABS(CAM*CAM+FE/PK(2)))
      FH=-CAM+ROOT
C*
      IF(HLTE) FE=FH*(G2-PK(1))+XNEN
      IF(FE.GT.0.E0) GOTO 60
      R=PK(2)/PK(1)/PK(1)
      CAM=(WKH*XNEN/PK(1)-1.E0-2.E0*XNEN*R)
      S=R-WKH/PK(1)
      CAM=CAM/2.E0/S
      ROOT=DSQRT(CAM*CAM-R*XNEN*XNEN/S)
C*
      IF(HLTE) FE=-CAM-ROOT
      IF(FE.LT.0.) FE=-CAM+ROOT
      FH=(XNEN-FE)/PK(1)
   60 CONTINUE
      R=1.E0+GO+PK(4)*FH*FH/FE/FE+PK(5)*FH/FE
      S=1.E0+GC+PK(6)*FH/FE
      B=PK(7)/FE
      CAM=(B*(ABUC-ABUO)+R*S)/(2.E0*R*B)
      BK=ABUO/R*S/B
      FO=-CAM+DSQRT(CAM*CAM+BK)
      FC=ABUC/(S+B*FO)
   61 QN=1.E0+(FH*PK(13)+FC*PK(8))/FE
      QNN=FE/4.E0/PK(10)
      CAM=QN*QNN
      ROOT=DSQRT(DABS(CAM*CAM+2.E0*ABUN*QNN))
      FN=-CAM+ROOT
      IF(FN.LT.0.E0) FN=0.E0
C
C        COMPUTATION OF FH,FC, ETC. USING ALL RELEVANT MOLECULES, ATOMS AND IONS
C        DIFF GIVES THE APPROX. ACCURACY TO WHICH FH ETC. HAVE TO CONVERGE
C        BEFORE THE ITERATIONS ARE STOPPED.
C
      DIFF=0.001
C*
C* 87-10-20 MODIFICATIONS START
C  IN NON-LTE: DO NOT INCLUDE CHARGE CONSERVATION EQUATION
C  THEREFORE SET NUMBER OF EQUATIONS TO 4 TO FORCE UNCHANGED
C  FE
      IF(HLTE) THEN
        M=5
      ELSE
        M=4
        D(5)=0.0
      ENDIF
C* 87-10-20 MODIFICATIONS END
C*
      DO 2 J=1,100
      FHP=FH
      FCP=FC
      FOP=FO
      FNP=FN
      FEP=FE
      NICO=J
      CALL MOLMAT(PK,G2,GC,GN,GO,ABUC,ABUN,ABUO,FH,FC,FN,FO,FE,XNEN,F,A)
      CALL AINV2(A,M)
      DO 30 L=1,M
      QN=0.E0
      DO 3 LL=1,M
    3 QN=QN+A(L,LL)*F(LL)
      D(L)=-QN
   30 CONTINUE
      FH=FH+D(1)
      FC=FC+D(2)
      FO=FO+D(3)
      FN=FN+D(4)
      FE=FE+D(5)
      CHECH=DABS(1.E0-FHP/FH)
      CHECC=DABS(1.E0-FCP/FC)
      CHECO=DABS(1.E0-FOP/FO)
      CHECN=DABS(1.E0-FNP/FN)
      CHECE=DABS(1.E0-FEP/FE)
      IF(NICO.LE.2) GOTO 2
      IF(CHECH.LT.DIFF.AND.CHECC.LT.DIFF.AND.CHECO.LT.DIFF.AND.CHECN.LT.
     *DIFF.AND.CHECE.LT.DIFF) GOTO 23
    2 CONTINUE
      PRINT 305,FH,FC,FO,FN,FE,CHECH,CHECC,CHECO,CHECN,CHECE
  305 FORMAT(' ***MOL*** THE DESIRED ACCURACY WAS NOT ACHIEVED AFTER 100
     * ITERATIONS.  LATEST VALUES AND DIFFERENCES WERE'/2X,5(1PE11.4),10
     *X,5E10.3)
   23 CONTINUE
C        COMPUTATION OF THE INNER ENERGY. DEH2 AND DEH2P ARE THE SUM OF
C        DISSOCIATION, ROTATION AND VIBRATION ENERGIES (IN EV PER MOLECULE) FOR
C        H2 AND H2+. DIS(I) IS THE DISSOCIATION ENERGY FOR THE MOLECULE (I+3)
C        IN THE LIST OF MOLECULES (VALUES ARE FROM TSUJI). FOR THESE MOLECULES
C        THE ROTATION AND VIBRATION ENERGIES ARE NEGLECTED.
   98 TETA=TH
      DEH2=(B1(1)-(B1(2)-(B1(3)-(B1(4)-B1(5)*TETA)*TETA)*TETA)*TETA)*
     *8.617E-5*T-4.476
      DEH2P=(B2(1)-(B2(2)-(B2(3)-(B2(4)-B2(5)*TETA)*TETA)*TETA)*TETA)*
     *8.617E-5*T-2.648
      FHE=FH/FE
      FCE=FC/FE
      FOE=FO/FE
      FNE=FN/FE
      EH2=(-2.*XIH+DEH2)*FHE*FH*PK(2)
      EH2P=(DEH2P-XIH)*FHE*FH*G2*PK(3)
      EHM=-(XIHM+XIH)*FH*PK(1)
      EHJ=-XIH*FH
      EH2O=-(2.*XIH+DIS(1))*FHE*FH*FO*PK(4)
      EOH=-(XIH+DIS(2))*FOE*FH*PK(5)
      ECH=-(XIH+DIS(3))*FHE*FC*PK(6)
      ECO=-DIS(4)*FCE*FO*PK(7)
      ECN=-DIS(5)*FCE*FN*PK(8)
      EC2=-DIS(6)*FCE*FC*PK(9)
      EN2=-DIS(7)*FNE*FN*PK(10)
      EO2=-DIS(8)*FOE*FO*PK(11)
      ENO=-DIS(9)*FNE*FO*PK(12)
      ENH=-(DIS(10)+XIH)*FNE*FH*PK(13)
      EH=EH2+EH2P+EHM+EHJ+EH2O+EOH+ECH+ECO+ECN+EC2+EN2+EO2+ENO+ENH
      FFH=FH
      FFC=FC
      FFN=FN
      FFO=FO
      FFE=FE
      DO 72 I=1,13
   72 PPK(I)=PK(I)
      F1=FH
      F2=G2*FH
      F3=FH*PK(1)
      F4=FH*FHE*G2*PK(3)
      F5=FH*FHE*PK(2)
      RETURN
      END
C
C **************************************************************************
C
      SUBROUTINE MOLMAT(PK,GH,GC,GN,GO,AC,AN,AO,FH,FC,FN,FO,FE,XNEN,F,A)
C
C        THIS ROUTINE COMPUTES THE ELEMENTS OF MATRIX A AND VECTOR F IN THE
C        NEWTON-RAPHSON PROCEDURE FOR DETERMINING THE MOLECULAR EQUILIBRIUM.
C        IT IS CALLED BY SUBR. MOL.
C
      INCLUDE 'PREC'
      DOUBLE PRECISION PK(13),F(6),FH,FC,FN,FO,FE,
     *H,HH,C,O,XN,A(6,6),FHE,FCE,FNE,FOE
      FHE=FH/FE
      FCE=FC/FE
      FNE=FN/FE
      FOE=FO/FE
      H=1.E0+GH+PK(1)+PK(5)*FOE+PK(6)*FCE+PK(13)*FNE
      HH=2.E0*FHE*(PK(2)+GH*PK(3)+PK(4)*FOE)
      C=1.E0+GC+PK(7)*FOE+PK(6)*FHE+PK(8)*FNE
      O=1.E0+GO+PK(4)*FHE*FHE+PK(5)*FHE+PK(7)*FCE+PK(12)*FNE
      XN=1.E0+GN+PK(13)*FHE+PK(8)*FCE+PK(12)*FOE
      F(1)=FH*(H+HH)-1.E0
      F(2)=FC*(C+2.E0*PK(9)*FCE)-AC
      F(3)=FO*(O+2.E0*PK(11)*FOE)-AO
      F(4)=FN*(XN+2.E0*PK(10)*FNE)-AN
      F(5)=FH*(GH+PK(3)*GH*FHE-PK(1))+GC*FC+GN*FN+GO*FO-FE+XNEN
      A(1,1)=H+2.E0*HH
      A(1,2)=FHE*PK(6)
      A(1,3)=FHE*(2.E0*PK(4)*FHE+PK(5))
      A(1,4)=FHE*PK(13)
      A(1,5)=-FHE*(PK(5)*FOE+PK(6)*FCE+PK(13)*FNE+2.E0*FHE*(PK(2)+GH*PK(
     *3)+2.E0*PK(4)*FOE))
      A(2,1)=FCE*PK(6)
      A(2,2)=C+4.E0*PK(9)*FCE
      A(2,3)=FCE*PK(7)
      A(2,4)=FCE*PK(8)
      A(2,5)=-FCE*(FOE*PK(7)+FHE*PK(6)+FNE*PK(8)+2.E0*PK(9)*FCE)
      A(3,1)=FOE*(2.E0*PK(4)*FHE+PK(5))
      A(3,2)=FOE*PK(7)
      A(3,3)=O+4.E0*PK(11)*FOE
      A(3,4)=FOE*PK(12)
      A(3,5)=-FOE*(FHE*PK(5)+FCE*PK(7)+FNE*PK(12)+2.E0*(FOE*PK(11)+PK(4)
     **FHE*FHE))
      A(4,1)=FNE*PK(13)
      A(4,2)=FNE*PK(8)
      A(4,3)=FNE*PK(12)
      A(4,4)=XN+4.E0*FNE*PK(10)
      A(4,5)=-FNE*(FHE*PK(13)+FCE*PK(8)+FOE*PK(12)+2.E0*PK(10)*FNE)
      A(5,1)=GH*(1.E0+2.E0*PK(3)*FHE)-PK(1)
      A(5,2)=GC
      A(5,3)=GO
      A(5,4)=GN
      A(5,5)=-GH*PK(3)*FHE*FHE-1.E0
      RETURN
      END
C
C **************************************************************************
C
      SUBROUTINE AINV2(A,M)
      INCLUDE 'PREC'
      DIMENSION A(6,6),C(6),IND(6)
C***** THIS SUBROUTINE EVALUATES THE INVERSE OF A
C***** SQUARE M*M MATRIX A
C***** THE DIMENSIONS OF THE ARRAYS MAY BE INTEGER VARIABLES WHEN USED*********
C***** ON THE IBM 7094,BUT THEY MUST BE INTEGER CONSTANTS ON THE IBM 1130******
      DOUBLE PRECISION A,C,AMAX,STO,W1,W
  100 AMAX=0.0
      DO 2 I=1,M
      IND(I)=I
      IF(DABS(A(I,1))-AMAX)2,2,3
    3 AMAX=DABS(A(I,1))
      I4=I
    2 CONTINUE
      MM=M-1
      DO 111 J=1,MM
      IF(I4-J)6,6,4
    4 ISTO=IND(J)
      IND(J)=IND(I4)
      IND(I4)=ISTO
      DO 5 K=1,M
      STO=A(I4,K)
      A(I4,K)=A(J,K)
      A(J,K)=STO
    5 CONTINUE
    6 AMAX=0.0
      J1=J+1
      DO 11 I=J1,M
      A(I,J)=A(I,J)/A(J,J)
      DO 10 K=J1,M
      A(I,K)=A(I,K)-A(I,J)*A(J,K)
      IF (K-J1)14,14,10
   14 IF(DABS(A(I,K))-AMAX)10,10,17
   17 AMAX=DABS(A(I,K))
      I4=I
   10 CONTINUE
   11 CONTINUE
  111 CONTINUE
      DO 140 I1=1,MM
      I=M+1-I1
      I2=I-1
      DO 41 J1=1,I2
      J=I2+1-J1
      J2=J+1
      W1=-A(I,J)
      IF(I2-J2)141,43,43
   43 DO 42 K=J2,I2
      W1=W1-A(K,J)*C(K)
   42 CONTINUE
  141 C(J)=W1
   41 CONTINUE
      DO 40 K=1,I2
      A(I,K)=C(K)
   40 CONTINUE
  140 CONTINUE
      DO 150 I1=1,M
      I=M+1-I1
      I2=I+1
      W=A(I,I)
      DO 56 J=1,M
      IF (I-J)52,53,54
   52 W1=0.0
      GO TO 55
   53 W1=1.0
      GO TO 55
   54 W1=A(I,J)
   55 IF(I1-1)156,156,57
   57 DO 58 K=I2,M
      W1=W1-A(I,K)*A(K,J)
   58 CONTINUE
  156 C(J)=W1
   56 CONTINUE
      DO 50 J=1,M
      A(I,J)=C(J)/W
   50 CONTINUE
  150 CONTINUE
      DO 60 I=1,M
   63 IF(IND(I)-I)61,60,61
   61 J=IND(I)
      DO 62 K=1,M
      STO=A(K,I)
      A(K,I)=A(K,J)
      A(K,J)=STO
   62 CONTINUE
      ISTO=IND(J)
      IND(J)=J
      IND(I)=ISTO
      GO TO 63
   60 CONTINUE
      RETURN
      END
C
C **************************************************************************
C
      SUBROUTINE DETABS(J,JP,NTP,IOUTR)
C
C        THIS ROUTINE GIVES THE DETAILS OF THE ABSORPTION MECHANISMS.
C        CHANGES IN THE ABSORPTION-COEFFICIENT PROGRAM ARE EXPECTED TO
C        BE CONFINED TO THE TABLES AND TO THIS ROUTINE.
C        DETABS HAS TWO PURPOSES
C        1. JP=0   DETERMINATION OF WAVELENGTH-INDEPENDENT FACTORS (DEP.ON
C                  T, PE AND THE COMPONENT) STORED IN FAKT.
C        2. JP= THE ACTUAL WAVELENGTH NUMBER.
C                  MULTIPLICATION OF AB, COMPUTED IN SUBROUTINE ABSKO,
C                  BY WAVELENGTH-DEPENDENT FACTORS. SUMMATION OF THE TOTAL
C                  ABSORPTION AND SCATTERING COEFFICIENTS ( SUMABS AND
C                  SUMSCA ).
C
C        N O T E .  BEFORE A CALL ON DETABS FOR PURPOSE 1, SUBROUTINE
C        JON MUST HAVE BEEN CALLED.
C
C        IF J IS LESS THAN OR EQUAL TO ZERO, THE WEIGHT FOR A ROSSELAND MEAN
C        WILL BE COMPUTED AND STORED IN VIKTR (THE WEIGHT BEING 1/VIKTR).
C        NTP IS THE ARRAY INDEX OF THE T-PE POINT.
C        IF IOUTR IS GREATER THAN ZERO AT A CALL WITH JP GREATER THAN ZERO
C        (PART TWO OF THE ROUTINE), DETAILS OF THE ABSORPTION COEFFICIENTS
C        ARE PRINTED. IF IOUTR IS GREATER THAN ONE, A TABLE HEADING IS ALSO
C        PRINTED.
C
C
C        CONTENTS OF COMMON/CI5/, COMMUNICATING PHYSICAL INFORMATION FROM
C        SUBROUTINE JON.
C             ABUND  ABUNDANCES
C             ANJON  FRACTIONS OF IONIZATION
C             H      QUANTUM NUMBER OF THE HIGHEST EXISTING HYDROGENIC LEVEL
C             PART   PARTITION FUNCTIONS
C             DXI    DECREASE OF IONIZATION ENERGY OF HYDROGEN IN ELECTRON VOLTS
C             F1     N(HI)/N(H)
C             F2     N(HII)/N(H)
C             F3     N(H-)/N(H)
C             F4     N(H2+)/N(H)
C             F5     N(H2)/N(H)
C             XKHM   'DISSOCIATION CONSTANT' OF H-
C             XMH    MASS OF THE HYDROGEN ATOM IN GRAMS
C             XMY    GRAMS OF STELLAR MATTER/GRAMS OF HYDROGEN
C
C        DIMENSIONS NECESSARY
C        ABUND(NEL),ANJON(NEL,MAX(NJ)),ELS(NT),H(5),HREST(NT),PART(NEL,MAX(NJ)),
C        PROV(NKOMP,MT)
C        THE DIMENSIONS ARE LOWER LIMITS. DIMENSIONS IN COMMON /CA5/ ARE
C        COMMENTED ON IN SUBROUTINE ABSKO.
C        NEL IS THE NUMBER OF CHEMICAL ELEMENTS INITIATED IN SUBROUTINE INJON
C        NJ(I) IS THE NUMBER OF STAGES OF IONIZATION, INCLUDING THE NEUTRAL
C             STAGE, FOR ELEMENT I
C        NKOMP IS THE NUMBER OF COMPONENTS, NOT INCLUDING THOSE ADDED BY
C             ANALYTICAL EXPRESSIONS AFTER STATEMENT NO. 13.
C        NT   IS THE NUMBER OF TEMPERATURES-ELECTRON PRESSURES GIVEN AT THE
C             CALL OF SUBROUTINE ABSKO.
C 
C:
C: DETABS 87-05-21  MODIFICATIONS: (MATS CARLSSON)
C:        COMMON BLOCK /CA2/ ADDED TO MAKE VARIABLE NKOMP AVAILABLE
C:        COMPONENTS 17 - NKOMP-6 BF CONTINUA GIVEN LEVEL BY LEVEL
C:
C:        88-05-20  MODIFICATIONS: (MATS CARLSSON)
C:        WRITES CONTRIBUTIONS TO UNFORMATTED FILE IDLOPC
C:
C:        89-03-24  MODIFICATIONS: (MATS CARLSSON)
C:        FORMATION OF MOLECULES WAS NOT TAKEN INTO ACCOUNT WHEN CALCULATING
C:        XNENH AND OPACITIES. THIS HAS BEEN CORRECTED. TOTAL NUMBER 
C:        ABUNDANCES OF ATOMS AFTER MOLECULE FORMATION HAS BEEN TAKEN INTO
C:        ACCOUNT ARE STORED IN NEW VARIABLE ABUNDM
C:
C:
C:
C:        92-04-02  MODIFICATIONS: (PHILIP JUDGE) 
C:        NON-LTE TREATMENT OF LEVELS N > 5 CORRECTED AND F-F OPACITY
C:        OF H CORRECTED.  EARLIER VERSIONS LEAD TO ERRORS ESPECIALLY AT
C:        TEMPERATURES BELOW ABOUT 2600K.
C:
C:        92-11-27  MODIFICATIONS: (MATS CARLSSON)
C:        SAVE STATEMENT ADDED
C:
C:        93-03-05  MODIFICATIONS: (MATS CARLSSON)
C:        RAYLEIGH SCATTERING ON H2 MOLECULES ADDED
C:
C:        94-03-23  MODIFICATIONS: (MATS CARLSSON, DAN KISELMAN)
C:        BACKGROUND OPACITY FROM LINES INCLUDED
C:
C:        95-11-07  MODIFICATIONS: (SALVADOR ALBA, MATS CARLSSON)
C:        CORRECT EMISSION F-VALUE USED IN CALL TO SEMIC
C:        AFFECTS ISOUL=2 (SET BY IOPACL=2)
C:
C:        02-10-28  MODIFICATIONS: (MATS CARLSSON)
C:        SWITCH OF HREST OPACITY ABOVE EDGE OF N=15
C:
C:        03-10-13  MODIFICATIONS: (MATS CARLSSON)
C:        ADDED SUPPORT FOR CH BACKGROUND LINE OPACITY
C:
      INCLUDE 'PREC'
      INCLUDE 'CALIN'
      INCLUDE 'CINPUT'
      INCLUDE 'PARAMO'
      DIMENSION ELS(MT),HREST(MT),CNTRB(MEL)
      DIMENSION FAKRAY(MT),H2RAY(MT)
C
C     03-02-19 MODIFICATIONS (RC)
C     MAXNU AND LFLAG ARE INSERTED IN A COMMON BLOCK /CBRULS/
      COMMON/CBRULS/ LFLAG
C
C     (RC)
C
      COMMON/CA2/ABKOF(NABDIM),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP,NABKOF
C
      COMMON/CI5/ABUND(MEL),ANJON(MEL,MJ),H(5),PART(MEL,MJ),DXI,
     * F1,F2,F3,F4,F5,XKHM,XMH,XMY
C
      COMMON/CA5/AB(MKOMP),FAKT(MKOMP),PE(MT),T(MT),XLA(ML),XLA3(ML),RO,
     *SUMABS,SUMSCA,VIKTR,ISET,NLB
C
      COMMON/UTPUT/ IREAD, IWRIT
C
      COMMON/CLEVD/ IONL(MKOMP),CHIL(MKOMP),G2L(MKOMP),IELL(MKOMP)
C
      COMMON/CBMET/ BMET(MT,MKOMP-23),BMETP(MT,MKOMP-23),
     *       FRCION(MEL,MJ,MT),ZNLTE(MEL,MJ,MT)
      COMMON/CBMET2/ ANMET(MT,MKOMP-23)
      COMMON/LDOPAC/ ALES,BLES
C*
C* MODIFICATIONS START
C              
      COMMON/COUTR/ NTO,NTPO(MT),IWOPTN
C
      COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4),
     *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL
      CHARACTER*3 CEL
      COMMON/CC1/CEL(MEL)
      REAL(8) NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE
      COMMON/HYDCOM/NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE
C
      LOGICAL HLTE
      REAL(8) NHYD,NPIN
      COMMON/CIN/ NHYD(MT,5),NPIN(MT),HLTE
C
      COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT),
     * TOTCH(MT),TOTCO(MT),TOTCN(MT),
     * TOTC(MT),TOTNIT(MT),TOTO(MT),
     * BHYD(MT,5),GRPH,TOTOH(MT)

CCC  00-09-12 TOTOH ADDED

C
      COMMON/CABNDM/ ABUNDM(MEL)
C
      COMMON/CABSB/ ABSLTE(MT),KMPEXC
      COMMON /CXNENH/ XNENH
C
      COMMON /COPBID/ PGC(MT),ROC(MT),XMYC(MT),EJONC(MT),
     * XNENHC(MT),PROV(20,MT)
      REAL(8) FAKTL(MKOMP,MT)
      COMMON/CI9/AI(MEL)
      DIMENSION POPLL(MLL,MT)
      LOGICAL MASKWR
C*
C* PGJ ADDITION
      CHARACTER*5 CPROV(20)
C* END PGJ ADDITION
      DATA BK/1.380662E-16/,EE/1.602189E-12/,RYD/13.598408/
      SAVE
C* MODIFICATIONS END
C*
C**
      DATA HH/6.626176E-27/,CC/2.99792458E10/,
     * EM/9.109534E-28/,UU/1.6605655E-24/
C**
C
      TETA=5040./T(NTP)
      IF(JP.GT.0)GO TO 7
C
C        1. COMPUTATION OF WAVELENGTH-INDEPENDENT QUANTITIES
C
      HN=1./(XMH*XMY)
      HNH=F1*HN
C        H-
C* H-FF SHOULD BE ADDED IN SEPARATELY TO ALLOW FOR THE FACT THAT THE
C* TABLES INCLUDE STIMULATED EMISSION. THIS IS DONE BY SETTING FAKTL
C* TO ZERO.
      FAKT(1)=PE(NTP)*HNH*1.E-17/XKHM
      FAKT(NKOMP-4)=PE(NTP)*HNH*2.E-26/PART(1,1)
      FAKTL(1,NTP)=1.0
      FAKTL(NKOMP-4,NTP)=0.0
C        HI
      TETA31=31.30364*TETA
C*
      XFAKH=2.0898E-26/PART(1,1)*NHLTE/NHT*HN
      NNIV=15
      XNIV=15.
      IF(H(1).LT.XNIV)NNIV=INT(H(1))
      DO3 M=1,NNIV
      XM2=M*M
      XM3=XM2*FLOAT(M)
C*
      IF(M.LE.5) THEN
        XM5=XM2*XM3
        CHIN=(1.0-1.0/(M*M))*RYD*EE
        BLZFAC=2.0*M*M/PART(1,1)*EXP(-CHIN/BK/T(NTP))
        IF(.NOT.HLTE) THEN
          IF(NHYD(NTP,M).NE.0.0) THEN
            BHYD(NTP,M)=NHYD(NTP,M)/(BLZFAC*NHLTE)
            FAKTL(M+1,NTP)=1.0/BHYD(NTP,M)
          ELSE
            BHYD(NTP,M)=0.0
            FAKTL(M+1,NTP)=1.0
          ENDIF
        ELSE
          NHYD(NTP,M)=BLZFAC*NH
          BHYD(NTP,M)=1.0
          FAKTL(M+1,NTP)=1.0
        ENDIF
        FAKT(M+1)=1.045E-26*NHYD(NTP,M)*(HNH/NH)/XM5
      ELSE
        FAKT(M+1)=XFAKH*EXP(-TETA31*(1.-1./XM2))/XM3
C*
C* 92-04-02 PGJ CHANGES FOR NON-LTE (AND LTE)
C*     IN THIS APPROXIMATION, THE DEPARTURE COEFFICIENTS OF
C*     LEVELS 6-15 ARE ASSUMED TO BE THE SAME AS THE GROUND LEVEL
C*     OF HYDROGEN.  THIS MEANS THAT THESE LEVELS ARE MORE STRONGLY
C*     COUPLED TO THE BOUND LEVELS OF H THAN THE CONTINUUM.
C*     IF THESE LEVELS ARE THOUGHT TO BE STRONGLY BOUND TO THE
C*     CONTINUUM THEN THE FOLLOWING LINE SHOULD BE COMMENTED OUT.
C*
C     *   * NH / NHLTE
C*
C* 92-04-02 PGJ CHANGES END
C*
        FAKTL(M+1,NTP)=1.0
      ENDIF
    3 CONTINUE
      IF(NPIN(NTP).EQ.0.0) THEN
        NPIN(NTP)=NP
      ENDIF
      ONE=1.
      FAKT(NNIV+1)=FAKT(NNIV+1)*MIN(H(1)-NNIV,ONE)
      IF(NNIV.GE.15)GO TO 6
    4 N1=NNIV+1
      DO 5 M=N1,15
        FAKT(M+1)=0.
        FAKTL(M+1,NTP)=1.0
    5 CONTINUE
C*
C*  PHOTOIONIZATION GIVEN LEVEL BY LEVEL
C*  THE CONSTANT 1.438786314 IS H*C/K
C*
C
C*  PGJ: FOLLOWING MATS' SUGGESTION, THE IONIZATION FRACTION IS TAKEN INTO
C*  ACCOUNT TWICE: I.E FACTM CONTAINS ANJON WHICH ALREADY IS NON-LTE
C*                     SHOULD REPLACE FACTM BY LTE VALUE?
C*
C* 89-03-24 START ABUND CHANGED TO ABUNDM
    6 CONTINUE
      DO 100 M=17,NKOMP-6
        IF(ANMET(NTP,M-16).GE. 0.0) THEN
          FAKT(M)=ANMET(NTP,M-16)/toth(ntp)*hn
        ELSE
          BLZFAC=G2L(M)*EXP(-1.438786314*CHIL(M)/T(NTP))
          FAKT(M)=ANJON(IELL(M),IONL(M))*ABUNDM(IELL(M))*HN*
     *     BLZFAC/PART(IELL(M),IONL(M))*BMET(NTP,M-16)
        ENDIF
        FAKTL(M,NTP)=BMETP(NTP,M-16)/BMET(NTP,M-16)
  100 CONTINUE
C* 89-03-24 END
C**               CHANGING AREA   *************
C** SAME THING HERE FOR LINES
      DO 110 L=1,NLL
        BLZFAC=GILL(L)*EXP(-1.438786314*CHILL(L)/T(NTP))
        IF(IELLLL(L).NE.0) THEN
          POPLL(L,NTP)=ANJON(IELLLL(L),IONILL(L))*ABUNDM(IELLLL(L))*
     *     HN*BLZFAC/PART(IELLLL(L),IONILL(L))
C** EXCLUDE: *BMET(NTP,M-16)
C**        FAKT(M,NTP)=BMETP(NTP,M-16)/BMET(NTP,M-16)
        ELSE
          POPLL(L,NTP)=TOTCH(NTP)/TOTH(NTP)*
     *     HN*BLZFAC/QJORG(NTP)
        ENDIF
  110 CONTINUE
C**                               * ***********
C
C        FREE-FREE HI ABSORPTION             
      UMC=2.3026*DXI*TETA
      EXPJ=XFAKH*EXP(-TETA31+UMC)/(2.*TETA31)*
C* 87-05-22 CORRECTION FOR NON-LTE
C* 92-04-03 PGJ CORRECTION.
C*
C*    THIS STATEMENT WAS INCORRECT
C*    IN THE ORIGINAL VERSION.  THE PROBLEM LEAD TO VAST OPACITIES
C*    AT LOW TEMPERATURES SINCE THE POPULATIONS OF THE HIGHER - N
C*    AND FREE LEVELS OF HYDROGEN WERE OVERESTIMATED 
C*    
C*    ORIGINAL CODE:
C*
C*     *  ANJON(1,1)/ANJON(1,2)*NP/NH
C*
C*    FIRST CORRECTION (INCORRECT)
C*
C*     *  NH/NHLTE
C*
C*    FINAL CORRECTION.  THIS WORKS BECAUSE NHLTE IS THE POP. OF
C*    NEUTRAL H ATOMS REQUIRED TO MAKE THE CORRECT NUMBER OF PROTONS
C*    AT THE GIVEN NE, NP AND TE.  THUS, THE OPACITY IS CORRECTLY 
C*    GIVEN ALREADY WIOTH NO FURTHER NEED FOR CORRECTIONS FOR NLTE.
C*    NOTICE THAT, FOR LEVELS WITH N GT 15, THE LEVELS ARE ASSUMED HERE
C*    TO BE STRONGLY BOUND TO THE CONTINUUM SO THAT THE OPACITY IS
C*    CORRECTLY GIVEN BY THE LTE POPNS RELATIVE TO THE NUMBER OF PROTONS
C*    AND ELECTRONS.
C*    TO RELAX THIS ASSUMPTION, THE FACTOR NH/NHLTE MUST BE USED
C*    TO MULTIPLY THE TERM HREST ONLY
     *  1.0 
C*
C* 92-04-03 END PGJ CORRECTION.
C*
      ADDF=EXP(TETA31/((FLOAT(NNIV)+0.5)**2)-UMC)-1.
      IF(H(1).LT.XNIV+0.5)ADDF=0.
      FAKT(NKOMP-5)=EXPJ
      FAKTL(NKOMP-5,NTP)=1.0
      HREST(NTP)=EXPJ*ADDF
C
C        H+H
      HNH25=HNH*1.E-25
      FAKT(NKOMP-3)=HNH25*HNH25*RO
      FAKTL(NKOMP-3,NTP)=1.0
C        H2+
      HNH20=HNH*1.E-20
      FAKT(NKOMP-2)=HNH20*HNH20*RO*ANJON(1,2)/ANJON(1,1)
      FAKTL(NKOMP-2,NTP)=1.0
C        H2-
      FAKT(NKOMP-1)=PE(NTP)*F5*HN
      FAKTL(NKOMP-1,NTP)=1.0
C        HE-
      FAKT(NKOMP)=PE(NTP)*ANJON(2,1)*ABUND(2)*HN
      FAKTL(NKOMP,NTP)=1.0
C        ELECTRON SCATTERING
      ELS(NTP)=4.8206E-9*PE(NTP)/(T(NTP)*RO)
C        RAYLEIGH SCATTERING
      FAKRAY(NTP)=HNH*2./PART(1,1)
      H2RAY(NTP)=F5*HN
      RETURN
C        N O T E . APART FROM VECTORS HREST AND ELS, NONE OF THE
C        TEMPERATURE- OR PRESSURE-DEPENDENT VARIABLES DEFINED ABOVE CAN
C        GENERALLY BE USED AT THE NEXT VISIT BELOW.
C        ANY SET OF FACTORS WHICH IS WANTED SHOULD BE STORED IN AN ARRAY WITH
C        DIMENSION = NT, LIKE HREST AND ELS, OR IN FAKT, WHERE THE DATA FOR
C        FURTHER USE ARE STORED IN SUBR. ABSKO.
C
C        2. WAVELENGTH-DEPENDENT FACTORS. SUMMATION.
C        CORRECTION FOR STIMULATED EMISSION
    7 EXPA=EXP(-28556.*TETA/XLA(JP))
   11 STIM=1.-EXPA
C
C        ABSORPTION
C*
C* 87-05-25 MODIFICATIONS FOR NON-LTE
C* SUMABS IS CORRECTED INDIVIDUALLY FOR STIMULATED EMISSION
C* ABSLTE IS COLLECTIVELY CORRECTED
C* ABSLTE IS LTE ABSORPTION CALCULATED USING ACTUAL ION
C* DENSITIES AND LTE SAHA RELATION. ABSLTE IS USED FOR
C* CALCULATING THE RECOMBINATION PART OF THE BACKGROUND
C* SOURCE FUNCTION
C*
      SUMABS=0.
      ABSLTE(NTP)=0.
C        H I
      IF(KMPEXC.LT.2 .OR. KMPEXC.GT.16) THEN
        DO 12 KOMP=2,16
          SUMABS=SUMABS+AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA)
          ABSLTE(NTP)=ABSLTE(NTP)+AB(KOMP)*FAKTL(KOMP,NTP)
   12   CONTINUE
      ELSE
        DO 121 KOMP=2,KMPEXC-1
          SUMABS=SUMABS+AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA)
          ABSLTE(NTP)=ABSLTE(NTP)+AB(KOMP)*FAKTL(KOMP,NTP)
  121   CONTINUE
        DO 122 KOMP=KMPEXC+1,16
          SUMABS=SUMABS+AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA)
          ABSLTE(NTP)=ABSLTE(NTP)+AB(KOMP)*FAKTL(KOMP,NTP)
  122   CONTINUE
      ENDIF
      if(xla(jp).le.207216) then
        SUMABS=(SUMABS+HREST(NTP)*STIM)*XLA3(JP)
      else
        SUMABS=SUMABS*XLA3(JP)
      endif
      PROV(1,NTP)=SUMABS
      PROV(2,NTP)=AB(NKOMP-5)*XLA3(JP)*STIM
      SUMABS=SUMABS+AB(NKOMP-5)*XLA3(JP)*STIM
      ABSLTE(NTP)=ABSLTE(NTP)+AB(NKOMP-5)*FAKTL(NKOMP-5,NTP)
      if(xla(jp).le.207216) then
        ABSLTE(NTP)=(ABSLTE(NTP)+HREST(NTP))*XLA3(JP)
      else
        ABSLTE(NTP)=ABSLTE(NTP)*XLA3(JP)
      endif
C        H-, STIMULATED EMMISION INCLUDED IN TABLES FOR FF
C  FAKTL FOR H-FF IS SET TO ZERO. H-FF IS THEREFORE ADDED INTO
C  ABSLTE BUT NOT SUMABS
C
C     MODIFICATION: INCLUDED MULTIPLICATION FACTORS TO
C     CONSIDER THE EFFECT OF LINE OPACITIES. SEE BRULS ET AL. 1992;
C     FACTORH:   MULTIPLICATION FACTOR APPLIED TO H- OPACITY
C     FACTORM:   MULTIPLICATION FACTOR APPLIED TO TOTAL METAL OPACITY
C
C     THE MULTIPLICATION FACTOR IS IMPLEMENTED ONLY IF THE 
C     VARIABLE LFLAG IS SET TO 2
C
C     (RC)

      FACTORH = 1.0      
      IF (LFLAG.EQ.2 .AND.
     &     XLA(JP) .GE.2100.0 .AND. XLA(JP) .LE.3000.0) THEN
           FACTORH = 8.0 - 7.778D-3 * (XLA(JP)-2100.0)
      ELSE
         FACTORH = 1.0
      ENDIF

C COMMENT OUT NEXT LINE NOT TO INCLUDE FACTORH
      AB(1) = FACTORH * AB(1)
     
      SUMABS=SUMABS+AB(1)*STIM
      ABSLTE(NTP)=ABSLTE(NTP)+AB(1)+AB(NKOMP-4)/STIM
C
C  ADD IN ALL NON-HYDROGEN CONTRIBUTIONS
C

C MULTIPLICATION FACTORS APPLIED TO TOTAL METAL OPACITY

      FACTORM =1.0
      IF (LFLAG.EQ.2 .AND. XLA(JP).GT. 1500.0
     &       .AND. XLA(JP) .LE. 1700.0) FACTORM = 2.0 

      IF (LFLAG.EQ.2 .AND. XLA(JP).GT. 1700.0
     &       .AND. XLA(JP) .LE. 1850.0) FACTORM = 16.0

      IF (LFLAG.EQ.2 .AND. XLA(JP).GT. 1850.0 
     &       .AND. XLA(JP) .LE. 2100.0) THEN 
         FACTORM = 2.0
      ELSE	
         FACTORM = 1.0
      ENDIF
      	 

      IF(KMPEXC.LT.17) THEN
        DO 13 KOMP=17,NKOMP
C COMMENT OUT NEXT LINE NOT TO INCLUDE FACTORM
          AB(KOMP) = AB(KOMP) * FACTORM 
          SUMABS=SUMABS+AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA)
          ABSLTE(NTP)=ABSLTE(NTP)+AB(KOMP)*FAKTL(KOMP,NTP)
   13   CONTINUE
      ELSE
        DO 131 KOMP=17,KMPEXC-1
C COMMENT OUT NEXT LINE NOT TO INCLUDE FACTORM
          AB(KOMP) = AB(KOMP) * FACTORM
          SUMABS=SUMABS+AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA)
          ABSLTE(NTP)=ABSLTE(NTP)+AB(KOMP)*FAKTL(KOMP,NTP)
  131   CONTINUE
        DO 132 KOMP=KMPEXC+1,NKOMP
C COMMENT OUT NEXT LINE NOT TO INCLUDE FACTORM
          AB(KOMP) = AB(KOMP) * FACTORM
          SUMABS=SUMABS+AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA)
          ABSLTE(NTP)=ABSLTE(NTP)+AB(KOMP)*FAKTL(KOMP,NTP)
  132   CONTINUE
      ENDIF
C**                  *****************************
C**                  *****************************
C**   NEW AND CHANGED CODE.
C**   LINE OPACITIES CONTRIBUTE TO BOTH SUMABS AND SUMSCA.
C**   THE FRACTION DELTA OF ABSORPTION IS SET TO 1.0 IF 
C**   ISOUL=1. IF ISOUL=2 IT IS CALCULATED FROM
C**   THE LIFETIME OF THE LEVEL AND THE COLLISIONAL RATE
C**   FROM THE VAN REGEMORTER APPROXIMATION.
C**   MUST INITIALISE SUMSCA.
      SUMSCA = 0.0
C     LINE OPACITIES
      DO 133 L=1,NLL
        IF(FLL(L).EQ.0.0) GOTO 133
        IF (XLA(JP).LT.REDLL(L) .AND. XLA(JP).GT.BLUELL(L)) THEN
          IF(IELLLL(L).NE.0) THEN
            PIONLL=XIONG(IELLLL(L),IONILL(L))
            AWGT = AI(IELLLL(L))*UU
          ELSE
            PIONLL=15.
            AWGT = 13.*UU
          ENDIF
          CHIEV=CHILL(L)*CC *HH/EE
          CHJEV=CHJLL(L)*CC *HH/EE
          PROF = PROFLL(XLA(JP),ALAMLL(L),GALL(L),GWLL(L),GQLL(L),
     *     IONILL(L),PIONLL,CHIEV,CHJEV,AWGT,TOTHI(NTP),QNORML,NTP)
C**   VAN REGEMORTERS APPROXIMATION IS USED FOR COLLISIONAL RATE.
          IF(ISOUL.EQ.2 .AND. IELLLL(L).NE.0) THEN
            COLL = SEMIC(IONILL(L),CHJLL(L),CHILL(L),
     *       FLL(L)*GILL(L)/GJLL(L),T(NTP),III)
            COLL = COLL * PE(NTP)/XKBOL/T(NTP)*(1.0-EXPA)
            AUL = GILL(L)/GJLL(L)*6.67E15/ALAMLL(L)**2 * FLL(L)
            DELTA = COLL/(AUL+COLL)
          ELSE
            DELTA = 1.0
          ENDIF
          XLINE = FLL(L)*POPLL(L,NTP)*PROF
          SUMABS = SUMABS + XLINE*(1.0-EXPA)*DELTA
          ABSLTE(NTP) = ABSLTE(NTP) + XLINE*DELTA
          SUMSCA = SUMSCA + XLINE*(1.-DELTA)
        ENDIF
  133 CONTINUE
C**                  *****************************
C**                  *****************************
C
C     THE ADDITION OF A MULTIPLICATIVE FACTOR TO SUMABS TO
C     SIMULATE THE MISSING UV OPACITY.  THE FORM IS
C     A(LAMDA)=A + B*LAMD
C     FLES=ALES+BLES*1.E-03*XLA(JP)
C     IF(FLES.LT.0.0) FLES=0.0
C     XSUMAB=FLES*SUMABS
C     SUMABS=SUMABS+XSUMAB
C     XSPC=XSUMAB/SUMABS
C     IF(XLA(JP).LT.2600. .AND. XLA(JP).GT.2200.) WRITE(6,1122)
C    *JP,XLA(JP),FLES,SUMABS,XSUMAB,XSPC
C1122 FORMAT(1X,' JP=',I5,5F12.4)
C
C        HERE FURTHER ABSORPTION MECHANISMS, GIVEN IN TABLES OR BY
C        ANALYTICAL EXPRESSIONS, MAY BE ADDED.
      ABSLTE(NTP)=ABSLTE(NTP)*STIM
C
C        SCATTERING
C* CONSTANT 1026. REPLACED BY VARIABLE TO FACILITATE TRANSITION TO DP
C* 90-02-12 RAYH SET TO 0. FOR XLA LT 911
      XLIMIT=1026.
      XRAY=MAX(XLA(JP),XLIMIT)
      XRAY2=1./(XRAY*XRAY)
      IF(XLA(JP).LT.911.) XRAY2=0.0
C* END CHANGE
      RAYH=XRAY2*XRAY2*(5.799E-13+XRAY2*(1.422E-6+XRAY2*2.784))*
     *FAKRAY(NTP)
      RAYH2=XRAY2*XRAY2*(8.14E-13+XRAY2*(1.28E-6+XRAY2*1.61))*H2RAY(NTP)
C*** ADD SUMSCA TO SUMSCA FROM LINES
      SUMSCA=SUMSCA+ELS(NTP)+RAYH+RAYH2
C***
C
      IF(J.GT.0)GO TO 15
C
C        WEIGHT FOR A ROSSELAND MEAN
   14 VIKTR=1./EXPA*STIM*STIM*XLA3(JP)*XLA3(JP)
   15 CONTINUE
C
C* 87-11-02  MODIFICATIONS:
C* IWOPTN GOVERNS PRINTOUT, BINARY SWITCHES:
C*   1 OPACITY CONTRIBUTIONS
C*   2 PARTIAL PRESSURES
C*   4 IONIZATION FRACTIONS, PARTITION FUNCTIONS
C*
C
      IF(.NOT.MASKWR(IWOPTN,0)) GOTO 23
C KL disabled next line 
C      IF(IOUTR-1)23,21,20
C
C        **** PRINT-OUT ****
C KL disabled to avoid huge out-file, but still have opacities in IDLOPC
C   20 WRITE(IWRIT,200) CONVL(XLA(JP))
C  200 FORMAT(////'  O P A C I T I E S    LAMBDA=',F10.2/
C     * 16X,'PERCENTAGES OF CONTINUOUS OPACITY'/
C     * '   K    OPACITY',3X,
C     * ' HBF  HFF H-BF H-FF  H2-  H2+  H+H  HE-   HE   SI   MG   AL',
C     * '   FE    C    N    O ELECT R(H) (H2) (HE)',3X,
C     * 'ABS  SCAT'/)
C
C  OPEN IDL OUTPUT FILE IF FIRST WAVELENGTH
C
      IF(JP.EQ.1) CALL MOPEN(LIDLO,'IDLOPC',0,'NEW')
      WRITE(LIDLO) REAL(XLA(JP))
C
   21 CONTINUE
C
C  STORE OPACITIES FOR PRINTOUT
C
      DO 211 M=1,NEL
        CNTRB(M)=0.0
  211 CONTINUE
      DO 212 KOMP=17,NKOMP-6
        IF(KOMP.NE.KMPEXC) CNTRB(IELL(KOMP))=CNTRB(IELL(KOMP))+
     *   AB(KOMP)*(1.0-FAKTL(KOMP,NTP)*EXPA)
  212 CONTINUE
      PROV(3,NTP)=AB(1)*STIM
C*
C* FOLLOWING CHANGED (89-03-06) P. JUDGE
C  FIND ELEMENT NUMBERS FOR MAJOR METALS
C
      IF(JP.EQ.1) THEN
        DO 300 I=1,NEL
          IF(CEL(I)(1:2).EQ.'HE') IHE=I
          IF(CEL(I)(1:2).EQ.'SI') ISI=I
          IF(CEL(I)(1:2).EQ.'MG') IMG=I
          IF(CEL(I)(1:2).EQ.'AL') IAL=I
          IF(CEL(I)(1:2).EQ.'FE') IFE=I
          IF(CEL(I)(1:2).EQ.'C ') IC=I
          IF(CEL(I)(1:2).EQ.'N ') IN=I
          IF(CEL(I)(1:2).EQ.'O ') IO=I
  300   CONTINUE
      ENDIF
      PROV(4,NTP) = AB(NKOMP-4)
      PROV(5,NTP) = AB(NKOMP-1)* (1.0E0-FAKTL(NKOMP-1,NTP)*EXPA)
      PROV(6,NTP) = AB(NKOMP-2)* (1.0E0-FAKTL(NKOMP-2,NTP)*EXPA)
      PROV(7,NTP) = AB(NKOMP-3)* (1.0E0-FAKTL(NKOMP-3,NTP)*EXPA)
      PROV(8,NTP) = AB(NKOMP)* (1.0E0-FAKTL(NKOMP,NTP)*EXPA)
      PROV(9,NTP) = CNTRB(IHE)
      PROV(10,NTP) = CNTRB(ISI)
      PROV(11,NTP) = CNTRB(IMG)
      PROV(12,NTP) = CNTRB(IAL)
      PROV(13,NTP) = CNTRB(IFE)
      PROV(14,NTP) = CNTRB(IC)
      PROV(15,NTP) = CNTRB(IN)
      PROV(16,NTP) = CNTRB(IO)
      PROV(17,NTP) = ELS(NTP)
      PROV(18,NTP) = RAYH
      PROV(19,NTP) = RAYH2
      PROV(20,NTP) = 0.0E0
      CHI=SUMABS+SUMSCA
C* END 89-03-06 ALTERATION
C* 
C* PGJ ALTERATION: WRITE BLANKS INSTEAD OF ZEROS
C*         
      DO 303 KP=1,20
         IF(PROV(KP,NTP)/CHI*1.0D2 .LT. 0.1E0)THEN
           CPROV(KP)(1:5)='     '
         ELSE
           WRITE(CPROV(KP)(1:5),FMT='(F5.1)')
     *     PROV(KP,NTP)/CHI*1.0D2
         ENDIF
  303 CONTINUE
C KL unmark 3 rows
C      WRITE (IWRIT,FMT=201) NTP,CHI, (CPROV(KP),KP=1,20),
C     +  SUMABS/CHI,SUMSCA/CHI

C  201   FORMAT (1X,I3,1X,1P,E10.3,2X,16A5,1X,4A5,2P,2F6.1)
C* END PGJ ALTERATIONS
C*
      WRITE(LIDLO) NTP,REAL(CHI),(REAL(PROV(KP,NTP)),KP=1,20),
     * REAL(SUMABS),REAL(SUMSCA)
   23 CONTINUE
C
      RETURN
      END
C
C **********************************************************************
C
      LOGICAL FUNCTION MASKWR(I,IBIT)
C
C  CHECKS BIT NUMBER IBIT OF INTEGER I AND RETURNS TRUE IF BIT IS ONE
C
      INCLUDE 'PREC'
      MASKWR=MOD(I/(2**IBIT),2).EQ.1
C
      RETURN
      END
C
C*******************************************************************************
C
      SUBROUTINE CORONA(CEL,ION,TEMP,PRESS,FR1)
C
C  CORONAL ION BALANCE CALCULATION
C  NEW ROUTINE FOR VERSION 2.0 OPACITY PACKAGE
C
C  INPUT:  ELEMENT IDENTIFIER    CEL (CHARACTER*3)
C          ION STAGE IDENTIFIER  ION (INTEGER)
C          TEMP   (ELECTRON TEMPERETURE IN K       (RL)
C          PRESS  (ELECTRON PRESSURE IN DYNE/CM2)  (RL)
C
C  OUTPUT: FR1   THE RATIO OF THE ION STAGE  ION TO THE ION STAGE ION+1
C  
C  EXAMPLE:
C          CEL='C  ', ION=1, WILL RETURN FR1= N(C II) / N(C I) IN CORONAL LIMIT
C
C  NOTES:
C          COMPUTATIONS FROM TABLES OF SHULL & VAN STEENBERG, 
C          AP J SUPPL  48 P95
C          NO PE-DEPENDENCE, THIS COULD BE ADDED WHEN COMPUTATIONS BECOME
C          AVAILABLE
C          IF THE ION FRACTION IS NOT FOUND THEN THE VALUE FR1 IS SET =
C          -1
C  88-04-26 NEW ROUTINE (PHILIP JUDGE)
C
C:        92-07-20  MODIFICATIONS (MATS CARLSSON)
C:        INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS
C:
      INCLUDE 'PREC'
      PARAMETER (MCOR=30)
      INTEGER NCOR,IONCOR(MCOR)
      DOUBLE PRECISION ARADC(MCOR),XRADC(MCOR),ADIC(MCOR),T0C(MCOR),
     * BDIC(MCOR),T1C(MCOR),ACOLC(MCOR),TCOLC(MCOR),TECOR,DECOR
      COMMON /CCORON/ TECOR,DECOR,
     * ARADC,XRADC,ADIC,T0C,BDIC,T1C,ACOLC,TCOLC,NCOR,IONCOR
      CHARACTER*3 CCOR
      COMMON /CCCOR/ CCOR(MCOR)
      COMMON /CLU/ LINPUT,LATOM,LATOM2,LATMOS,LDSCAL,LABUND,LOUT,
     * LTIME,LRSTRT,LDSCA2,LWMAT,LNIIT,LDUMS,LDUMI,LDUMC,LOPC,
     * LJNY,LINIT,LPHI,LJOBLO,LATHSE
      CHARACTER*(*) CEL
C
C  IDENTIFY THE ELEMENT AND IONIZATION STAGE TO BE COMPUTED
C
      DO 100 N=1,NCOR
        IF( CEL .EQ. CCOR(N) .AND. ION .EQ. IONCOR(N) )GOTO 99
  100 CONTINUE
      WRITE(LJOBLO,FMT=1000)CEL,ION
 1000  FORMAT(' CORONA: SPECIES',A3,I3,' NOT FOUND IN ABSDAT FILE'
     * ,      '         SPECIES COMPUTED IN LTE')
      FR1=-1.E0
      RETURN
C
C  ELEMENT HAS BEEN COMPUTED- NOW RETURN THE ION FRACTION
C
   99 RRATE=ARADC(N)*(TEMP/1.E4)**(-XRADC(N))  +     
     +  ADIC(N) * (TEMP**(-1.5)) * EXP(-T0C(N)/TEMP)*
     +  (1.E0+BDIC(N) * (EXP(- T1C(N)/TEMP)))
      RIRATE=ACOLC(N) * SQRT(TEMP) * EXP( -TCOLC(N) / TEMP)
     +    / (1.E0 + 0.1 * TEMP / TCOLC(N))
      FR1=RIRATE/RRATE
      RETURN
      END
C
C***************************************************************************
C
      SUBROUTINE RCORON(IFILE)
C
C  READS CORONAL ION BALANCE PARAMETERS
C  NEW ROUTINE FOR VERSION 2.0 OPACITY PACKAGE
C
      INCLUDE 'PREC'
      PARAMETER (MCOR=30)
      INTEGER NCOR,IONCOR(MCOR)
      DOUBLE PRECISION ARADC(MCOR),XRADC(MCOR),ADIC(MCOR),T0C(MCOR),
     * BDIC(MCOR),T1C(MCOR),ACOLC(MCOR),TCOLC(MCOR),TECOR,DECOR
      COMMON /CCORON/ TECOR,DECOR,
     * ARADC,XRADC,ADIC,T0C,BDIC,T1C,ACOLC,TCOLC,NCOR,IONCOR
      CHARACTER*3 CCOR
      COMMON /CCCOR/ CCOR(MCOR)
      CHARACTER *80 CARD
      PARAMETER (MCORO=16)
      INTEGER KELEM(MCORO)
      CHARACTER*3 CELEM(MCORO)
      DATA CELEM /'H  ','HE ','C  ','N  ','O  ', 
     *     'NE ','NA ','MG ','AL ','SI ','S  ','K  ','CA ','CR ',
     *     'FE ','NI '/
      DATA KELEM /1,2,6,7,8,10,11,12,13,14,16,19,20,24,26,28/
C
      READ(IFILE,10000)CARD
10000 FORMAT(A)
      READ (IFILE,*)NCOR,TECOR,DECOR
      DO 100 N=1,NCOR
        READ(IFILE,*)ICOR,IONCOR(N),ACOLC(N),TCOLC(N),ARADC(N),
     *  XRADC(N),ADIC(N),BDIC(N),T0C(N),T1C(N)
C 
C  USE ICOR ELEMENT NUMBER AND KELEM ARRAY TO ASSIGN CCOR
C  FOR LATER USE (IN ROUTINE CORONA)
C
        DO 200 I=1,MCORO
          IF (ICOR .EQ. KELEM(I)) CCOR(N) = CELEM(I)
  200   CONTINUE
 100  CONTINUE
      RETURN
      END
C
C**********************************************************************************
C
      SUBROUTINE INLIN
C
C  READS ABSLIN FILE WITH DATA FOR BACKGROUND OPACITIES FROM LINES
C  ONLY ELEMENTS INCLUDED IN ABSDAT CAN BE TREATED
C
C  VARIABLES:
C
C  NLL    NUMBER OF LINES
C  SRCELL DESCRIPTIVE COMMENT LINE
C  ABNILL STRING GIVING LABEL FOR LOWER LEVEL, STANDARD FORMAT
C  IONILL IONIZATION STAGE FOR LOWER LEVEL, 1=NEUTRAL
C  CHILL  EXCITATION POTENTIAL, LOWER LEVEL. CM^-1.
C  GILL   STATISTICAL WEIGHT, LOWER LEVEL
C  ABNJLL SAME FOR UPPER LEVEL
C  IONJLL
C  CHJLL
C  GJLL
C  ALAMLL VACUUM WAVELENGTH FOR TRANSITION
C  BLUELL LIMITING BLUE WAVELENGTH FOR LINE INFLUENCE ON OPACITY
C  REDLL  LIMITING RED  WAVELENGTH FOR LINE INFLUENCE ON OPACITY
C  FLL    OSCILLATOR STRENGTH
C  GALL   BROADENING RADIATIVE DAMPING PARAMETER GA (SEE ATOM)
C  GWLL   BROADENING VAN DER WAALS PARAMETER GW (SEE ATOM)
C  GQLL   BROADENING STARCK PARAMETER GQ (SEE ATOM)
C
C:
C: INLIN  94-03-23  NEW ROUTINE (MATS CARLSSON, DAN KISELMAN)
C:
      INCLUDE 'PREC'
      INCLUDE 'CALIN'
      INCLUDE 'CCONST'
      INCLUDE 'C3D'
C
      CHARACTER*80 TEXT    
C
      IF(L3D) THEN
        CALL MOPEN(LLIN,'ABSLIN',1,'OLD')
      ELSE
        CALL MOPEN(LLIN,'DUMS4',1,'NEW') 
        CALL CSTRI2(LDUMS2,LLIN,'ABSLIN')
      ENDIF
C
C  READ NUMBER OF LINES
C
      READ(LLIN,*) NLL
      IF (NLL.GT.MLL) CALL STOP('INLIN: NLL .GT. MLL')
C
C  READ DATA FOR LINES
C
      DO 200 L=1,NLL
C
C  SOURCE - A DESCRIPTIVE COMMENT LINE
C
        READ(LLIN,100) TEXT
        CALL LJUST(TEXT)
        SRCELL(L) = TEXT(1:20)
C
C  LOWER LEVEL
C
        READ(LLIN,100) TEXT
  100   FORMAT(A)
        CALL LJUST(TEXT)
        ABNILL(L) = TEXT(1:20)
        CALL LJUST(ABNILL(L))
        READ(LLIN,*) IONILL(L), CHILL(L), GILL(L)
C
C  UPPER LEVEL
C
        READ(LLIN,100) TEXT
        CALL LJUST(TEXT)
        ABNJLL(L) = TEXT(1:20)
        CALL LJUST(ABNJLL(L))
        READ(LLIN,*) IONJLL(L), CHJLL(L), GJLL(L)
C
C  SPECTRAL LINE QUANTITIES
C
        READ(LLIN,*) ALAMLL(L), BLUELL(L), REDLL(L)
        READ(LLIN,*) FLL(L), GALL(L), GWLL(L), GQLL(L)
C
  200 CONTINUE
      DO 300 L=1,NLL
        CALL ELMCLL(L)
  300 CONTINUE
C
      CALL CLOSE(LLIN)
      RETURN
      END
C
C **********************************************************************
C
      SUBROUTINE ELMCLL(LL)
C
C  FINDS ELEMENT NUMBER CORRESPONDING TO ABSORPTION COMPONENT
C  ABNAME(KOMP). THIS IS DONE BY COMPARING THE FIRST TWO LETTERS
C  IN ABNAME WITH THE ARRAY IEL READ BY INJON
C
C: ELMCLL 94-03-08  NEW ROUTINE (DAN KISELMAN)
C:        NEW ROUTINE THAT DOES THE SAME THING FOR LINE DATA
C:        AS ELMCMP DOES FOR LEVEL DATA. IDENTIFICATION IS BASED
C:        ON LOWER LEVEL OF LINE - ABNILL.
C:        THE RESULT IS THE ARRAY IELLLL
C:
C:        03-10-13  MODIFICATIONS (MATS CARLSSON)
C:        ADDED SUPPORT FOR CH
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAMO'
C
      COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4),
     *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL
      CHARACTER*3 CEL
      COMMON/CC1/CEL(MEL)
C
      INCLUDE 'CALIN'
C
      COMMON /CLU/ LINPUT,LATOM,LATOM2,LATMOS,LDSCAL,LABUND,LOUT,
     * LTIME,LRSTRT,LDSCA2,LWMAT,LNIIT,LDUMS,LDUMI,LDUMC,LOPC,
     * LJNY,LINIT,LPHI,LJOBLO,LATHSE
C
      CHARACTER*20 TEXT
C
      TEXT=ABNILL(LL)
      CALL LJUST(TEXT)
      IF(TEXT(1:2).EQ.'CH') THEN
        IELLLL(LL)=0
        RETURN
      ENDIF
      DO 200 I=1,NEL
        IF(TEXT(1:2).EQ.CEL(I)(1:2)) GOTO 300
  200 CONTINUE
      WRITE(LJOBLO,210) TEXT(1:2)
  210 FORMAT(' ELMCLL: ELEMENT ',A,' NOT FOUND')
      CALL STOP(' ')
C
  300 CONTINUE

      IELLLL(LL)=I
C
      END
C
C **********************************************************************
C
      FUNCTION PROFLL(ALAMD,ALAMB,GA,GW,GQ,ION,PION,CHIEV,CHJEV,
     *       AWGT,TOTHI,QNORM,K)
C
C  CALCULATES HNY4P*B(I,J)*PHI IN UNITS CM**2/PARTICLE
C  VARIABLES:
C  ALAMD    VACUUM WAVELENGTH WHERE PROFILE IS TO BE CALCULATED
C  ALAMB    VACUUM WAVELENGTH FOR CENTER OF LINE
C  GA,GW,GQ BROADENING PARAMETERS, SEE ATOM
C  ION      IONIZATION DEGREE
C  PION     IONIZATION POTENTIAL FROM GROUND STAGE (ELECTRON VOLTS)
C  CHIEV    EXCITATION POTENTIAL OF LOWER LEVEL (ELECTRON VOLTS)
C  CHJEV    EXCITATION POTENTIAL OF UPPER LEVEL (ELECTRON VOLTS)
C  AWGT     ATOMIC WEIGHT IN CGS UNITS OF ABSORBER
C  TOTHI    NUMBER DENSITY OF NEUTRAL HYDROGEN
C  K        DEPTH POINT INDEX
C  
C  LINE OPACITY IS XLIN=N(LOWER LEVEL)*FLL*(1.-EXP(HNY/KT))*PROFLL
C  THERMODYNAMIC VARIABLES ARE TRANSFERRED IN COMMON CATMOS AND
C  CATMO2. NOTE THAT MANY OF THE LOCAL VARIABLES HAVE NAMES
C  IDENTICAL WITH ARRAYS IN MULTI. CATOM CAN THEREFORE NOT
C  BE INCLUDED AS A COMMON-BLOCK
C
C:
C: PROFLL 94-03-23  NEW ROUTINE: (MATS CARLSSON, DAN KISELMAN)
C:
C:        00-11-27  MODIFICATIONS: (PAUL BARKLEM)
C:        ABO THEORY X-SECTIONS IMPLEMENTED
C:        IF GW > 20. ASSUMED X-SECTION DATA
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'CATMOS'
      INCLUDE 'CATMO2'
      INCLUDE 'CCONST'
C
      DATA IDEBUG/0/
      SAVE IDEBUG
C
      T=TEMP(K)
C
C  CALCULATE DOPPLER WIDTH
C
      DNYD=SQRT(2.*BK*T/AWGT)*1.E-5/QNORM
C
C  INCLUDE MICROTURBULENCE
C
      DNYD=SQRT(DNYD**2+VTURB(K)**2)
C
C  CALCULATE GAMMA, ADAMP
C
      IF(GW.GE.20.0) THEN
        GV=GW
        SIGMA=INT(GV)*2.80028E-21
        XALPHA=GV-INT(GV)
        GX=2.-XALPHA*.5
        GX=GX-1.0
        GAMMAF=1+(-.5748646+(.9512363+(-.6998588+
     *     (.4245549-.1010678*GX)*GX)*GX)*GX)*GX
        GV=(4./PI)**(XALPHA*0.5)*GAMMAF*1.E4*SIGMA
        VBAR=SQRT(21173.*T*(1./1.008+1./(AWGT/UU)))
        GV=GV*((VBAR/1.E4)**(1.-XALPHA))
        GV=GV*TOTHI*1.E6*2.
      ELSEIF(GW.NE.0.0) THEN
        ZZ=ION
        C625=1.283984E-12*ZZ**0.8*(ABS(1./(PION-CHJEV)**2-
     *                           1./(PION-CHIEV)**2))**.4
        GV=GW*8.411*(8.*BK*T/PI*(1./(1.008*UU)+1./AWGT))**0.3*
     *   TOTHI*C625
      ELSE
        GV=0.0
      ENDIF
      GR=GA
      IF(GQ.GE.0.0) THEN
        GS=GQ*NE(K)
      ELSE
C       FORMULA FROM GRAY, P.237
        GSLG=19.4+2./3.*GQ+LOG10(NE(K)*BK)+LOG10(T)/6.
        GS=10.**GSLG
      ENDIF
C
      GAMMA=GR+GV+GS
C
C  DNYD*QNORM IS IN UNITS OF KM/S
C  DOP        IS IN UNITS HZ
C
      DOP=DNYD*QNORM/ALAMB*1.E13
      ADAMP=GAMMA/(4.*PI*DOP)
C
C  Q IS DELTA(NY) IN UNITS OF A TYPICAL DOPPLER WIDTH
C  V IS DELTA(NY)/DNYD, UNITLESS
C
      Q = (CC/ALAMD - CC/ALAMB)*ALAMB*1.E-5/QNORM
      V=(Q-VEL(K))/DNYD
C
      CALL VOIGT(ADAMP,V,H)
      PHI=H/(DNYD*1.772453851)
C
C  PHI IS IN UNITS OF PER TYPICAL DOPPLER WIDTH
C  WE NOW CONVERT TO CM^2 PER PARTICLE AT FLL=1.0 BY
C  MULTIPLYING WITH HNY4P*B(I,J). FOLLOW MULTI NOTATION TO
C  SIMPLIFY COMPARISON
C  RELATION BETWEEN B(I,J) AND FLL IS:
C  HH*NU/(4*PI)*B(I,J)=PI*ESU^2/(EM*CC)*FLL 
C  WE CONTINUE TO USE THE FORM FROM MULTI, SUBROUTINE ATOM
C  BIJ=ALAMB/HC2*FLL*6.671E15
C
      HNY4P=HH*CC/QNORM/4./PI*1.E-5
      FLL=1.00
      HC2=2.*HH*CC*1.E24
      BIJ=FLL*ALAMB/HC2*6.671E15
C
      PROFLL=HNY4P*BIJ*PHI
      if(idebug.eq.1) then 
        print *,'dnyd    =',dnyd
        print *,'adamp   =',adamp
        print *,'gv      =',gv
        print *,'c625    =',c625
        print *,'awgt    =',awgt
        print *,'hh,cc,bk=',hh,cc,bk
        print *,'bij     =',bij
        print *,'phi     =',phi
        print *,'hny4p   =',hny4p
        print *,'h       =',h
        print *,'profll  =',profll
      endif
C
      RETURN
      END
      subroutine gencol
c:
c: gencol 87-05-21  new routine: (philip judge)
c:        general collisonal routine reading tables
c:
c:        07-01-29  modifications: (mats carlsson)
c:        gencol split into rcoll (reads data) and gencl (interpolation)
c:        to enable multiple calls to gencol without rereading atom file
c:        especially important for _3d version
c:        based on gencol for radyn
c:
      logical fcall
      data fcall/.true./
      save fcall
c
      if(fcall) then
        call rcoll
        fcall=.false.
      endif
      call gencl
c
      return
      end
c
c********************************************************************
c
      subroutine rcoll
c
c  general routine for reading collisional data
c  is to be used to read data for gencol
c
c: rcoll  07-01-29  new routine: (mats carlsson)
c:        gencol split into rcoll (reads data) and gencol (interpolation)
c:        to enable multiple calls to gencol without rereading atom file
c:        especially important for _3d version
c:        based on rcoll for radyn
c:
      include 'PREC'
      include 'PARAM'
      include 'CATOM'
      include 'CCONST'
      include 'CLU'
      include 'C3D'
      include 'CGENCL'
c
c  local variables: up to mtgrd points in temperature grid allowed
c  this can be increased
c
      dimension tgrid(mtgrd),cgrid(mtgrd),work(mtgrd,6)
      character*80 errmsg,text
c
c  assume initially that data are given independent of temperature:
c  i.e. that ntemp is originally set = 1
c
      ntemp=1
      nid=0
      iel=1
c
c  read the keyword 'key'
c
      do 800 i=1,mid
c
c  read atom file and store values in arrays
c  key,ntmp,tgrd,il,ih
c  put in possibility of fixed rate
c  rate goes from il to ih, not necessarily from low to high
c  (il and ih not converted in gencol to ilo and ihi as for other
c  rates)
c
        read(ldums,'(a)',end=998) text
        call lcase(text)
        k0=1
        call getwrd(text,k0,k1,k2)
        if(text(k1:k2).eq.'ar85-che+') then
          key(i)='ar85-chp'
        else if(k2-k1.le.7) then
          key(i)='       '
          key(i)(1:k2-k1+1)=text(k1:k2)
        else
          call stop('rcoll: key more than 8 characters')
        endif
        if (key(i) .eq. 'end     ') then
          goto 999
        else if (key(i) .eq. 'temp    ') then
          read(ldums,*) ntemp,(tgrid(it),it=1,min(ntemp,mtgrd))
          if(ntemp .gt. mtgrd) then
            write(ljoblo,*) 'ntemp, mtgrd=',ntemp,mtgrd
            call stop(' rcoll: ntemp.gt.mtgrd')
          endif
          goto 800
        else if (key(i)(1:3) .eq. 'ohm'
     *  .or.     key(i) .eq. 'ce      '
     *  .or.     key(i) .eq. 'cp      '
     *  .or.     key(i) .eq. 'ch      '
     *  .or.     key(i) .eq. 'chi     '
     *  .or.     key(i) .eq. 'ci      '
     *  .or.     key(i) .eq. 'ch0     '
     *  .or.     key(i) .eq. 'ch+     '
     *  .or.     key(i) .eq. 'calp    '
     *  .or.     key(i) .eq. 'reco    '
     *  .or.     key(i) .eq. 'fixrat  ') then
          if(key(i).eq.'calp    ') then
            call stop('rcoll: calp not implemented in _3d')
          endif
          read(ldums,*) il(i),ih(i),(cgrid(it),it=1,ntemp)
c 
          if(key(i) .eq. 'ch+     ') then 
            write(ljoblo,*)'interpolation of log10 ',key(i)
     *      ,  ' between levels', il(i), ih(i)
            do jt=1,ntemp
              cgrid(jt)=log10(cgrid(jt))
            end do
          endif
c 
c  23-feb-1994 p.g.judge modifications end:
c 
c
c  set up spline coefficients
c
          if(ntemp.ge.4) then
            m=4
            x55=5.5d0
            call tautsp(tgrid,cgrid,ntemp,x55,work,tgrd(1,i),
     *       cgrd(1,1,i),ntmp(i),m,iflag)
          else
            if(ntemp.le.2) then
              write(ljoblo,*) 'linear interpolation: ',key(i)
     *        ,  ' between levels', il(i), ih(i)
            else
              write(ljoblo,*) 'splin interpolation: ',key(i)
     *        ,  ' between levels', il(i), ih(i)
            endif
            do j=1,ntemp
              tgrd(j,i)=tgrid(j)
              cgrd(1,j,i)=cgrid(j)
            enddo
            ntmp(i)=ntemp
          endif
c
c  additional key-words from philip judge
c
        else if (key(i) .eq. 'semi    ') then
          read(ldums,*) il(i),ih(i),coeff(1,i)
        else if (key(i) .eq. 'ltdr    ') then
          read(ldums,*) il(i),ih(i),(coeff(j,i),j=1,5)
        else if (key(i) .eq. 'corona  ') then
          read(ldums,*) il(i),ih(i)
        else if (key(i) .eq. 'ar85-rr ') then
          read(ldums,*) il(i),ih(i),(coeff(j,i),j=1,2)
        else if (key(i) .eq. 'ar85-cdi') then
          read(ldums,*) il(i),ih(i),ncoeff(i)
          if(ncoeff(i) .gt. mshell)
     *      call stop('gencol: ncdi .gt. mshell')
          read(ldums,*) ((cdi(j,l,i),j=1,5),l=1,ncoeff(i))
        else if (key(i) .eq. 'ar85-cea') then
          read(ldums,*) il(i),ih(i),coeff(1,i)
        else if (key(i)(1:7) .eq. 'ar85-ch') then
          read(ldums,*) il(i),ih(i)
          read(ldums,*) (coeff(j,i),j=1,6)
        else if (key(i) .eq. 'shull82 ') then
          read(ldums,*) il(i),ih(i),
     *      (coeff(j,i),j=1,8)
        else if (key(i) .eq. 'burgess ') then
          read(ldums,*) il(i),ih(i),coeff(1,i)
c
        else if(key(i)(1:1).ne.' ')then
          errmsg='rcoll:  unknown keyword '//key(i)//
     .           ' in atomic data'
          call stop(errmsg)
        endif
  800 continue
c
      call stop('rcoll: nid.gt.mid')
  998 continue
      call stop(' rcoll: keyword ''end'' not found in collision file')
  999 continue
      nid=i-1
      return
      end
c
c********************************************************************
c
      subroutine gencl
c
c  general routine for computing collisional rates
c  format is either given in terms of a collision strength omega
c         or                          a ce(te) rate
c
c  omegas are used for charged ions in general, since they remain roughl
c  constant with temperature.  rate is prop. to 1/sqrt(te) * exp(delta-e
c
c  ce(te) values are used largely for neutrals for same reason.
c  rate is prop. to sqrt(te) * exp(delta-e)
c
c  ci(te) values are used for ionization rates: these have a
c         sqrt(te) * exp(delta-e) dependence as for ce(te)
c
c  originally coded by p.g. judge,  april 2nd, 1987
c  modified by p.g. judge, may 21st 1987
c    derivatives with respect to ne and t also returned
c    file read only once and values stored
c    reading of data performed by rcol
c
c:
c: gencl  07-01-29  new routine: (mats carlsson)
c:        gencol split into rcoll (reads data) and gencl (interpolation)
c:        to enable multiple calls to gencol without rereading atom file
c:        especially important for _3d version
c:        based on gencol for radyn
c:
      include 'PREC'
      include 'PARAM'
      include 'CATOM'
      include 'CATMOS'
      include 'CATMO2'
      include 'CCONST'
      include 'CINPUT'
      include 'CLU'
      include 'CGENCL'
c
c  local variables: up to mtgrd points in temperature grid allowed
c  this can be increased
c
      parameter (x100=500.d0)
      dimension ct(mdep)
      dimension cea(mdep)
      dimension tgrid(mtgrd),cgrid(mtgrd)
      logical ctneg
      logical alprd
      data alprd/.false./
      save
c
      ctneg=.false.
c
c  assume initially that data are given independent of temperature:
c  i.e. that ntemp is originally set = 1
c
      ntemp=1
c
c  read the keyword 'key'
c
      do 800 i=1,nid
c
        if (key(i) .eq. 'end     ') then
          goto 999
        else if (key(i) .eq. 'temp    ') then
          goto 800
        else if (      key(i)(1:3) .ne. 'ohm'
     *  .and.          key(i) .ne. 'ce      '
     *  .and.          key(i) .ne. 'cp      '
     *  .and.          key(i) .ne. 'ch      '
     *  .and.          key(i) .ne. 'calp    '
     *  .and.          key(i) .ne. 'reco    '
     *  .and.          key(i) .ne. 'ch0     '
     *  .and.          key(i) .ne. 'ch+     '
     *  .and.          key(i) .ne. 'ci      '
     *  .and.          key(i) .ne. 'chi     '
     *  .and.          key(i) .ne. 'fixrat  '
c
     *  .and.          key(i) .ne. 'semi    '
     *  .and.          key(i) .ne. 'ltdr    '
     *  .and.          key(i) .ne. 'corona  '
     *  .and.          key(i) .ne. 'shull82 '
     *  .and.          key(i) .ne. 'burgess '
     *  .and.          key(i)(1:4) .ne. 'ar85' )then
          goto 800
        else if ( key(i)(1:3) .eq. 'ohm'
     *  .or.      key(i) .eq. 'ce      '
     *  .or.      key(i) .eq. 'cp      '
     *  .or.      key(i) .eq. 'ch      '
     *  .or.      key(i) .eq. 'calp    '
     *  .or.      key(i) .eq. 'reco    '
     *  .or.      key(i) .eq. 'ch0     '
     *  .or.      key(i) .eq. 'ch+     '
     *  .or.      key(i) .eq. 'ci      '
     *  .or.      key(i) .eq. 'chi     '
     *  .or.      key(i) .eq. 'fixrat  ') then
c
c  make interpolation for all depths
c
          do k=1,ndep
            tgp=temp(k)
            tgp=min(tgp,tgrd(ntmp(i),i))
            tgp=max(tgp,tgrd(1,i))
            if(ntmp(i).ge.4) then
              ct(k)=ppvalu(tgrd(1,i),cgrd(1,1,i),ntmp(i),4,tgp,0,
     *                     mflag)
            else
              do j=1,ntmp(i)
                tgrid(j)=tgrd(j,i)
                cgrid(j)=cgrd(1,j,i)
              enddo
              ct(k)=splin(temp(k),tgrid,cgrid,ntmp(i),ntmp(i))
            endif
            if(key(i).eq.'ch+     ') then
              ct(k)=10.**ct(k)
            endif
            if(ct(k).lt.0.0d0) then

c the following condition has been introduced to force the ct value
c to a minimum level (zero) in case of collisions with hi (a la drawin)
c with very low (but positive) cross-sections that may cause
c the spline to be slightly negative   

              ilo=min( il(i), ih(i) )
              ihi=max( il(i), ih(i) )
              write(ljoblo,48) key(i),ilo,ihi,temp(k)
   48         format('gencol: ct negative;key,ilo,ihi,t=',a,2i4,f15.0)
              if(key(i).eq.'chi     '.or.key(i).eq.'ch      ') then
                ct(k) = 0.
                write(ljoblo,'(a)') 'gencol: ct set to zero'
              else
                ctneg=.true.
              endif
            endif
          end do
        endif
c
c  identify the upper and lower levels:
c
        ilo=min( il(i), ih(i) )
        ihi=max( il(i), ih(i) )
c
c  check to see that the levels are between 1 and nk
c
        if(ilo .lt. 1 .or. ihi .gt. nk) then
          write(ljoblo,*) '  i=',i
          write(ljoblo,*) 'key=',key(i)
          write(ljoblo,*) 'ilo=',ilo
          write(ljoblo,*) 'ihi=',ihi
          write(ljoblo,*) ' nk=', nk
          call stop(' gencol:  level index outside range (1,nk)')
        endif
c
c  omegas are given (+ve ions)
c
        if(key(i)(1:3) .eq. 'ohm') then
          do  k=1,ndep
            cdn = 8.63e-06 * ct(k) * ne(k) / ( g(ihi)*sqrt(temp(k)) )
            cup = cdn * nstar(ihi,k) / nstar(ilo,k)
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
            c(ilo,ihi,k) = cup + c(ilo,ihi,k)
          end do
c
c  ce values are given (neutrals)
c
        else if (key(i) .eq. 'ce      ') then
          do k=1,ndep
            cdn = ne(k) * ct(k) * g(ilo) * sqrt(temp(k)) / g(ihi)
            cup= cdn * nstar(ihi,k) / nstar(ilo,k)
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
            c(ilo,ihi,k) = cup + c(ilo,ihi,k)
          end do
c
c  cp values are given (b-b collisions with protons)
c
        else if (key(i) .eq. 'cp      ') then
          do k=1,ndep
            cdn = nh(6,k) * ct(k)
            cup= cdn * nstar(ihi,k) / nstar(ilo,k)
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
            c(ilo,ihi,k) = cup + c(ilo,ihi,k)
          end do
c
c  ch values are given (collisions with neutral hydrogen)
c
        else if (key(i) .eq. 'ch      ') then
          do k=1,ndep
            cdn = nh(1,k) * ct(k)
            cup= cdn * nstar(ihi,k) / nstar(ilo,k)
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
            c(ilo,ihi,k) = cup + c(ilo,ihi,k)
          end do
c
c  added by aegp 27/06/01
c  chi values are given (b-f collisions with neutral hydrogen)
c  changes by KL 2009: scaling factor added.
c
        else if (key(i) .eq. 'chi     ') then
          do k=1,ndep
            dekt=  (ev(ihi)-ev(ilo)) * ek / temp(k)
            cup = nh(1,k) * ct(k) * exp(-dekt)
            cdn= cup * nstar(ilo,k) / nstar(ihi,k) 
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
            c(ilo,ihi,k) = cup + c(ilo,ihi,k)
          end do
c
c  ci values are given
c
        else if (key(i) .eq. 'ci      ') then
          do k=1,ndep
            dekt=  (ev(ihi)-ev(ilo)) * ek / temp(k)
            cup = ne(k) * ct(k) * exp(-dekt) * sqrt(temp(k))
            cdn = cup * nstar(ilo,k) / nstar(ihi,k)
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
            c(ilo,ihi,k) = cup + c(ilo,ihi,k)
          end do
c
c  ch0 or ch+ values given:  charge transfer collisions with 
c            hydrogen atoms/ions  
c 
c  addition by KL 2009: reverse rates added for CH0 assuming 
c  detailed balance. Added scaling factor.
c 
        else if (key(i) .eq. 'ch0     ') then
          do k=1,ndep
            dekt=  (ev(ihi)-ev(ilo)-0.754) * ek / temp(k)
            cup = nh(1,k) * ct(k) * exp(-dekt) 
            cdn= cup * nstar(ilo,k) / nstar(ihi,k) 
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
            c(ilo,ihi,k) = cup + c(ilo,ihi,k)
          end do
        else if (key(i) .eq. 'ch+     ') then
          do k=1,ndep
            c(il(i),ih(i),k)= nh(6,k) * ct(k)  + c(il(i),ih(i),k)
          end do
c
c  calp values are given (collisions with alpha particles)
c  atom has to be he
c  initia is called for first rate to read populations
c  from rstrt
c
        else if(key(i).eq.'calp    ') then
          if(atomid(1:2).ne.'he') then
            call stop('gencol: atom has to be he for calpha')
          endif
          if(.not.alprd) then
            call rdalp
            alprd=.true.
          endif
          do k=1,ndep
            cdn = n(nk,k) * ct(k) 
            cup= cdn * nstar(ihi,k) / nstar(ilo,k)
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
            c(ilo,ihi,k) = cup + c(ilo,ihi,k)
          end do
c
c  recombination coefficients are given
c  c(j-i)=ne*ct
c
        else if(key(i).eq.'reco    ') then
          do k=1,ndep
            c(ihi,ilo,k)= ne(k)*ct(k) + c(ihi,ilo,k)
          end do
c
c  fixrat values are given
c  fixed rates from il to ih (not necessarily from low to high)
c  no reverse rate
c
        else if (key(i) .eq. 'fixrat  ') then
          do k=1,ndep
            c(il(i),ih(i),k)= c(il(i),ih(i),k) + ct(k)
          end do
        else if (key(i) .eq. 'semi    ') then
          fab=coeff(1,i)
          eupcm=ev(ihi)*ee/cc/hh
          elocm=ev(ilo)*ee/cc/hh
          fem = fab*g(ilo)/g(ihi)
          do k=1,ndep
            ct(k)=semic(ion(ilo),eupcm,elocm,fem,temp(k),iii)
            cdn=ct(k)*ne(k)
            cup = cdn * nstar(ihi,k) / nstar(ilo,k)
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
            c(ilo,ihi,k) = cup + c(ilo,ihi,k)
          end do
c
c  low-temperature dielectronic recombination coeffs. are given
c  formula (9) of nussbaumer and storey (a+a paper ii)
c
        else if (key(i) .eq. 'ltdr    ') then
          altdr=coeff(1,i)
          bltdr=coeff(2,i)
          cltdr=coeff(3,i)
          dltdr=coeff(4,i)
          fltdr=coeff(5,i)
          do k=1,ndep
            t4ltdr=temp(k)/1.e4
            cdn = 1.d-12*ne(k)* (altdr/t4ltdr + bltdr +
     *             cltdr*t4ltdr +dltdr*t4ltdr*t4ltdr) *
     *             exp(-fltdr/t4ltdr)/t4ltdr/sqrt(t4ltdr)
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
          end do
        else if (key(i) .eq. 'corona  ') then
          do k=1,ndep
            pe=bk*ne(k)*temp(k)
            call coronr(atomid(1:3),ion(ilo),temp(k),pe,recrat,rirat)
            c(ihi,ilo,k) =  c(ihi,ilo,k) + recrat*ne(k)
            c(ilo,ihi,k) =  c(ilo,ihi,k) + rirat*ne(k)
          end do
        else if(key(i)(1:7) .eq. 'ar85-rr') then
          aradar=coeff(1,i)
          etaar=coeff(2,i)
          do k=1,ndep
            cdn= aradar*(temp(k)/1.e4)**etaar
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
          end do
        else if(key(i)(1:8) .eq. 'ar85-cdi') then
          do k=1,ndep
            cup=0.d0
            do j=1,ncoeff(i)
              xj=cdi(1,j,i)*ee/bk/temp(k)
              fac=exp(-xj)*sqrt(xj)
              fxj=fac*( cdi(2,j,i)+cdi(3,j,i)*(1.d0+xj)
     *           +(cdi(4,j,i)-xj*(cdi(2,j,i)+cdi(3,j,i)
     *                  *(2.d0+xj)))*fone(xj)+
     *          cdi(5,j,i)*xj*ftwo(xj) )
              fac=6.69d-07/cdi(1,j,i)/sqrt(cdi(1,j,i))
c
              cup = cup+fac*fxj
            end do
            if(cup .lt. -1.d-30) call stop('gencol: cdi-cup .lt.0')
            c(ilo,ihi,k) = cup*ne(k) + c(ilo,ihi,k)
            c(ihi,ilo,k) = cup*ne(k)*nstar(ilo,k)/nstar(ihi,k)
     *          + c(ihi,ilo,k)
          end do
c
c  addition p. judge 24-jan-1994: end
c
c
c  22-feb-1994 p.g.judge modifications start:
c
        else if(key(i) .eq. 'ar85-cea') then
          ceafak=coeff(1,i)
          call ar85cea(ilo,ihi,cea)
          do k=1,ndep
            cea(k)=cea(k)*ceafak
            c(ilo,ihi,k) = cea(k)*ne(k) + c(ilo,ihi,k)
c
c  this is incorrect since population of upper level is the upper level
c  of the doubly excited state, **, i.e. this should be multiplied by
c  g(**)/g(ihi) exp(e(**) - e(ihi)).  a better approximation would seem to
c  be 0. times this to avoid problems. hence comment this line out
c
c          c(ihi,ilo,k) = cea(k)*ne(k)*nstar(ilo,k)/nstar(ihi,k)
c     *        + c(ihi,ilo,k)
c
c  22-feb-1994 p.g.judge modifications end:
c
          end do
        else if(key(i)(1:7) .eq. 'ar85-ch') then
          ar85t1=coeff(1,i)
          ar85t2=coeff(2,i)
          ar85a=coeff(3,i)
          ar85b=coeff(4,i)
          ar85c=coeff(5,i)
          ar85d=coeff(6,i)
c 
c   ar85-ch    charge transfer recombination with neutral hydrogen
c 
          if(key(i)(1:8).eq.'ar85-ch ') then
            do k=1,ndep
              if(temp(k).ge.ar85t1 .and. temp(k).le.ar85t2) then 
                t4=temp(k)/1.d4
                cup = ar85a * 1.d-9 * t4**ar85b * (1. + ar85c 
     *               * exp(ar85d*t4))*nh(1,k)           
                c(il(i),ih(i),k) = cup + c(il(i),ih(i),k)
              endif
            end do
c 
c   ar85-ch+   charge transfer with ionized hydrogen
c 
          else if(key(i)(1:8).eq.'ar85-ch+') then
            do k=1,ndep
              if(temp(k) .ge. ar85t1 .and. temp(k) .le. ar85t2) then 
                t4=temp(k)/1.d4
                cup = ar85a * 1.d-9 * t4**ar85b * exp(-ar85c*t4) 
     *            * exp(-ar85d*ee/bk/temp(k))*nh(6,k) 
                c(il(i),ih(i),k) = cup + c(il(i),ih(i),k)
              endif
            end do
c  
c   ar85-che   charge transfer with neutral helium
c 
          else if(key(i)(1:8) .eq. 'ar85-che') then
            do k=1,ndep
              if(temp(k) .ge. ar85t1 .and. temp(k) .le. ar85t2) then 
                t4=temp(k)/1.d4
                hpop=nh(1,k)+nh(2,k)+nh(3,k)+nh(4,k)+
     *           nh(5,k)+nh(6,k)
                call hepop(temp(k),hpop,he1,he2,he3)
                cup = ar85a * 1.d-9 * t4**ar85b * (1. + ar85c 
     *               * exp(ar85d*t4))*he1 
                c(il(i),ih(i),k) = cup + c(il(i),ih(i),k)
              endif
            end do
c 
c   ar85-chp  charge transfer with ionized helium
c 
          else if(key(i)(1:8) .eq. 'ar85-chp') then 
            do k=1,ndep
              if(temp(k) .ge. ar85t1 .and. temp(k) .le. ar85t2) then 
                t4=temp(k)/1.d4
                hpop=nh(1,k)+nh(2,k)+nh(3,k)+nh(4,k)+
     *           nh(5,k)+nh(6,k)
                call hepop(temp(k),hpop,he1,he2,he3)
                cup = ar85a * 1.d-9 * t4**ar85b * exp(-ar85c*t4) 
     *               * exp(-ar85d*ee/bk/temp(k))*he2 
                c(il(i),ih(i),k) = cup + c(il(i),ih(i),k)
              endif
            end do
          endif
        else if(key(i)(1:7) .eq. 'shull82') then
          acolsh=coeff(1,i)
          tcolsh=coeff(2,i)
          aradsh=coeff(3,i)
          xradsh=coeff(4,i)
          adish=coeff(5,i)
          bdish=coeff(6,i)
          t0sh=coeff(7,i)
          t1sh=coeff(8,i)
c
c  november 9, 1994, modifications p. judge, begin
c  idea is to reduce dielectronic recombination rate
c  owing to collisional ionization of rydberg states
c  following summers 1974, appleton lab rept.
c
          summrs=1.0d0
          do k=1,ndep
c to remove density dependence in dielectronic rate comment out
c the next line
            summrs=summers(ilo,ihi,ne(k))
            cdn=aradsh*(temp(k)/1.d4)**(-xradsh)  +  summrs*
     *        adish /temp(k)/sqrt(temp(k)) * exp(-t0sh/temp(k))*  
     *        (1.d0+bdish * (exp(- t1sh/temp(k))))
c
c  november 9, 1994, modifications p. judge, end
c
            cdn=cdn*ne(k)
            cup=acolsh * sqrt(temp(k)) * exp( -tcolsh / temp(k)) 
     *         / (1.d0 + 0.1d0 * temp(k) / tcolsh) 
            cup=cup*ne(k)
c*
c*  3-body recombination (high density limit)
c*
            cdn=cdn+cup*nstar(ilo,k)/nstar(ihi,k)
c*
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
            c(ilo,ihi,k) = cup + c(ilo,ihi,k)
          end do
c
        else if(key(i) .eq. 'burgess ') then
          de=(ev(ihi)-ev(ilo))
          zc=ion(ilo)-1
          betab = 0.25d0*(sqrt((100.d0*zc +91)/(4.d0*zc+3))-5.d0)
          cbar=2.3d0
          do k=1,ndep
            dekt=de*ee/bk/temp(k)
            ddekt=-dekt/temp(k)
            dekt=min(x100,dekt)
            dekti=1.d0/dekt
            wlog=log(1.d0 + dekti)
            wb = wlog**(betab/(1.d0+dekti))
c
            exin1=expint(1,dekt,dum)
            dexin1=-exp(-dekt)/dekt*ddekt
            qb = 2.1715d-08*cbar*(13.6d0/de)**1.5d0 * sqrt(dekt) *
     .         exin1*wb
c  gencol 95-05-22 vh actelc=1 to be replaced later by
c                     routine that computes number
c                     of active electrons from term information
            actelc=1.d0
            cup=qb*actelc*ne(k)
            cdn=cup*nstar(ilo,k)/nstar(ihi,k)
            c(ilo,ihi,k) = cup + c(ilo,ihi,k)
            c(ihi,ilo,k) = cdn + c(ihi,ilo,k)
          end do
        else if(key(i)(1:6).eq.'radrat')then
           crat=coeff(1,i)
           do k=1,ndep
             c(il(i),ih(i),k)=crat+c(il(i),ih(i),k)
           end do
        endif
  800 continue
c
  999 continue
      if(ctneg) call stop('gencol: ct negative')
      return
      end
C
C ****************************************************************
C
        FUNCTION SPLIN(T, X, Y, N, NNN)
C
C  SPLINE INTERPOLATION OF T IN A GIVEN TABLE OF POINTS(X(I),Y(I)).
C
C Y(I) IS A FUNCTION OF X(I) - X(N)>X(N-1)>....X(1) -OR- X(1)> X(2)
C > ....> X(N) - WHEN X IS NORMALISED X(MIN) = 0, XMAX=1,
C NORM(ABS(X(I+1)-X(I))) < 1.0E-8,(I=1,N-1). THE ARRAY X IS DIVIDED
C INTO OVERLAPPING INTERVALS. EACH INTERVAL CONSISTS OF NNN POINTS,
C THE OVERLAP IS INT(LOG(NNN)+3) POINTS. ( 3<=NNN<=100,N).
C EACH TIME AFTER A CALL WHEN T CHANGES OF INTERVAL OR AFTER A CALL
C WITH ANOTHER SET OF POINTS, A NEW CUBIC SPLINE OF NNN POINTS HAS
C TO BE COMPUTED, THEREFORE THE COMPUTING TIME DEPENDS STRONGLY OF
C THE SUCCESSION OF CALLS.
C FOR EXAMPLE: SUCCESSIVE CALLS, WHERE T IS RANDOMLY CHOSEN WILL COST
C A LOT OF COMPUTING TIME - (T OFTEN CHANGES OF INTERVAL) --->
C TAKE NNN THEN AS LARGE AS POSSIBLE. SUCCESSIVE CALLS WHERE T CHANGES
C SLIGHTLY COST LESS COMPUTING TIME, SO IT WILL BE CLEAR THAT YOUR
C CHOICE OF NNN DEPENDS HEAVILY UPON ITS WAY OF USEAGE.
C
C COMPUTING TIME:   FOR THE COMPUTATION OF SPLINE COEFFICIENTS
C        THIS ROUTINE NEEDS ABOUT 21*N MULTIPLICATIONS OR DIVISIONS
C        FOR THE INTERPOLATION BY MEANS OF THE SPLINE COEFFICIENTS
C        THE ROUTINE NEEDS 9 MULTIPLICATIONS OR DIVISIONS.
C
C EXTRAPOLATION: IF T IS NOT IN [X(1),X(N)] T IS LINEAR EXTRAPOLATED
C
C A PART OF THE ALGORITM FOR THE COMPUTATION OF A NATURAL SPLINE
C IS TAKEN FROM T.N.E. GREVILLE, THE LINEAR SYSTEM IS SOLVED BY
C THE METHOD OF SUCCESSIVE OVERRELAXATION. (ERROR = 1.0E-6)
C
C REF: T.N.E. GREVILLE, MATHEMATICS RESEARCH CENTER, U.S. ARMY,
C        UNIVERSITY OF WISCONSIN. MATHEMATICAL METHODS.
C
C THIS ROUTINE WAS IMPLEMENTED BY E.B.J. VAN DER ZALM, STERRENWACHT
C UTRECHT (MAY 7TH 1981). ADAPTED FOR VAX\11 BY PAUL KUIN AT OXFORD.
C WRITTEN IN REAL*4 BY P.G. JUDGE, OXFORD
C MODIFIED SO THAT IF THE ARGUMENT IS OUTSIDE THE RANGE OF X-VALUES
C THEN THE FIRST (OR LAST) Y-VALUE IS TAKEN
C
C INPUT:         T        ARGUMENT   (REAL)
C                X        ARRAY OF ARGUMENTS        (REAL)
C                Y        ARRAY OF FUNCTION VALUES (REAL)
C                N        LENGTH OF THE ARRAYS X,Y
C                        IF N = 2 ---> LINEAR INTERPOLATION
C                NNN        NUMBER OF POINTS OF THE CUBIC SPLINE
C                        IF NNN > N   ---> NNN = N
C                        IF NNN > 100 ---> NNN = 100
C                        IF NNN = 2 LINEAR INTERPOLATION ADOPTED.
C
C                        IF NNN IS ZERO NNN=7  (ALTERED BY P JUDGE)
C                       (USED TO BE IF NNN OMITTED )
C OUTPUT:        SPLIN INTERPOLATED VALUE AT T
C
      INCLUDE 'PREC'
        DIMENSION X(N), Y(N), S2(100), S3(100), DELY(100), H(100),
     * H2(100), DELSQY(100), C(100), B(100), XX(100), YY(100)
        LOGICAL SEARCH, FOUND
        CHARACTER*4 INIT
        DATA INIT/'NOTO'/
        SAVE
C
C  NN = NUMBER OF POINTS OF THE SPLINE INTERVAL
C
        NN = MIN(7,N)
        IF (NNN .EQ. 0) GO TO 10
C PGJ        IF (%LOC(NNN).EQ.0) GO TO 10
        NN = NNN
        NN = MIN(N,NNN,100)
C
C           IF T IN [X(K)-ERROR,X(K)+ERROR] T = X(K)
C
 10        ERROR = 1.0E-12
        IF (T.NE.0) ERROR = ABS(1.0E-12*T)
        FOUND = SEARCH(X,T,1,N,K,ERROR)
        IF (.NOT.FOUND) GOTO 20
        SPLIN = Y(K)
        RETURN
 20        IF (N.NE.2.AND.NN.NE.2) GOTO 30
C
C           IF N=2 OR NNN=2 LINEAR INTERPOLATION IS ADOPTED
C
        SPLIN = (Y(K+1)-Y(K))*(T-X(K))/(X(K+1)-X(K)) + Y(K)
        RETURN
 30        IF (N.NE.1) GOTO 40
        SPLIN = Y(1)
        RETURN
C
C           INTERVAL OF THE SPLINE IS COMPUTED
C
 40        IOVER = LOG10(FLOAT(NN))*3
        INT = (K-IOVER)/(NN-2*IOVER) + 1
        I1 = (INT-1)*(NN-2*IOVER)
        I2 = I1 + NN -1
        IF (I1.GE.1) GOTO 50
        I2 = NN
        I1 = 1
 50        IF (I2.LE.N) GOTO 60
        I2 = N
        I1 = N - NN + 1
 60         ISHIFT = I1 - 1
        N1 = NN - 1
C
C           INITIALIZATION CHECK
C
        IF (INIT.NE.'OKAY') GOTO 80
C
C           INTERVAL CHECK
C
        DO 70 I=1,NN
        IF (XX(I).NE.X(I+ISHIFT)) GOTO 90
        IF (YY(I).NE.Y(I+ISHIFT)) GOTO 90
70        CONTINUE
        GOTO 200
80        INIT = 'OKAY'
C
C           START OF THE COMPUTATION OF SPLINE COEFFICIENTS
C
 90        RMIN = 1.0E37
        RMAX = -1.0E37
        DO 100 I=1,NN
        IF (Y(I+ISHIFT).LT.RMIN)  RMIN = Y(I+ISHIFT)
        IF (Y(I+ISHIFT).GT.RMAX)  RMAX = Y(I+ISHIFT)
 100        CONTINUE
C
C           COMPUTATION OF THE NORM FACTORS XNORM AND YNORM
C
        XNORM = 1/(X(NN+ISHIFT)-X(1+ISHIFT))
        YNORM = RMAX - RMIN
        IF (YNORM.EQ.0) YNORM = RMAX
        IF (YNORM.EQ.0) YNORM = 1
        YNORM = 1 / YNORM
        DO 110 I=1,N1
           H(I) = (X(I+1+ISHIFT)-X(I+ISHIFT))*XNORM
           DELY(I) = ((Y(I+1+ISHIFT)-Y(I+ISHIFT))/H(I))*YNORM
 110        CONTINUE
        DO 120 I=2,N1
           H2(I) = H(I-1) + H(I)
           B(I) = 0.5*H(I-1)/H2(I)
           DELSQY(I) = (DELY(I)-DELY(I-1))/H2(I)
           S2(I) = 2.*DELSQY(I)
           C(I) = 3.*DELSQY(I)
 120        CONTINUE
        S2(1) = 0
        S2(N1+1) = 0
C
C        SOLUTION OF THE LINEAR SYSTEM OF THE SPLINE COEFFICIENTS
C        BY SUCCESSIVE OVERRELAXATION.
C        CONSTANTS: EPS = ERROR CRITERION IN THE ITERATIVE SOLUTION.
C                   OMEGA = RELAXATION COEFFICIENT.
C
        EPSLN = 1.0E-8
        OMEGA = 1.0717968
 130        ETA = 0.
        DO 160 I=2,N1
           W = (C(I)-B(I)*S2(I-1)-(0.5-B(I))*S2(I+1)-S2(I))*OMEGA
           IF (ABS(W)-ETA) 150, 150, 140
 140        ETA = ABS(W)
 150        S2(I) = S2(I) + W
 160        CONTINUE
        IF (ETA-EPSLN) 170, 130, 130
 170        DO 180 I=1,N1
           S3(I) = (S2(I+1)-S2(I))/H(I)
 180        CONTINUE
C
C        X AND Y STORED IN XX AND YY FOR INTERVAL CHECK
C
        DO 190 I=1,NN
           XX(I) = X(I+ISHIFT)
           YY(I) = Y(I+ISHIFT)
 190        CONTINUE
 200        I = K - I1 + 1
        HT1 = (T-X(I+ISHIFT))*XNORM
        HT2 = (T-X(I+ISHIFT+1) )*XNORM
        IF ((T-X(1))*XNORM.GT.0) GOTO 210
C
C        EXTRAPOLATION   T < X(1)
C
        SPLIN = Y(1)
        RETURN
210        IF ((T-X(N))*XNORM.GT.0) GOTO 220
C
C        INTERPOLATION BY MEANS OF THE SPLINE COEFFICIENTS
C
        SS2 = S2(I) + HT1*S3(I)
        PROD = HT1*HT2
        DELSQS = (S2(I)+S2(I+1)+SS2)/6.
        SPLIN = Y(I+ISHIFT) + (HT1*DELY(I)+PROD*DELSQS)/YNORM
        RETURN
C
C        EXTRAPOLATION   T > X(N)
C
 220        SPLIN =  Y(N)
        RETURN
        END
C
C **********************************************************************
C
      LOGICAL FUNCTION SEARCH(ARR,X,IA,IB,K,ERR)
C
C * SEARCHES THE POINT X WITHIN AN ERROR BOUND -ERR- IN ARRAY ARR      *
C * IF THAT POINT IS NOT FOUND, IT GIVES THE                           *
C * INTERVAL IN THE ARRAY, WHERE THAT POINT FITS.                      *
C * THE INTERVAL K IF X IN [ARR(K),ARR(K+1)), INTERVAL 1 IF X IN       *
C * (-INF,ARR(2)), INTERVAL N-1 IF X IN [ARR(N-1),INF)-(ARR INCREASING)*
C * INTERVAL 1 IF X IN (INF,ARR(2)),INTERVAL N-1 IF X IN [ARR(N-1),    *
C * -INF)-(ARR DECREASING)                                             *
C * IN THE WORST CASE A SEARCH COSTS 2*LOG2(N) CYCLES.                 *
C * THIS ROUTINE IS VERY ECONOMIC, WHEN IN A SEQUENCE OF SEARCHES,     *
C * THE DIFFERENCES BETWEEN THE POINTS WHICH ARE TO BE SEARCHED ARE    *
C * SMALL.                                                             *
C * FOR EXAMPLE: A SEQUENCE OF SEARCHES WHICH GOES ALONG THE ARRAY,    *
C * OR A SEQUENCE OF SEARCHES WHICH REMAINS IN A SMALL AREA OF         *
C * THE ARRAY.                                                         *
C *                                                                    *
C * INPUT:     - ARR         ARRAY WITH A NON DECREASING OR A NON      *
C *                          INCREASING FUCNTION.                      *
C *            - IA,IB       LOWER AND UPPER LIMIT OF THE ARRAY WITHIN *
C *                          IS SEARCHED.                              *
C *            - X           VALUE WHICH YOU WANT TO SEARCH            *
C *            - K           LAST INDEX WHICH WAS FOUND                *
C *                          SEARCH                                    *
C *            - ERR         ERROR BOUND                               *
C *                                                                    *
C * OUTPUT:    - K           INDEX OF THE POINT OR INTERVAL OF THE     *
C *                          ARRAY WHICH IS FOUND.                     *
C *            - SEARCH      TRUE - X IS FOUND WITHIN THE ERRORBOUND   *
C *                                  -ERR-                             *
C *                          FALSE - X IS NOT FOUND.                   *
C *                                                                    *
C * SEND IN BY E.V.D.ZALM, UTRECHT, STERREWACHT, MARCH 24TH 1981       *
C **********************************************************************
      INCLUDE 'PREC'
      DIMENSION ARR(IB)
C
      ONE=1.0
      SEARCH = .TRUE.
      IF (ARR(IB)-ARR(IA).LT.0.0) GOTO 100
5     IF (X.LT.ARR(IA).OR.X.GT.ARR(IB)) GOTO 25
      IF (K.LT.IA.OR.K.GT.IB-1) GOTO 25
      L = K
      IP = SIGN(ONE,X-ARR(K))
      IF (IP.LT.0.) GOTO 20
10    L = MIN(K+IP,IB)
      IF (ARR(L).GE.X) GOTO 30
      IP = IP * 2
      K = L            
      GOTO 10
20    K = MAX(L+IP,IA)
      IF (ARR(K).LE.X) GOTO 30
      IP = IP * 2
      L = K
      GOTO 20
25    K = IA
      L = IB
30    IF ((L-K).LE.1) GOTO 50
      I = INT((K+L)/2.)
      IF (ARR(I).GE.X) GOTO 40
      K = I
      GOTO 30
40    L = I
      GOTO 30
100   IF (X.LT.ARR(IB).OR.X.GT.ARR(IA)) GOTO 250
      IF (K.LT.IA.OR.K.GT.IB-1) GOTO 250
      L = K
      IP = SIGN(ONE,ARR(K)-X)
      IF (IP.LT.0.) GOTO 200
110   L = MIN(K+IP,IB)
      IF (ARR(L).LE.X) GOTO 300
      IP = IP * 2
      K = L
      GOTO 110
200   K = MAX(L+IP,IA)
      IF (ARR(K).GE.X) GOTO 300
      IP = IP * 2
      L = K
      GOTO 200
250   K = IA
      L = IB
300   IF ((L-K).LE.1) GOTO 50
      I = INT((K+L)/2.)
      IF (ARR(I).LE.X) GOTO 400
      K = I
      GOTO 300
400   L = I
      GOTO 300
50    IF (ABS(X-ARR(K)).LE.ERR) RETURN
      IF (ABS(X-ARR(L)).GT.ERR) GOTO 60
      K = L
      RETURN
60    SEARCH = .FALSE.
      RETURN
      END
C
C***********************************************************************
C
      FUNCTION SEMIC(Z,EUP,ELO,FEM,TEMP,IFLAG)
C
C  RETURNS COLLISION RATE DOWNWARDS USING SEMI-EMPIRICAL GF'S
C
C  P.G. JUDGE, NOVEMBER 1987.
C
C  INPUT:
C         Z      - CHARGE OF ION+1 (E.G. FOR C II Z=2)
C         EUP    - ENERGY OF UPPER LEVEL IN CM-1
C         ELO    - ENERGY OF LOWER LEVEL IN CM-1
C         FEM    - EMISSION OSCILLATOR STRENGTH ( = GF/G(UPPER))
C         TEMP   - TEMPERATURE IN DEGREES KELVIN
C
C  OUTPUT:
C         IFLAG  -  = 1 FOR VAN REGEMORTER APPROXIMATION
C         IFLAG  -  = 2 FOR SHEVELKO       APPROXIMATION
C         SEMIC-  DOWNWARD COLLISION RATE IN CM3 /S
C
      INCLUDE 'PREC'
      INTEGER Z
      DATA C1,RY /1.43882,109737.312/
C
C INITIALIZE
C
      DELTE=EUP-ELO
      BETA=DELTE*C1/TEMP
      SEMIC=0.0
C
C  IFLAG=1 => VAN REGEMORTER APPROXN.
C
      IF(BETA .GE. 0.01)THEN
        IFLAG=1
        SEMIC = 3.2E-7*FEM*(RY/DELTE)**1.5*SQRT(BETA)*PSEMI(Z,BETA)
C
C  IFLAG=2 => SHEVELKO APPROX
C
      ELSE IF(BETA .LT. 0.01)THEN
        IFLAG=2
        SEMIC=1.74E-07*FEM*EXP(BETA)/SQRT(BETA*DELTE/RY)
     +  *LOG( ELO / DELTE * SQRT(RY / C1 / TEMP))
      ENDIF
C
      RETURN
      END
C
C **********************************************************************
C
      FUNCTION PSEMI(Z,B)
C
C  THERMAL P-FUNCTION FOR SEMIC EMPIRICAL COLLISION RATES
C  REFERENCE: SOBEL'MAN - 'ATOMIC PHYSICS II.  '
C
C:
C: PSEMI  94-08-29  MODIFICATIONS: (MATS CARLSSON)
C:        MULTIPLE RETURN CHANGED TO SINGLE RETURN TO AVOID
C:        COMPILER BUG IN DIGITAL FORTRAN
C:
      INCLUDE 'PREC'
      PARAMETER (N1=10)
      DIMENSION  BETREF(N1),PNREF(N1),PCREF(N1)
      INTEGER Z
      DATA BETREF/-2.0,-1.699,-1.398,-1.0,-0.699,-0.398,0.0
     +  ,0.301,0.602,1.0/
      DATA PNREF/1.160,0.956,0.758,0.493,0.331,0.209
     +  ,0.100,0.063,0.040,0.023/
      DATA PCREF/1.160,0.977,0.788,0.554,0.403
     +  ,0.290,0.214,0.201,0.200,0.200/
C
C  LIMIT OF HIGH TEMPERATURE: KT >> E
C
      IF (B .LT. 0.01)THEN
        PSEMI = 0.27566 * (0.577 + LOG(B))
C
C  INTERMEDIATE TEMPS (MOST IMPORTANT FOR EQM PLASMAS)
C  SPLINE INTERPOLATION ONTO LOGB GRID:
C
      ELSE IF(B .GT. 0.01 .AND. B .LT. 10.0)THEN
        BB=LOG10(B)
        IF (Z .EQ. 1) PSEMI = SPLIN(BB,BETREF,PNREF,N1,N1)
        IF (Z .GT. 1) PSEMI = SPLIN(BB,BETREF,PCREF,N1,N1)
C
C  LIMIT OF LOW TEMPERATURE: KT << E
C
      ELSE  IF(B .GT. 10.0)THEN
        IF(Z .EQ. 1) PSEMI = 0.066 / SQRT(B)
        IF(Z .GT. 1) PSEMI = 0.200
      ENDIF
      RETURN
      END
C
C **********************************************************************
C
      SUBROUTINE CORONR(CEL,ION,TEMP,PRESS,RRATE,RIRATE)
C
C  CORONAL ION BALANCE CALCULATION
C  NEW ROUTINE FOR USE WITH V2.0 OPACITY PACKAGE AND GENCOL
C
C  INPUT:  ELEMENT IDENTIFIER    CEL (CHARACTER)
C          ION STAGE IDENTIFIER  ION (INTEGER)
C          TEMP   (ELECTRON TEMPERATURE IN K       (RL)
C          PRESS  (ELECTRON PRESSURE IN DYNE/CM2)  (RL)
C
C  OUTPUT: RRATE    RECOMBINATION RATE (CM3/S)
C          RIRATE   IONIZATION RATE    (CM3/S)
C  
C  EXAMPLE:
C          CEL='C  ', ION=1, WILL RETURN 
C          THE RECOMBINATION RATE PER C II ATOM PER ELECTRON
C          AND THE IONIZATION RATE PER C I ATOM PER ELECTRON
C
C  NOTES:
C          COMPUTATIONS FROM TABLES OF SHULL & VAN STEENBERG, 
C          AP J SUPPL  48 P95
C          NO PE-DEPENDENCE, THIS COULD BE ADDED WHEN COMPUTATIONS BECOME
C          AVAILABLE
C          IF THE ION FRACTION IS NOT FOUND THEN THE ROUTINE WILL STOP
C          
C  89-03-28 NEW ROUTINE (PHILIP JUDGE)
C
C: CORONR 92-08-10  MODIFICATIONS: (MATS CARLSSON)
C:        INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS
C:
C:        92-09-09  MODIFICATIONS: (MATS CARLSSON)
C:        INTEGER IEL IN WRITE STATEMENT CHANGED TO CHARACTER
C:
C:        95-09-06  MODIFICATIONS: (MATS CARLSSON)
C:        COMMON BLOCK CLU CHANGED TO INCLUDE FILE
C:
      INCLUDE 'PREC'
      INCLUDE 'CLU'
C
      PARAMETER (MCOR=30)
      INTEGER NCOR,IONCOR(MCOR)
      DOUBLE PRECISION ARADC(MCOR),XRADC(MCOR),ADIC(MCOR),T0C(MCOR),
     * BDIC(MCOR),T1C(MCOR),ACOLC(MCOR),TCOLC(MCOR),TECOR,DECOR
      COMMON /CCORON/ TECOR,DECOR,
     * ARADC,XRADC,ADIC,T0C,BDIC,T1C,ACOLC,TCOLC,NCOR,IONCOR
      CHARACTER*3 CCOR
      COMMON /CCCOR/ CCOR(MCOR)
      CHARACTER*(*) CEL
C
C  IDENTIFY THE ELEMENT AND IONIZATION STAGE TO BE COMPUTED
C
      DO 100 N=1,NCOR
        IF( CEL .EQ. CCOR(N) .AND. ION .EQ. IONCOR(N) )GOTO 99
  100 CONTINUE
      WRITE(LJOBLO,1024) CEL,ION
 1024  FORMAT(' CORONR: SPECIES',A3,I3,' NOT FOUND IN ABSDAT FILE')
      CALL STOP(' ')
C
C  ELEMENT HAS BEEN COMPUTED- NOW RETURN THE RATES
C
   99 RRATE=ARADC(N)*(TEMP/1.E4)**(-XRADC(N))  +     
     *  ADIC(N) * (TEMP**(-1.5)) * EXP(-T0C(N)/TEMP)*
     *  (1.E0+BDIC(N) * (EXP(- T1C(N)/TEMP)))
      RIRATE=ACOLC(N) * SQRT(TEMP) * EXP( -TCOLC(N) / TEMP)
     *    / (1.E0 + 0.1 * TEMP / TCOLC(N))
      RETURN
      END
C
C******************************************************************************
C
      SUBROUTINE RDALP
C
C  READS POPULATIONS FROM RSTRT
C  AS INITIA WITH ISTART=-1 AND LMAX=0
C:
C: RDALP  92-09-24  NEW ROUTINE: (MATS CARLSSON)
C:        READS RSTRT
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'CATOM'
      INCLUDE 'CATMOS'
      INCLUDE 'CSLINE'
      INCLUDE 'CINPUT'
      INCLUDE 'CCONST'
      INCLUDE 'CLU'
C
      PARAMETER (INDEP=200)
      DIMENSION DPIN(INDEP),ANIN(MK,INDEP),DP(MDEP)
      CHARACTER*80 TEXT
C
C  READ HELIUM POPULATIONS FROM FILE RSTRT
C  CSTRIP CAN NOT BE USED BECAUSE FILE DUMS IS BEING READ BY GENCOL
C
      CALL MOPEN(LRSTRT,'RSTRT',1,'OLD')
      CALL MOPEN(LDUMS2,'DUMS2',1,'UNKNOWN')
   50 CONTINUE
        READ(LRSTRT,100,END=90) TEXT
        IF(TEXT(1:1).NE.'*') WRITE(LDUMS2,100) TEXT
      GOTO 50
   90 CONTINUE
      CALL CLOSE(LRSTRT)
      CALL REWIND(LDUMS2)
        READ(LDUMS2,100,END=900) ATMOID
  100   FORMAT(A)
        READ(LDUMS2,100) TEXT
        CALL LJUST(TEXT)
        IF(DPTYPE.NE.TEXT(1:1)) THEN
          CALL STOP('RDALP: DIFFERENT SCALE TYPES IN DSCALE AND RSTRT')
        ENDIF
        READ(LDUMS2,*) GDUM
        READ(LDUMS2,*) KDEP
        IF(KDEP.GT.INDEP) CALL STOP('RDALP:KDEP.GT.INDEP')
        READ(LDUMS2,*) (DPIN(K),DUM,DUM,DUM,DUM,K=1,KDEP)
        READ(LDUMS2,*) ((ANIN(I,K),I=1,NK),K=1,KDEP)
C
C  STORE DEPTH-GRID USED IN DP
C
        IF(DPTYPE.EQ.'M') THEN
          DO 110 K=1,NDEP
            DP(K)=LOG10(CMASS(K))
  110     CONTINUE
        ELSE IF(DPTYPE.EQ.'T') THEN
          DO 120 K=1,NDEP
            DP(K)=LOG10(TAU(K))
  120     CONTINUE
        ELSE
          CALL STOP('RDALP: DPTYPE NOT IMPLEMENTED YET')
        ENDIF
C
C  INTERPOLATE START APPROXIMATION TO DEPTH-GRID USED,
C  LINEAR INTERPOLATION IN THE LOG OF THE POPULATION NUMBERS
C
C  TAKE THE LOG OF THE INPUT POPULATION NUMBERS
C
        DO 140 K=1,KDEP
          DO 130 I=1,NK
            ANIN(I,K)=LOG(ANIN(I,K))
  130     CONTINUE
  140   CONTINUE
C
        IF(DPIN(1).GT.DP(1)) WRITE(LOUT,150) DPIN(1),DP(1)
  150   FORMAT(' EXTRAPOLATION IN MIN DEPTH, DPIN=',F13.7,' DP=',F13.7)
        IF(DPIN(KDEP).LT.DP(NDEP)) WRITE(LOUT,160) DPIN(KDEP),DP(NDEP)
  160   FORMAT(' EXTRAPOLATION IN MAX DEPTH, DPIN=',F13.7,' DP=',F13.7)
        L=1
        DO 200 K=1,NDEP
  170     L=L+1
          IF(DP(K).GT.DPIN(L) .AND. L.LT.KDEP) GOTO 170
          APOL=(DP(K)-DPIN(L-1))/(DPIN(L)-DPIN(L-1))
          DO 180 I=1,NK
            N(I,K)=EXP(ANIN(I,L-1)+APOL*(ANIN(I,L)-ANIN(I,L-1)))
  180     CONTINUE
          L=L-1
  200   CONTINUE
C
      RETURN
  900   CALL STOP('RDALP: RSTRT NOT EXISTING')
      END
C
C*********************************************************************
C
      SUBROUTINE HEPOP(T,TOTH,HE1,HE2,HE3)
      INCLUDE 'PREC'
C  
C  RATIOS OF HELIUM IONIZATION FRACTIONS FROM TABLE IV OF ARNAUD AND ROTHENFLUG
C  ABHE IS ABUNDANCE OF HELIUM - ASSUMED = 0.1
C
      PARAMETER(NT=19)
      DIMENSION TT(NT),ONE(NT),TWO(NT)
      DATA TT /3.50, 4.00, 4.10, 4.20, 4.30, 4.40, 4.50, 4.60, 
     *  4.70, 4.80, 4.90,
     *  5.00, 5.10, 5.20, 5.30, 5.40, 5.50, 5.60, 5.70/
      DATA ONE /0.0, 0.0 ,0.0 ,0.0 ,0.0 ,-0.07,-0.51,-1.33,-2.07,
     * -2.63,-3.20,-3.94,-4.67,-5.32,-5.90,-6.42,
     * -6.90,-7.33,-7.73/
      DATA TWO /-20.0,-9.05,-6.10,-3.75,-2.12,-0.84,-0.16, 
     * -0.02,-0.01,-0.05,-0.34,-0.96,-1.60,-2.16,-2.63,
     * -3.03,-3.38,-3.68,-3.94/
      ABHE=0.1
      TLOG=LOG10(T)
      F1=10.**(SPLIN(TLOG,TT,ONE,NT,NT))
      F2=10.**(SPLIN(TLOG,TT,TWO,NT,NT))
      HE1=TOTH*ABHE*F1
      HE2=TOTH*ABHE*F2
      ALFA=1.-F1-F2
      IF(ALFA .LT. 0.) THEN ALFA=1.E-30
      ALFA=TOTH*ABHE*ALFA
      RETURN
      END
C
C*********************************************************************
C
      SUBROUTINE AR85CEA(ILO,IHI,CEA)
C
C  NEW ROUTINE FOR COMPUTING COLLISIONAL AUTOIONIZATION 
C  RATES USING FORMALISM AND FORMULAE FROM ARNAUD AND ROTHENFLUG 1985
C
C
C: AR85CEA 94-02-22  NEW ROUTINE: (PHILIP JUDGE)
C:
C:         96-03-07  MODIFICATIONS: (PHILIP JUDGE)
C:                   BUG FIXED: CUP INITIALIZED TO ZERO
C:
        
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'CATOM'
      INCLUDE 'CATMOS'
      INCLUDE 'CCONST'
      INCLUDE 'CLU'
      DIMENSION CEA(MDEP)
      CHARACTER*2 CSEQ, ARELEM, ATOMNM
      LOGICAL DEBUG
      DATA DEBUG /.FALSE./
C
C  INITIALIZE OUTPUT TO ZERO
C
C 96-03-07 BUG FIX BEGIN
      CUP=0.0
C 96-03-07 BUG FIX END
      DO 2 K=1,NDEP
        CEA(K)=0.0
    2 CONTINUE
C
C
C  FIND ELEMENT
C
      ARELEM = ATOMID(1:2)
      IZ=IATOMN(ARELEM)   
      ZZ=0.0 + IZ
      IF (IZ .LT. 1 .OR. IZ .GT. 92) THEN 
        WRITE(LJOBLO,*)'AR85-CEA:  ATOMIC NUMBER = ',IZ, ' FOR ',ARELEM
        WRITE(LJOBLO,*)'AR85-CEA:  NO AUTOIONIZATION INCLUDED'
        RETURN
      ELSE IF(DEBUG) THEN
        WRITE(LJOBLO,*)'AR85-CEA: ',ARELEM, ' CHARGE ',ION(ILO)-1
      ENDIF
C
C  FIND ISO-ELECTRONIC SEQUENCE
C
      ICHRGE=ION(ILO)-1
      ISOSEQ=IZ-ICHRGE
      CSEQ=ATOMNM(ISOSEQ)  
      DO 1 K=1, NDEP
        BKT=BK*TEMP(K)/EE
C
C*********************************************************************
C LITHIUM SEQUENCE
C*********************************************************************
C
        IF (CSEQ .EQ. 'LI') THEN 
          CEAB=1. / (1. + 2.E-4*ZZ*ZZ*ZZ)
          CEAZEFF=(ZZ-1.3)
          CEAIEA=13.6*((ZZ-0.835)*(ZZ-0.835) - 0.25*(ZZ-1.62)*
     *     (ZZ-1.62))
          Y=CEAIEA/BKT
          F1Y=FONE(Y)
CPREPRINT          CUP= 8.0E+10 * CEAB /CEAZEFF/CEAZEFF/SQRT(BKT) 
CPREPRINT     *   * EXP(-Y)*(2.22*F1Y+0.67*(1.-Y*F1Y)+0.49*Y*F1Y+1.2*(Y-F1Y))
          CUP=1.60E-07*1.2*CEAB/CEAZEFF/CEAZEFF/SQRT(BKT)*EXP(-Y)*
     *     (2.22*F1Y+0.67*(1.-Y*F1Y)+0.49*Y*F1Y+1.2*Y*(1.-Y*F1Y))
C
C  TWO SPECIAL CASES:
C
C C IV - APP A AR85
          IF(ARELEM .EQ. 'C ') CUP = CUP*0.6
C N V  - APP A AR85
          IF(ARELEM .EQ. 'N ') CUP = CUP*0.8
C O VI - APP A AR85
          IF(ARELEM .EQ. 'O ') CUP = CUP*1.25  
C
C*********************************************************************
C SODIUM SEQUENCE
C*********************************************************************
C
        ELSE IF (CSEQ .EQ. 'NA') THEN 
          IF (IZ .LE. 16) THEN 
            CEAA=2.8E-17*(ZZ-11.)**(-0.7)
            CEAIEA=26.*(ZZ-10.)
            Y=CEAIEA/BKT
            F1Y=FONE(Y)
            CUP= 6.69E+7 * CEAA *CEAIEA/SQRT(BKT) * EXP(-Y)*(1. - Y*F1Y)
          ELSE IF (IZ .GE. 18 .AND.  IZ .LE. 28) THEN 
            CEAA=1.3E-14*(ZZ-10.)**(-3.73)
            CEAIEA=11.*(ZZ-10.)*SQRT(ZZ-10.)
            Y=CEAIEA/BKT
            F1Y=FONE(Y)
            CUP= 6.69E+7 * CEAA *CEAIEA/SQRT(BKT) * EXP(-Y)  
     *      *(1. - 0.5*(Y -Y*Y + Y*Y*Y*F1Y))
          ELSE 
            RETURN
          ENDIF
        ENDIF
C
C*********************************************************************
C MAGNESIUM-SULFUR SEQUENCES
C*********************************************************************
C
        IF(CSEQ .EQ. 'MG' .OR. CSEQ .EQ. 'AL' 
     *   .OR. CSEQ .EQ. 'SI' .OR. 
     *   CSEQ .EQ. 'P ' .OR. CSEQ .EQ. 'S ') THEN 
          IF(CSEQ .EQ. 'MG') CEAIEA=10.3*(ZZ-10.)**1.52
          IF(CSEQ .EQ. 'AL') CEAIEA=18.0*(ZZ-11.)**1.33
          IF(CSEQ .EQ. 'SI') CEAIEA=18.4*(ZZ-12.)**1.36
          IF(CSEQ .EQ. 'P ' ) CEAIEA=23.7*(ZZ-13.)**1.29
          IF(CSEQ .EQ. 'S ' ) CEAIEA=40.1*(ZZ-14.)**1.1
          CEAA=4.0E-13/ZZ/ZZ/CEAIEA
          Y=CEAIEA/BKT
          F1Y=FONE(Y)
          CUP= 6.69E+7 * CEAA *CEAIEA/SQRT(BKT) * EXP(-Y)  
     *    *(1. - 0.5*(Y -Y*Y + Y*Y*Y*F1Y))
        ENDIF
C
C
C*********************************************************************
C  SPECIAL CASES
C*********************************************************************
C
C
        IF(ARELEM .EQ. 'CA' .AND.  (ICHRGE .EQ. 0)) THEN 
          CEAA = 9.8E-17
          CEAIEA= 25.
          CEAB=1.12         
          CUP=6.69E+7*CEAA *CEAIEA/SQRT(BKT) * EXP(-Y)*(1. + CEAB*F1Y)
          WRITE(LJOBLO,*)'AR85-CEA SPECIAL CASE ',ARELEM, 
     *     ' ION ICHRGE ',ICHRGE
        ELSE IF(ARELEM .EQ. 'CA' .AND.  (ICHRGE .EQ. 1)) THEN 
          CEAA = 6.0E-17
          CEAIEA= 25.
          CEAB=1.12         
          CUP=6.69E+7*CEAA *CEAIEA/SQRT(BKT) * EXP(-Y)*(1. + CEAB*F1Y)
        ELSE IF(ARELEM .EQ. 'FE' .AND.  (ICHRGE .EQ. 3)) THEN 
          CEAA = 1.8E-17
          CEAIEA= 60.
          CEAB=1.0         
          CUP=6.69E+7*CEAA *CEAIEA/SQRT(BKT) * EXP(-Y)*(1. + CEAB*F1Y)
        ELSE IF(ARELEM .EQ. 'FE' .AND.  (ICHRGE .EQ. 4)) THEN 
         CEAA = 5.0E-17
         CEAIEA= 73.
         CEAB=1.0         
         CUP=6.69E+7*CEAA *CEAIEA/SQRT(BKT) * EXP(-Y)*(1. + CEAB*F1Y)
        ENDIF
        CEA(K)=CUP
    1 CONTINUE
      RETURN
      END
C
C*********************************************************************
C
      INTEGER FUNCTION IATOMN(STRING)
C
C  ATOMN 94-02-22  NEW ROUTINE: (PHILIP JUDGE)
C  GIVES ATOMIC NUMBER OF ARELEMENT IF STRING IS A STRING CONTAINING
C  THE NAME OF THE ARELEMENT, E.G. IF INPUT  IS 'H ' IT WILL RETURN 1
C        
      PARAMETER (NDATA=28)
      CHARACTER*2 ARELEM(NDATA)
      CHARACTER *(*) STRING
      DATA ARELEM /'H ','HE','LI','BE','B ','C ','N ','O ','F ','NE',
     * 'NA','MG','AL','SI','P ','S ','CL','AR',
     * 'K ','CA','SC','TI','V ','CR','MN','FE','CO','NI'/
      IATOMN=-1
      DO 1 I=1,NDATA
        IF(STRING .EQ. ARELEM(I)) THEN
          IATOMN=I
          RETURN
        ENDIF
    1 CONTINUE
      END
C
C*********************************************************************
C
       CHARACTER*2 FUNCTION ATOMNM(I)
C
C  ATOMNM 94-02-22  NEW ROUTINE: (PHILIP JUDGE)
C  GIVES ATOMIC NAME OF ARELEMENT IF I IS AN INTEGER CONTAINING
C  E.G. IF INPUT  IS 'H ' IT WILL RETURN 1, 'HE', IT WILL RETURN 2, ETC.
C
      PARAMETER (NDATA=28)
      CHARACTER*2 ARELEM(NDATA)
      DATA ARELEM /'H ','HE','LI','BE','B ','C ','N ','O ','F ','NE',
     * 'NA','MG','AL','SI','P ','S ','CL','AR',
     * 'K ','CA','SC','TI','V ','CR','MN','FE','CO','NI'/
      IF(I .LE. NDATA .AND.  I .GE. 1) THEN 
        ATOMNM= ARELEM(I)
      ELSE
        ATOMNM='  '
      ENDIF
      RETURN
      END

C
C***********************************************************************
C
      FUNCTION FONE(X)
C
C NEW ROUTINE 24-JAN-1994
C CALCULATES F1(X) NEEDED FOR COLLISIONAL RATES OF ARNAUD AND ROTHENFLUG 
C MODIFIED BY P. JUDGE 15-MAR-1994 
C FOR LARGE VALUES OF X, USE ASYMPTOTIC LIMIT
C 
      INCLUDE 'PREC'
      DATA SPLIT /50.0/
      IF(X .LE. SPLIT) THEN 
        FONE = EXP(X)*EXPINT(1,X,EX)
      ELSE
        FONE= 1./X
      ENDIF
      RETURN
      END
C
C**********************************************************************
C
      FUNCTION FTWO(X)
C
C NEW ROUTINE 24-JAN-1994  P. JUDGE
C CALCULATES F2(X) NEEDED FOR COLLISIONAL RATES OF ARNAUD AND ROTHENFLUG 
C IF ARGUMENT X IS < BREAK, THEN USE THE EQNS 5 AND 6 OF HUMMER (1983, JQSRT, 30 281)
C BREAK GIVEN BY HUMMER AS 4.0
C
C NOTE THAT THE SUGGESTED POLYNOMIAL EXPANSION OF ARNAUD AND ROTHENFLUG
C FAILS FOR ARGUMENTS < BREAK- SEE HUMMER'S ORIGINAL PAPER.
C IT IS UNCLEAR IF THE TABULATED IONIZATION FRACTIONS OF ARNAUD AND ROTHENFLUG
C CONTAIN THIS ERROR.   
C 
      INCLUDE 'PREC'
      INCLUDE 'CCONST'
      DIMENSION P(15), Q(15)
      DATA BREAK /4.0/
      DATA P /1.0,2.1658E+02,2.0336E+04,1.0911E+06,3.7114E+07,
     * 8.3963E+08,1.2889E+10,1.3449E+11,9.4002E+11,4.2571E+12,
     * 1.1743E+13,1.7549E+13,1.0806E+13,4.9776E+11,0.0000/,
     *     Q /1.0,2.1958E+02,2.0984E+04,1.1517E+06,4.0349E+07,
     * 9.4900E+08,1.5345E+10,1.7182E+11,1.3249E+12,6.9071E+12,
     * 2.3531E+13,4.9432E+13,5.7760E+13,3.0225E+13, 3.3641E+12/
      IF(X .GE. BREAK) THEN 
        PX=P(1)
        XFACT=1.0
        DO 1 I=2,15
          XFACT = XFACT/X
          PX=PX+ P(I)*XFACT
    1   CONTINUE
C        PX = P(1) + XI*(P(2) + (XI*P(3) +(XI*P(4) + (XI*P(5) + (XI*P(6) 
C     *   + (XI*P(7) + (XI*P(8) +(XI*P(9) + (XI*P(10) + (XI*P(11) +
C     *   (XI*P(12) + (XI*P(13) +(XI*P(14)+XI*P(15))))))))))))))
C        QX = Q(1) + XI*(Q(2) + (XI*Q(3) +(XI*Q(4) + (XI*Q(5) + (XI*Q(6) 
C     *   + (XI*Q(7) + (XI*Q(8) +(XI*Q(9) + (XI*Q(10) + (XI*Q(11) +
C     *   (XI*Q(12) + (XI*Q(13) +(XI*Q(14)+XI*Q(15))))))))))))))
        QX=Q(1)
        XFACT=1.0
        DO 2 I=2,15
          XFACT = XFACT/X
          QX=QX+ Q(I)*XFACT
    2   CONTINUE
        FTWO=PX/QX/X/X
      ELSE
C
C  HUMMER'S EQUNS 5 AND 6
C  GAMMA IS EULER'S CONSTANT (ABRAMOVICZ+STEGUN)
C
        GAMMA=0.5772156649  
        F0X = PI*PI/12.
        TERM=1.0
        COUNT=0.0
        FACT=1.0
        XFACT=1.0
        DO WHILE (ABS(TERM/F0X) .GT. 1.E-8)
          COUNT=COUNT+1.0
          FACT = FACT*COUNT
          XFACT=XFACT*(-X)
          TERM = XFACT/COUNT/COUNT/FACT
          F0X=F0X+TERM
          IF(COUNT .GT. 100.) CALL STOP('FTWO: TOO MANY ITERATIONS')
        ENDDO
        FTWO=EXP(X)*((LOG(X)+GAMMA)*(LOG(X)+GAMMA)*0.5 + F0X)
      ENDIF
      RETURN
      END

      FUNCTION SUMMERS(ILO,IHI,EDENS)
C
C  NEW ROUTINE FOR COMPUTING COLLISIONAL REDUCTION OF DIELECTRONIC 
C  RECOMBINATION RATE BY ELECTRON COLLISIONS FOLLOWING SUMMERS 1974
C  Inputs:
C    ILO  - index of lower level of transition
C    IHI  - index of upper level of transition
C    EDENS - electron density in /cm3
C SUMMERS 94-11-09  NEW ROUTINE: (PHILIP JUDGE)
C        
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'CATOM'
      INCLUDE 'CATMOS'
      INCLUDE 'CCONST'
      INCLUDE 'CLU'
      CHARACTER*2 CSEQ, ARELEM, ATOMNM
      LOGICAL DEBUG
      DATA DEBUG /.FALSE./
      SUMMERS=1.0
C
C
C  FIND ELEMENT
C
      ARELEM = ATOMID(1:2)
      IZ=IATOMN(ARELEM)   
      ZZ=0.0 + IZ
      IF (IZ .LT. 1 .OR. IZ .GT. 92) THEN 
        WRITE(LJOBLO,*)'SUMMERS:  ATOMIC NUMBER = ',IZ, ' FOR ',ARELEM
        WRITE(LJOBLO,*)'SUMMERS:  NO DENSITY EFFECTS IN DIEL RATE'
        RETURN
      ELSE IF(DEBUG) THEN
        WRITE(LJOBLO,*)'SUMMERS: ',ARELEM, ' CHARGE ',ION(ILO)
      ENDIF
C
C  FIND ISO-ELECTRONIC SEQUENCE OF RECOMBINING ION
C
      ICHRGE=ION(ILO)
      ZZ=FLOAT(ICHRGE)
      ISOSEQ=IZ-ICHRGE
      CSEQ=ATOMNM(ISOSEQ)  
C
C*********************************************************************
C LITHIUM, SODIUM, POTASSIUM SEQUENCES
C*********************************************************************
C
      RHO0=2000.0
      IF (CSEQ .EQ. 'LI' .OR. CSEQ .EQ. 'NA' .OR. 
     *   CSEQ .EQ. 'K') RHO0=30.0
      RHOQ=EDENS/ZZ/ZZ/ZZ/ZZ/ZZ/ZZ/ZZ
      SUMMERS=1. / (1.+ RHOQ/RHO0)**0.14
      IF(DEBUG) THEN
         WRITE(LJOBLO,*)'SUMMERS: ',LABEL(IHI),' -> ', 
     *    LABEL(ILO), ' SEQUENCE =', CSEQ
         WRITE(LJOBLO,*)'SUMMERS: DENSITY FACTOR = ',SUMMERS, 
     *      ' NE = ', EDENS, 'RHO0=',RHO0
      ENDIF
      RETURN
      END
C*********************************************************************
      SUBROUTINE TAUTSP ( TAU, GTAU, NTAU, GAMMA, S,
     *                    BREAK, COEF, L, K, IFLAG )
      INCLUDE 'PREC'
C  FROM  * A PRACTICAL GUIDE TO SPLINES *  BY C. DE BOOR
CONSTRUCTS CUBIC SPLINE INTERPOLANT TO GIVEN DATA
C         TAU(I), GTAU(I), I=1,...,NTAU.
C  IF  GAMMA .GT. 0., ADDITIONAL KNOTS ARE INTRODUCED WHERE NEEDED TO
C  MAKE THE INTERPOLANT MORE FLEXIBLE LOCALLY. THIS AVOIDS EXTRANEOUS
C  INFLECTION POINTS TYPICAL OF CUBIC SPLINE INTERPOLATION AT KNOTS TO
C  RAPIDLY CHANGING DATA.
C
C  PARAMETERS
C            INPUT
C  TAU      SEQUENCE OF DATA POINTS. MUST BE STRICTLY INCREASING.
C  GTAU     CORRESPONDING SEQUENCE OF FUNCTION VALUES.
C  NTAU     NUMBER OF DATA POINTS. MUST BE AT LEAST  4 .
C  GAMMA    INDICATES WHETHER ADDITIONAL FLEXIBILITY IS DESIRED.
C          = 0., NO ADDITIONAL KNOTS
C          IN (0.,3.), UNDER CERTAIN CONDITIONS ON THE GIVEN DATA AT
C                POINTS I-1, I, I+1, AND I+2, A KNOT IS ADDED IN THE
C                I-TH INTERVAL, I=2,...,NTAU-2. SEE DESCRIPTION OF METH-
C                OD BELOW. THE INTERPOLANT GETS ROUNDED WITH INCREASING
C                GAMMA. A VALUE OF  2.5  FOR GAMMA IS TYPICAL.
C          IN (3.,6.), SAME , EXCEPT THAT KNOTS MIGHT ALSO BE ADDED IN
C                INTERVALS IN WHICH AN INFLECTION POINT WOULD BE PERMIT-
C                TED.  A VALUE OF  5.5  FOR GAMMA IS TYPICAL.
C            OUTPUT
C  BREAK, COEF, L, K  GIVE THE PP-REPRESENTATION OF THE INTERPOLANT.
C          SPECIFICALLY, FOR BREAK(I) .LE. X .LE. BREAK(I+1), THE
C        INTERPOLANT HAS THE FORM
C  F(X) = COEF(1,I) +DX(COEF(2,I) +(DX/2)(COEF(3,I) +(DX/3)COEF(4,I)))
C        WITH  DX = X - BREAK(I) AND I=1,...,L .
C  IFLAG   = 1, OK
C          = 2, INPUT WAS INCORRECT. A PRINTOUT SPECIFYING THE MISTAKE
C            WAS MADE.
C            WORKSPACE
C  S     IS REQUIRED, OF SIZE (NTAU,6). THE INDIVIDUAL COLUMNS OF THIS
C        ARRAY CONTAIN THE FOLLOWING QUANTITIES MENTIONED IN THE WRITE-
C        UP AND BELOW.
C     S(.,1) = DTAU = TAU(.+1) - TAU
C     S(.,2) = DIAG = DIAGONAL IN LINEAR SYSTEM
C     S(.,3) = U = UPPER DIAGONAL IN LINEAR SYSTEM
C     S(.,4) = R = RIGHT SIDE FOR LINEAR SYSTEM (INITIALLY)
C            = FSECND = SOLUTION OF LINEAR SYSTEM , NAMELY THE SECOND
C                       DERIVATIVES OF INTERPOLANT AT  TAU
C     S(.,5) = Z = INDICATOR OF ADDITIONAL KNOTS
C     S(.,6) = 1/HSECND(1,X) WITH X = Z OR = 1-Z. SEE BELOW.
C
C  ------  M E T H O D  ------
C  ON THE I-TH INTERVAL, (TAU(I), TAU(I+1)), THE INTERPOLANT IS OF THE
C  FORM
C  (*)  F(U(X)) = A + B*U + C*H(U,Z) + D*H(1-U,1-Z) ,
C  WITH  U = U(X) = (X - TAU(I))/DTAU(I). HERE,
C       Z = Z(I) = ADDG(I+1)/(ADDG(I) + ADDG(I+1))
C  (= .5, IN CASE THE DENOMINATOR VANISHES). WITH
C       ADDG(J) = ABS(DDG(J)), DDG(J) = DG(J+1) - DG(J),
C       DG(J) = DIVDIF(J) = (GTAU(J+1) - GTAU(J))/DTAU(J)
C  AND
C       H(U,Z) = ALPHA*U**3 + (1 - ALPHA)*(MAX(((U-ZETA)/(1-ZETA)),0)**3
C  WITH
C       ALPHA(Z) = (1-GAMMA/3)/ZETA
C       ZETA(Z) = 1 - GAMMA*MIN((1 - Z), 1/3)
C  THUS, FOR 1/3 .LE. Z .LE. 2/3,  F  IS JUST A CUBIC POLYNOMIAL ON
C  THE INTERVAL I. OTHERWISE, IT HAS ONE ADDITIONAL KNOT, AT
C         TAU(I) + ZETA*DTAU(I) .
C  AS  Z  APPROACHES  1, H(.,Z) HAS AN INCREASINGLY SHARP BEND  NEAR 1,
C  THUS ALLOWING  F  TO TURN RAPIDLY NEAR THE ADDITIONAL KNOT.
C     IN TERMS OF F(J) = GTAU(J) AND
C       FSECND(J) = 2.DERIVATIVE OF  F  AT  TAU(J),
C  THE COEFFICIENTS FOR (*) ARE GIVEN AS
C       A = F(I) - D
C       B = (F(I+1) - F(I)) - (C - D)
C       C = FSECND(I+1)*DTAU(I)**2/HSECND(1,Z)
C       D = FSECND(I)*DTAU(I)**2/HSECND(1,1-Z)
C  HENCE CAN BE COMPUTED ONCE FSECND(I),I=1,...,NTAU, IS FIXED.
C   F  IS AUTOMATICALLY CONTINUOUS AND HAS A CONTINUOUS SECOND DERIVAT-
C  IVE (EXCEPT WHEN Z = 0 OR 1 FOR SOME I). WE DETERMINE FSCND(.) FROM
C  THE REQUIREMENT THAT ALSO THE FIRST DERIVATIVE OF  F  BE CONTIN-
C  UOUS. IN ADDITION, WE REQUIRE THAT THE THIRD DERIVATIVE BE CONTINUOUS
C  ACROSS  TAU(2) AND ACROSS  TAU(NTAU-1) . THIS LEADS TO A STRICTLY
C  DIAGONALLY DOMINANT TRIDIAGONAL LINEAR SYSTEM FOR THE FSECND(I)
C  WHICH WE SOLVE BY GAUSS ELIMINATION WITHOUT PIVOTING.
C
C:
C: TAUTSP 89-08-30 MATS CARLSSON
C:        TEST OF ONEMZT CHANGED FROM 0. TO 1.E-11 TO AVOID DIVISION
C:        BY UNDERFLOWED EXPRESSION (ONEMZT**3)
C:
C:        89-09-05 MATS CARLSSON
C:        DIMENSION OF BREAK AND COEF CHANGED FROM 1 TO * TO MAKE 
C:        POSSIBLE CHECK OF INDEX OUT OF BOUNDS
C:
      INTEGER IFLAG,K,L,NTAU,   I,METHOD,NTAUM1
      DIMENSION BREAK(*),COEF(4,*),GTAU(NTAU),S(NTAU,6),TAU(NTAU)
      DATA ONE/1.0/
      SAVE ONE
C
      ALPH(X) = MIN(ONE,ONEMG3/X)
C
C  THERE MUST BE AT LEAST  4  INTERPOLATION POINTS.
      IF (NTAU .GE. 4)                  GO TO 5
      PRINT 600,NTAU
  600 FORMAT(8H NTAU = ,I4,20H. SHOULD BE .GE. 4 .)
                                        GO TO 999
C
CONSTRUCT DELTA TAU AND FIRST AND SECOND (DIVIDED) DIFFERENCES OF DATA
C
    5 NTAUM1 = NTAU - 1
      DO 6 I=1,NTAUM1
         S(I,1) = TAU(I+1) - TAU(I)
         IF (S(I,1) .GT. 0.)            GO TO 6
         PRINT 610,I,TAU(I),TAU(I+1)
  610    FORMAT(7H POINT ,I3,13H AND THE NEXT,2E15.6,15H ARE DISORDERED)
                                        GO TO 999
    6    S(I+1,4) = (GTAU(I+1)-GTAU(I))/S(I,1)
      DO 7 I=2,NTAUM1
    7    S(I,4) = S(I+1,4) - S(I,4)
C
CONSTRUCT SYSTEM OF EQUATIONS FOR SECOND DERIVATIVES AT  TAU. AT EACH
C  INTERIOR DATA POINT, THERE IS ONE CONTINUITY EQUATION, AT THE FIRST
C  AND THE LAST INTERIOR DATA POINT THERE IS AN ADDITIONAL ONE FOR A
C  TOTAL OF  NTAU  EQUATIONS IN  NTAU  UNKNOWNS.
C
      I = 2
      S(2,2) = S(1,1)/3.        
      SIXTH = 1./6.
      METHOD = 2
      GAM = GAMMA
      IF (GAM .LE. 0.)   METHOD = 1
      IF ( GAM .LE. 3.)                 GO TO 9
      METHOD = 3
      GAM = GAM - 3.
    9 ONEMG3 = 1. - GAM/3.
C                 ------ LOOP OVER I ------
   10 CONTINUE
C          CONSTRUCT Z(I) AND ZETA(I)
      Z = .5
                                        GO TO (19,11,12),METHOD
   11 IF (S(I,4)*S(I+1,4) .LT. 0.)      GO TO 19
   12 TEMP = ABS(S(I+1,4))
      DENOM = ABS(S(I,4)) + TEMP
      IF (DENOM .EQ. 0.)                GO TO 19
      Z = TEMP/DENOM
      IF (ABS(Z - .5) .LE. SIXTH)  Z = .5
   19 S(I,5) = Z
C   ******SET UP PART OF THE I-TH EQUATION WHICH DEPENDS ON
C         THE I-TH INTERVAL
      IF (Z - .5)                       21,22,23
   21 ZETA = GAM*Z
      ONEMZT = 1. - ZETA
      ZT2 = ZETA**2
      ALPHA = ALPH(ONEMZT)
      FACTOR = ZETA/(ALPHA*(ZT2-1.) + 1.)
      S(I,6) = ZETA*FACTOR/6.
      S(I,2) = S(I,2) + S(I,1)*((1.-ALPHA*ONEMZT)*FACTOR/2. - S(I,6))
C     IF Z = 0 AND THE PREVIOUS Z = 1, THEN D(I) = 0. SINCE THEN
C     ALSO U(I-1) = L(I+1) = 0, ITS VALUE DOES NOT MATTER. RESET
C     D(I) = 1 TO INSURE NONZERO PIVOT IN ELIMINATION.
      IF (S(I,2) .LE. 0.) S(I,2) = 1.
      S(I,3) = S(I,1)/6.
                                        GO TO 25
   22 S(I,2) = S(I,2) + S(I,1)/3.
      S(I,3) = S(I,1)/6.
                                        GO TO 25
   23 ONEMZT = GAM*(1. - Z)
      ZETA = 1. - ONEMZT
      ALPHA = ALPH(ZETA)
      FACTOR = ONEMZT/(1. - ALPHA*ZETA*(1.+ONEMZT))
      S(I,6) = ONEMZT*FACTOR/6.
      S(I,2) = S(I,2) + S(I,1)/3.
      S(I,3) = S(I,6)*S(I,1)
   25 IF (I .GT. 2)                     GO TO 30
      S(1,5) = .5
C  ******THE FIRST TWO EQUATIONS ENFORCE CONTINUITY OF THE FIRST AND OF
C        THE THIRD DERIVATIVE ACROSS TAU(2).
      S(1,2) = S(1,1)/6.
      S(1,3) = S(2,2)
      ENTRY3 = S(2,3)
      IF (Z - .5)                       26,27,28
   26 FACTR2 = ZETA*(ALPHA*(ZT2-1.) + 1.)/(ALPHA*(ZETA*ZT2-1.)+1.)
      RATIO = FACTR2*S(2,1)/S(1,2)
      S(2,2) = FACTR2*S(2,1) + S(1,1)
      S(2,3) = -FACTR2*S(1,1)
                                        GO TO 29
   27 RATIO = S(2,1)/S(1,2)
      S(2,2) = S(2,1) + S(1,1)
      S(2,3) = -S(1,1)
                                        GO TO 29
   28 RATIO = S(2,1)/S(1,2)
      S(2,2) = S(2,1) + S(1,1)
      S(2,3) = -S(1,1)*6.*ALPHA*S(2,6)
C       AT THIS POINT, THE FIRST TWO EQUATIONS READ
C              DIAG(1)*X1 + U(1)*X2 + ENTRY3*X3 = R(2)
C       -RATIO*DIAG(1)*X1 + DIAG(2)*X2 + U(2)*X3 = 0.
C       ELIMINATE FIRST UNKNOWN FROM SECOND EQUATION
   29 S(2,2) = RATIO*S(1,3) + S(2,2)
      S(2,3) = RATIO*ENTRY3 + S(2,3)
      S(1,4) = S(2,4)
      S(2,4) = RATIO*S(1,4)
                                        GO TO 35
   30 CONTINUE
C  ******THE I-TH EQUATION ENFORCES CONTINUITY OF THE FIRST DERIVATIVE
C        ACROSS TAU(I). IT HAS BEEN SET UP IN STATEMENTS 35 UP TO 40
C        AND 21 UP TO 25 AND READS NOW
C         -RATIO*DIAG(I-1)*XI-1 + DIAG(I)*XI + U(I)*XI+1 = R(I) .
C        ELIMINATE (I-1)ST UNKNOWN FROM THIS EQUATION
      S(I,2) = RATIO*S(I-1,3) + S(I,2)
      S(I,4) = RATIO*S(I-1,4) + S(I,4)
C
C  ******SET UP THE PART OF THE NEXT EQUATION WHICH DEPENDS ON THE
C        I-TH INTERVAL.
   35 IF (Z - .5)                       36,37,38
   36 RATIO = -S(I,6)*S(I,1)/S(I,2)
      S(I+1,2) = S(I,1)/3.
                                        GO TO 40
   37 RATIO = -(S(I,1)/6.)/S(I,2)
      S(I+1,2) = S(I,1)/3.
                                        GO TO 40
   38 RATIO = -(S(I,1)/6.)/S(I,2)
      S(I+1,2) = S(I,1)*((1.-ZETA*ALPHA)*FACTOR/2. - S(I,6))
C         ------  END OF I LOOP ------
   40 I = I+1
      IF (I .LT. NTAUM1)                GO TO 10
      S(I,5) = .5
C
C        ------  LAST TWO EQUATIONS  ------
C  THE LAST TWO EQUATIONS ENFORCE CONTINUITY OF THIRD DERIVATIVE AND
C  OF FIRST DERIVATIVE ACROSS  TAU(NTAU-1).
      ENTRY = RATIO*S(I-1,3) + S(I,2) + S(I,1)/3.
      S(I+1,2) = S(I,1)/6.
      S(I+1,4) = RATIO*S(I-1,4) + S(I,4)
      IF (Z - .5)                       41,42,43
   41 RATIO = S(I,1)*6.*S(I-1,6)*ALPHA/S(I-1,2)
      S(I,2) = RATIO*S(I-1,3) + S(I,1) + S(I-1,1)
      S(I,3) = -S(I-1,1)
                                        GO TO 45
   42 RATIO = S(I,1)/S(I-1,2)
      S(I,2) = RATIO*S(I-1,3) + S(I,1) + S(I-1,1)
      S(I,3) = -S(I-1,1)
                                        GO TO 45
   43 FACTR2 = ONEMZT*(ALPHA*(ONEMZT**2-1.)+1.)/
     *               (ALPHA*(ONEMZT**3-1.)+1.)
      RATIO = FACTR2*S(I,1)/S(I-1,2)
      S(I,2) = RATIO*S(I-1,3) + FACTR2*S(I-1,1) + S(I,1)
      S(I,3) = -FACTR2*S(I-1,1)
C     AT THIS POINT, THE LAST TWO EQUATIONS READ
C             DIAG(I)*XI + U(I)*XI+1 = R(I)
C      -RATIO*DIAG(I)*XI + DIAG(I+1)*XI+1 = R(I+1)
C     ELIMINATE XI FROM LAST EQUATION
   45 S(I,4) = RATIO*S(I-1,4)
      RATIO = -ENTRY/S(I,2)
      S(I+1,2) = RATIO*S(I,3) + S(I+1,2)
      S(I+1,4) = RATIO*S(I,4) + S(I+1,4)
C
C        ------ BACK SUBSTITUTION ------
C
      S(NTAU,4) = S(NTAU,4)/S(NTAU,2)
   50    S(I,4) = (S(I,4) - S(I,3)*S(I+1,4))/S(I,2)
         I = I - 1
         IF (I .GT. 1)                  GO TO 50
      S(1,4) = (S(1,4)-S(1,3)*S(2,4)-ENTRY3*S(3,4))/S(1,2)
C
C        ------ CONSTRUCT POLYNOMIAL PIECES ------
C
      BREAK(1) = TAU(1)
      L = 1
      DO 70 I=1,NTAUM1
         COEF(1,L) = GTAU(I)
         COEF(3,L) = S(I,4)
         DIVDIF = (GTAU(I+1)-GTAU(I))/S(I,1)
         Z = S(I,5)
         IF (Z - .5)                    61,62,63
   61    IF (Z .EQ. 0.)                 GO TO 65
         ZETA = GAM*Z
         ONEMZT = 1. - ZETA
         C = S(I+1,4)/6.
         D = S(I,4)*S(I,6)
         L = L + 1
         DEL = ZETA*S(I,1)
         BREAK(L) = TAU(I) + DEL
         ZT2 = ZETA**2
         ALPHA = ALPH(ONEMZT)
         FACTOR = ONEMZT**2*ALPHA
         COEF(1,L) = GTAU(I) + DIVDIF*DEL
     *             + S(I,1)**2*(D*ONEMZT*(FACTOR-1.)+C*ZETA*(ZT2-1.))
         COEF(2,L) = DIVDIF + S(I,1)*(D*(1.-3.*FACTOR)+C*(3.*ZT2-1.))
         COEF(3,L) = 6.*(D*ALPHA*ONEMZT + C*ZETA)
         COEF(4,L) = 6.*(C - D*ALPHA)/S(I,1)
         COEF(4,L-1) = COEF(4,L) - 6.*D*(1.-ALPHA)/(DEL*ZT2)
         COEF(2,L-1) = COEF(2,L) - DEL*(COEF(3,L) -(DEL/2.)*COEF(4,L-1))
                                        GO TO 68
   62    COEF(2,L) = DIVDIF - S(I,1)*(2.*S(I,4) + S(I+1,4))/6.
         COEF(4,L) = (S(I+1,4)-S(I,4))/S(I,1)
                                        GO TO 68
   63    ONEMZT = GAM*(1. - Z)
         IF (ABS(ONEMZT) .LT. 1.E-11)            GO TO 65
         ZETA = 1. - ONEMZT
         ALPHA = ALPH(ZETA)
         C = S(I+1,4)*S(I,6)
         D = S(I,4)/6.
         DEL = ZETA*S(I,1)
         BREAK(L+1) = TAU(I) + DEL
         COEF(2,L) = DIVDIF - S(I,1)*(2.*D + C)
         COEF(4,L) = 6.*(C*ALPHA - D)/S(I,1)
         L = L + 1
         COEF(4,L) = COEF(4,L-1) + 6.*(1.-ALPHA)*C/(S(I,1)*ONEMZT**3)
         COEF(3,L) = COEF(3,L-1) + DEL*COEF(4,L-1)
         COEF(2,L) = COEF(2,L-1)+DEL*(COEF(3,L-1)+(DEL/2.)*COEF(4,L-1))
         COEF(1,L) = COEF(1,L-1)+DEL*(COEF(2,L-1)+(DEL/2.)*(COEF(3,L-1)
     *                  +(DEL/3.)*COEF(4,L-1)))
                                        GO TO 68
   65    COEF(2,L) = DIVDIF
         COEF(3,L) = 0.
         COEF(4,L) = 0.
   68    L = L + 1
   70    BREAK(L) = TAU(I+1)
C*      L = L - 1   DELETION OF THIS STATEMENT MAKES EXTRAPOL WARNING POSSIBLE
      K = 4
      IFLAG = 1
                                        RETURN
  999 IFLAG = 2
                                        RETURN
      END
C*********************************************************************
      FUNCTION PPVALU (BREAK, COEF, L, K, X, JDERIV ,MFLAG)
      INCLUDE 'PREC'
C
C: PPVALU 94-07-20 MATS CARLSSON
C:        SETS VALUE TO 0 IF EXTRAPOLATION
C: 
C  FROM  * A PRACTICAL GUIDE TO SPLINES *  BY C. DE BOOR
CALLS  INTERV
CALCULATES VALUE AT  X  OF  JDERIV-TH DERIVATIVE OF PP FCT FROM PP-REPR
C
C******  I N P U T  ******
C  BREAK, COEF, L, K.....FORMS THE PP-REPRESENTATION OF THE FUNCTION  F
C        TO BE EVALUATED. SPECIFICALLY, THE J-TH DERIVATIVE OF  F  IS
C        GIVEN BY
C
C     (D**J)F(X) = COEF(J+1,I) + H*(COEF(J+2,I) + H*( ... (COEF(K-1,I) +
C                             + H*COEF(K,I)/(K-J-1))/(K-J-2) ... )/2)/1
C
C        WITH  H = X - BREAK(I),  AND
C
C       I  =  MAX( 1 , MAX( J ,  BREAK(J) .LE. X , 1 .LE. J .LE. L ) ).
C
C  X.....THE POINT AT WHICH TO EVALUATE.
C  JDERIV.....INTEGER GIVING THE ORDER OF THE DERIVATIVE TO BE EVALUAT-
C        ED.  A S S U M E D  TO BE ZERO OR POSITIVE.
C
C******  O U T P U T  ******
C  PPVALU.....THE VALUE OF THE (JDERIV)-TH DERIVATIVE OF  F  AT  X.
C
C******  M E T H O D  ******
C     THE INTERVAL INDEX  I , APPROPRIATE FOR  X , IS FOUND THROUGH A
C  CALL TO  INTERV . THE FORMULA ABOVE FOR THE  JDERIV-TH DERIVATIVE
C  OF  F  IS THEN EVALUATED (BY NESTED MULTIPLICATION).
C 
C: PPVALU 95-11-06 MATS CARLSSON
C:        RETURNS VALUE OF FLAG FROM INTERV
C:
      INTEGER JDERIV,K,L,   I,M,MFLAG
      DIMENSION BREAK(L),COEF(K,L)
      PPVALU = 0.
      FMMJDR = K - JDERIV
C              DERIVATIVES OF ORDER  K  OR HIGHER ARE IDENTICALLY ZERO.
      IF (FMMJDR .LE. 0.)               GO TO 99
C
C              FIND INDEX  I  OF LARGEST BREAKPOINT TO THE LEFT OF  X .
      CALL INTERV ( BREAK, L, X, I, MFLAG )
C
      IF(MFLAG.NE.0) THEN
        PPVALU=0.0
        RETURN
      ENDIF
C
C      EVALUATE  JDERIV-TH DERIVATIVE OF  I-TH POLYNOMIAL PIECE AT  X .
      H = X - BREAK(I)
      M = K
    9    PPVALU = (PPVALU/FMMJDR)*H + COEF(M,I)
         M = M - 1
         FMMJDR = FMMJDR - 1.
         IF (FMMJDR .GT. 0.)            GO TO 9
   99                                   RETURN
      END
C*********************************************************************
      SUBROUTINE INTERV ( XT, LXT, X, LEFT, MFLAG )
C  FROM  * A PRACTICAL GUIDE TO SPLINES *  BY C. DE BOOR
COMPUTES  LEFT = MAX( I , 1 .LE. I .LE. LXT  .AND.  XT(I) .LE. X )  .
C
C******  I N P U T  ******
C  XT.....A REAL*8 SEQUENCE, OF LENGTH  LXT , ASSUMED TO BE NONDECREASING
C  LXT.....NUMBER OF TERMS IN THE SEQUENCE  XT .
C  X.....THE POINT WHOSE LOCATION WITH RESPECT TO THE SEQUENCE  XT  IS
C        TO BE DETERMINED.
C
C******  O U T P U T  ******
C  LEFT, MFLAG.....BOTH INTEGERS, WHOSE VALUE IS
C
C   1     -1      IF               X .LT.  XT(1)
C   I      0      IF   XT(I)  .LE. X .LT. XT(I+1)
C  LXT     1      IF  XT(LXT) .LE. X
C
C        IN PARTICULAR,  MFLAG = 0 IS THE 'USUAL' CASE.  MFLAG .NE. 0
C        INDICATES THAT  X  LIES OUTSIDE THE HALFOPEN INTERVAL
C        XT(1) .LE. Y .LT. XT(LXT) . THE ASYMMETRIC TREATMENT OF THE
C        INTERVAL IS DUE TO THE DECISION TO MAKE ALL PP FUNCTIONS CONT-
C        INUOUS FROM THE RIGHT.
C
C******  M E T H O D  ******
C  THE PROGRAM IS DESIGNED TO BE EFFICIENT IN THE COMMON SITUATION THAT
C  IT IS CALLED REPEATEDLY, WITH  X  TAKEN FROM AN INCREASING OR DECREA-
C  SING SEQUENCE. THIS WILL HAPPEN, E.G., WHEN A PP FUNCTION IS TO BE
C  GRAPHED. THE FIRST GUESS FOR  LEFT  IS THEREFORE TAKEN TO BE THE VAL-
C  UE RETURNED AT THE PREVIOUS CALL AND STORED IN THE  L O C A L  VARIA-
C  BLE  ILO . A FIRST CHECK ASCERTAINS THAT  ILO .LT. LXT (THIS IS NEC-
C  ESSARY SINCE THE PRESENT CALL MAY HAVE NOTHING TO DO WITH THE PREVI-
C  OUS CALL). THEN, IF  XT(ILO) .LE. X .LT. XT(ILO+1), WE SET  LEFT =
C  ILO  AND ARE DONE AFTER JUST THREE COMPARISONS.
C     OTHERWISE, WE REPEATEDLY DOUBLE THE DIFFERENCE  ISTEP = IHI - ILO
C  WHILE ALSO MOVING  ILO  AND  IHI  IN THE DIRECTION OF  X , UNTIL
C                      XT(ILO) .LE. X .LT. XT(IHI) ,
C  AFTER WHICH WE USE BISECTION TO GET, IN ADDITION, ILO+1 = IHI .
C  LEFT = ILO  IS THEN RETURNED.
C
C:
C: INTERV 88-08-30 MATS CARLSSON
C:        STOP IF MORE THAN 20 EXTRAPOLATIONS
C:
C:        88-10-26 MATS CARLSSON
C:        SAVE STATEMENT INSERTED, EXTRAPOLATION CHECK CHANGED
C:        TO WORK FOR THE CASE X=XT
C:
C:        94-01-06 MATS CARLSSON
C:        IEXTR IN COMMON TO ENABLE ZEROING OUTSIDE ROUTINE
C:        INITIALIZATION WITH DATA STATEMENT IN VIOLATION OF F77 STANDARD
C:
C:        94-07-20 MATS CARLSSON
C:        EXTRAPOLATION RESULTS IN ZERO VALUE AND WARNING MESSAGE
C:        ONLY 10 WARNINGS PRINTED BUT PROGRAM CONTINUES
C:
C:        95-08-16 MATS CARLSSON
C:        INITIALIZATION OF IEXTR MOVED TO BLOCK DATA SUBPROGRAM
C:
C:        95-11-27 MATS CARLSSON
C:        MFLAG=1 ONLY SET IF X.GT.XT
C:
      INCLUDE 'PREC'
      COMMON /CINTV/ IEXTR
      INTEGER LEFT,LXT,MFLAG,   IHI,ILO,ISTEP,MIDDLE
      DIMENSION XT(LXT)
      DATA ILO /1/
      SAVE ILO  
      IHI = ILO + 1
      IF (IHI .LT. LXT)                 GO TO 20
         IF (X .GE. XT(LXT))            GO TO 110
         IF (LXT .LE. 1)                GO TO 90
         ILO = LXT - 1
         IHI = LXT
C
   20 IF (X .GE. XT(IHI))               GO TO 40
      IF (X .GE. XT(ILO))               GO TO 100
C
C              **** NOW X .LT. XT(ILO) . DECREASE  ILO  TO CAPTURE  X .
      ISTEP = 1
   31    IHI = ILO
         ILO = IHI - ISTEP
         IF (ILO .LE. 1)                GO TO 35
         IF (X .GE. XT(ILO))            GO TO 50
         ISTEP = ISTEP*2
                                        GO TO 31
   35 ILO = 1
      IF (X .LT. XT(1))                 GO TO 90
                                        GO TO 50
C              **** NOW X .GE. XT(IHI) . INCREASE  IHI  TO CAPTURE  X .
   40 ISTEP = 1
   41    ILO = IHI
         IHI = ILO + ISTEP
         IF (IHI .GE. LXT)              GO TO 45
         IF (X .LT. XT(IHI))            GO TO 50
         ISTEP = ISTEP*2
                                        GO TO 41
   45 IF (X .GE. XT(LXT))               GO TO 110
      IHI = LXT
C
C           **** NOW XT(ILO) .LE. X .LT. XT(IHI) . NARROW THE INTERVAL.
   50 MIDDLE = (ILO + IHI)/2
      IF (MIDDLE .EQ. ILO)              GO TO 100
C     NOTE. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1 .
      IF (X .LT. XT(MIDDLE))            GO TO 53
         ILO = MIDDLE
                                        GO TO 50
   53    IHI = MIDDLE
                                        GO TO 50
C**** SET OUTPUT AND RETURN.
   90 MFLAG = -1
      LEFT = 1
      IF(IEXTR.LE.10) THEN
        WRITE(*,92) X,XT(1)
   92   FORMAT(' INTERV: X OUTSIDE XT, VALUE SET TO ZERO, X,XT=',
     *   1P,2E14.6)
      ENDIF
      IEXTR=IEXTR+1
                                        RETURN
  100 MFLAG = 0
      LEFT = ILO
                                        RETURN
  110 CONTINUE
      LEFT = LXT-1
      MFLAG = 0
      IF(X.GT.XT(LXT)) THEN
        MFLAG = 1
        IF(IEXTR.LE.10) THEN
          WRITE(*,92) X,XT(LXT)
        ENDIF
        IEXTR=IEXTR+1
      ENDIF
                                        RETURN
      END
c
c***********************************************************************
c
      subroutine lcase(text)
c
c  converts a string to all lower case
c
      character*(*) text
c
      l=len(text)
      do 100 i=1,l
        ic=ichar(text(i:i))
        if(ic.ge.65 .and. ic.le.90) text(i:i)=char(ic+32)
  100 continue
c
      return
      end
      SUBROUTINE COCOL
C
C  COLLISION RATES FOR VIB-ROT LEVELS WITHIN THE GROUND STATE
C  OF THE CO MOLECULE
C
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'CATOM'
      INCLUDE 'CATMOS'
      INCLUDE 'CATMO2'
      INCLUDE 'CCONST'
      INCLUDE 'CLU'
C
      INCLUDE 'PARAMO'
      COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT),
     * TOTCH(MT),TOTCO(MT),TOTCN(MT),
     * TOTC(MT),TOTNIT(MT),TOTO(MT),
     * BHYD(MT,5),GRPH,TOTOH(MT)

CCC  00-09-12 TOTOH ADDED

C
      DIMENSION EN(MK)
C
C  CONVERT ENERGIES FROM ELECTRON VOLTS BACK INTO INVERSE CENTIMETERS
C
      DO 50 I=1,NK
        EN(I)=EV(I)*EE/CC/HH
   50 CONTINUE
C
C  SET CROSS SECTION VARIABLES AND REDUCED MASSES (IN UNITS OF CM^-1)
C
      SV1H=5.0E-17
      SV1H2=1.4E-16
      SV1HE=1.0E-16
C
      SV0H=2.0E-16
      SV0H2=7.0E-16
      SV0HE=5.0E-16
C
      RMH=1.616E-24
      RMH2=3.123E-24
      RMHE=5.816E-24
C
C  START LOOPS TO FIND CROSS-SECTIONS FOR J(UPPER LEVEL) TO
C  I(LOWER LEVEL) TRANSITIONS
C
      DO 300 J=2,NK
        DO 200 I=1,J-1
C
C  TEST IF ROTATIONAL TRANSITIONS OCCURS ACROSS LESS THAN 2 ROT LEVELS
C
          JJ=JFIND(G(J))
          IJ=JFIND(G(I))
          IF (ABS(JJ-IJ).LE.2) THEN
C
C  TEST IF VIBRATIONAL TRANSITION OCCURS FIRSTLY, THEN CALCULATE
C  COLLISION RATES
C
            JV=IVFIND(EN(J))
            IV=IVFIND(EN(I))
            IF ((JV-IV).EQ.1) THEN
              DO 100 K=1,NDEP
                CH=SV1H*SQRT(8.*BK*TEMP(K)/(RMH*PI))*TOTHI(K)
                CH2=SV1H2*SQRT(8.*BK*TEMP(K)/(RMH2*PI))*TOTH2(K)
                CHE=SV1HE*SQRT(8.*BK*TEMP(K)/(RMHE*PI))*(0.1*TOTHI(K))
                C(J,I,K)=CH+CH2+CHE
                C(I,J,K)=C(J,I,K)*NSTAR(J,K)/NSTAR(I,K)
  100         CONTINUE
C
C  IF VIBRATIONAL TRANSITION DOES NOT OCCUR, THEN CALCULATE COLLISION RATES
C
            ELSE IF ((JV-IV).EQ.0) THEN
              DO 150 K=1,NDEP
                CH=SV0H*SQRT(8.*BK*TEMP(K)/(RMH*PI))*TOTHI(K)
                CH2=SV0H2*SQRT(8.*BK*TEMP(K)/(RMH2*PI))*TOTH2(K)
                CHE=SV0HE*SQRT(8.*BK*TEMP(K)/(RMHE*PI))*(0.1*TOTHI(K))
                C(J,I,K)=CH+CH2+CHE
                C(I,J,K)=C(J,I,K)*NSTAR(J,K)/NSTAR(I,K)
  150         CONTINUE
            ENDIF
          ENDIF
  200   CONTINUE
  300 CONTINUE
      END
C
      FUNCTION IVFIND(EN)
      INCLUDE 'PREC'
        IF (EN.LT.1000.) THEN
          IVFIND=0
        ELSE IF (EN.LT.3000.) THEN
          IVFIND=1
        ELSE IF (EN.LT.5000.) THEN
          IVFIND=2
        ELSE IF (EN.LT.7000.) THEN
          IVFIND=3
        ENDIF
      RETURN
      END
C
      FUNCTION JFIND(G)
      INCLUDE 'PREC'
        IG=G+0.5
        JFIND=(IG-1)/2
      RETURN
      END
C
C***********************************************************************
C
      SUBROUTINE HSEINT(HSE)
C
C  DOES THE HYDROSTATIC EQUILIBRIUM INTEGRATION
C  ROUTINE ELCNTM IS FOUND IN THE  OPACITY PACKAGE
C  NOTE THAT NO MORE HSE INTEGRATIONS ARE DONE WHEN
C  THE CORRECTIONS (CORMAX) FALL BELOW ELIM2
C
C  THE SET OF EQUATIONS THAT ARE SOLVED BY THE NEWTON-RAPHSON
C  SCHEME ARE:
C
C  1. XNHN+XNP+XNHM+XNH2+XNH2P+XNH*(SUMABN+GRPH*VTURB**2/(2*BK*TEMP)+NE=
C         CMASS*GRAV/(BK*TEMP)       (HYDROSTATIC EQUILBRIUM INCLUDING
C                                     TURBULENT PRESSURE BUT NEGLECTING
C                                     RADIATION PRESSURE)
C  2. NE + XNHM - XNH*ELCNTM - XNP - XNH2P = 0    (CHARGE CONSERVATION)
C  3. XNH = XNHN + XNP + XNHM + 2*XNH2 + 2*XNH2P
C  4. D/DNE (Z***) = 0
C  4A.ZH = XNHN/(NE*XNP)
C  4B.ZHM = XNHM/(XNHN*NE)
C  4C.ZH2 = XNH2/(XNHN*XNHN)
C  4D.ZH2P = XNH2P/(XNHN*XNP)
C
C  WHERE THE VARIABLES DENOTE THE FOLLOWING NUMBER DENSITIES:
C  NE     ELECTRONS
C  XNH    HYDROGEN NUCLEI
C  XNHN   NEUTRAL HYDROGEN
C  XNP    IONIZED HYDROGEN (PROTONS)
C  XNHM   NEGATIVE HYDROGEN ION
C  XNH2   HYDROGEN MOLECULE
C  XNH2P  POSITIVE H2
C  AND ALL ''RECIPROCAL DISSOCIATION CONSTANTS'' Z*** ARE CONSTANT
C  WITH ELECTRON DENSITY AND TAKEN EITHER FROM THE CURRENT RADIATIVE
C  TRANSFER SOLUTION (ZH) OR FROM LTE (ZH2, ZH2P, ZHM)
C
C  GRPH IS THE NUMBER OF GRAMS PER HYDROGEN NUCLEUS,
C
C  THE INCLUSION OF RADIATION PRESSURE WOULD MODIFY EQUATION 1
C
C  THERE IS NO CHECK AGAINST WILD BEHAVIOUR OF THE NEWTON-RAPHSON SCHEME
C  EXCEPT THAT NEGATIVE NE CAUSES THE NEW NE TO BE TAKEN AS OLD NE
C  DIVIDED BY 10. IF PROBLEMS ARE ENCOUNTERED, SEE NUMERICAL RECIPES
C  BY PRESS ET AL., PP. 240-259 FOR MORE ROBUST SOLUTION METHODS.
C
C  THE ROUTINE CHECK PROVIDES A DEBUG PRINTOUT WITH NUMERICAL AND
C  ANALYTICAL NUMERICAL DERIVATIVES AND THE TERMS OF THE NUMERICAL
C  DERIVATIVES. NORMALLY LCHECK=.FALSE. TO USE ROUTINE CHECK, SET
C  LCHECK=.TRUE.
C:
C: HSEINT 87-12-11  MODIFICATIONS: (MATS CARLSSON)
C:        REWRITTEN TO FIT UPPSALA OPACITY PACKAGE
C:
C:        89-03-24  MODIFICATIONS: (MATS CARLSSON)
C:        DEPTH POINT INDEX K PASSED AS AN ARGUMENT TO ELCNTM
C:        TO ENABLE CORRECT BMET VALUES TO BE USED BY JON
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'CATOM'
      INCLUDE 'CATMOS'
      INCLUDE 'CATMO2'
      INCLUDE 'CCONST'
      INCLUDE 'CINPUT'
      INCLUDE 'CLU'
C
      INCLUDE 'PARAMO'
C
      COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT),
     * TOTCH(MT),TOTCO(MT),TOTCN(MT),
     * TOTC(MT),TOTNIT(MT),TOTO(MT),
     * BHYD(MT,5),GRPH,TOTOH(MT)

CCC  00-09-12 TOTOH ADDED

      COMMON/ELMSUM/ SUMABN,SUMMY,NELM,NELME
C
      COMMON/COUTR/ NTO,NTPO(MT),IWOPTN
      DIMENSION OLDNE(MDEP)
      LOGICAL HSE
      COMMON/CI4/ IDUM1(MEL),IDUM2(MEL,MJ),TMOLIM,MOLH
      LOGICAL LCHECK
      SAVE LCHECK
      DATA LCHECK/.FALSE./
C
      CORMAX=0.0
      DO 600 K=1,NDEP
        T=TEMP(K)
        XPE=NE(K)*BK*T
C
C  STORE OLD VALUES
C
        OLDNE(K)=NE(K)
        XNHN0=0.0
        DO 100 I=1,NK-1
          XNHN0=XNHN0+N(I,K)
  100   CONTINUE
C
C  ZH IS THE RECIPROCAL ''DISSOCIATION CONSTANT'' FOR HYDROGEN
C  ASSUMED TO BE CONSTANT
C
        ZH=XNHN0/(NE(K)*N(NK,K))
        TETA=5040./T
        TETA25=1.202E9/(TETA*TETA*SQRT(TETA))
        DXI=4.98E-4*TETA*SQRT(XPE)
        XIHM=0.747-2.*DXI
        XKHM=TETA25*2.*10.**(-TETA*XIHM)
        ZHM=1.0/XKHM*BK*T
        IF(T.GT.TMOLIM) THEN
          ZH2=0.0
          ZH2P=0.0
        ELSE
          CALL MOLFYS(T,XKH2,XKH2P,DEH2,DEH2P)
          ZH2=1.0/XKH2*BK*T
          ZH2P=1.0/XKH2P*BK*T
        ENDIF
C
C  HYDROSTATIC EQUILIBRIUM EQUATION  GIVES TOTAL NUMBER OF PARTICLES
C
        XNTOT=CMASS(K)*GRAV/(BK*T)
C
C  FQ IS THE NUMBER OF NON-ELECTRONIC PARTICLES PER HYDROGEN NUCLEUS
C  IF THERE ARE NO MOLECULES PRESENT
C  THIS IS WHERE TURBULENT PRESSURE AND RADIATION PRESSURE ENTERS
C  SEE EQUATION (1)
C
        VT=VTURB(K)*QNORM*1.E5
        FQM=SUMABN+GRPH*VT*VT/(2.0*BK*T)
        FQ=1.0+FQM
C
C  FAC GIVES THE STEP IN THE NUMERICAL DERIVATION OF ELCNTM
C
        FAC=0.01
C
C  GET STARTING VALUES
C
        ITRY=0
        LCHECK=.FALSE.
        XNE=NE(K)
  110   CONTINUE
        ITRY=ITRY+1
        AX2=(1.+FQM/FQ)*(ZH2+ZH2P/XNE/ZH)
        BX=1.0+1.0/(XNE*ZH)+ZHM*XNE
        CX=-(XNTOT-XNE)/FQ
        XNHN=QUADEQ(AX2,BX,CX)
        XNP=XNHN/(XNE*ZH)
        XNHM=ZHM*XNHN*XNE
        XNH2=ZH2*XNHN*XNHN
        XNH2P=ZH2P*XNHN*XNP
        XNH=XNHN+XNP+XNHM+2.*XNH2+2.*XNH2P
        TOTH(K)=XNH
C
C  SOLVE THE CHARGE CONSERVATION EQUATION BY NEWTON-RAPHSON ITERATION
C
        DO 200 M=1,100
C
C  FIND THE DERIVATIVE OF ELCNTM WITH RESPECT TO NE
C  THIS IS DONE NUMERICALLY
C
          XUP=XNE*(1.0+FAC)
          XDN=XNE/(1.0+FAC)
          DNE=XUP-XDN
          DION=ELCNTM(K,T,XUP*BK*T)-
     *     ELCNTM(K,T,XDN*BK*T)
C
          XPE=XNE*BK*T
          XION=ELCNTM(K,T,XPE)
          XNEOLD=XNE
C
C  FF IS THE RHS OF THE CHARGE CONSERVATION EQUATION (2)
C
          FF=XNE+XNHM-XNH*XION-XNP-XNH2P
C
C  FIND DERIVATIVES
C
          DHNDE=(XNHN*XNHN*(1.+FQM/FQ)*ZH2P/ZH/XNE/XNE+
     *     XNHN/XNE/XNE/ZH-ZHM*XNHN-1./FQ)/(2.*XNHN*AX2+BX)
          DPDE=1./XNE/ZH*DHNDE-XNP/XNE
          DHMDE=ZHM*(XNE*DHNDE+XNHN)
          DH2DE=2.*ZH2*XNHN*DHNDE
          DH2PDE=ZH2P/ZH*(2.*XNHN/XNE*DHNDE-XNHN/XNE*XNHN/XNE)
          DHDE=DHNDE+DPDE+DHMDE+2.*DH2DE+2.*DH2PDE
C
C  DFDE IS D/DNE OF THE CHARGE CONSERVATION EQUATION
C  CALCULATE NEWTON-RAPHSON STEP AND RELATIVE CHANGE
C  IF CORRECTION WOULD RESULT IN NEGATIVE NE, DIVIDE
C  OLD NE BY 10.
C
          DFDE=1.0+DHMDE-DHDE*XION-XNH*DION/DNE-DPDE-DH2PDE
          DELTA=-FF/DFDE
          IF(DELTA.LT.-XNE) DELTA=-0.9*XNE
          SIG=ABS(DELTA/XNE)
          IF(LCHECK) THEN
            CALL CHECK(T,XNE,XNHN,XNP,XNHM,XNH2,XNH2P,ZH,ZHM,ZH2,ZH2P,
     *       FQM,XNTOT,AX2,BX,K,SIG)
          ENDIF
C
C  UPDATE VARIABLES
C
  150     CONTINUE
          XNE=XNE+DELTA
          AX2=(1.+FQM/FQ)*(ZH2+ZH2P/XNE/ZH)
          BX=1.0+1.0/(XNE*ZH)+ZHM*XNE
          CX=-(XNTOT-XNE)/FQ
          XNHN=QUADEQ(AX2,BX,CX)
          XNP=XNHN/(XNE*ZH)
          XNHM=ZHM*XNHN*XNE
          XNH2=ZH2*XNHN*XNHN
          XNH2P=ZH2P*XNHN*XNP
          XNH=XNHN+XNP+XNHM+2.*XNH2+2.*XNH2P
          TOTH(K)=XNH
          TETA=5040./T
          TETA25=1.202E9/(TETA*TETA*SQRT(TETA))
          DXI=4.98E-4*TETA*SQRT(XPE)
          XIHM=0.747-2.*DXI
          XKHM=TETA25*2.*10.**(-TETA*XIHM)
          ZHM=1.0/XKHM*BK*T
          IF(SIG.LT.1.E-4) GOTO 300
  200   CONTINUE
        LCHECK=.TRUE.
        IF(ITRY.LT.3) THEN
          XNE=2.*XNE
          GOTO 110
        ENDIF
        WRITE(LJOBLO,210) K,SIG
  210   FORMAT(' K=',I4,' SIG=',1P,E10.2)
        CALL STOP('HSEINT: NO CONVERGENCE')
  300   CONTINUE
C
C  UPDATE POPULATIONS N
C
        N(NK,K)=XNP
        DO 400 I=1,NK-1
          N(I,K)=XNHN/XNHN0*N(I,K)
  400   CONTINUE
C
C  UPDATE POPULATIONS NH. IF NK IS LESS THAN 6 THE LAST LEVELS
C  IN NH ARE SET TO ZERO
C
        NH(6,K)=N(NK,K)
        IMAX=MIN(5,NK-1)
        DO 500 I=1,IMAX
          NH(I,K)=N(I,K)
  500   CONTINUE
        DO 550 I=IMAX+1,5
          NH(I,K)=0.0
  550   CONTINUE
C
C  UPDATE NE
C
        NE(K)=XNE
        CORMAX=MAX(CORMAX,ABS(NE(K)/OLDNE(K)-1.))
C
  600 CONTINUE
C
C  IF NE HAS CONVERGED TO WITHIN ELIM2, STOP HSE INTEGRATIONS BY
C  SETTING HSE=.FALSE. SWITCH ON PRINTOUTS IN OPACITY PACKAGE BY
C  SETTING IWOPTN
C
      IF(CORMAX.LT.ELIM2) THEN
        HSE=.FALSE.
        IF(IWOPAC.GT.0) THEN
          IWOPTN=1
        ELSE
          IWOPTN=7
        ENDIF
      ENDIF
      CALL OPAC(1)
      CALL DPCONV
      CALL LTEPOP
      IF(CROUT.NE.'HCOL') THEN
        CALL ATOM(1)
        CALL FREQ
      ENDIF
      CALL COLRAT
      CALL FIXRAD
      CALL DAMP
      CALL PROFIL
      CALL WHSE(OLDNE)
C
C  DO IHSE-1 LAMBDA ITERATIONS
C
      DO 700 I=1,IHSE-1
        CALL TRPT
        CALL STATEQ(ISUM,1)
  700 CONTINUE
C
C  WRITE NEW ATMOSPHERE TO FILE ATHSE
C
      CALL WATHSE
C
      RETURN
      END
C
C***********************************************************************
C
      FUNCTION QUADEQ(AX2,BX,CX)
C
C  SOLVES AX2*X**2 + BX*X + CX = 0.0.  GIVES ONLY LARGEST ROOT
C
      INCLUDE 'PREC'
      IF(ABS(AX2*CX/BX/BX).LT.1.0E-5) THEN
        QUADEQ=-CX/BX
      ELSE
        QUADEQ=(-BX+SQRT(BX*BX-4.*AX2*CX))/(2.0*AX2)
      ENDIF
C
      RETURN
      END
C
C **********************************************************************
C
      SUBROUTINE CHECK(T,XNE,XNHN,XNP,XNHM,XNH2,XNH2P,ZH,ZHM,ZH2,ZH2P,
     * FQM,XNTOT,AX2,BX,K,SIG)
C
C  CHECK DERIVATIVES IN HSEINT
C
      INCLUDE 'PREC'
      INCLUDE 'CLU'
C
      FQ=1.0+FQM
      DHN1=XNHN*XNHN*(1.+FQM/FQ)*ZH2P/ZH/XNE/XNE
      DHN2=XNHN/XNE/XNE/ZH
      DHN3=-ZHM*XNHN
      DHN4=-1./FQ
      DHNDE=(DHN1+DHN2+DHN3+DHN4)/(2.*XNHN*AX2+BX)
      DP1=1./XNE/ZH*DHNDE
      DP2=-XNP/XNE
      DPDE=DP1+DP2
      DHM1=XNE*DHNDE
      DHM2=XNHN
      DHMDE=ZHM*(DHM1+DHM2)
      DH2DE=2.*ZH2*XNHN*DHNDE
      DH2P1=2.*XNHN/XNE*DHNDE
      DH2P2=-XNHN/XNE*XNHN/XNE
      DH2PDE=ZH2P/ZH*(DH2P1+DH2P2)
      DHDE=DHNDE+DPDE+DHMDE+2.*DH2DE+2.*DH2PDE
C
C  NUMERICAL DERIVATIVE
C
      DXNE=XNE*0.001
      XNED=XNE+DXNE
      AX2D=(1.+FQM/FQ)*(ZH2+ZH2P/XNED/ZH)
      BXD=1.0+1.0/(XNED*ZH)+ZHM*XNED
      CXD=-(XNTOT-XNED)/FQ
      XNHND=QUADEQ(AX2D,BXD,CXD)
      XNPD=XNHND/(XNED*ZH)
      XNHMD=ZHM*XNHND*XNED
      XNH2D=ZH2*XNHND*XNHND
      XNH2PD=ZH2P*XNHND*XNPD
      XNHD=XNHND+XNPD+XNHMD+2.*XNH2D+2.*XNH2PD
      XNH=XNHN+XNP+XNHM+2.*XNH2+2.*XNH2P
      DNHN=(XNHND-XNHN)/DXNE
      DNP=(XNPD-XNP)/DXNE
      DNHM=(XNHMD-XNHM)/DXNE
      DNH2=(XNH2D-XNH2)/DXNE
      DNH2P=(XNH2PD-XNH2P)/DXNE
      DNH=(XNHD-XNH)/DXNE
C
      SMALL=1.E-37
      WRITE(*,90) K,T,XNE,SIG,LOG10(MAX(SMALL,SIG))
   90 FORMAT(/' K=',I4,' T=',F7.0,' NE=',1P,E10.2,
     * ' SIG=',1P,E10.2,' LG SIG=',0P,F7.3/
     * 13X,'N',5X,'NUMERIC',2X,'ANALYTIC',7X,'TERMS')
      WRITE(LJOBLO,100) 'HN ',XNHN,DNHN,DHNDE,DHN1,DHN2,DHN3,DHN4
      WRITE(LJOBLO,100) 'P  ',XNP,DNP,DPDE,DP1,DP2
      WRITE(LJOBLO,100) 'HM ',XNHM,DNHM,DHMDE,DHM1,DHM2
      WRITE(LJOBLO,100) 'H2 ',XNH2,DNH2,DH2DE
      WRITE(LJOBLO,100) 'H2P',XNH2P,DNH2P,DH2PDE,DH2P1,DH2P2
      WRITE(LJOBLO,100) 'H  ',XNH,DNH,DHDE
  100 FORMAT(1X,A,1P,E10.2,2X,2E10.2,2X,4E10.2)
C
  999 CONTINUE
      RETURN
      END
C
C **********************************************************************
C
      SUBROUTINE FORMAL
C
C  ADMINISTERS THE PRINTOUTS. VERSION FOR CONTRIBUTION PRINTOUTS
C:
C: FORMAL 88-01-21  MODIFICATIONS: (MATS CARLSSON)
C:        CALLS CONTRIBUTION FUNCTION ROUTINES
C:        CALLS WRBMET
C:
C:        88-05-04  MODIFICATIONS: (MATS CARLSSON)
C:        CALLS WRJFIX
C:        DSCAL2 IS NOT CALLED IF NO TRANSITIONS ARE IN DETAIL
C:
C:        89-03-18  MODIFICATIONS: (MATS CARLSSON)
C:        EMAX PRINTOUT CHANGED TO INCLUDE SIGN AND
C:        LEVEL/TRANSITION AND DEPTH 
C:
C:        90-07-31  MODIFICATIONS: (MATS CARLSSON)
C:        CALL TO WCHANG CHANGED TO INCLUDE DUMMY ARGUMENTS
C:        IN PLACE OF E,NK1 AND NDEP1 (E IS NOT USED IN WCHANG
C:        WHEN ICALL=2)
C:
C:        92-06-05  MODIFICATIONS: (MATS CARLSSON)
C:        TEST OF KREJ AND KEJ INCLUDED TO AVOID ACCESSING
C:        EJ(0,0) WHEN NRAD=0
C: 
C:        94-03-22  MODIFICATIONS: (MATS CARLSSON)
C:        IOPAC.GE.10 ALLOWED
C:
C:        95-08-16  MODIFICATIONS: (MATS CARLSSON)
C:        BOTH OLD PRINTOUT ROUTINES (TO FILE OUT) AND IDL PRINTOUT
C:        ROUTINES ARE CALLED
C:
C:        95-10-20  MODIFICATIONS: (MATS CARLSSON)
C:        ERROR CAUSING CNTRB TO BE CALLED ONLY FOR IWLINE.LE.0 AND
C:        NOT WHEN IDLCNT.NE.0 CORRECTED
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'CATOM'
      INCLUDE 'CATMOS'
      INCLUDE 'CATMO2'
      INCLUDE 'CTRAN'
      INCLUDE 'CSLINE'
      INCLUDE 'CGAUSI'
      INCLUDE 'CCONST'
      INCLUDE 'CINPUT'
      INCLUDE 'CLGMX'
      INCLUDE 'CTAUQQ'
      INCLUDE 'CLU'
      INCLUDE 'COPCL'
      INCLUDE 'C3D'
C
      DIMENSION DUMMY(1,1)
C
      CHARACTER*16 ETEXT
C
      CALL MCTIME('FORMAL',0,0,3)
      CALL WRSTRT
      IF(ICONV.EQ.1) THEN
C
C  PRINT OPACITY DEPARTURE COEFFICIENTS
C
        IF(MOD(IOPAC,10).EQ.3 .OR. MOD(IOPAC,10).EQ.4) CALL WRBMET
C
C  GO THROUGH PRINTOUTS FIRST WITH ATOMIC MODEL ATOM THEN ATOM2
C
        DO 300 IRUN=1,2
          IF(IRUN.EQ.2) THEN
            IF(IATOM2.EQ.0) GOTO 400
            CALL ATOM2
          ENDIF
          CALL TRPT
          IF(IRUN.EQ.1) THEN
C*
C* 89-03-18 START MODIFICATION
C  STORE KR INDEX FOR MAX CHANGE IN KREJ, K INDEX IN KEJ
C
            KREJ=0
            KEJ=0
            EMAXJ=0.
            DO 24 KR=1,NRAD
              DO 22 K=1,NDEP
                IF(ABS(EJ(KR,K)).GT.EMAXJ) THEN
                  KREJ=KR
                  KEJ=K
                  EMAXJ=ABS(EJ(KR,K))
                ENDIF
   22         CONTINUE
   24       CONTINUE
            IF(KREJ.GT.0 .AND. KEJ.GT.0) EMAXJ=EJ(KREJ,KEJ)
            WRITE(ETEXT,25) KREJ,KEJ
   25       FORMAT('EMAXJ(',I4,',',I4,')')
            CALL WCHANG(DUMMY,1,1,2)
            CALL WEMAX(ETEXT,EMAXJ)
          ENDIF
          CALL TRCONT
          CALL WN
          CALL REWIND(LOPC)
C
C  PRINT EQUIVALENT WIDTHS
C
          IF(IWEQW.NE.0) THEN
            DO 30 KR=1,NLINE
              CALL EQWDTH(WW,KR)
              WEQ(KR)=WW
   30       CONTINUE
            CALL WEQW
          ENDIF
C
          DO 200 KR=1,NRAD
C
C  FIND NY FOR LINECENTER
C
            NY0=1
            QMIN=ABS(Q(1,KR))
            DO 50 NY=1,NQ(KR)
              IF(ABS(Q(NY,KR)).LT.QMIN) THEN
                NY0=NY
                QMIN=ABS(Q(NY,KR))
              ENDIF
   50       CONTINUE

C
C  PRINT LINE INFORMATION FOR LINE CENTER AND MU=1
C  PRINT TAUNY SCALES
C
            DO 100 NY=1,NQ(KR)
              CALL READX
              IF(IWLINE.LT.0 .OR. IDLCNT.NE.0) CALL CNTRB(NY,KR)
              IF(IWLINE.NE.0 .AND. NY.EQ.NY0) THEN
                CALL TAUNYQ(NY,KR)
                IF(KR.LE.NLINE) THEN
                  CALL RWING(KR)
                  CALL WLINE(KR)
                ELSE
                  CALL WCONT(KR)
                ENDIF
              ELSE IF(IWTAUQ.NE.0) THEN
                CALL TAUNYQ(NY,KR)
              ENDIF
  100       CONTINUE
            CALL WTAUQQ(KR)
            CALL WCNTRB(KR)
            CALL WIDLCN(KR)
  200     CONTINUE
          IF(NRAD.NE.0 .AND. .NOT.L3D) CALL DSCAL2
          CALL WLGMX
          CALL WRAD
          CALL WIDL1
          IF(IRUN.EQ.1) THEN
            CALL WRATE
            CALL WATHSE
          ENDIF
  300   CONTINUE
      ELSE
        CALL WN
      ENDIF
  400 CONTINUE
      CALL WRJFIX
      CALL MCTIME('FORMAL',0,2,3)
      RETURN
      END
C
C***********************************************************************
C
      SUBROUTINE RDBMET
C
C  READS DEPARTURE COEFFICIENTS OF BACKGROUND ABSORBERS
C  READS IONIZATION FRACTIONS FOR NON-LTE ELEMENTS
C:
C: RDBMET 88-01-21  NEW ROUTINE: (MATS CARLSSON, PHILIP JUDGE)
C:        READS DEPARTURE COEFFICIENTS OF BACKGROUND ABSORBERS
C:        UPPSALA OPACITY PACKAGE INTERFACE ROUTINE
C:
C:        88-03-01  ALTERATIONS: (PHILIP JUDGE)
C:        ALSO READS COMPUTED PARTITION FUNCTIONS FOR CONSISTENCY
C:        THESE ARE STORED IN ZNLTE
C:
C:        89-03-23  MODIFICATIONS: (MATS CARLSSON)
C:        SETS FRCION TO 0.0 FOR THE IONIZATION STAGES NOT INCLUDED
C:        IN BMET FOR ALL ELEMENTS WITH DATA IN BMET
C:
C:        92-08-10  MODIFICATIONS (MATS CARLSSON)
C:        INTEGER ARRAYS WITH ELEMENT NAME CHANGED TO CHARACTER ARRAYS
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'CATOM'
      INCLUDE 'CATMOS'
      INCLUDE 'CATMO2'
      INCLUDE 'CSLINE'
      INCLUDE 'CCONST'
      INCLUDE 'CINPUT'
      INCLUDE 'CLU'
C
      INCLUDE 'PARAMO'
C
      COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4),
     *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL
      CHARACTER*3 CEL
      COMMON/CC1/CEL(MEL)
C
      COMMON/CA2/ABKOF(NABDIM),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP,NABKOF
C
      CHARACTER*20 ABNAME,LVNAMEI,LVNAMEJ
      COMMON/CNAME/ ABNAME(MKOMP),LVNAMEI(MKOMP),LVNAMEJ(MKOMP)
C
      COMMON/CBMET/ BMET(MT,MKOMP-23),BMETP(MT,MKOMP-23),
     *       FRCION(MEL,MJ,MT),ZNLTE(MEL,MJ,MT)
      COMMON/CBMET2/ ANMET(MT,MKOMP-23)
C
      CHARACTER*20 LBNAMEI,LBNAMEJ,TEXT
      PARAMETER (MIN=1000,MIONST=5)
      DIMENSION CMIN(MIN),TAUIN(MIN),BIN(MIN),BPIN(MIN),ANIN(MIN)
      DIMENSION DP(MDEP),DPIN(MIN),FRCIN(MIONST,MIN),
     *                 ZIN(MIONST,MIN)
      INTEGER IONST(MIONST)
C             
      WRITE(LOUT,1002)
 1002 FORMAT(/' AS WELL AS HYDROGEN (FROM FILE ''ATMOS''),'/
     *  ' THE FOLLOWING ABSORBERS ARE TREATED OUT OF LTE: '//)
C*
      CALL MOPEN(LUBMET,'BMET',0,'OLD')
C
C  PUT LOG DEPTH-SCALE IN DP
C
      IF(DPTYPE.EQ.'M') THEN
        DO 50 K=1,NDEP
          DP(K)=LOG10(CMASS(K))
   50   CONTINUE
      ELSE
        DO 60 K=1,NDEP
          DP(K)=LOG10(TAU(K))
   60   CONTINUE
      ENDIF
C*
C*  OUTPUT:
C*
  100 CONTINUE
        READ(LUBMET,END=900) LBNAMEI
  200   FORMAT(A)
        CALL LJUST(LBNAMEI)
        CALL LJUST(LBNAMEJ)
        IF(LBNAMEI(1:20).EQ.'IONIZATION FRACTIONS') GOTO 501
        READ(LUBMET,END=900) LBNAMEJ
        READ(LUBMET) NIN
        IF(NIN.GT.MIN) THEN
          WRITE(LJOBLO,210) LBNAMEI,LBNAMEJ
  210     FORMAT(' RDBMET: ABSORBERS: NIN.GT.MIN ',A,'->',A)
          CALL STOP(' ')
        ENDIF
C*
        DO 270 K=1,NIN
          READ(LUBMET) CMIN(K),TAUIN(K),BIN(K),BPIN(K),ANIN(K)
  270   CONTINUE
C*
C
C  CHECK TO SEE IF LBNAME CORRESPONDS TO A BACKGROUND ABSORBER
C
        DO 300 KOMP=17,NKOMP-6
          IF(LBNAMEI.EQ.LVNAMEI(KOMP) .AND.
     *       LBNAMEJ.EQ.LVNAMEJ(KOMP)) GOTO 310
  300   CONTINUE
        WRITE(LJOBLO,305) LBNAMEI,LBNAMEJ
  305   FORMAT(' RDBMET: WARNING: ABSORBER FOUND IN THE BMET FILE'/
     *   ' BUT NOT IN THE ABSDAT FILE :',A,'->',A)
        GOTO 100
C
C  INTERPOLATE AND FILL BMET AND BMETP
C
  310   CONTINUE
        WRITE(LOUT,315) LBNAMEI,LBNAMEJ
  315   FORMAT(' ',A,'->',A)
        IF(DPTYPE.EQ.'M') THEN
          DO 320 K=1,NIN
            DPIN(K)=CMIN(K)
  320     CONTINUE
        ELSE
          DO 330 K=1,NIN
            DPIN(K)=TAUIN(K)
  330     CONTINUE
        ENDIF
C
C  LINEAR INTERPOLATION. OUTSIDE RANGE, SET VALUE TO LAST KNOWN
C
        L=1
        DO 400 K=1,NDEP
          IF(DP(K).LT.DPIN(1)) THEN
            BMET(K,KOMP-16)=BIN(1)
            BMETP(K,KOMP-16)=BPIN(1)
            ANMET(K,KOMP-16)=ANIN(1)
          ELSE IF(DP(K).GT.DPIN(NIN)) THEN
            BMET(K,KOMP-16)=BIN(NIN)
            BMETP(K,KOMP-16)=BPIN(NIN)
            ANMET(K,KOMP-16)=ANIN(NIN)
          ELSE
  350       CONTINUE
            L=L+1
            IF(DP(K).GT.DPIN(L)) GOTO 350
            APOL=(DP(K)-DPIN(L-1))/(DPIN(L)-DPIN(L-1))
            BMET(K,KOMP-16)=BIN(L-1)+APOL*(BIN(L)-BIN(L-1))
            BMETP(K,KOMP-16)=BPIN(L-1)+APOL*(BPIN(L)-BPIN(L-1))
            ANMET(K,KOMP-16)=EXP( LOG(ANIN(L-1))+
     *       APOL*(LOG(ANIN(L))-LOG(ANIN(L-1))) )
            L=L-1
          ENDIF
  400   CONTINUE
      GOTO 100
C
C  IONIZATION FRACTIONS
C
  501 WRITE(LOUT,1003)
 1003 FORMAT(/' THE FOLLOWING ION STAGES ARE TREATED OUT OF LTE: '//)
C*
  500 CONTINUE
        READ(LUBMET,END=900) TEXT
        READ(LUBMET) NIN,NIONST,(IONST(I),I=1,NIONST)
        IF(NIN.GT.MIN) THEN
          WRITE(LJOBLO,510) TEXT
  510     FORMAT(' RDBMET: IONIZATION: NIN.GT.MIN ',A)
          CALL STOP(' ')
        ENDIF
        IF(NIONST+1.GT.MIONST) THEN
          WRITE(LJOBLO,520) TEXT
  520     FORMAT(' RDBMET: IONIZATION: NIONST+1.GT.MIONST ',A)
          CALL STOP(' ')
        ENDIF
C*
C*  88-06-19 (P. JUDGE) ASSUME NEXT IONIZATION STAGE IS PREVIOUS+1
C*
        IONST(NIONST+1)=IONST(NIONST)+1
C*  88-06-19 END
C*
        DO 370 K=1,NIN
          READ(LUBMET) CMIN(K),TAUIN(K),(FRCIN(I,K),I=1,NIONST),
     *    (ZIN(I,K),I=1,NIONST+1)
  370   CONTINUE
C*
C
C  FIND ELEMENT INDEX (FIRST WORD IN TEXT IS ASSUMED TO BE ELEMENT NAME)
C
        CALL GETWRD(TEXT,1,K1,K2)
        DO 610 IELMNT=1,NEL
          IF(TEXT(K1:K2).EQ.CEL(IELMNT)) GOTO 630
  610   CONTINUE
        WRITE(LJOBLO,620) TEXT(K1:K2)
  620   FORMAT(' RDBMET: WARNING: IONIZATION FRACTION ELEMENT FOUND',
     *   ' IN BMET FILE'/' BUT NOT AMONG ELEMENTS: ',A)
        GOTO 500
C
  630   CONTINUE
C*
C* 89-03-23 MODIFICATION
C* PGJ ADDITION OF 88-03-01 GAVE INCORRECT ALIGNMENT OF PARTITION
C* FUNCTION INPUT IN OPACITY PACKAGE. FRCION IS NOW SET TO 0.0 FOR
C* ELEMENTS WITH DATA IN BMET BEFORE DATA IS INTERPOLATED IN ORDER
C* TO TAKE OUT IONIZATION STAGES NOT CALCULATED BY MULTI
C* OLD STATEMENT WAS    NJ(IELMNT)=NIONST+1
C* REPLACED BY:
C*
        DO 645 I=1,MJ
          DO 640 K=1,NDEP
            FRCION(IELMNT,I,K)=0.0
            ZNLTE(IELMNT,I,K)=1.0
  640     CONTINUE
  645   CONTINUE
C* 89-03-23 END
C*
        WRITE(LOUT,650) CEL(IELMNT),IONST(1),IONST(NIONST)+1
  650   FORMAT(' ',A,' ',I3,' - ',I3)
C
C  INTERPOLATE
C
        IF(DPTYPE.EQ.'M') THEN
          DO 720 K=1,NIN
            DPIN(K)=CMIN(K)
  720     CONTINUE
        ELSE
          DO 730 K=1,NIN
            DPIN(K)=TAUIN(K)
  730     CONTINUE
        ENDIF
C
C  LINEAR INTERPOLATION. OUTSIDE RANGE, SET VALUE TO LAST KNOWN
C* 88-06-19 MODIFICATIONS (P. JUDGE)
C* SUM OVER NIONST+1 TO ALLOW INCLUSION OF MULTI-COMPUTED PARTITION FUNCTIONS
C*
C
        L=1
        DO 800 K=1,NDEP
          IF(DP(K).LT.DPIN(1)) THEN
            DO 740 I=1,NIONST+1
              IF(I .LE. NIONST)
     *          FRCION(IELMNT,IONST(I),K)=FRCIN(I,1)
              ZNLTE(IELMNT,IONST(I),K)=ZIN(I,1)
  740       CONTINUE
          ELSE IF(DP(K).GT.DPIN(NIN)) THEN
            DO 750 I=1,NIONST+1
              IF(I .LE. NIONST)
     *          FRCION(IELMNT,IONST(I),K)=FRCIN(I,NIN)
              ZNLTE(IELMNT,IONST(I),K)=ZIN(I,NIN)
  750       CONTINUE
          ELSE
  760       CONTINUE
            L=L+1
            IF(DP(K).GT.DPIN(L)) GOTO 760
            APOL=(DP(K)-DPIN(L-1))/(DPIN(L)-DPIN(L-1))
            DO 770 I=1,NIONST+1
              IF(I .LE. NIONST)
     *          FRCION(IELMNT,IONST(I),K)=FRCIN(I,L-1) +
     *          APOL*(FRCIN(I,L)-FRCIN(I,L-1))
              ZNLTE(IELMNT,IONST(I),K)=ZIN(I,L-1) +
     *          APOL*(ZIN(I,L)-ZIN(I,L-1))
  770       CONTINUE
            L=L-1
          ENDIF
C*  END 88-06-19 ALTERATIONS
  800   CONTINUE
      GOTO 500
C
  900 CONTINUE
      WRITE(LOUT,1004)
 1004 FORMAT(/' ALL ADDITIONAL ABSORBERS ARE TREATED IN LTE: '//)
C*
      CALL CLOSE(LUBMET)
      END
C
C***********************************************************************
C
      SUBROUTINE WRBMET
C
C  WRITES DEPARTURE COEFFICIENTS OF BACKGROUND ABSORBERS
C  WRITES IONIZATION FRACTIONS
C:
C: WRBMET 88-01-21  NEW ROUTINE: (MATS CARLSSON)
C:        WRITES DEPARTURE COEFFICIENTS OF BACKGROUND ABSORBERS
C:        UPPSALA OPACITY PACKAGE INTERFACE ROUTINE
C:
C:        88-03-01  ALTERATIONS: (PHILIP JUDGE)
C:        ALSO WRITES COMPUTED PARTITION FUNCTIONS FOR CONSISTENCY
C:
C:        89-03-23  MODIFICATIONS: (MATS CARLSSON)
C:        USES ONLY FIRST WORD IN ATOMID TO CHECK IF OLD BMET ENTRY
C:        SHOULD BE REPLACED WITH THE ONE NOW CALCULATED
C:
C:        94-03-22  MODIFICATIONS: (MATS CARLSSON)
C:        IOPAC.GE.10 ALLOWED
C:
C:        01-02-13  MODIFICATIONS: (MATS CARLSSON)
C:        ADDED UPPER LEVEL OF CONTINUA
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'CATOM'
      INCLUDE 'CATMOS'
      INCLUDE 'CATMO2'
      INCLUDE 'CSLINE'
      INCLUDE 'CCONST'
      INCLUDE 'CINPUT'
      INCLUDE 'CLU'
C
      INCLUDE 'PARAMO'
C
      COMMON/CA2/ABKOF(NABDIM),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP,NABKOF
C
      CHARACTER*20 ABNAME,LVNAMEI,LVNAMEJ
      COMMON/CNAME/ ABNAME(MKOMP),LVNAMEI(MKOMP),LVNAMEJ(MKOMP)
C
      COMMON/ CBMET/BMET(MT,MKOMP-23),BMETP(MT,MKOMP-23),
     *       FRCION(MEL,MJ,MT),ZNLTE(MEL,MJ,MT)
      COMMON/CBMET2/ ANMET(MT,MKOMP-23)
C
      PARAMETER (MION=10)
      CHARACTER*20 TEXT,LABI,LABJ
      DIMENSION ANION(MION),ZION(MION)
      INTEGER IONST(MION)
C
C  UPDATE BMET AND BMETP WITH CURRENTLY CALCULATED CONTINUA
C  WRITE THOSE VALUES TO FILE BMET2
C
      CALL MOPEN(LUBMET,'BMET2',0,'NEW')
      DO 300 I=1,NK-1
C
        DO 200 KOMP=17,NKOMP-6
          IF(LVNAMEI(KOMP).EQ.LABEL(I)) GOTO 205
  200   CONTINUE
        GOTO 209
  205   CONTINUE
        DO 206 J=I+1,NK
          IF(LVNAMEJ(KOMP).EQ.LABEL(J)) GOTO 210
  206   CONTINUE
        WRITE(LJOBLO,110) LVNAMEJ(KOMP)
  110   FORMAT(' WRBMET: UPPER LEVEL NOT FOUND: ',A)
        CALL STOP(' ')
  209   CONTINUE
C*  
C*  89-03-11   MODIFICATIONS (PHILIP JUDGE)
C*             OUTPUT A WARNING WHEN UNKNOWN OPACITY SOURCE COMPUTED.
C*  THESE LEVELS EXIST IN THE ATOM COMPUTED ION DETAIL 
C*  BUT HAVE NO CORRESPONDENCE WITH THE DATA IN THE ABSDAT FILE.
C*  
        WRITE(LJOBLO,1001)LABEL(I)
 1001   FORMAT(' WRBMET: WARNING- LEVEL ',A,', COMPUTED IN',
     *  ' DETAIL,'/'         DOES NOT EXIST IN THE ABSDAT OPACITY FILE')
C*  89-03-11   MODIFICATIONS END (PHILIP JUDGE)
C*
        GOTO 300
  210   CONTINUE
        DO 250 K=1,NDEP
          BMET(K,KOMP-16)=N(I,K)/NSTAR(I,K)
          BMETP(K,KOMP-16)=N(J,K)/NSTAR(J,K)
          ANMET(K,KOMP-16)=N(I,K)
  250   CONTINUE
        WRITE(LUBMET) LVNAMEI(KOMP)
        WRITE(LUBMET) LVNAMEJ(KOMP)
        WRITE(LUBMET) NDEP
        DO 270 K=1,NDEP
          WRITE(LUBMET) LOG10(CMASS(K)),LOG10(TAU(K)),
     *     BMET(K,KOMP-16),BMETP(K,KOMP-16),ANMET(K,KOMP-16)
  270   CONTINUE
  300 CONTINUE
C
C  IF IOPAC=3, COPY THE VALUES FROM THE BMET FILE THAT HAVE NOT
C  BEEN REPLACED WITH NEWER VALUES
C
      IF(MOD(IOPAC,10).EQ.3) THEN
        CALL MOPEN(LUOLD,'BMET',0,'OLD')
  310   CONTINUE
C
C  READ OLD BMET FILE
C
          READ(LUOLD,END=500) LABI
          CALL LJUST(LABI)
          IF(LABI(1:20).EQ.'IONIZATION FRACTIONS') GOTO 500
          READ(LUOLD,END=500) LABJ
          DO 330 I=1,NK-1
            IF(LABI.EQ.LABEL(I)) THEN
              DO 328 J=I+1,NK
                IF(LABJ.EQ.LABEL(J)) THEN
                  READ(LUOLD) NIN
                  DO 325 K=1,NIN
                    READ(LUOLD) CLG,TAULG,BM,BMP,AM
  325             CONTINUE
                  GOTO 310
                ENDIF
  328         CONTINUE
            ENDIF
  330     CONTINUE
C
C  DEPARTURE COEFFICIENTS NOT CALCULATED NOW. PRINT OLD VALUES
C
          WRITE(LUBMET) LABI
          WRITE(LUBMET) LABJ
          READ(LUOLD) NIN
          WRITE(LUBMET) NIN
          DO 340 K=1,NIN
            READ(LUOLD) CLG,TAULG,BM,BMP,AM
            WRITE(LUBMET) CLG,TAULG,BM,BMP,AM
  340     CONTINUE
        GOTO 310
      ENDIF
C
C  IONIZATION FRACTIONS
C
  500 CONTINUE
      TEXT='IONIZATION FRACTIONS'
      WRITE(LUBMET) TEXT(1:20)
      IF(ATOMID(1:1).EQ.'H') GOTO 900
C
C  WRITE IONIZATION FRACTIONS OF ELEMENT CALCULATED
C
C  FIND LOWEST AND HIGHEST IONIZATION STAGE
C
      MINION=100
      MAXION=0
      DO 520 I=1,NK
        MINION=MIN(MINION,ION(I))
        MAXION=MAX(MAXION,ION(I))
  520 CONTINUE
      IF(MAXION.GT.MION) CALL STOP('WRBMET: MAXION.GT.MION')
      WRITE(LUBMET) ATOMID
      WRITE(LUBMET) NDEP,MAXION-MINION,(I,I=MINION,MAXION-1)
      DO 600 K=1,NDEP
        DO 550 I=MINION,MAXION
          ANION(I)=0.0
          ZION(I)=0.0
  550   CONTINUE
        ICONT=1
        DO 560 J=1,NK
          I=ION(J)
          ANION(I)=ANION(I)+N(J,K)
C*
C* ADDED BY PGJ
          IF(J.GT.1 .AND. ION(J).EQ.ION(J-1)+1) ICONT=J
          BIG=37.0
          DEN=MIN(EE*(EV(J)-EV(ICONT))/BK/TEMP(K),BIG)
          ZION(I)=ZION(I)+G(J)*EXP(-DEN)
C* END PGJ ADDITION
C*
  560   CONTINUE
        WRITE(LUBMET) LOG10(CMASS(K)),LOG10(TAU(K)),
     *   (ANION(I+1)/ANION(I),I=MINION,MAXION-1),
     *   (ZION(I),I=MINION,MAXION)
  600 CONTINUE
C
C  IF IOPAC=3, COPY THE VALUES FROM THE BMET FILE THAT HAVE NOT
C  BEEN REPLACED WITH NEWER VALUES
C
      IF(MOD(IOPAC,10).EQ.3) THEN
  610   CONTINUE
          READ(LUOLD,END=900) TEXT
C
C  COMPARE FIRST WORD IN TEXT WITH FIRST WORD OF ATOM ID TO FIND OUT
C  IF ELEMENT IN RDBMET IS THE SAME AS THE ONE NOW TREATED IN DETAIL
C
          CALL GETWRD(TEXT,1,K1,K2)
          CALL GETWRD(ATOMID,1,K11,K22)
          IF(TEXT(K1:K2).EQ.ATOMID(K11:K22)) THEN
            READ(LUOLD) NIN,NIONST,(IDUM,I=1,NIONST)
            IF(NIONST.GT.MION) THEN
              WRITE(LJOBLO,620) TEXT
  620         FORMAT(' WRBMET: IONIZATION: NIONST.GT.MION ',A)
              CALL STOP(' ')
            ENDIF
            DO 630 K=1,NIN
              READ(LUOLD) CLG,TAULG,(ANION(I),I=1,NIONST),
     *         (ZION(I),I=1,NIONST+1)
  630       CONTINUE
            GOTO 610
          ENDIF
C
C  IONIZATION FRACTIONS NOT CALCULATED NOW, PRINT OLD VALUES
C
          WRITE(LUBMET) TEXT
          READ(LUOLD) NIN,NIONST,(IONST(J),J=1,NIONST)
          WRITE(LUBMET) NIN,NIONST,(IONST(J),J=1,NIONST)
          DO 700 K=1,NIN
            READ(LUOLD) CLG,TAULG,(ANION(I),I=1,NIONST),
     *       (ZION(I),I=1,NIONST+1)
            WRITE(LUBMET) CLG,TAULG,(ANION(I),I=1,NIONST),
     *       (ZION(I),I=1,NIONST+1)
  700     CONTINUE
        GOTO 610
      ENDIF
C
  900 CONTINUE
      IF(MOD(IOPAC,10).EQ.3) CALL CLOSE(LUOLD)
      CALL CLOSE(LUBMET)
      END
C
C***********************************************************************
C
      FUNCTION ELCNTM(K,T,PE)
C
C  RETURNS THE NUMBER OF FREE ELECTRONS PER HYDROGEN NUCLEUS
C  CONTRIBUTED BY ELEMENTS OTHER THAN HYDROGEN
C:
C: ELCNTM 88-01-20  NEW ROUTINE: (MATS CARLSSON)
C:        UPPSALA OPACITY PACKAGE INTERFACE ROUTINE
C:
C:        89-03-24  MODIFICATIONS: (MATS CARLSSON)
C:        DEPTH POINT INDEX K PASSED AS AN ARGUMENT TO ENABLE CORRECT 
C:        BMET VALUES TO BE USED BY JON
C:
C:        IEPRO CHANGED TO 1 TO ENABLE MOLECULE CALCULATION IN JON
C:
C
      INCLUDE 'PREC'
      COMMON /CXNENH/ XNENH
C
      IOUTR=0
      IEPRO=1
      CALL JON(K,T,PE,IEPRO,PGDUM,RODUM,EDUM,IOUTR)
C
      ELCNTM=XNENH
      END
C
C***********************************************************************
C
      SUBROUTINE OPINIT
C
C  INITIALIZES OPACITY PACKAGE
C:
C: OPINIT 88-01-21  MODIFICATIONS: (MATS CARLSSON)
C:        UPPSALA OPACITY PACKAGE INTERFACE ROUTINE
C:
C:        88-06-22  MODIFICATIONS: (MATS CARLSSON)
C:        CLOSES INPUT FILES IF THEY ARE OPEN MAKING MULTIPLE
C:        CALLS POSSIBLE
C:
C:        90-11-08  MODIFICATIONS: (MATS CARLSSON)
C:        ABNAME CHANGED TO NOT INCLUDE LEADING /
C:        ABNAME AND LVNAME THEREFORE IDENTICAL
C:
C:        94-03-24  MODIFICATIONS: (MATS CARLSSON)
C:        IOPAC.GE.10 ALLOWED, SIGNALS BACKGROUND OPACITY
C:        FROM LINES
C:
C:        95-08-04  MODIFICATIONS: (MATS CARLSSON)
C:        BACKGROUND OPACITY FROM LINES SIGNALLED BY IOPACL
C:        SOURCE FUNCTION OPTION TRANSFERRED TO OPACITY PACKAGE 
C         WITH ISOUL IN CALIN
C:
C:        03-06-23  MODIFICATIONS: (MATS CARLSSON)
C:        FIND FORMAT OF ABSDAT FILE NUMBER OF WAVELENGTHS
C:        FORMAT FOR NLATB CAN BE EITHER I2 OR I3
C:        TRANSFERRED AS INLATB IN CFIL
C:
C:        07-12-28  MODIFICATIONS: (MATS CARLSSON)
C:        SCRATCH FILES DUMO1 AND DUMO2 NOT USED
C:
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'CATOM'
      INCLUDE 'CATMOS'
      INCLUDE 'CSLINE'
      INCLUDE 'CINPUT'
      INCLUDE 'CCONST'
      INCLUDE 'CLU'
      INCLUDE 'CALIN'
C            
      INCLUDE 'PARAMO'
C
      COMMON/CI1/FL2(5),PARCO(MJMAX),PARQ(4*MJMAX),SHXIJ(5),TPARF(4),
     *XIONG(MEL,MJ),EEV,ENAMN,SUMH,XKBOL,SUMM,NJ(MEL),NEL
C
      COMMON/CA2/ABKOF(NABDIM),KOMPLA(ML*MKOMP),KOMPR,KOMPS,NKOMP,NABKOF
C
      COMMON/UTPUT/ IREAD, IWRIT
C
      COMMON/CFIL/IREAT,INLATB
C
      COMMON/COUTR/ NTO,NTPO(MT),IWOPTN
C
      COMMON/CXLSET/NSET,NL(MSET),XL(ML,MSET)
C
      COMMON /CBMET/BMET(MT,MKOMP-23),BMETP(MT,MKOMP-23),
     *       FRCION(MEL,MJ,MT),ZNLTE(MEL,MJ,MT)
      COMMON/CBMET2/ ANMET(MT,MKOMP-23)
C
      CHARACTER*20 ABNAME,LVNAMEI,LVNAMEJ
      COMMON/CNAME/ ABNAME(MKOMP),LVNAMEI(MKOMP),LVNAMEJ(MKOMP)
C
      CHARACTER*80 TEXT
      SAVE LABSDA
      DATA LABSDA/0/
C
C  CHECK DIMENSIONS
C
      IF(NDEP.GT.MT) THEN
        WRITE(LJOBLO,40) NDEP,MT
   40   FORMAT(' OPINIT: NDEP=',I4,' MT=',I4)
        CALL STOP('OPINIT: NDEP.GT.MT')
      ENDIF
C* 
C* 17-04-88  PGJ ADDITION 
      IF(IWOPAC.NE.0) WRITE (LOUT,201)
  201 FORMAT(' OPACITIES FROM UPPSALA PACKAGE')
C*  END PGJ ADDITION
C*
C
C  OPEN ABSORPTION DATA INPUT FILE AND TEMPORARY FILES
C  ASSIGN OUTPUT TO OUT FILE
C  CLOSE FILES IF THEY ARE ALREADY OPEN
C
C KL changes here: If IATOM2 is set, read ABSDAT2
      IF (IATOM2.EQ.1.AND.LABSDA.NE.0) THEN
         IF(LABSDA.NE.0) CALL CLOSE(LABSDA) 
         CALL MOPEN(LABSDA,'ABSDAT2',1,'OLD') 
         WRITE(*,*) 'Reading ABSDAT2 for ATOM2 !'
      ELSE 
         CALL MOPEN(LABSDA,'ABSDAT',1,'OLD')
         WRITE(*,*) 'Reading ABSDAT for ATOM !'
      ENDIF
C KL unmarked two rows
C      IF(LABSDA.NE.0) CALL CLOSE(LABSDA)
C
C      CALL MOPEN(LABSDA,'ABSDAT',1,'OLD')
      IWRIT=LOUT
      IREAD=LABSDA
      IREAT=LABSDA
C
C  FIND FORMAT OF NLATB BY READING THROUGH UNTIL FIRST OCCURANCE OF
C  TEXT STRING ILOGL
C
   45 CONTINUE
        READ(LABSDA,'(A)',END=46) TEXT
        K0=1
        CALL GETWRD(TEXT,K0,K1,K2)
      IF(TEXT(K1:K2).NE.'ILOGL') GOTO 45
      K0=49
      CALL GETWRD(TEXT,K0,K1,K2)
      INLATB=K2-K0+1
C      WRITE(*,*) 'INLATB=',INLATB
      GOTO 47
   46 CONTINUE
      CALL STOP('OPINIT: TEXT ILOGL NOT FOUND IN ABSDAT')
   47 CONTINUE
      CALL REWIND(LABSDA)
C
C  FILL WAVELENGTH ARRAY
C
      NSET=1
      L=1
      DO 50 KR=1,NRAD
        IF(.NOT.IWIDE(KR)) THEN
          L=L+1
        ELSE
          L=L+NQ(KR)
        ENDIF
   50 CONTINUE
      IF(L.GT.ML) THEN
        WRITE(LJOBLO,70) L,ML
   70   FORMAT(' OPINIT: L=',I7,' ML=',I7)
        CALL STOP('OPINIT: TOO MANY WAVELENGTHS')
      ENDIF
      L=1
      XL(1,1)=5000.
      DO 200 KR=1,NRAD
        IF(.NOT.IWIDE(KR)) THEN
          L=L+1
          XL(L,1)=ALAMB(KR)
        ELSE
          KT=KTRANS(KR)
          DO 100 NY=1,NQ(KR)
            L=L+1
            XL(L,1)=CC/FRQ(NY,KT)*1.E8
  100     CONTINUE
        ENDIF
  200 CONTINUE
      NL(1)=L
C
      IOUTS=0
      CALL MCTIME('INJON ',0,0,1)
      CALL INJON(IOUTS)
      CALL MCTIME('INJON ',0,1,1)
      CALL INABS(IOUTS)
      CALL MCTIME('INABS ',0,1,1)
C
C  READ BACKGROUND LINE OPACITIES IF IOPACL.NE.0
C  TRANSFER QNORM TO OPACITY PACKAGE THROUGH QNORML IN CALIN
C  TRANSFER SOURCE FUNCTION OPTION TO OPACITY PACKAGE 
C  THROUGH ISOUL IN CALIN
C
      QNORML=QNORM
      ISOUL=IOPACL
      NLL=0
      IF(IOPACL.NE.0) CALL INLIN
      CALL MCTIME('INLIN ',0,1,1)
C
C  FILL ARRAY WITH INDICES WHERE PRINTOUT IS WANTED
C  IF ATOM IS HYDROGEN AND HSE INTEGRATIONS ARE PERFORMED THEN
C  THE PRINTOUT IS SET BY HSEINT WHEN THE HSE INTEGRATIONS HAVE
C  CONVERGED.
C  IWOPTN GOVERNS PRINTOUT, BINARY SWITCHES:
C    1 OPACITY CONTRIBUTIONS
C    2 PARTIAL PRESSURES
C    4 IONIZATION FRACTIONS, PARTITION FUNCTIONS
C  IWOPAC.LT.0 GIVES IWOPTN=7, IWOPAC.GT.0 GIVES IWOPTN=1
C
      M=0
      IF(IWOPAC.NE.0) THEN
        ISTEP=ABS(IWOPAC)
        DO 300 L=1,NDEP,ISTEP
          M=M+1
          NTPO(M)=L
  300   CONTINUE
      ENDIF
      NTO=M
      IF(IHSE.EQ.0 .OR. ATOMID.NE.'H') THEN
        IF(IWOPAC.GT.0) THEN
          IWOPTN=1
        ELSE
          IWOPTN=7
        ENDIF
      ELSE
        IWOPTN=0
      ENDIF
C
C  INITIALIZE BMET AND BMETP ARRAYS TO 1.0
C             
      DO 500 KOMP=17,NKOMP-6
        DO 400 K=1,NDEP
          BMET(K,KOMP-16)=1.0
          BMETP(K,KOMP-16)=1.0
          ANMET(K,KOMP-16)=-1.0
  400   CONTINUE
  500 CONTINUE
C
C  INITIALIZE FRCION ARRAY TO -1.
C
      DO 800 K=1,NDEP
        DO 700 J=1,MJ          
          DO 600 I=1,MEL
            FRCION(I,J,K)=-1.0
  600     CONTINUE
  700   CONTINUE
  800 CONTINUE
C
C  READ BMET FILE IF IOPAC = 2 OR 3
C
      IF(MOD(IOPAC,10).EQ.2 .OR. MOD(IOPAC,10).EQ.3) THEN
        CALL RDBMET
      ENDIF
C
      END
C
C***********************************************************************
C
C     02-01-16 MODIFICATIONS (RC)
C     11-02-14 MODIFICATIONS (KL)
C     
      SUBROUTINE OSMET(MAXNU)
C
C     READ FROM FILE <OSFILE> (SEE INCLUDE FILE OSMPAR)
C     THE LINE OPACITIES TABULATED AT VARIOUS WAVELENGTHS,
C     TEMPERATURES AND P6 VALUES.
C     CALLS SUBROUTINE OSINTP THAT PERFORMS AN INTERPOLATION
C     OF THE LINE OPACITIES.
C
C     XITURB :   MICROTURBULENCE
C     P6     :   VAN DER WAALS PRESSURE PARAMETER, LOGARITM OF 
C     T      :   TEMPERATURE
C     OSTABL :   OPACITY TABLE
C     NDEP   :   NUMBER OF OPTICAL DEPTH POINTS
C     MAXNU  :   NUMBER OF FREQUENCY POINT READ BY OSMET
C
C     NOTE: ADDED NEW 'INCLUDE' FILES (OSMPAR, COSM1, COSM2, COSM3)
C
C     IOSMET.EQ.-1 INDICATES OLD FORMAT WITH P6-PRESSURES. 
C     IOSMET.EQ.1 INDICATES NEW FORMAT WITH TOTAL GAS-PRESSURES. 
C
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'OSMPAR'
      INCLUDE 'CATMOS'
      INCLUDE 'COSM1'
      INCLUDE 'COSM2'
      INCLUDE 'COSM3'
      INCLUDE 'CCONST'
      INCLUDE 'CINPUT'

      CHARACTER*80 TEXTATOM      
      INTEGER ISPEC(2*92), SPECIES(83)
      REAL(4) ABUNDLOG(83)
      INTEGER MAXP6, MAXTEM, MAXNU
      INTEGER NP6, NTEM, NNU, NXI,K
      REAL(8) WNUM
      REAL(4) XITURB(MXI)

C     OPEN THE FILE CONTAINING THE OPACITY TABLE
C     READ THE HEADER OF <OSFILE>
C     READ ISPEC (SEE OSMET_35.F)
      CALL MOPEN(LUOS,OSFILE,0,'OLD')
      CALL MOPEN(LOPLIN,'LOPLIN',0,'NEW')

      READ (LUOS) TEXTATOM
      READ (LUOS) TEXTATOM
      IF (IOSMET.EQ.-1) THEN
         READ (LUOS) ISPEC
      ELSE
         READ (LUOS) SPECIES
         READ (LUOS) ABUNDLOG
      ENDIF
C     READ XITURB, MAXP6, P6PT, MAXTEM, TEMPT
C     CONTROL ON MAXP6 AND MAXTEM SHOULD BE INSERTED IN THE FUTURE
      READ (LUOS) XITURB(1)
      READ (LUOS) MAXP6
      READ (LUOS) (P6PT(NP6), NP6=1,MAXP6)
      READ (LUOS) MAXTEM
      READ (LUOS) (TEMPT(NTEM), NTEM=1,MAXTEM)
      IF (IOSMET.EQ.-1) THEN
         READ (LUOS)
         READ (LUOS)
         READ (LUOS)
         READ (LUOS)
      ENDIF

C     P6 VALUES IN LOGARITMIC (LOG10) SCALE
      DO 200 NP6=1,MAXP6
         P6PT(NP6) = LOG10(P6PT(NP6))         
 200  CONTINUE
C
C     11-02-14 KL : IF IOSMET.EQ.-1 USE P6-SCALE, ELSE TOTAL GAS PRESSURE
      IF (IOSMET.EQ.-1) THEN 
         CALL OSP6
      ELSE
         DO 201 K=1,NDEP 
            P6(K)=LOG10(PG(K))
 201     CONTINUE
      ENDIF
C     THE SUBROUTINE OSP6 CALCULATES THE P6 SCALE (THAT IS FOR ALL THE
C     OPTICAL DEPTH POINTS). 
C     PAY ATTENTION: P6 IS EXPRESSED IN LOGARITMIC SCALE!


C     READ THE OPACITIES FROM <OSFILE> AND STORE THEM IN OSTABL.
C     OPACITIES IN OSTABL ARE EXPRESSED IN LOGARITMIC SCALE
C     A LINEAR INTERPOLATION IS PERFORMED TO CALCULATE THE OPACITIES
C     AS A FUNCTION OF THE OPTICAL DEPTH.

      DO 100 NNU =1, MNU
C KL 2011-02 bug fixed in next line
C         READ(LUOS, END=300) WNUM, (((OSTABL(NTEM, NXI, NP6),
C     &        NP6=1,MAXP6), NXI=1,MXI), NTEM=1,MAXTEM)
         READ(LUOS, END=300) WNUM, (((OSTABL(NTEM, NXI, NP6),
     &        NTEM=1,MAXTEM), NXI=1,MXI), NP6=1,MAXP6)
C     WNU    UNITS:  CM^-1
C     OSFREQ UNITS:  HZ

         OSFREQ(NNU) = CC * WNUM

C     CONTROL STRING PRINTED ON STANDARD OUTPUT
C         WRITE (*,*) 'OSMET: --- OSFREQ (HZ) = ',OSFREQ(NNU)

         CALL OSINTP(NNU-1,MAXTEM, MAXP6, NNU)

 100  CONTINUE
      
 300  CONTINUE
      MAXNU = NNU-1

      WRITE (*,*) 'OSMET: --- READ ALL THE OPACITIES ---'
      WRITE (*,*) 'OSMET:     MAXNU = ', MAXNU
C
      WRITE(LOPLIN) (OSFREQ(NNU)/CC,NNU=1,MAXNU)
      WRITE(LOPLIN) ((OPLIN(NNU,K),K=1,NDEP),NNU=1,MAXNU)
      CALL CLOSE(LOPLIN)
C
      CALL CLOSE(LUOS)

      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     02-01-16 MODIFICATIONS (RC)
C 
      SUBROUTINE OSINTP(JFLAG, MAXTEM, MAXP6, NNU)
C
C     THIS SUBROUTINE PERFORMS A LINEAR INTERPOLATION OF LINE OPACITY
C     AT A GIVEN WAVELENGTH, FOR ALL THE DEPTH POINTS.
C     OUTPUT STORED IN OPLIN(NNU, K), WHERE  NNU   IS THE INDEX
C     REFERRING TO THE FREQUENCY AND K  THE OPTICAL DEPTH POINT.
C
C     IF JFLAG IS DIFFERENT FROM   0  THEN USE THE VALUES ALREADY 
C     STORED IN   JTEM   AND  JP6.
C     
C     PAY ATTENTION: OPLIN IS REAL(8) PRECISION  AND IN LINEAR SCALE !
C
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'OSMPAR'
      INCLUDE 'CATMOS'
      INCLUDE 'COSM1'
      INCLUDE 'COSM2'
      INCLUDE 'COSM3'
      
      INTEGER JFLAG, MAXTEM, MAXP6, NNU
      REAL(8) TEMDP(MTEM), P6DP(MP6)
      REAL(8) LOPAC(2,2)
      REAL(8) OPINT
      REAL(8) LOGE10

      LOGE10 = LOG(DBLE(10.0))
      
      JJX = 1
      JJT = 0
      JJP = 0
C     JJX     :   INDEX   FOR MICROTURBULENCE VALUE      
C     JJT,JJP :   INDECES FOR TEM. AND P6 

C     COPY TEMPT AND P6PT RESPECTIVELY INTO TEMDP AND P6DP
C     (DOUBLE PRECISION)
      DO I=1,MAXTEM
         TEMDP(I) = DBLE(TEMPT(I))
      ENDDO
      DO I=1,MAXP6
         P6DP(I) = DBLE(P6PT(I))
      ENDDO


      IF (JFLAG .EQ. 0) THEN
         DO 100 K = 1, NDEP
            JTEM(K) = JJT
            JP6(K)  = JJP
            CALL HUNT(TEMDP, MAXTEM, TEMP(K), JTEM(K) )
            CALL HUNT(P6DP,  MAXP6,  P6(K),   JP6(K)  )
C     JJT(K) AND JJP(K)  SHOULD BE LARGER THAN  0  AND SMALLER THAN
C     MAXTEM AND MAXP6 RESPECTIVELY
C     SEE CONTROL SEQUENCE BELOW
            JJT = JTEM(K)
            JJP = JP6(K)
            IF (JJT .EQ. MAXTEM) THEN
               WRITE (*,*) 'OSINTP: JJT=MAXTEM'
               WRITE(*,*) 'TEMP=',TEMP(K),' MAXT=',TEMDP(MAXTEM)
            ENDIF
            IF (JJP .EQ. MAXP6) THEN
               WRITE (*,*) 'OSINTP: JJP=MAXP6 !!'
               WRITE(*,*) 'P6=',P6(K),' MAXP6=',P6DP(MAXP6)
               CALL STOP('OSINTP')
            ENDIF

 100     CONTINUE
      ENDIF

         DO 200 K = 1, NDEP
            JJT = JTEM(K)
            JJP = JP6(K)

            IF (JJT .EQ. MAXTEM) THEN
              OPLIN(NNU,K) = 0.D0
              GOTO 200
            ENDIF
            IF(JJT.GT.0) THEN
              T1 = TEMDP(JJT)
            ELSE
              T1 = TEMDP(1)
            ENDIF
            T2 = TEMDP(JJT+1)
            IF(JJP.GT.0) THEN
              P1 = P6DP(JJP)
            ELSE
              P1 = P6DP(1)
            ENDIF
            P2 = P6DP(JJP+1)

C     SIMPLE LINEAR INTERPLOATION 
C
C     IT MAY HAPPEN THAT JJP = 0 (IF P6 TOO SMALL): THEN WE SET
C     P6 TO THE LOWEST VALUE  CONSIDERED  WHEN  OPACITIES IN 
C     OSTABL   WERE COMPUTED, THAT IS PG = 1. (LOG SCALE, CGS UNITS)
C 
C     SHOULD A SIMILAR CONTROL BE INSERTED FOR THE TEMPERATURE ?
C     SHOULD A CONTROL ON   OSTABL   VALUES BE CONSIDERED TOO?
C
C     02-01-17, REMO COLLET
C

            IF (JJP .EQ. 0) THEN
C     INTERPOLATION OVER TEMP ONLY (SETTING P6 = LOWEST VALUE)

c               LOPAC(1,2) = EXP(LOGE10 * OSTABL(JJT, JJX, 1))
c               LOPAC(2,2) = EXP(LOGE10 * OSTABL(JJT+1, JJX, 1))
               LOPAC(1,2) = DBLE(OSTABL(JJT, JJX, 1))
               LOPAC(2,2) = DBLE(OSTABL(JJT+1, JJX, 1))

               OPINT = ( LOPAC(1,2)*(T2-TEMP(K)) +
     &                   LOPAC(2,2)*(TEMP(K)-T1) )/ (T2 - T1)

            ELSE
C     'ORDINARY' INTERPOLATION

c               LOPAC(1,1) = EXP(LOGE10 * OSTABL(JJT, JJX, JJP))
c               LOPAC(1,2) = EXP(LOGE10 * OSTABL(JJT, JJX, JJP+1))
c               LOPAC(2,1) = EXP(LOGE10 * OSTABL(JJT+1, JJX, JJP))
c               LOPAC(2,2) = EXP(LOGE10 * OSTABL(JJT+1, JJX, JJP+1))
             LOPAC(1,1) = DBLE(OSTABL(JJT, JJX, JJP))
             LOPAC(1,2) = DBLE(OSTABL(JJT, JJX, JJP+1))
             LOPAC(2,1) = DBLE(OSTABL(JJT+1, JJX, JJP))
             LOPAC(2,2) = DBLE(OSTABL(JJT+1, JJX, JJP+1))
               
               OPINT = 
     &              (LOPAC(1,1) * (T2-TEMP(K)) * (P2-P6(K)) +
     &              LOPAC(1,2) * (T2-TEMP(K)) * (P6(K)-P1) +
     &              LOPAC(2,1) * (TEMP(K)-T1) * (P2-P6(K)) +
     &              LOPAC(2,2) * (TEMP(K)-T1) * (P6(K)-P1))/
     &              ((P2-P1) * (T2-T1))
            ENDIF
c            OPLIN(NNU,K) = OPINT
            OPLIN(NNU,K) = EXP(LOGE10*(OPINT))
 200     CONTINUE
         RETURN
         END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     02-01-16 MODIFICATIONS (RC)
C                       
      SUBROUTINE HUNT(XX,N,X,JLO)
C     THIS SOUBROUTINE HAS BEEN TAKEN FROM 
C     'NUMERICAL RECIPES', W.H.Press et al., CAMBRIDGE UNIV. PRESS
C     (X, XX ARE REQUIRED TO BE DOUBLE PRECISION)
C     
      INTEGER jlo,n
      REAL(8)  x,xx(n)
      INTEGER inc,jhi,jm
      LOGICAL ascnd
      ascnd=xx(n).ge.xx(1)
      if(jlo.le.0.or.jlo.gt.n)then
        jlo=0
        jhi=n+1
        goto 3
      endif
      inc=1
      if(x.ge.xx(jlo).eqv.ascnd)then
1       jhi=jlo+inc
        if(jhi.gt.n)then
          jhi=n+1
        else if(x.ge.xx(jhi).eqv.ascnd)then
          jlo=jhi
          inc=inc+inc
          goto 1
        endif
      else
        jhi=jlo
2       jlo=jhi-inc
        if(jlo.lt.1)then
          jlo=0
        else if(x.lt.xx(jlo).eqv.ascnd)then
          jhi=jlo
          inc=inc+inc
          goto 2
        endif
      endif
3     if(jhi-jlo.eq.1)then
        if(x.eq.xx(n))jlo=n-1
        if(x.eq.xx(1))jlo=1
        return
      endif
      jm=(jhi+jlo)/2
      if(x.ge.xx(jm).eqv.ascnd)then
        jlo=jm
      else
        jhi=jm
      endif
      goto 3
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     02-01-16 MODIFICATIONS (RC)
C 
      SUBROUTINE OSP6
C
C     THIS SUBROUTINE CALCULATES THE VAN DER WAALS PARAMETER  P6  AT
C     VARIOUS OPTICAL DEPTHS. THE P6 SCALE IS REQUIRED BY THE 
C     SUBROUTINE   OSINTP  TO PERFORM THE INTERPOLATION OF   OSTABL
C     VALUES.
C     NOTE: P6 IS IN LOGARITMIC SCALE
C
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'CCONST'
      INCLUDE 'COSM1'
      INCLUDE 'CATMOS'
      INCLUDE 'PARAMO'
      COMMON/CI5/ABUND(MEL),ANJON(MEL,MJ),H(5),PART(MEL,MJ),DXI,
     &     F1,F2,F3,F4,F5,XKHM,XMH,XMY
      COMMON/COUT/ TOTH(MT),TOTHI(MT),TOTH2(MT),
     * TOTCH(MT),TOTCO(MT),TOTCN(MT),
     * TOTC(MT),TOTNIT(MT),TOTO(MT),
     * BHYD(MT,5),GRPH,TOTOH(MT)
      REAL(8) NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE
      COMMON/HYDCOM/NH,NP,NH2,NH2P,NHMIN,NHT,NHLTE

C     /CI5/  INCLUDED TO READ INTO THE ARRAYS   ABUND AND  ANJON
C     /COUT/ INCLUDED TO ACCESS THE VALUE OF THE TOTAL DENSITY OF  HI 
C     /HYDCOM/ INCLUDED FOR NH2P

      INTEGER IOUTR, IEPRO, K
      REAL(8) PE, T, PH1, PTOTH, PTOTH2, PHE1

C     PE    : ELECTRON PRESSURE
C     T     : TEMPERATURE
C     PH1   : PRESSURE OF NEUTRAL ATOMIC HYDROGEN
C     PTOTH : TOTAL PRESSURE OF HYDROGEN
C     PHE1  : PRESSURE OF NEUTRAL HELIUM
C     PTOTH2   : PRESSURE OF  MOLECULAR HYDROGEN (H2 AND H2+)

C     THE LOG10(P6) SCALE IS PRINTED INTO THE FILE P6.OUT

      DO 100 K=1,NDEP

         T  = TEMP(K)
         PE = NE(K) * BK * T

         IOUTR=0
         IEPRO=1
         CALL JON(K,T,PE,IEPRO,PGDUM,RODUM,EDUM,IOUTR)
C     JON IS REQUIRED TO COMPUTE  ANJON(2,1) I.E. THE RATIO
C     N(HEII)/N(HEI)

         PH1    = TOTHI(K) * BK * T 
         PTOTH  = TOTH(K)  * BK * T
         PTOTH2 = (TOTH2(K)+NH2P) * BK * T
C     PTOTH  = TOTAL PRESSURE OF HYDROGEN
C     PTOTH2 = TOTAL PRESSURE OF NEUTRAL MOLECULAR HYDROGEN
C     THE TERM NH2P HAS BEEN ADDED TO TAKE INTO ACCOUNT 
C     THE CONTRIBUTE OF H2+ TO THE PRESSURE.
     

C     THE VAN DER WAALS P6 PARAMETER IS COMPUTED MAKING USE OF THE
C     FOLLOWING FORMULA:
C
C     P6 = PRESSURE(HI) + 0.42 * PRESSURE(HEI)
C        + 0.85 * PRESSURE(H2)
C
C     THE RATIO BETWEEN THE PRESSURE OF HeI AND HYDROGEN IS GIVEN BY:
C
C     PHE1/PTOTH = ABUND(2) * ANJON(2,1)

         PHE1 = ANJON(2,1) * ABUND(2) * PTOTH
         P6(K) = PH1 + 0.42 * PHE1 + 0.85 * PTOTH2
C     P6 CONVERTED TO LOGARITMIC SCALE (LOG 10)
C         if (k.eq.1) then
C         write(*,'(2es15.4)') p6(k),pgdum
C         endif
         P6(K) = LOG10(P6(K))
C 
C 
C 
 100  CONTINUE

      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     02-01-16 MODIFICATIONS (RC)
C 
      SUBROUTINE OSLINE(NYFREQ, MAXNU, LFLAG)
C
C     THIS SUBROUTINE PERFORMS A LINEAR INTERPOLATION OF LINE
C     OPACITIES FROM THE ARRAY   OPLIN  FOR ALL THE DEPTH POINTS
C     AND FOR A GIVEN FREQUENCY     NYFREQ (HZ)
C     INTERPOLATED OPACITIES STORED IN  THE ARRAY   LINOP
C
C     MAXNU   IS THE NUMBER OF FREQUENCY POINT READ BY THE SUBROUTINE
C             OSMET
C
C     IF LFLAG = 0  THEN RETURNS AN EMPTY ARRAY   (I.E. SUBROUTINE
C     OPAC WILL NOT ADD 'OSMARCS'  LINE OPACITIES TO THE CONTINUUM)
C
C     IF LFLAG = 1  THEN THE INTERPOLATION WILL BE PERFORMED
C
      INCLUDE 'PREC'
      INCLUDE 'PARAM'
      INCLUDE 'OSMPAR'
      INCLUDE 'CATMOS'
      INCLUDE 'COSM1'
      INCLUDE 'COSM3'
      
      REAL(8) NYFREQ
      INTEGER LFLAG, JLO
      INTEGER MAXNU

      JLO = 1

      IF (LFLAG .EQ. 1) THEN
         CALL HUNT(OSFREQ, MAXNU, NYFREQ, JLO)
      ENDIF

      IF ((LFLAG .NE. 1).OR.(JLO.EQ.MAXNU).OR.(JLO.EQ.0)) THEN
         DO 100 K=1,NDEP
            LINOP(K) = 0.0
 100     CONTINUE

      ELSE

C     SIMPLE LINEAR INTERPOLATION WITH RESPECT TO FREQUENCIES
C     SIMPLE LINEAR INTERPOLATION WITH RESPECT TO FREQUENCIES

         DO 200 K=1,NDEP
            LINOP(K) = ( OPLIN(JLO,K)  * (OSFREQ(JLO+1)-NYFREQ) +
     &           OPLIN(JLO+1,K)* (NYFREQ - OSFREQ(JLO)))/
     &           (OSFREQ(JLO+1) - OSFREQ(JLO))
cc            LINOP(K) =  OPLIN(JLO,K)

 200     CONTINUE

      ENDIF

      RETURN
      END
C
C     *****************************************************************
C
