LCOV - code coverage report
Current view: top level - star/private - kap_support.f90 (source / functions) Coverage Total Hit
Test: coverage.info Lines: 24.3 % 230 56
Test Date: 2025-05-08 18:23:42 Functions: 80.0 % 5 4

            Line data    Source code
       1              : ! ***********************************************************************
       2              : !
       3              : !   Copyright (C) 2010-2019  The MESA Team
       4              : !
       5              : !   This program is free software: you can redistribute it and/or modify
       6              : !   it under the terms of the GNU Lesser General Public License
       7              : !   as published by the Free Software Foundation,
       8              : !   either version 3 of the License, or (at your option) any later version.
       9              : !
      10              : !   This program is distributed in the hope that it will be useful,
      11              : !   but WITHOUT ANY WARRANTY; without even the implied warranty of
      12              : !   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
      13              : !   See the GNU Lesser General Public License for more details.
      14              : !
      15              : !   You should have received a copy of the GNU Lesser General Public License
      16              : !   along with this program. If not, see <https://www.gnu.org/licenses/>.
      17              : !
      18              : ! ***********************************************************************
      19              : 
      20              : module kap_support
      21              : 
      22              :   use star_private_def
      23              :   use const_def, only: dp, ln10
      24              :   use auto_diff
      25              : 
      26              :   implicit none
      27              : 
      28              :   private
      29              :   public :: prepare_kap
      30              :   public :: setup_for_op_mono
      31              :   public :: fraction_of_op_mono
      32              :   public :: frac_op_mono
      33              :   public :: get_kap
      34              : 
      35              : contains
      36              : 
      37        80060 :   subroutine prepare_kap (s, ierr)
      38              : 
      39              :     type(star_info), pointer :: s
      40              :     integer, intent(out)     :: ierr
      41              : 
      42              :     ! Set opacity parameters and monochromatic stuff
      43              : 
      44           66 :     call setup_for_op_mono(s, .true., ierr)
      45              :     if (ierr /= 0) return
      46              : 
      47              :   end subroutine prepare_kap
      48              : 
      49              : 
      50           66 :   subroutine setup_for_op_mono(s, check_if_need, ierr)
      51              : 
      52              :     use kap_lib, only: load_op_mono_data, get_op_mono_params
      53              :     use utils_lib, only: utils_OMP_GET_MAX_THREADS
      54              : 
      55              :     type (star_info), pointer :: s
      56              :     logical, intent(in)       :: check_if_need
      57              :     integer, intent(out)      :: ierr
      58              : 
      59              :     integer  :: k, nptot, ipe, nrad, n
      60              :     logical  :: need_op
      61              :     type(auto_diff_real_2var_order1) :: beta
      62              : 
      63              :     include 'formats'
      64              : 
      65           66 :     ierr = 0
      66           66 :     if (s% op_mono_n > 0) return  ! already setup
      67              : 
      68           66 :     if (check_if_need) then
      69           66 :        if (s% high_logT_op_mono_full_off < 0d0 .or. &
      70              :             s% low_logT_op_mono_full_off > 99d0) return
      71            0 :        need_op = .false.
      72            0 :        do k=1,s% nz
      73            0 :           beta = fraction_of_op_mono(s, k)
      74            0 :           if (beta > 0d0) then
      75              :              need_op = .true.
      76              :              exit
      77              :           end if
      78              :        end do
      79            0 :        if (.not. need_op) return
      80              :     end if
      81              : 
      82              :     call load_op_mono_data( &
      83            0 :          s% op_mono_data_path, s% op_mono_data_cache_filename, ierr)
      84            0 :     if (ierr /= 0) then
      85            0 :        write(*,*) 'error while loading OP data, ierr = ',ierr
      86            0 :        return
      87              :     end if
      88              : 
      89            0 :     call get_op_mono_params(nptot, ipe, nrad)
      90              : 
      91            0 :     n = utils_OMP_GET_MAX_THREADS()
      92              : 
      93              :     if (n /= s% op_mono_n .or. &
      94              :          nptot /= s% op_mono_nptot .or. &
      95            0 :          ipe /= s% op_mono_ipe .or. &
      96              :          nrad /= s% op_mono_nrad) then
      97            0 :        if (associated(s% op_mono_umesh1)) deallocate(s% op_mono_umesh1)
      98            0 :        if (associated(s% op_mono_semesh1)) deallocate(s% op_mono_semesh1)
      99            0 :        if (associated(s% op_mono_ff1)) deallocate(s% op_mono_ff1)
     100            0 :        if (associated(s% op_mono_rs1)) deallocate(s% op_mono_rs1)
     101            0 :        if (s% use_op_mono_alt_get_kap) then
     102              :           allocate( &
     103              :              s% op_mono_umesh1(nptot*n), s% op_mono_semesh1(nptot*n), s% op_mono_ff1(nptot*ipe*6*6*n), &
     104            0 :              s% op_mono_rs1(nptot*6*6*n), stat=ierr)
     105              :        else
     106              :           allocate( &
     107              :              s% op_mono_umesh1(nptot*n), s% op_mono_semesh1(nptot*n), s% op_mono_ff1(nptot*ipe*4*4*n), &
     108            0 :              s% op_mono_rs1(nptot*4*4*n), stat=ierr)
     109              :        end if
     110            0 :        if (ierr /= 0) return
     111            0 :        s% op_mono_n = n
     112            0 :        s% op_mono_nptot = nptot
     113            0 :        s% op_mono_ipe = ipe
     114            0 :        s% op_mono_nrad = nrad
     115              :     end if
     116              : 
     117           66 :   end subroutine setup_for_op_mono
     118              : 
     119              : 
     120            0 :   real(dp) function fraction_of_op_mono(s, k) result(beta)
     121              :     ! returns the real(dp) value of the blend function for cell k
     122              :     type (star_info), pointer :: s
     123              :     integer, intent(in)       :: k
     124              : 
     125              :     type(auto_diff_real_2var_order1) :: frac
     126              : 
     127            0 :     if (s% op_mono_method == 'mombarg' .and. k < 2) then
     128            0 :        beta = 0d0  ! don't use 'mombarg' op mono method for atmospheres
     129              :     else
     130            0 :        frac = frac_op_mono(s, s% lnd(k)/ln10, s% lnT(k)/ln10)
     131              :     end if
     132              : 
     133            0 :     beta = frac% val
     134              : 
     135           66 :   end function fraction_of_op_mono
     136              : 
     137              : 
     138        79994 :   type(auto_diff_real_2var_order1) function frac_op_mono(s, logRho, logT) result(beta)
     139              :     ! returns an auto_diff type: var1 = lnd, var2 = lnT (derivs w.r.t. ln *not* log)
     140              :     use utils_lib, only: mesa_error
     141              :     type (star_info), pointer :: s
     142              :     real(dp), intent(in)       :: logRho, logT
     143              : 
     144              :     real(dp) :: high_full_off, high_full_on, low_full_off, low_full_on
     145              :     type(auto_diff_real_2var_order1) :: alfa, log10_T
     146              : 
     147              :     include 'formats'
     148              : 
     149              :     ! default to 0
     150        79994 :     beta = 0
     151              : 
     152        79994 :     high_full_off = s% high_logT_op_mono_full_off
     153        79994 :     high_full_on = s% high_logT_op_mono_full_on
     154        79994 :     low_full_off = s% low_logT_op_mono_full_off
     155        79994 :     low_full_on = s% low_logT_op_mono_full_on
     156              : 
     157              :     if (high_full_off < high_full_on &
     158              :           .or. high_full_on < low_full_on &
     159        79994 :           .or. low_full_on < low_full_off) then
     160            0 :        write(*,*) "ERROR: OP mono controls must satisfy"
     161            0 :        write(*,*) "high_logT_op_mono_full_off >= high_logT_op_mono_full_on"
     162            0 :        write(*,*) "high_logT_op_mono_full_on >= low_logT_op_mono_full_on"
     163            0 :        write(*,*) "low_logT_op_mono_full_on >= high_logT_op_mono_full_off"
     164            0 :        call mesa_error(__FILE__,__LINE__,'fraction_of_op_mono')
     165              :     end if
     166              : 
     167        79994 :     if (high_full_off <= 0d0 .or. high_full_on <= 0d0) then
     168        79994 :        beta = 0._dp
     169        79994 :        return
     170              :     end if
     171              : 
     172              :     ! auto_diff version of inputs
     173            0 :     log10_T = logT
     174            0 :     log10_T % d1val2 = 1d0/ln10
     175              : 
     176              :     ! alfa is fraction standard opacity
     177              : 
     178            0 :     if (log10_T >= high_full_off .or. log10_T <= low_full_off) then
     179            0 :        alfa = 1d0
     180            0 :     else if (log10_T <= high_full_on .and. log10_T >= low_full_on) then
     181            0 :        alfa = 0d0
     182            0 :     else if (log10_T > high_full_on) then  ! between high_on and high_off
     183            0 :        if (high_full_off - high_full_on > 1d-10) then
     184            0 :           alfa = (log10_T - high_full_on) / (high_full_off - high_full_on)
     185              :        else
     186            0 :           alfa = 1d0
     187              :        end if
     188              :     else  ! between low_off and low_on
     189            0 :        if (low_full_on - low_full_off > 1d-10) then
     190            0 :           alfa = (log10_T - low_full_on) / (low_full_off - low_full_on)
     191              :        else
     192            0 :           alfa = 1d0
     193              :        end if
     194              :     end if
     195              : 
     196              :     ! beta is fraction of op mono
     197              :     ! transform linear blend to smooth quintic blend
     198            0 :     alfa = -alfa*alfa*alfa*(-10d0 + alfa*(15d0 - 6d0*alfa))
     199            0 :     beta = 1d0 - alfa
     200              : 
     201            0 :   end function frac_op_mono
     202              : 
     203              : 
     204        79994 :   subroutine get_kap( &
     205        79994 :        s, k, zbar, xa, logRho, logT, &
     206              :        lnfree_e, dlnfree_e_dlnRho, dlnfree_e_dlnT, &
     207              :        eta, d_eta_dlnRho, d_eta_dlnT, &
     208              :        kap_fracs, kap, dlnkap_dlnd, dlnkap_dlnT, ierr)
     209              : 
     210              :     use utils_lib
     211              :     use num_lib
     212              :     use kap_def, only: kap_test_partials, &
     213              :        kap_test_partials_val, kap_test_partials_dval_dx, &
     214              :        num_kap_fracs
     215              :     use kap_lib, only: &
     216              :          load_op_mono_data, get_op_mono_params, &
     217              :          get_op_mono_args, kap_get_op_mono, kap_get, &
     218              :          call_compute_kappa_mombarg
     219              : 
     220              :     use chem_def, only: chem_isos
     221              :     use star_utils, only: get_XYZ, lookup_nameofvar
     222              : 
     223              :     type (star_info), pointer :: s
     224              :     integer, intent(in) :: k
     225              :     real(dp), intent(in) :: &
     226              :        zbar, logRho, logT
     227              :     real(dp), intent(in) :: lnfree_e, dlnfree_e_dlnRho, dlnfree_e_dlnT
     228              :     real(dp), intent(in) :: eta, d_eta_dlnRho, d_eta_dlnT
     229              :     real(dp), intent(in) :: xa(:)
     230              :     real(dp), intent(out) :: kap_fracs(num_kap_fracs)
     231              :     real(dp), intent(out) :: kap, dlnkap_dlnd, dlnkap_dlnT
     232              :     integer, intent(out) :: ierr
     233              : 
     234       719946 :     real(dp) :: dlnkap_dxa(s% species)
     235              : 
     236              :     integer :: i, iz, nptot, ipe, nrad, thread_num, sz, offset
     237              :     type(auto_diff_real_2var_order1) :: beta, lnkap, lnkap_op
     238        79994 :     real(dp) :: kap_op, dlnkap_op_dlnRho, dlnkap_op_dlnT, &
     239        79994 :        Z, xh, xhe, xc, xn, xo, xne, &
     240      1439892 :        log_kap_rad, fk(17)
     241              : 
     242              :     character(len=4) :: e_name
     243              : 
     244        79994 :     integer, pointer :: net_iso(:)
     245              :     real, pointer :: &
     246        79994 :          umesh(:), semesh(:), ff(:,:,:,:), rs(:,:,:)
     247       159988 :     integer :: nel, izzp(s% species)
     248      1359898 :     real(dp) :: fap(s% species), fac(s% species)
     249              :     logical :: screening
     250              :     real(dp), parameter :: &
     251              :          eps = 1d-6, minus_eps = -eps, one_plus_eps = 1d0 + eps
     252              : 
     253              :     include 'formats'
     254              : 
     255        79994 :     if (s% doing_timing) s% timing_num_get_kap_calls = s% timing_num_get_kap_calls + 1
     256              : 
     257        79994 :     kap = -1d99
     258        79994 :     if (k > 0 .and. k <= s% nz) s% kap_frac_op_mono(k) = 0
     259              : 
     260        79994 :     net_iso => s% net_iso
     261        79994 :     xc = 0; xn = 0; xo = 0; xne = 0
     262       719946 :     do i=1, s% species
     263       639952 :        iz = chem_isos% Z(s% chem_id(i))
     264        79994 :        select case(iz)
     265              :        case (6)
     266        79994 :           xc = xc + xa(i)
     267              :        case (7)
     268        79994 :           xn = xn + xa(i)
     269              :        case (8)
     270        79994 :           xo = xo + xa(i)
     271              :        case (10)
     272       639952 :           xne = xne + xa(i)
     273              :        end select
     274              :     end do
     275              : 
     276              :     if (xc < minus_eps .or. xn < minus_eps .or. &
     277              :          xo < minus_eps .or. xne < minus_eps .or. &
     278              :          xc > one_plus_eps .or. xn > one_plus_eps .or. &
     279        79994 :          xo > one_plus_eps .or. xne > one_plus_eps) then
     280            0 :        ierr = -1
     281            0 :        if (xc < 0d0 .or. xc > 1d0) write(s% retry_message,2) 'get_kap: xc', k, xc
     282            0 :        if (xn < 0d0 .or. xn > 1d0) write(s% retry_message,2) 'get_kap: xn', k, xn
     283            0 :        if (xo < 0d0 .or. xo > 1d0) write(s% retry_message,2) 'get_kap: xo', k, xo
     284            0 :        if (xne < 0d0 .or. xne > 1d0) write(s% retry_message,2) 'get_kap: xne', k, xne
     285            0 :        if (s% report_ierr) write(*, *) s% retry_message
     286            0 :        return
     287              :        call mesa_error(__FILE__,__LINE__,'bad mass fraction: get_kap')
     288              :     end if
     289              : 
     290        79994 :     call get_XYZ(s, xa, xh, xhe, Z)
     291              : 
     292        79994 :     if (xh < 0d0 .or. xhe < 0d0 .or. Z < 0d0) then
     293            0 :        ierr = -1
     294            0 :        if (xh < 0d0) write(s% retry_message,2) 'xh', k, xh
     295            0 :        if (xhe < 0d0) write(s% retry_message,2) 'xhe', k, xhe
     296            0 :        if (Z < 0d0) write(s% retry_message,2) 'Z', k, Z
     297            0 :        if (s% report_ierr) write(*, *) s% retry_message
     298            0 :        return
     299              :        call mesa_error(__FILE__,__LINE__,'negative mass fraction: get_kap')
     300              :     end if
     301              : 
     302        79994 :     if (s% use_simple_es_for_kap) then
     303            0 :        kap = 0.2d0*(1 + xh)
     304            0 :        dlnkap_dlnd = 0
     305            0 :        dlnkap_dlnT = 0
     306            0 :        return
     307              :     end if
     308              : 
     309        79994 :     if (s% op_mono_method == 'mombarg' .and. k < 2) then
     310            0 :        beta = 0d0  ! don't use 'mombarg' op mono method for atmospheres
     311              :     else
     312        79994 :        beta = frac_op_mono(s, logRho, logT)
     313              :     end if
     314              : 
     315        79994 :     if (k > 0 .and. k <= s% nz) s% kap_frac_op_mono(k) = beta % val
     316              : 
     317        79994 :     if (beta > 0d0) then
     318              : 
     319            0 :       if (s% op_mono_method == 'hu') then
     320              :          call get_op_mono_args( &
     321              :               s% species, xa, s% op_mono_min_X_to_include, s% chem_id, &
     322            0 :               s% op_mono_factors, nel, izzp, fap, fac, ierr)
     323            0 :          if (ierr /= 0) then
     324            0 :             write(*,*) 'error in get_op_mono_args, ierr = ',ierr
     325            0 :             return
     326              :          end if
     327              : 
     328            0 :          if (associated(s% op_mono_umesh1)) then
     329              : 
     330            0 :             thread_num = utils_OMP_GET_THREAD_NUM()  ! in range 0 to op_mono_n-1
     331            0 :             if (thread_num < 0) then
     332            0 :                write(*,3) 'thread_num < 0', thread_num, s% op_mono_n
     333            0 :                ierr = -1
     334            0 :                return
     335              :             end if
     336            0 :             if (thread_num >= s% op_mono_n) then
     337            0 :                write(*,3) 'thread_num >= s% op_mono_n', thread_num, s% op_mono_n
     338            0 :                ierr = -1
     339            0 :                return
     340              :             end if
     341            0 :             nptot = s% op_mono_nptot
     342            0 :             ipe = s% op_mono_ipe
     343            0 :             nrad = s% op_mono_nrad
     344              : 
     345            0 :             sz = nptot; offset = thread_num*sz
     346            0 :             umesh(1:nptot) => s% op_mono_umesh1(offset+1:offset+sz)
     347            0 :             semesh(1:nptot) => s% op_mono_semesh1(offset+1:offset+sz)
     348            0 :             if (s% use_op_mono_alt_get_kap) then
     349            0 :                sz = nptot*ipe*6*6; offset = thread_num*sz
     350            0 :                ff(1:nptot,1:ipe,1:6,1:6) => s% op_mono_ff1(offset+1:offset+sz)
     351            0 :                sz = nptot*6*6; offset = thread_num*sz
     352            0 :                rs(1:nptot,1:6,1:6) => s% op_mono_rs1(offset+1:offset+sz)
     353            0 :                sz = nptot*nrad*6*6; offset = thread_num*sz
     354              :             else
     355            0 :                sz = nptot*ipe*4*4; offset = thread_num*sz
     356            0 :                ff(1:nptot,1:ipe,1:4,1:4) => s% op_mono_ff1(offset+1:offset+sz)
     357            0 :                sz = nptot*4*4; offset = thread_num*sz
     358            0 :                rs(1:nptot,1:4,1:4) => s% op_mono_rs1(offset+1:offset+sz)
     359            0 :                sz = nptot*nrad*4*4; offset = thread_num*sz
     360              :             end if
     361              : 
     362              :          else
     363              : 
     364              :             call load_op_mono_data( &
     365            0 :                  s% op_mono_data_path, s% op_mono_data_cache_filename, ierr)
     366            0 :             if (ierr /= 0) then
     367            0 :                write(*,*) 'error while loading OP data, ierr = ',ierr
     368            0 :                return
     369              :             end if
     370              : 
     371            0 :             call get_op_mono_params(nptot, ipe, nrad)
     372            0 :             if (s% use_op_mono_alt_get_kap) then
     373              :                allocate( &
     374              :                     umesh(nptot), semesh(nptot), ff(nptot,ipe,6,6), &
     375            0 :                     rs(nptot,6,6), stat=ierr)
     376              :             else
     377              :                allocate( &
     378              :                     umesh(nptot), semesh(nptot), ff(nptot,ipe,4,4), &
     379            0 :                     rs(nptot,4,4), stat=ierr)
     380              :             end if
     381            0 :             if (ierr /= 0) return
     382              : 
     383              :          end if
     384              : 
     385            0 :          if (s% solver_test_kap_partials) then
     386              :             kap_test_partials = (k == s% solver_test_partials_k .and. &
     387              :                  s% solver_call_number == s% solver_test_partials_call_number .and. &
     388            0 :                  s% solver_iter == s% solver_test_partials_iter_number )
     389              :          end if
     390              : 
     391            0 :          screening = .true.
     392            0 :          if (s% use_other_kap) then
     393              :             call s% other_kap_get_op_mono( &
     394              :                  s% kap_handle, zbar, logRho, logT, &
     395              :                  s% use_op_mono_alt_get_kap, &
     396              :                  nel, izzp, fap, fac, screening, umesh, semesh, ff, rs, &
     397            0 :                  kap_op, dlnkap_op_dlnRho, dlnkap_op_dlnT, ierr)
     398              :          else
     399              :             call kap_get_op_mono( &
     400              :                  s% kap_handle, zbar, logRho, logT, &
     401              :                  s% use_op_mono_alt_get_kap, &
     402              :                  nel, izzp, fap, fac, screening, umesh, semesh, ff, rs, &
     403            0 :                  kap_op, dlnkap_op_dlnRho, dlnkap_op_dlnT, ierr)
     404              :          end if
     405              : 
     406            0 :          if (s% solver_test_kap_partials .and. kap_test_partials) then
     407            0 :             s% solver_test_partials_val = kap_test_partials_val
     408            0 :             s% solver_test_partials_dval_dx = kap_test_partials_dval_dx
     409              :          end if
     410              : 
     411            0 :          if (.not. associated(s% op_mono_umesh1)) deallocate(umesh, semesh, ff, rs)
     412              : 
     413            0 :       else if (s% op_mono_method == 'mombarg') then
     414            0 :          fk = 0
     415            0 :          if (logT > 3.5d0 .and. logT < 8.0d0) then
     416            0 :             do i=1, s% species
     417            0 :                e_name = chem_isos% name(s% chem_id(i))
     418            0 :                if (e_name == 'h1')  fk(1)  =  xa(i)/ chem_isos% W(s% chem_id(i))
     419            0 :                if (e_name == 'he4') fk(2)  =  xa(i)/ chem_isos% W(s% chem_id(i))
     420            0 :                if (e_name == 'c12') fk(3)  =  xa(i)/ chem_isos% W(s% chem_id(i))
     421            0 :                if (e_name == 'n14') fk(4)  =  xa(i)/ chem_isos% W(s% chem_id(i))
     422            0 :                if (e_name == 'o16') fk(5)  =  xa(i)/ chem_isos% W(s% chem_id(i))
     423            0 :                if (e_name == 'ne20')fk(6)  =  xa(i)/ chem_isos% W(s% chem_id(i))
     424            0 :                if (e_name == 'na23')fk(7)  =  xa(i)/ chem_isos% W(s% chem_id(i))
     425            0 :                if (e_name == 'mg24')fk(8)  =  xa(i)/ chem_isos% W(s% chem_id(i))
     426            0 :                if (e_name == 'al27')fk(9)  =  xa(i)/ chem_isos% W(s% chem_id(i))
     427            0 :                if (e_name == 'si28')fk(10) =  xa(i)/ chem_isos% W(s% chem_id(i))
     428            0 :                if (e_name == 's32') fk(11) =  xa(i)/ chem_isos% W(s% chem_id(i))
     429            0 :                if (e_name == 'ar40')fk(12) =  xa(i)/ chem_isos% W(s% chem_id(i))
     430            0 :                if (e_name == 'ca40')fk(13) =  xa(i)/ chem_isos% W(s% chem_id(i))
     431            0 :                if (e_name == 'cr52')fk(14) =  xa(i)/ chem_isos% W(s% chem_id(i))
     432            0 :                if (e_name == 'mn55')fk(15) =  xa(i)/ chem_isos% W(s% chem_id(i))
     433            0 :                if (e_name == 'fe56')fk(16) =  xa(i)/ chem_isos% W(s% chem_id(i))
     434            0 :                if (e_name == 'ni58')fk(17) =  xa(i)/ chem_isos% W(s% chem_id(i))
     435              :             end do
     436            0 :             fk = fk / sum(fk)
     437              :             call call_compute_kappa_mombarg(s% kap_handle, k, &
     438              :                  fk, logT, logRho, &
     439              :                  zbar, lnfree_e, dlnfree_e_dlnRho, dlnfree_e_dlnT, &
     440            0 :                  kap_op, dlnkap_op_dlnT, dlnkap_op_dlnRho, log_kap_rad, ierr)
     441              :          end if
     442              :       else
     443            0 :          write(*,*) 'Invalid argument for op_mono_method.'
     444            0 :          stop
     445              :       end if
     446              : 
     447            0 :       if (ierr /= 0) then
     448              :          ! Fall back to standard opacities, not OP
     449            0 :          beta = 0
     450            0 :          if (k > 0 .and. k <= s% nz) s% kap_frac_op_mono(k) = 0
     451            0 :          ierr = 0
     452            0 :       else if (beta == 1d0) then
     453            0 :          kap = kap_op
     454            0 :          dlnkap_dlnT = dlnkap_op_dlnT
     455            0 :          dlnkap_dlnd = dlnkap_op_dlnRho
     456            0 :          return
     457              :       end if
     458              : 
     459            0 :        if (is_bad(kap_op)) then
     460            0 :          ierr = 1
     461            0 :          return
     462              :        end if
     463              : 
     464            0 :        if (kap_op <= 0d0) then
     465            0 :          ierr = 1
     466            0 :          return
     467              :        end if
     468              : 
     469            0 :     lnkap_op = log(kap_op)
     470            0 :     lnkap_op% d1val1 = dlnkap_op_dlnRho
     471            0 :     lnkap_op% d1val2 = dlnkap_op_dlnT
     472              : 
     473              :     end if
     474              : 
     475        79994 :     if (s% solver_test_kap_partials) then
     476              :        kap_test_partials = (k == s% solver_test_partials_k .and. &
     477              :           s% solver_call_number == s% solver_test_partials_call_number .and. &
     478            0 :           s% solver_iter == s% solver_test_partials_iter_number )
     479              :     end if
     480              : 
     481        79994 :     if (s% use_other_kap) then
     482              :        call s% other_kap_get( &
     483              :             s% id, k, s% kap_handle, s% species, s% chem_id, s% net_iso, xa, &
     484              :             logRho, logT, &
     485              :             lnfree_e, dlnfree_e_dlnRho, dlnfree_e_dlnT, &
     486              :             eta, d_eta_dlnRho, d_eta_dlnT, &
     487            0 :             kap_fracs, kap, dlnkap_dlnd, dlnkap_dlnT, dlnkap_dxa, ierr)
     488              :     else
     489              :        call kap_get( &
     490              :             s% kap_handle, s% species, s% chem_id, s% net_iso, xa, &
     491              :             logRho, logT, &
     492              :             lnfree_e, dlnfree_e_dlnRho, dlnfree_e_dlnT, &
     493              :             eta, d_eta_dlnRho, d_eta_dlnT, &
     494        79994 :             kap_fracs, kap, dlnkap_dlnd, dlnkap_dlnT, dlnkap_dxa, ierr)
     495              :     end if
     496              : 
     497        79994 :     if (ierr /= 0) then
     498              :        return
     499              :     end if
     500              : 
     501        79994 :     if (s% solver_test_kap_partials .and. kap_test_partials) then
     502            0 :        s% solver_test_partials_val = kap_test_partials_val
     503            0 :        s% solver_test_partials_dval_dx = kap_test_partials_dval_dx
     504              :     end if
     505              : 
     506        79994 :     if (beta == 0d0) then
     507              :        return
     508              :     end if
     509              : 
     510              :     ! OP mono already packed in lnkap_op
     511              :     ! pack lnkap with standard opacities
     512            0 :     lnkap = log(kap)
     513            0 :     lnkap% d1val1 = dlnkap_dlnd
     514            0 :     lnkap% d1val2 = dlnkap_dlnT
     515              : 
     516              :     ! Blend opacities
     517            0 :     lnkap = (1d0-beta)*lnkap + beta*lnkap_op
     518              : 
     519              :     ! unpack autodiff type
     520            0 :     kap = exp(lnkap% val)
     521            0 :     dlnkap_dlnd = lnkap% d1val1
     522            0 :     dlnkap_dlnT = lnkap% d1val2
     523              : 
     524       159988 :   end subroutine get_kap
     525              : 
     526              : end module kap_support
        

Generated by: LCOV version 2.0-1