diff --git a/CODEOWNERS b/CODEOWNERS index 3b4ac5903..e06607e5b 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -128,8 +128,8 @@ star/test_suite/wd_he_shell_ignition @wmwolf star/test_suite/wd_nova_burst @wmwolf star/test_suite/wd_stable_h_burn @wmwolf -star/test_suite/12M_pre_ms_to_core_collapse @Debraheem -star/test_suite/20M_pre_ms_to_core_collapse @Debraheem +star/test_suite/12M_pre_ms_to_core_collapse @Debraheem @aurimontem +star/test_suite/20M_pre_ms_to_core_collapse @Debraheem @aurimontem star/test_suite/split_burn_big_net star/test_suite/zams_to_cc_80 @Debraheem star/test_suite/20M_z2m2_high_rotation diff --git a/astero/private/adipls_support.f90 b/astero/private/adipls_support.f90 index 457dd338c..11eef7366 100644 --- a/astero/private/adipls_support.f90 +++ b/astero/private/adipls_support.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,20 +19,20 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module adipls_support - + use astero_def use star_lib use star_def use const_def use utils_lib - + implicit none - - + + ! args for adipls integer, save :: i_paramset, ierr_param, i_inout, nn real(dp), save, pointer :: x(:) => null() ! (nn) @@ -44,15 +44,15 @@ module adipls_support integer, save :: iounit_dev_null = -1 integer, save :: nn_redist ! set from redistrb.c input file - - + + real(dp), save, pointer :: x_arg(:) => null(), aa_arg(:,:) => null() integer, save :: nn_arg real(dp), save :: data_arg(8) - + logical, parameter :: ADIPLS_IS_ENABLED = .true. - + contains @@ -77,17 +77,17 @@ subroutine do_adipls_get_one_el_info( & real(dp), pointer, dimension(:) :: l_freq, l_inertia integer, pointer, dimension(:) :: l_order, l_em integer, intent(out) :: ierr - + real(dp) :: sig_fac integer :: nsel, itrsig, nsig real(dp) :: els1, dels, sig1, sig2, dfsig integer :: i, j - integer, pointer :: index(:) - + integer, pointer :: index(:) + logical, parameter :: dbg = .false. include 'formats' - + ierr = 0 sig_fac = (2*pi)**2*pow3(R)/(G*M) nsel = 0 @@ -98,7 +98,7 @@ subroutine do_adipls_get_one_el_info( & sig2 = sig_fac*(nu2*1d-6)*(nu2*1d-6) nsig = 2 dfsig = sig_fac*delta_nu_model*delta_nu_model - + if (dbg) write(*,*) 'call set_adipls_controls' call set_adipls_controls( & l, nsel, els1, dels, itrsig, iscan, sig1, sig2, dfsig, nsig, & @@ -108,7 +108,7 @@ subroutine do_adipls_get_one_el_info( & el_to_save = l order_to_save = order_to_save_in save_mode_filename = save_mode_filename_in - + num_results = 0 if (dbg) write(*,*) 'call run_adipls' call run_adipls(s, .false., store_for_adipls, & @@ -120,12 +120,12 @@ subroutine do_adipls_get_one_el_info( & return end if num = num_results - + if (num_results == 0) then write(*,*) 'failed to find any modes in specified frequency range' return end if - + ! sort results by increasing frequency allocate(index(num_results), stat=ierr) if (ierr /= 0) then @@ -161,7 +161,7 @@ subroutine do_adipls_get_one_el_info( & call realloc_double(l_inertia,num_results,ierr) if (ierr /= 0) return end if - + do j = 1, num_results i = index(j) l_freq(j) = cyclic_freq(i) @@ -169,12 +169,12 @@ subroutine do_adipls_get_one_el_info( & l_order(j) = order(i) l_em(j) = em(i) end do - + deallocate(index) - + end subroutine do_adipls_get_one_el_info - + subroutine adipls_mode_info( & l, order, em, freq, inertia, x, y, aa, data, nn, iy, iaa, ispcpr) integer, intent(in) :: l, order, em @@ -221,10 +221,10 @@ subroutine adipls_mode_info( & write(iounit,'(i6,4e26.16)') i-skip, x(i), y_r, y_h end do close(iounit) - call free_iounit(iounit) + call free_iounit(iounit) end subroutine adipls_mode_info - - + + subroutine store_model_for_adipls (s, add_atmosphere, do_redistribute_mesh, ierr) type (star_info), pointer :: s @@ -240,11 +240,11 @@ subroutine store_model_for_adipls (s, add_atmosphere, do_redistribute_mesh, ierr real(dp), allocatable :: global_data(:) ! (iconst) real(dp), allocatable :: point_data(:,:) ! (ivar,nn_in) character (len=2000) :: format_string, num_string, filename - + ierr = 0 iriche = 0 iturpr = 0 - + if (associated(x)) deallocate(x) if (associated(aa)) deallocate(aa) @@ -259,7 +259,7 @@ subroutine store_model_for_adipls (s, add_atmosphere, do_redistribute_mesh, ierr end if ! If necessary, write it - + if (write_fgong_for_each_model) then write(format_string,'( "(i",i2.2,".",i2.2,")" )') & @@ -294,23 +294,23 @@ subroutine store_model_for_adipls (s, add_atmosphere, do_redistribute_mesh, ierr write(*,*) 'failed in fgong_amdl' call mesa_error(__FILE__,__LINE__) end if - + call store_amdl(nn, iriche, iturpr, data, aa, x, nn, ierr) if (ierr /= 0) then write(*,*) 'failed in store_amdl' call mesa_error(__FILE__,__LINE__) end if - + call redist_amdl(ierr) if (ierr /= 0) then write(*,*) 'failed in redist_amdl' call mesa_error(__FILE__,__LINE__) end if - - + + contains - - + + subroutine redist_amdl(ierr) integer, intent(out) :: ierr real(dp), pointer :: aa_new(:,:) @@ -333,11 +333,11 @@ subroutine redist_amdl(ierr) nn = nn_new if (ierr_param < 0) ierr = -1 end subroutine redist_amdl - - + + end subroutine store_model_for_adipls - - + + subroutine run_adipls( & s, first_time, store_model, & add_center_point, keep_surface_point, add_atmosphere, & @@ -348,20 +348,20 @@ subroutine run_adipls( & add_center_point, keep_surface_point, add_atmosphere, & do_redistribute_mesh integer, intent(out) :: ierr - + integer :: iounit, nn_arg_0 integer(8) :: time0, time1, clock_rate real(dp) :: time, x_arg0(0), aa_arg0(0,0) character (len=256) :: filename common/cstdio/ istdin, istdou, istdpr, istder integer :: istdin, istdou, istdpr, istder - + logical, parameter :: dbg = .false. - + include 'formats' - + ierr = 0 - + i_inout = 0 i_paramset = 1 ierr_param = 0 @@ -372,7 +372,7 @@ subroutine run_adipls( & call setup_adipls return end if - + if (iounit_dev_null > 0) then close(iounit_dev_null) else @@ -382,26 +382,26 @@ subroutine run_adipls( & call mesa_error(__FILE__,__LINE__,'run_adipls') end if end if - + filename = 'adipls.stdout' open(unit=iounit_dev_null, file=trim(filename), iostat=ierr) if (ierr /= 0) then write(*,*) 'adipls failed to open ' // trim(filename) call mesa_error(__FILE__,__LINE__,'run_adipls') - end if + end if istdou = iounit_dev_null istdpr = iounit_dev_null - + if (store_model) then if (dbg) write(*,*) 'call store_model_for_adipls' call store_model_for_adipls(s, add_atmosphere, do_redistribute_mesh, ierr) if (dbg) write(*,*) 'done store_model_for_adipls' if (ierr /= 0) return end if - - ! ivarmd and iaa_arg are defined in file with store_amdl + + ! ivarmd and iaa_arg are defined in file with store_amdl if (dbg) write(*,*) 'call adipls' - + if (trace_time_in_oscillation_code) then call system_clock(time0, clock_rate) end if @@ -409,7 +409,7 @@ subroutine run_adipls( & call adipls(i_paramset, ierr_param, i_inout, & x, aa, data, nn, ivarmd, iaa_arg) if (dbg) write(*,*) 'done adipls' - + if (trace_time_in_oscillation_code) then call system_clock(time1, clock_rate) time = dble(time1-time0)/clock_rate @@ -422,11 +422,11 @@ subroutine run_adipls( & write(*,*) 'call to adipls failed' call mesa_error(__FILE__,__LINE__,'run_adipls') end if - - + + contains - - + + subroutine setup_adipls iounit = alloc_iounit(ierr) if (ierr /= 0) then @@ -436,21 +436,21 @@ subroutine setup_adipls filename = 'adipls.c.pruned.in' open(unit=iounit, file=trim(filename), action='read', status='old', iostat=ierr) if (ierr /= 0) then - write(*,*) - write(*,*) - write(*,*) - write(*,*) + write(*,*) + write(*,*) + write(*,*) + write(*,*) write(*,*) 'ERROR: failed to open ' // trim(filename) write(*,*) 'please convert adipls.c.in to "pruned" form' write(*,*) 'e.g., you can run the get-input script from mesa/adipls/adipack.c/bin:' write(*,*) './../../adipls/adipack.c/bin/get-input adipls.c.in > adipls.c.pruned.in' - write(*,*) - write(*,*) - write(*,*) - write(*,*) + write(*,*) + write(*,*) + write(*,*) + write(*,*) call mesa_error(__FILE__,__LINE__,'run_adipls') - end if - + end if + write(*,'(A)') write(*,'(a)') 'call adipls to read ' // trim(filename) call setups_adi @@ -459,28 +459,28 @@ subroutine setup_adipls call adipls(i_paramset, ierr_param, i_inout, & x_arg0, aa_arg0, data_arg, nn_arg_0, ivarmd, iaa_arg) close(iounit) - + call free_iounit(iounit) - + if (ierr_param < 0) then ierr = ierr_param write(*,*) '1st call to adipls failed in setup_adipls' call mesa_error(__FILE__,__LINE__,'run_adipls') end if - + write(*,*) 'back from 1st call on adipls' write(*,'(A)') end subroutine setup_adipls - + subroutine setup_redist common/comgrp/ isprtp integer :: isprtp if (.not. do_redistribute_mesh) return - + iounit = alloc_iounit(ierr) if (ierr /= 0) then write(*,*) 'setup_redist failed in alloc_iounit' @@ -490,54 +490,54 @@ subroutine setup_redist open(unit=iounit, file=trim(filename), action='read', status='old', iostat=ierr) if (ierr /= 0) then write(*,*) 'setup_redist failed to open ' // trim(filename) - write(*,*) - write(*,*) - write(*,*) - write(*,*) + write(*,*) + write(*,*) + write(*,*) + write(*,*) write(*,*) 'ERROR: failed to open ' // trim(filename) write(*,*) 'please convert redistrb.c.in to "pruned" form' write(*,*) 'e.g., you can run the get-input script from mesa/adipls/adipack.c/bin:' write(*,*) './../../adipls/adipack.c/bin/get-input redistrb.c.in > redistrb.c.pruned.in' - write(*,*) - write(*,*) - write(*,*) - write(*,*) + write(*,*) + write(*,*) + write(*,*) + write(*,*) call mesa_error(__FILE__,__LINE__,'run_adipls') call mesa_error(__FILE__,__LINE__,'run_rdist') - end if - + end if + read(iounit,*,iostat=ierr) nn_redist if (ierr /= 0) then write(*,*) 'setup_redist failed to read nn_redist from ' // trim(filename) call mesa_error(__FILE__,__LINE__,'run_rdist') - end if + end if write(*,*) 'nn_redist', nn_redist - + rewind(iounit) - + write(*,'(A)') write(*,'(a)') 'call srdist to read ' // trim(filename) - + istdin = iounit i_inout = 0 i_paramset = 1 ierr_param = 0 isprtp = 0 - + call srdist(i_paramset, ierr_param, i_inout, & x_arg0, aa_arg0, data_arg, x_arg0, aa_arg0, & nn_arg_0, nn_arg_0, ivarmd, iaa_arg, iaa_arg) - + close(iounit) - + call free_iounit(iounit) - + if (ierr_param < 0) then ierr = ierr_param write(*,*) '1st call to srdist failed' call mesa_error(__FILE__,__LINE__,'run_rdist') end if - + write(*,*) 'back from 1st call on srdist' write(*,'(A)') @@ -545,8 +545,8 @@ end subroutine setup_redist end subroutine run_adipls - - + + subroutine set_adipls_controls( & el, nsel, els1, dels, itrsig, iscan, sig1, sig2, dfsig, nsig, & irotkr, nprtkr, igm1kr, npgmkr) @@ -563,14 +563,14 @@ subroutine set_adipls_controls( & para_el, para_els1, para_dels, para_dfsig1, para_dfsig2, & para_sig1, para_sig2, para_dfsig, para_eltrw1, para_eltrw2, & para_sgtrw1, para_sgtrw2 - + common/cadi_param/ & ipara_nsel, ipara_nsig1, ipara_nsig2, ipara_itrsig, ipara_nsig, & ipara_istsig, ipara_inomd1, ipara_iscan integer :: & ipara_nsel, ipara_nsig1, ipara_nsig2, ipara_itrsig, ipara_nsig, & ipara_istsig, ipara_inomd1, ipara_iscan - + common/coutpt/ & ipara_nout, ipara_nprcen, ipara_iper, ipara_irotkr, ipara_nprtkr, & ipara_igm1kr, ipara_npgmkr, ipara_nfmode, ipara_nfmesh, ipara_ispcpr, & @@ -579,7 +579,7 @@ subroutine set_adipls_controls( & ipara_nout, ipara_nprcen, ipara_iper, ipara_irotkr, ipara_nprtkr, & ipara_igm1kr, ipara_npgmkr, ipara_nfmode, ipara_nfmesh, ipara_ispcpr, & ipara_npout, ipara_nobs_stmx, ipara_nfmscn - + para_el = dble(el) ipara_nsel = nsel para_els1 = els1 @@ -594,10 +594,10 @@ subroutine set_adipls_controls( & ipara_nprtkr = nprtkr ipara_igm1kr = igm1kr ipara_npgmkr = npgmkr - + end subroutine set_adipls_controls - - + + ! this is called by modmod subroutine check_arg_data(nn, data, ldaa, aa, x, ierr) integer, intent(in) :: nn, ldaa @@ -605,25 +605,25 @@ subroutine check_arg_data(nn, data, ldaa, aa, x, ierr) real(dp) :: aa(ldaa,nn) real(dp) :: x(nn) integer, intent(out) :: ierr - + real(dp), parameter :: rtol = 1d-9, atol = 1d-9 - + integer :: i, j - + ierr = 0 - + if (ldaa /= iaa_arg) then write(*,*) 'ldaa /= iaa_arg', ldaa, iaa_arg ierr = -1 call mesa_error(__FILE__,__LINE__) end if - + if (nn /= nn_arg) then write(*,*) 'nn /= nn_arg', nn, nn_arg ierr = -1 call mesa_error(__FILE__,__LINE__) end if - + do i=1,8 if (is_bad(data(i),data_arg(i))) then write(*,'(a40,i6,99e26.16)') 'data(i) /= data_arg(i)', i, data(i), data_arg(i) @@ -631,7 +631,7 @@ subroutine check_arg_data(nn, data, ldaa, aa, x, ierr) call mesa_error(__FILE__,__LINE__) end if end do - + do j=1,nn if (is_bad(x(j),x_arg(j))) then write(*,'(a40,i6,99e26.16)') 'x(j) /= x_arg(j)', j, x(j), x_arg(j) @@ -646,23 +646,23 @@ subroutine check_arg_data(nn, data, ldaa, aa, x, ierr) end if end do end do - + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'check_arg_data') - - + + contains - + logical function is_bad(v1,v2) real(dp), intent(in) :: v1, v2 real(dp) :: err err = abs(v1-v2)/(atol + rtol*max(abs(v1),abs(v2))) is_bad = (err > 1d0) end function is_bad - - + + end subroutine check_arg_data - - + + subroutine read_and_store(iriche, iturpr, cgrav) integer, intent(inout) :: iriche, iturpr real(dp), intent(in) :: cgrav @@ -673,7 +673,7 @@ subroutine read_and_store(iriche, iturpr, cgrav) real(dp), pointer :: aa(:,:) ! (iaa_arg,nn) will be allocated real(dp), pointer :: x(:) ! (nn) will be allocated real(dp) :: data(8) - + ierr = 0 fname = 'test.fgong' call read_fgong_file(fname, nn_in, iconst, ivar, ivers, glob, var, ierr) @@ -692,10 +692,10 @@ subroutine read_and_store(iriche, iturpr, cgrav) write(*,*) 'read_and_store failed in store_amdl' call mesa_error(__FILE__,__LINE__) end if - + end subroutine read_and_store - - + + subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) ! derived from adipls readml.n.d.f integer, intent(in) :: nn_in, iriche @@ -705,13 +705,13 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) real(dp), pointer :: x(:) ! (nn) will be allocated ! nn can be less than nn_in integer, intent(out) :: nn, ierr - + ! local integer :: i, j, nsin, iggt, nshift, nnr, n, n1, idata8 logical :: sincen, sinsur real(dp), pointer :: aa1(:,:) real(dp) :: ggt - + ierr = 0 nn = nn_in @@ -721,7 +721,7 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) aa1(j,i) = aa(j,i) end do end do - + ! test for singular centre and/or surface sincen=aa1(1,1) == 0 @@ -741,7 +741,7 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) end if ! we always take every point in model - + ! test for number of nonsingular points if (iriche /= 1.or.mod(nn-nsin,2) == 1) then @@ -753,9 +753,9 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) if (nshift /= 0) then nn=nn-nshift end if - + allocate(x(nn)) - + if (sincen) then x(1)=aa1(1,1) do i=1,ivarmd @@ -781,7 +781,7 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) end do end do end if - + deallocate(aa1) ! set g/gtilde (=1 in models without turbulent pressure) @@ -804,15 +804,15 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) aa(10,n)=1 end do end if - + x_arg => x aa_arg => aa nn_arg = nn data_arg(:) = data(:) end subroutine store_amdl - - + + subroutine fgong_amdl(cgrav, nn_in, iconst, ivar, ivers, glob, var, data, aa, nn, ierr) ! derived from fgong-amdl.d.f real(dp), intent(in) :: cgrav @@ -822,16 +822,16 @@ subroutine fgong_amdl(cgrav, nn_in, iconst, ivar, ivers, glob, var, data, aa, nn real(dp), intent(inout) :: data(8) real(dp), pointer :: aa(:,:) ! (iaa_arg,nn) will be allocated integer, intent(out) :: nn, ierr - + integer, parameter :: ireset(16) = & (/3,4,5,6,8,9,10,11,12,13,14,16,17,18,19,20/) integer :: nn1, i, n, ir real(dp) :: d2amax, var1(ivar,nn_in+100), q(nn_in+100), x(nn_in+100) - + ierr = 0 nn = nn_in - if (var(1,1) > var(1,nn)) then + if (var(1,1) > var(1,nn)) then nn1=nn+1 do i=1,ivar do n=1,nn @@ -842,41 +842,41 @@ subroutine fgong_amdl(cgrav, nn_in, iconst, ivar, ivers, glob, var, data, aa, nn end do end do end if - - if (var(1,1) > 1.d6) then + + if (var(1,1) > 1.d6) then do i=1,ivar do n=1,nn var1(i,n+1)=var(i,n) end do end do - + do i=1,ivar var1(i,1)=0 end do - + do ir=1,16 i=ireset(ir) var1(i,1)=var1(i,2) end do - - nn=nn+1 + + nn=nn+1 do i=1,ivar do n=1,nn var(i,n)=var1(i,n) end do end do end if - + do n=1,nn q(n)=exp(var(2,n)) x(n)=var(1,n)/glob(2) end do - + x(1)=0 q(1)=0 - + allocate(aa(iaa_arg,nn)) - + do n=2,nn aa(1,n)=x(n) aa(2,n)=q(n)/pow3(x(n)) @@ -885,25 +885,25 @@ subroutine fgong_amdl(cgrav, nn_in, iconst, ivar, ivers, glob, var, data, aa, nn aa(5,n)=var(15,n) aa(6,n)=pi4*var(5,n)*pow3(var(1,n))/(glob(1)*q(n)) end do - + aa(1,1)=0 aa(2,1)=four_thirds_pi*var(5,1)*pow3(glob(2))/glob(1) aa(3,1)=0 aa(4,1)=var(10,1) aa(5,1)=0 aa(6,1)=3.d0 - if (aa(5,nn) <= 10) then - nn=nn-1 - !write(6,*) 'Chop off outermost point' + if (aa(5,nn) <= 10) then + nn=nn-1 + !write(6,*) 'Chop off outermost point' end if data(1)=glob(1) data(2)=glob(2) data(3)=var(4,1) data(4)=var(5,1) - if (glob(11) < 0.and.glob(11) > -10000) then + if (glob(11) < 0.and.glob(11) > -10000) then data(5)=-glob(11)/var(10,1) - data(6)=-glob(12) - else + data(6)=-glob(12) + else data(5)=four_thirds_pi*cgrav*(var(5,1)*glob(2))**2/(var(4,1)*var(10,1)) d2amax=0.d0 do n=2,nn @@ -915,9 +915,9 @@ subroutine fgong_amdl(cgrav, nn_in, iconst, ivar, ivers, glob, var, data, aa, nn end if data(7)=-1.d0 data(8)=0.d0 - + end subroutine fgong_amdl - + subroutine read_fgong_file(fin, nn, iconst, ivar, ivers, glob, var, ierr) character (len=*), intent(in) :: fin @@ -925,10 +925,10 @@ subroutine read_fgong_file(fin, nn, iconst, ivar, ivers, glob, var, ierr) real(dp), pointer :: glob(:) ! (iconst) will be allocated real(dp), pointer :: var(:,:) ! (ivar,nn) will be allocated integer, intent(out) :: ierr - + integer :: ios, iounit, i, n character(80) :: head - + 120 format(4i10) 130 format(5e16.9) @@ -938,7 +938,7 @@ subroutine read_fgong_file(fin, nn, iconst, ivar, ivers, glob, var, ierr) write(*,*) 'failed in read_fgong_file' return end if - + ios = 0 open(iounit,file=trim(fin),status='old', iostat=ios) if (ios /= 0) then @@ -959,29 +959,29 @@ subroutine read_fgong_file(fin, nn, iconst, ivar, ivers, glob, var, ierr) write(*,*) 'failed to read dimensions' return end if - + allocate(glob(iconst), var(ivar,nn+10)) - + read(iounit,130, iostat=ios) (glob(i),i=1,iconst) if (ios /= 0) then write(*,*) 'failed to read globals' return - end if + end if do n=1,nn read(iounit,130, iostat=ios) (var(i,n),i=1,ivar) if (ios /= 0) exit end do close(iounit) - + if (ios /= 0) then write(*,*) 'failed to read vars' return end if end subroutine read_fgong_file - - + + ! for testing subroutine dump(filename_for_dump,nn,glob,var,ierr) character (len=*), intent(in) :: filename_for_dump @@ -989,10 +989,10 @@ subroutine dump(filename_for_dump,nn,glob,var,ierr) real(dp), pointer :: glob(:) ! (iconst) real(dp), pointer :: var(:,:) ! (ivar,nn) integer, intent(out) :: ierr - + real(dp), parameter :: Msun = 1.9892d33, Rsun = 6.9598d10, Lsun = 3.8418d33 integer :: iounit, k, offset - + ierr = 0 if (len_trim(filename_for_dump) == 0) return @@ -1001,7 +1001,7 @@ subroutine dump(filename_for_dump,nn,glob,var,ierr) write(*,*) 'failed in alloc_iounit for dump fgong' return end if - + open(iounit, file=trim(filename_for_dump), iostat=ierr) if (ierr /= 0) then write(*,*) 'dump fgong failed to open ' // trim(filename_for_dump) @@ -1009,28 +1009,28 @@ subroutine dump(filename_for_dump,nn,glob,var,ierr) end if write(*,*) 'dump fgong data to ' // trim(filename_for_dump) - + if (VAR(1,1) <= 1) then ! skip tny r offset = 1 else offset = 0 end if - + write(iounit,'(99a24)') & 'num_zones', 'star_mass', 'star_radius', 'star_L', 'initial_z', & 'mlt_alpha', 'star_age', 'star_Teff' write(iounit,fmt='(i24,99e24.12)') & nn-offset, GLOB(1)/Msun, GLOB(2)/Rsun, GLOB(3)/Lsun, GLOB(4), & - GLOB(6), GLOB(13), GLOB(14) - + GLOB(6), GLOB(13), GLOB(14) + write(iounit,'(a5,99a24)') & 'i', 'r', 'm', 'temperature', 'pressure', 'density', & 'xh1', 'luminosity', 'opacity', 'eps', 'gamma1', & 'grada', 'chiT_div_chiRho', 'cp', 'free_e', 'brunt_A', & 'dxdt_nuc_h1', 'z', 'dr_to_surf', 'eps_grav', 'xhe3', & 'xc12', 'xc13', 'xn14', 'xo16', 'xh2', 'xhe4', 'xli7', & - 'xbe7', 'xn15', 'xo17', 'xo18', 'xne20' - + 'xbe7', 'xn15', 'xo17', 'xo18', 'xne20' + do k=1+offset,nn write(iounit,fmt='(i5,99e24.12)') k-offset, & VAR(1,k), & @@ -1064,10 +1064,10 @@ subroutine dump(filename_for_dump,nn,glob,var,ierr) VAR(33,k), & VAR(34,k), & VAR(35,k), & - VAR(36,k) + VAR(36,k) end do close(iounit) - + end subroutine dump diff --git a/astero/private/adipls_support_procs.f90 b/astero/private/adipls_support_procs.f90 index 2ef742898..8d00f6a76 100644 --- a/astero/private/adipls_support_procs.f90 +++ b/astero/private/adipls_support_procs.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,13 +19,13 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - - - - ! routines that are called by adipls - ! uses adipls_support, so must compile after that - + + + + ! routines that are called by adipls + ! uses adipls_support, so must compile after that + subroutine spcout_adi(x,y,aa,data,nn,iy,iaa,ispcpr) ! must set ispcpr > 0 to get this called use astero_def, only: store_new_oscillation_results, & @@ -35,49 +35,49 @@ subroutine spcout_adi(x,y,aa,data,nn,iy,iaa,ispcpr) use utils_lib, only: mesa_error implicit none - + integer :: nn, iy, iaa, ispcpr real(dp) :: x(1:nn), y(1:iy,1:nn), aa(1:iaa,1:nn), data(8) - ! common for storage of model parameters + ! common for storage of model parameters ! degree, order, cyclic frequency (microHz), inertia common/cobs_param/ icobs_st, nobs_st, obs_st real(dp) :: csummm(50) common/csumma/ csummm - + integer :: icobs_st, nobs_st real(dp) :: obs_st(10,100000) ! huge 2nd dimension to satisfy bounds checking integer :: ierr, new_el, new_order, new_em, n real(dp) :: new_inertia, new_cyclic_freq - + include 'formats' - + new_el = int(obs_st(1,nobs_st) + 0.5_dp) new_order = int(obs_st(2,nobs_st) + 0.5_dp) new_em = csummm(38) new_inertia = obs_st(4,nobs_st)*pi4 new_cyclic_freq = obs_st(3,nobs_st) - + call store_new_oscillation_results( & new_el, new_order, new_em, new_inertia, new_cyclic_freq, 0._dp, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + n = num_results call adipls_mode_info( & el(n), order(n), em(n), cyclic_freq(n), inertia(n), & x, y, aa, data, nn, iy, iaa, ispcpr) - end subroutine spcout_adi - - + end subroutine spcout_adi + + subroutine modmod(x,aa,data,nn,ivarmd,iaa,imdmod) use const_def, only: dp integer :: nn, ivarmd, iaa, imdmod real(dp) :: x(nn), aa(iaa,nn), data(8) end subroutine modmod - - + + subroutine resdif return end subroutine resdif diff --git a/astero/private/adipls_support_procs_stub.f90 b/astero/private/adipls_support_procs_stub.f90 index 8d38a3441..153ce68ce 100644 --- a/astero/private/adipls_support_procs_stub.f90 +++ b/astero/private/adipls_support_procs_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,13 +19,13 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - - - - ! routines that are called by adipls - ! uses adipls_support, so must compile after that - + + + + ! routines that are called by adipls + ! uses adipls_support, so must compile after that + subroutine spcout_adi(x,y,aa,data,nn,iy,iaa,ispcpr) ! must set ispcpr > 0 to get this called use astero_def, only: store_new_oscillation_results, & @@ -35,22 +35,22 @@ subroutine spcout_adi(x,y,aa,data,nn,iy,iaa,ispcpr) use utils_lib, only: mesa_error implicit none - + integer :: nn, iy, iaa, ispcpr real(dp) :: x(1:nn), y(1:iy,1:nn), aa(1:iaa,1:nn), data(8) - - end subroutine spcout_adi - - + + end subroutine spcout_adi + + subroutine modmod(x,aa,data,nn,ivarmd,iaa,imdmod) use const_def, only: dp integer :: nn, ivarmd, iaa, imdmod real(dp) :: x(nn), aa(iaa,nn), data(8) end subroutine modmod - - + + subroutine resdif return end subroutine resdif diff --git a/astero/private/adipls_support_stub.f90 b/astero/private/adipls_support_stub.f90 index 9e98a920e..cecc836e2 100644 --- a/astero/private/adipls_support_stub.f90 +++ b/astero/private/adipls_support_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,19 +19,19 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module adipls_support - + use astero_def use star_lib use star_def use const_def use utils_lib - + implicit none - - + + ! args for adipls integer :: i_paramset, ierr_param, i_inout, nn real(dp), pointer :: x(:) ! (nn) @@ -43,14 +43,14 @@ module adipls_support integer :: iounit_dev_null = -1 integer :: nn_redist ! set from redistrb.c input file - - + + real(dp), pointer :: x_arg(:), aa_arg(:,:) integer :: nn_arg real(dp) :: data_arg(8) - + logical, parameter :: ADIPLS_IS_ENABLED = .false. - + contains @@ -75,22 +75,22 @@ subroutine do_adipls_get_one_el_info( & real(dp), pointer, dimension(:) :: l_freq, l_inertia integer, pointer, dimension(:) :: l_order, l_em integer, intent(out) :: ierr - + real(dp) :: sig_fac integer :: nsel, itrsig, nsig, irotkr, nprtkr, igm1kr, npgmkr real(dp) :: els1, dels, sig1, sig2, dfsig integer :: k, i, j - integer, pointer :: index(:) - + integer, pointer :: index(:) + logical, parameter :: dbg = .false. include 'formats' - + ierr = -1 - + end subroutine do_adipls_get_one_el_info - + subroutine adipls_mode_info( & l, order, em, freq, inertia, x, y, aa, data, nn, iy, iaa, ispcpr) integer, intent(in) :: l, order, em @@ -99,10 +99,10 @@ subroutine adipls_mode_info( & real(dp), intent(in) :: x(1:nn), y(1:iy,1:nn), aa(1:iaa,1:nn), data(8) integer :: iounit, ierr, i, j, skip real(dp) :: y_r, y_h - + end subroutine adipls_mode_info - - + + subroutine store_model_for_adipls (s, add_atmosphere, do_redistribute_mesh, ierr) type (star_info), pointer :: s @@ -118,12 +118,12 @@ subroutine store_model_for_adipls (s, add_atmosphere, do_redistribute_mesh, ierr real(dp), allocatable :: global_data(:) ! (iconst) real(dp), allocatable :: point_data(:,:) ! (ivar,nn) character (len=2000) :: format_string, num_string, filename - + ierr = -1 - + end subroutine store_model_for_adipls - - + + subroutine run_adipls( & s, first_time, store_model, & add_center_point, keep_surface_point, add_atmosphere, & @@ -134,24 +134,24 @@ subroutine run_adipls( & add_center_point, keep_surface_point, add_atmosphere, & do_redistribute_mesh integer, intent(out) :: ierr - + integer :: iounit, nn_arg_0 integer(8) :: time0, time1, clock_rate real(dp) :: time, x_arg0(0), aa_arg0(0,0) character (len=256) :: filename common/cstdio/ istdin, istdou, istdpr, istder integer :: istdin, istdou, istdpr, istder - + logical, parameter :: dbg = .false. - + include 'formats' - + ierr = -1 - + end subroutine run_adipls - - + + subroutine set_adipls_controls( & el, nsel, els1, dels, itrsig, iscan, sig1, sig2, dfsig, nsig, & irotkr, nprtkr, igm1kr, npgmkr) @@ -159,10 +159,10 @@ subroutine set_adipls_controls( & irotkr, nprtkr, igm1kr, npgmkr real(dp), intent(in) :: els1, dels, sig1, sig2, dfsig - + end subroutine set_adipls_controls - - + + ! this is called by modmod subroutine check_arg_data(nn, data, ldaa, aa, x, ierr) integer, intent(in) :: nn, ldaa @@ -170,16 +170,16 @@ subroutine check_arg_data(nn, data, ldaa, aa, x, ierr) real(dp) :: aa(ldaa,nn) real(dp) :: x(nn) integer, intent(out) :: ierr - + real(dp), parameter :: rtol = 1d-9, atol = 1d-9 - + integer :: i, j - + ierr = -1 - + end subroutine check_arg_data - - + + subroutine read_and_store(iriche, iturpr, cgrav) integer, intent(inout) :: iriche, iturpr real(dp), intent(in) :: cgrav @@ -190,11 +190,11 @@ subroutine read_and_store(iriche, iturpr, cgrav) real(dp), pointer :: aa(:,:) ! (iaa_arg,nn) will be allocated real(dp), pointer :: x(:) ! (nn) will be allocated real(dp) :: data(8) - - + + end subroutine read_and_store - - + + subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) ! derived from adipls readml.n.d.f integer, intent(in) :: nn_in, iriche @@ -204,18 +204,18 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) real(dp), pointer :: x(:) ! (nn) will be allocated ! nn can be less than nn_in integer, intent(out) :: nn, ierr - + ! local integer :: i, j, nsin, iggt, inp, in, nshift, nnr, n, n1, nstart, idata8 logical :: sincen, sinsur real(dp), pointer :: aa1(:,:) real(dp) :: ggt - + ierr = -1 end subroutine store_amdl - - + + subroutine fgong_amdl( & cgrav, nn_in, iconst, ivar, ivers, glob, var, data, aa, nn, ierr) ! derived from fgong-amdl.d.f @@ -226,16 +226,16 @@ subroutine fgong_amdl( & real(dp), intent(inout) :: data(8) real(dp), pointer :: aa(:,:) ! (iaa_arg,nn) will be allocated integer, intent(out) :: nn, ierr - + integer, parameter :: ireset(16) = & (/3,4,5,6,8,9,10,11,12,13,14,16,17,18,19,20/) integer :: nn1, i, n, ir real(dp) :: d2amax, var1(ivar,nn_in+100), q(nn_in+100), x(nn_in+100) - + ierr =-1 - + end subroutine fgong_amdl - + subroutine read_fgong_file(fin, nn, iconst, ivar, ivers, glob, var, ierr) character (len=*), intent(in) :: fin @@ -243,7 +243,7 @@ subroutine read_fgong_file(fin, nn, iconst, ivar, ivers, glob, var, ierr) real(dp), pointer :: glob(:) ! (iconst) will be allocated real(dp), pointer :: var(:,:) ! (ivar,nn) will be allocated integer, intent(out) :: ierr - + real(dp), pointer :: var1(:,:) ! (ivar,nn) integer :: ios, iounit, i, n, ir, nn1 character(80) :: head @@ -251,8 +251,8 @@ subroutine read_fgong_file(fin, nn, iconst, ivar, ivers, glob, var, ierr) ierr = -1 end subroutine read_fgong_file - - + + ! for testing subroutine dump(filename_for_dump,nn,glob,var,ierr) character (len=*), intent(in) :: filename_for_dump @@ -260,7 +260,7 @@ subroutine dump(filename_for_dump,nn,glob,var,ierr) real(dp), pointer :: glob(:) ! (iconst) real(dp), pointer :: var(:,:) ! (ivar,nn) integer, intent(out) :: ierr - + ierr = -1 end subroutine dump diff --git a/astero/private/astero_run_support.f90 b/astero/private/astero_run_support.f90 index 85aa7c053..417f23aa1 100644 --- a/astero/private/astero_run_support.f90 +++ b/astero/private/astero_run_support.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,23 +19,23 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module astero_run_support use star_lib use star_def use const_def use astero_support - + implicit none - - + + logical, parameter :: scale_simplex_params = .false. contains - - + + subroutine do_run_star_astero( & extras_controls, inlist_astero_search_controls_fname) use run_star_support @@ -46,14 +46,14 @@ subroutine do_run_star_astero( & subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - end subroutine extras_controls + end subroutine extras_controls end interface character (len=256) :: inlist_astero_search_controls_fname optional inlist_astero_search_controls_fname type (star_info), pointer :: s integer :: id, i, ierr - + include 'formats' ierr = 0 @@ -63,16 +63,16 @@ end subroutine extras_controls id = id_from_read_star_job id_from_read_star_job = 0 - star_id = id + star_id = id call star_setup(id, 'inlist', ierr) if (ierr /= 0) then write(*,*) 'failed in star_setup' call mesa_error(__FILE__,__LINE__) end if - + okay_to_restart = .true. - + star_astero_procs% extras_controls => extras_controls if (present(inlist_astero_search_controls_fname)) then @@ -91,7 +91,7 @@ end subroutine extras_controls do i = 1, max_constraints if (constraint_name(i) /= '') num_constraints = num_constraints + 1 end do - + num_parameters = 0 do i = 1, max_parameters if (param_name(i) /= '') num_parameters = num_parameters + 1 @@ -101,22 +101,22 @@ end subroutine extras_controls call star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% job% pgstar_flag) then call read_astero_pgstar_controls(inlist_astero_fname, ierr) if (failed('read_astero_pgstar_controls',ierr)) return end if - + if (oscillation_code == 'gyre') then - - if (gyre_is_enabled) then + + if (gyre_is_enabled) then call init_gyre(gyre_input_file, ierr) if (ierr /= 0) return ! else give caller a chance to respond before quitting. end if - - else if (oscillation_code == 'adipls') then + + else if (oscillation_code == 'adipls') then if(adipls_is_enabled) then call run_adipls(s, .true., .false., & @@ -125,11 +125,11 @@ end subroutine extras_controls if (ierr /= 0) return end if else - + write(*,'(a)') 'invalid oscillation_code: ' // trim(oscillation_code) ierr = -1 return - + end if if (save_controls) then @@ -139,13 +139,13 @@ end subroutine extras_controls call mesa_error(__FILE__,__LINE__) end if end if - + call check_search_controls(ierr) if (ierr /= 0) then write(*,*) 'failed in check_search_controls' call mesa_error(__FILE__,__LINE__) end if - + nu_max_sun = s% nu_max_sun delta_nu_sun = s% delta_nu_sun call init_obs_data(ierr) @@ -153,7 +153,7 @@ end subroutine extras_controls write(*,*) 'failed in init_obs_data' call mesa_error(__FILE__,__LINE__) end if - + next_param_to_try(1:max_parameters) = -1 sample_number = 0 max_num_samples = 0 @@ -165,11 +165,11 @@ end subroutine extras_controls nvar = 0 total_time_in_oscillation_code = 0d0 constraint_value = 0d0 - + call init_sample_ptrs - + write(*,*) 'search_type == ' // trim(search_type) - + if (search_type == 'use_first_values' .or. & s% job% astero_just_call_my_extras_check_model) then vary_param(1:max_parameters) = .false. @@ -184,7 +184,7 @@ end subroutine extras_controls call do_scan_grid(s, ierr) else if (search_type == 'from_file') then call do_get_parameters_from_file(s, ierr) - else + else write(*,*) 'bad value for search_type ' // trim(search_type) ierr = -1 end if @@ -192,83 +192,83 @@ end subroutine extras_controls end subroutine do_run_star_astero - - real(dp) function eval1(id_in,ierr) + + real(dp) function eval1(id_in,ierr) use run_star_support, only: run1_star use extras_support - + integer, intent(in) :: id_in integer, intent(out) :: ierr - + logical, parameter :: & do_alloc_star = .false., & do_free_star = .false. - + type (star_info), pointer :: s logical :: restart - integer :: id + integer :: id include 'formats' - + ierr = 0 id = id_in - + call star_ptr(id, s, ierr) if (ierr /= 0) return eval1 = -1 - + ! init for start of run - best_chi2 = -1 - num_chi2_too_big = 0 + best_chi2 = -1 + num_chi2_too_big = 0 astero_max_dt_next = 1d99 - + call run1_star( & do_alloc_star, do_free_star, okay_to_restart, & id, restart, & astero_extras_controls, & ierr) if (ierr /= 0) return - + s% max_years_for_timestep = initial_max_years_for_timestep s% astero_using_revised_max_yr_dt = .false. - s% astero_revised_max_yr_dt = s% max_years_for_timestep - + s% astero_revised_max_yr_dt = s% max_years_for_timestep + okay_to_restart = .false. ! only allow restart on 1st call to run1_star - + eval1 = best_chi2 - + if (s% job% astero_just_call_my_extras_check_model) return - + if (best_chi2 < 0) then write(*,*) 'failed to find chi^2 for this run' call zero_best_info best_chi2 = 999999d0 return end if - + sample_number = sample_number + 1 - write(*,*) + write(*,*) call show_best(6) - + if (write_best_model_data_for_each_sample) & call write_best(sample_number) - + end function eval1 - - + + subroutine do_get_parameters_from_file(s, ierr) use utils_lib type (star_info), pointer :: s integer, intent(out) :: ierr - + integer, parameter :: max_col_num = 500 real(dp) :: filedata(max_col_num) integer :: iounit, num_to_read, i - + include 'formats' - - + + write(*,*) 'do_get_parameters_from_file' sample_number = 0 @@ -289,7 +289,7 @@ subroutine do_get_parameters_from_file(s, ierr) iounit = alloc_iounit(ierr) if (ierr /= 0) return - + open(iounit, file=trim(filename_for_parameters), & action='read', status='old', iostat=ierr) if (ierr /= 0) then @@ -298,95 +298,95 @@ subroutine do_get_parameters_from_file(s, ierr) call free_iounit(iounit) return end if - + write(*,*) 'reading ' // trim(filename_for_parameters) write(*,2) 'max_num_from_file', max_num_from_file - + read(iounit,*) ! skip 1st line - + do while (sample_number < max_num_from_file .or. max_num_from_file < 0) - + read(iounit,*,iostat=ierr) filedata(1:num_to_read) if (ierr /= 0) then write(*,2) 'read failed: sample_number', sample_number exit end if - + do i = 1, max_parameters if (param_name(i) /= '' .and. vary_param(i)) then next_param_to_try(i) = filedata(file_column_for_param(i)) write(*,2) 'next_param_to_try '//trim(param_name(i)), i, next_param_to_try(i) end if end do - + call do1_grid(ierr) if (ierr /= 0) then write(*,2) 'do1_grid failed: sample_number', sample_number exit end if - + end do - + close(iounit) call free_iounit(iounit) contains - - + + subroutine do1_grid(ierr) integer, intent(out) :: ierr real(dp) :: chi2 character(len=256) :: filename - + include 'formats' ierr = 0 - + chi2 = eval1(s% id,ierr) if (ierr /= 0) then write(*,*) 'failed in eval1' return end if - + call save_best_for_sample(sample_number, 0) if (.not. folder_exists(trim(astero_results_directory))) call mkdir(trim(astero_results_directory)) filename = trim(astero_results_directory) // '/' // trim(from_file_output_filename) - + call save_sample_results_to_file(-1, filename, ierr) if (ierr /= 0) then write(*,*) 'failed in save_sample_results_to_file' return end if - + end subroutine do1_grid - + end subroutine do_get_parameters_from_file - - + + subroutine do_scan_grid(s, ierr) use utils_lib type (star_info), pointer :: s integer, intent(out) :: ierr - + integer :: num_param(1:max_parameters) integer :: i_total, i real(dp) :: chi2, param(1:max_parameters) real(dp), parameter :: eps = 1d-6 logical :: just_counting - + include 'formats' - + ierr = 0 call set_starting_values - + num_param(1:max_parameters) = 0 - + just_counting = .true. call do_param(max_parameters, ierr) i_total = sample_number - + write(*,2) 'grid total', i_total do i = 1, max_parameters @@ -394,10 +394,10 @@ subroutine do_scan_grid(s, ierr) end do write(*,'(A)') - + sample_number = 0 just_counting = .false. - + if (restart_scan_grid_from_file) then call read_samples_from_file( & trim(astero_results_directory) // '/' // trim(scan_grid_output_filename), ierr) @@ -410,10 +410,10 @@ subroutine do_scan_grid(s, ierr) end if call do_param(max_parameters, ierr) - - + + contains - + ! if param_name(k) == '', then param isn't set ! we want that so that FPE trapping can detect @@ -462,19 +462,19 @@ recursive subroutine do_param(k, ierr) if (num_param(k) == 0) num_param(k) = cnt if (vary_param(k)) param(k) = min_param(k) end subroutine do_param - - + + subroutine do1_grid(ierr) integer, intent(out) :: ierr character(len=256) :: filename include 'formats' ierr = 0 - + if (just_counting) then sample_number = sample_number + 1 return end if - + if (sample_number < scan_grid_skip_number) then sample_number = sample_number + 1 if (mod(sample_number,20) == 1) then @@ -508,14 +508,14 @@ subroutine do1_grid(ierr) write(*,*) 'failed in eval1' return end if - + if (best_chi2 > 9d5) then sample_number = sample_number + 1 write(*,2) 'failed to get chi2 for grid point', sample_number else write(*,2) 'save best sample for grid point', sample_number end if - + call save_best_for_sample(sample_number, 0) if (.not. folder_exists(trim(astero_results_directory))) call mkdir(trim(astero_results_directory)) @@ -526,10 +526,10 @@ subroutine do1_grid(ierr) write(*,*) 'failed in save_sample_results_to_file' return end if - + end subroutine do1_grid - + end subroutine do_scan_grid @@ -537,7 +537,7 @@ subroutine bobyqa_fun(n,x,f) integer, intent(in) :: n double precision, intent(in) :: x(*) double precision, intent(out) :: f - + character(len=256) :: filename integer :: ierr @@ -554,18 +554,18 @@ subroutine bobyqa_fun(n,x,f) write(*,*) 'failed in save_sample_results_to_file' call mesa_error(__FILE__,__LINE__,'bobyqa_fun') end if - + end subroutine bobyqa_fun - + subroutine newuoa_fun(n,x,f) integer, intent(in) :: n double precision, intent(in) :: x(*) double precision, intent(out) :: f - + character(len=256) :: filename integer :: ierr - + call bobyqa_or_newuoa_fun(n,x,f) write(*,'(A)') @@ -579,7 +579,7 @@ subroutine newuoa_fun(n,x,f) write(*,*) 'failed in save_sample_results_to_file' call mesa_error(__FILE__,__LINE__,'newuoa_fun') end if - + end subroutine newuoa_fun @@ -589,7 +589,7 @@ subroutine bobyqa_or_newuoa_fun(n,x,f) double precision, intent(out) :: f integer :: ierr, prev_sample_number, i include 'formats' - + ierr = 0 do i = 1, max_parameters @@ -599,7 +599,7 @@ subroutine bobyqa_or_newuoa_fun(n,x,f) write(*,2) 'next_param_to_try '//trim(param_name(i)), i, next_param_to_try(i), x(i_param(i)) end if end do - + prev_sample_number = sample_number f = eval1(star_id, ierr) if (ierr /= 0) then @@ -614,7 +614,7 @@ subroutine bobyqa_or_newuoa_fun(n,x,f) end if return ! failed to get new chi^2 end if - + call save_best_for_sample(sample_number, 0) write(*,'(A)') @@ -624,12 +624,12 @@ subroutine bobyqa_or_newuoa_fun(n,x,f) write(*,*) 'failed in show_all_sample_results' call mesa_error(__FILE__,__LINE__,'bobyqa_fun') end if - + min_sample_chi2_so_far = minval(sample_chi2(1:sample_number)) - + end subroutine bobyqa_or_newuoa_fun - + real(dp) function bobyqa_param(x, first, min, max) real(dp), intent(in) :: x, first, min, max if (x > 0) then @@ -638,8 +638,8 @@ real(dp) function bobyqa_param(x, first, min, max) bobyqa_param = first + x*(first-min) end if end function bobyqa_param - - + + subroutine do_bobyqa_or_newuoa(newuoa_flag, ierr) use num_lib logical, intent(in) :: newuoa_flag @@ -650,7 +650,7 @@ subroutine do_bobyqa_or_newuoa(newuoa_flag, ierr) integer :: i, npt include 'formats' ierr = 0 - + write(*,'(A)') write(*,'(A)') @@ -666,16 +666,16 @@ subroutine do_bobyqa_or_newuoa(newuoa_flag, ierr) end do if (ierr /= 0) return - + npt = 2*nvar + 1 - + allocate( & xl(nvar), xu(nvar), x(nvar), w((npt+5)*(npt+nvar)+3*nvar*(nvar+5)/2)) - + XL(1:nvar) = 0 X(1:nvar) = 0 XU(1:nvar) = 1 - + ! RHOBEG and bobyqa_rhoend must be set to the initial and final values of a trust ! region radius, so both must be positive with bobyqa_rhoend no greater than ! RHOBEG. Typically, RHOBEG should be about one tenth of the greatest @@ -685,7 +685,7 @@ subroutine do_bobyqa_or_newuoa(newuoa_flag, ierr) ! is less than 2*RHOBEG. rhobeg = 0.45d0 max_value = 1d6 - + if (newuoa_flag) then call newuoa( & nvar,npt,x,rhobeg,newuoa_rhoend,iprint,& @@ -702,10 +702,10 @@ subroutine do_bobyqa_or_newuoa(newuoa_flag, ierr) x(i_param(i)), first_param(i), min_param(i), max_param(i)) end if end do - + deallocate(xl, xu, x, w) - - + + end subroutine do_bobyqa_or_newuoa @@ -720,13 +720,13 @@ real(dp) function simplex_f( & real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(in) :: op_code integer, intent(out) :: ierr - + character(len=256) :: filename integer :: prev_sample_number, i include 'formats' - + ierr = 0 - + write(*,'(A)') write(*,'(A)') @@ -738,7 +738,7 @@ real(dp) function simplex_f( & i, next_param_to_try(i), x(i_param(i)) end if end do - + prev_sample_number = sample_number simplex_f = eval1(star_id, ierr) if (ierr /= 0) then @@ -747,13 +747,13 @@ real(dp) function simplex_f( & simplex_f = 1d99 return end if - + if (sample_number == prev_sample_number) then write(*,*) 'failed to get new chi^2 -- try again' simplex_f = 1d99 return end if - + call save_best_for_sample(sample_number, op_code) if (.not. folder_exists(trim(astero_results_directory))) call mkdir(trim(astero_results_directory)) @@ -770,10 +770,10 @@ real(dp) function simplex_f( & ierr = -1 return endif - + end function simplex_f - + real(dp) function simplex_param(x, first, min, max) result(param) real(dp), intent(in) :: x, first, min, max if (.not. scale_simplex_params) then @@ -787,7 +787,7 @@ real(dp) function simplex_param(x, first, min, max) result(param) end if end function simplex_param - + real(dp) function simplex_inverse(param, first, min, max) result(x) real(dp), intent(in) :: param, first, min, max if (.not. scale_simplex_params) then @@ -808,12 +808,12 @@ real(dp) function simplex_inverse(param, first, min, max) result(x) end if end if end function simplex_inverse - - + + subroutine do_simplex(ierr) use num_lib integer, intent(out) :: ierr - + real(dp) :: final_param(1:max_parameters) real(dp), dimension(:), pointer :: x_first, x_lower, x_upper, x_final real(dp), pointer :: simplex(:,:), f(:) @@ -825,11 +825,11 @@ subroutine do_simplex(ierr) num_fcn_calls_for_ars, num_accepted_for_ars integer :: i, num_samples logical :: start_from_given_simplex_and_f - + include 'formats' - + ierr = 0 - + do i = 1, max_parameters if (param_name(i) /= '' .and. vary_param(i)) then nvar = nvar+1; i_param(i) = nvar @@ -842,13 +842,13 @@ subroutine do_simplex(ierr) end do if (ierr /= 0) return - + lrpar = 0; lipar = 0 allocate( & rpar(lrpar), ipar(lipar), simplex(nvar,nvar+1), f(nvar+1), & x_lower(nvar), x_upper(nvar), x_first(nvar), x_final(nvar)) - + if (.not. scale_simplex_params) then call set_xs else ! values are scaled to -1..1 with first at 0 @@ -856,7 +856,7 @@ subroutine do_simplex(ierr) x_upper(1:nvar) = 1 x_first(1:nvar) = 0 end if - + if (restart_simplex_from_file) then call read_samples_from_file( & trim(astero_results_directory) // '/' // trim(simplex_output_filename), ierr) @@ -868,13 +868,13 @@ subroutine do_simplex(ierr) end if num_samples = sample_number call setup_simplex_and_f(ierr) - if (ierr /= 0) return + if (ierr /= 0) return start_from_given_simplex_and_f = .true. call set_sample_averages else start_from_given_simplex_and_f = .false. end if - + call NM_simplex( & nvar, x_lower, x_upper, x_first, x_final, f_final, & simplex, f, start_from_given_simplex_and_f, simplex_f, & @@ -898,11 +898,11 @@ subroutine do_simplex(ierr) deallocate( & rpar, ipar, simplex, f, x_lower, x_upper, x_first, x_final) - - + + contains - - + + subroutine set_xs ! x_first, x_lower, x_upper do i = 1, max_parameters @@ -914,18 +914,18 @@ subroutine set_xs ! x_first, x_lower, x_upper end do end subroutine set_xs - - + + subroutine setup_simplex_and_f(ierr) use num_lib, only: qsort integer, intent(out) :: ierr - + integer :: j, i, k, max_i, jj integer, pointer :: index(:) ! sort results by increasing sample_chi2 - + include 'formats' - + ierr = 0 allocate(index(num_samples), stat=ierr) if (ierr /= 0) then @@ -949,7 +949,7 @@ subroutine setup_simplex_and_f(ierr) end do end do - + deallocate(index) write(*,2) 'num_samples', max_i @@ -977,17 +977,17 @@ subroutine setup_simplex_and_f(ierr) write(*,'(A)') write(*,'(A)') num_samples = max_i - + end subroutine setup_simplex_and_f - - + + end subroutine do_simplex - - + + subroutine save_best_for_sample(i, op_code) integer, intent(in) :: i, op_code integer :: ierr - + if (i <= 0) return if (i > max_num_samples) then call alloc_sample_ptrs(ierr) @@ -997,14 +997,14 @@ subroutine save_best_for_sample(i, op_code) return end if end if - + sample_constraint_value(1:max_constraints,i) = best_constraint_value(1:max_constraints) sample_op_code(i) = op_code sample_chi2(i) = best_chi2 sample_chi2_seismo(i) = best_chi2_seismo sample_chi2_spectro(i) = best_chi2_spectro - + sample_age(i) = best_age sample_param(1:max_parameters,i) = current_param(1:max_parameters) @@ -1019,22 +1019,22 @@ subroutine save_best_for_sample(i, op_code) sample_freq(0,:,i) = best_freq(0,:) sample_freq_corr(0,:,i) = best_freq_corr(0,:) sample_inertia(0,:,i) = best_inertia(0,:) - + sample_order(1,:,i) = best_order(1,:) sample_freq(1,:,i) = best_freq(1,:) sample_freq_corr(1,:,i) = best_freq_corr(1,:) sample_inertia(1,:,i) = best_inertia(1,:) - + sample_order(2,:,i) = best_order(2,:) sample_freq(2,:,i) = best_freq(2,:) sample_freq_corr(2,:,i) = best_freq_corr(2,:) sample_inertia(2,:,i) = best_inertia(2,:) - + sample_order(3,:,i) = best_order(3,:) sample_freq(3,:,i) = best_freq(3,:) sample_freq_corr(3,:,i) = best_freq_corr(3,:) sample_inertia(3,:,i) = best_inertia(3,:) - + sample_ratios_r01(:,i) = best_ratios_r01(:) sample_ratios_r10(:,i) = best_ratios_r10(:) sample_ratios_r02(:,i) = best_ratios_r02(:) @@ -1042,14 +1042,14 @@ subroutine save_best_for_sample(i, op_code) call set_sample_averages end subroutine save_best_for_sample - - + + subroutine set_sample_averages integer :: jj, j, n real(dp) :: avg_age_top_samples2, avg_model_number_top_samples2 - + include 'formats' - + call set_sample_index_by_chi2 n = min(sample_number, max_num_samples_for_avg) if (n < max(2,min_num_samples_for_avg)) then @@ -1087,7 +1087,7 @@ subroutine set_sample_averages sqrt(max(0d0,(avg_model_number_top_samples2 - & avg_model_number_top_samples*avg_model_number_top_samples/n)/(n-1))) avg_model_number_top_samples = avg_model_number_top_samples/n - + write(*,'(A)') write(*,2) 'n for averages', n write(*,1) 'avg_age_top_samples', avg_age_top_samples @@ -1100,10 +1100,10 @@ subroutine set_sample_averages avg_model_number_sigma_limit*avg_model_number_sigma write(*,'(A)') !call mesa_error(__FILE__,__LINE__,'set_sample_averages') - + end subroutine set_sample_averages - - + + subroutine zero_best_info best_chi2 = 0 best_chi2_seismo = 0 diff --git a/astero/private/astero_support.f90 b/astero/private/astero_support.f90 index 0d891469e..d7ba6a53d 100644 --- a/astero/private/astero_support.f90 +++ b/astero/private/astero_support.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,10 +19,10 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module astero_support - + use astero_def use star_lib use star_def @@ -30,13 +30,13 @@ module astero_support use math_lib use utils_lib use auto_diff - + implicit none - + contains - + subroutine check_search_controls(ierr) integer, intent(out) :: ierr integer :: i, l @@ -53,9 +53,9 @@ subroutine check_search_controls(ierr) end do if (ierr /= 0) & - write(*,1) 'please put frequency values in ascending order' + write(*,1) 'please put frequency values in ascending order' end subroutine check_search_controls - + subroutine get_one_el_info( & s, l, nu1, nu2, iscan, i1, i2, store_model, code, ierr) @@ -68,20 +68,20 @@ subroutine get_one_el_info( & logical, intent(in) :: store_model character (len=*), intent(in) :: code integer, intent(out) :: ierr - + real(dp) :: dist, min_dist, R, G, M, sig_fac, b, sum_1, sum_2, sum_3, empty(0) integer :: min_dist_j, cnt, int_empty(0), int_empty2(0) integer :: nsel, itrsig, nsig real(dp) :: els1, dels, sig1, sig2, dfsig integer :: i, j - integer, pointer :: index(:) + integer, pointer :: index(:) include 'formats' - + ierr = 0 - + if (code == 'gyre') then - + if (.not. gyre_is_enabled) then ierr = -1 write(*,'(A)') @@ -99,8 +99,8 @@ subroutine get_one_el_info( & write(*,*) 'failed in do_gyre_get_modes' call mesa_error(__FILE__,__LINE__,'get_one_el_info') end if - - else if (code == 'adipls') then + + else if (code == 'adipls') then if (.not. adipls_is_enabled) then ierr = -1 @@ -116,7 +116,7 @@ subroutine get_one_el_info( & M = s% m_grav(1) sig_fac = (2*pi)*(2*pi)*R*R*R/(G*M) b = correction_b - + ! set controls for adipls nsel = 0 dels = 1 @@ -126,12 +126,12 @@ subroutine get_one_el_info( & sig2 = sig_fac*(nu2*1d-6)*(nu2*1d-6) dfsig = sig_fac*delta_nu_model*delta_nu_model nsig = 2 - + call set_adipls_controls( & l, nsel, els1, dels, itrsig, iscan, sig1, sig2, dfsig, nsig, & adipls_irotkr, adipls_nprtkr, adipls_igm1kr, & adipls_npgmkr) - + num_results = 0 call run_adipls( & s, .false., store_model, & @@ -141,13 +141,13 @@ subroutine get_one_el_info( & write(*,*) 'failed in run_adipls' call mesa_error(__FILE__,__LINE__,'get_one_el_info') end if - + else - + write(*,'(a)') 'invalid oscillation_code: ' // trim(oscillation_code) ierr = -1 return - + end if ! sort results by increasing frequency @@ -183,11 +183,11 @@ subroutine get_one_el_info( & write(*,2) 'failed to match frequencies for l =', l return end if - + if (l == 0 .and. correction_factor > 0 .and. nl(0) > 0 .and. & - delta_nu > 0 .and. nu_max > 0 .and. avg_nu_obs > 0) then + delta_nu > 0 .and. nu_max > 0 .and. avg_nu_obs > 0) then ! calculate surface correction info - + cnt = 0 sum_1 = 0 do i=1,nl(0) @@ -197,7 +197,7 @@ subroutine get_one_el_info( & end do if (cnt == 0) return avg_nu_model = sum_1/cnt - + sum_1 = 0 sum_2 = 0 sum_3 = 0 @@ -216,14 +216,14 @@ subroutine get_one_el_info( & correction_a = & ! K08 eqn 10 min(0d0, avg_nu_obs - correction_r*avg_nu_model)*nl(0)/sum_3 a_div_r = correction_a/correction_r - + end if - + deallocate(index) - - + + contains - + subroutine set_to_closest( & l_obs, & @@ -277,11 +277,11 @@ subroutine set_to_closest( & end if jprev = j end if - end do + end do end subroutine set_to_closest - - - integer function find_closest(nu,jprev) ! find closest model frequency + + + integer function find_closest(nu,jprev) ! find closest model frequency real(dp), intent(in) :: nu integer, intent(in) :: jprev min_dist = 1d99; min_dist_j = -1 @@ -295,9 +295,9 @@ integer function find_closest(nu,jprev) ! find closest model frequency end do find_closest = min_dist_j end function find_closest - - - integer function find_next_down(j) result(j_down) ! same l, next lower freq + + + integer function find_next_down(j) result(j_down) ! same l, next lower freq integer, intent(in) :: j do j_down = j-1, 1, -1 if (el(j_down) /= l) cycle @@ -305,9 +305,9 @@ integer function find_next_down(j) result(j_down) ! same l, next lower freq end do j_down = 0 end function find_next_down - - - integer function find_next_up(j) result(j_up) ! same l, next higher freq + + + integer function find_next_up(j) result(j_up) ! same l, next higher freq integer, intent(in) :: j do j_up = j+1, num_results if (el(j_up) /= l) cycle @@ -315,11 +315,11 @@ integer function find_next_up(j) result(j_up) ! same l, next higher freq end do j_up = 0 end function find_next_up - + end subroutine get_one_el_info - - + + subroutine get_frequency_ratios( & init, nl0, l0, nl1, l1, n, l0_first, l1_first, r01, r10) logical, intent(in) :: init @@ -327,22 +327,22 @@ subroutine get_frequency_ratios( & real(dp), intent(in) :: l0(:), l1(:) integer, intent(out) :: n, l0_first, l1_first real(dp), intent(out) :: r01(:), r10(:) - + integer :: l0_seq_n, l0_last, l1_seq_n, l1_last, i, i0, i1 real(dp) :: d01, d10, sd01, sd10, dnu, sdnu - + logical :: dbg - + include 'formats' - + dbg = .false. call fill_with_NaNs(r01) call fill_with_NaNs(r10) - + n = 0 - + if (nl1 <= 0) return - + call get_max_sequence(nl0, l0, l0_first, l0_seq_n) l0_last = l0_first + l0_seq_n - 1 if (dbg) write(*,4) 'l0_first l0_last l0_seq_n', l0_first, l0_last, l0_seq_n @@ -350,7 +350,7 @@ subroutine get_frequency_ratios( & call get_max_sequence(nl1, l1, l1_first, l1_seq_n) l1_last = l1_first + l1_seq_n - 1 if (dbg) write(*,4) 'l1_first l1_last l1_seq_n', l1_first, l1_last, l1_seq_n - + do ! trim high end of l0 until < last l1 if (l0(l0_last) < l1(l1_last)) exit l0_last = l0_last - 1 @@ -362,7 +362,7 @@ subroutine get_frequency_ratios( & end if end do if (dbg) write(*,2) 'l0_last after trim', l0_last - + do ! trim low end of l1 until > first l0 if (l1(l1_first) > l0(l0_first)) exit l1_first = l1_first + 1 @@ -371,31 +371,31 @@ subroutine get_frequency_ratios( & end if end do if (dbg) write(*,2) 'l1_first after trim', l1_first - + do ! trim low end of l0 until only 1 < 1st l1 if (l0_first == l0_last) exit if (l0(l0_first+1) >= l1(l1_first)) exit l0_first = l0_first + 1 end do if (dbg) write(*,2) 'l0_first after trim', l0_first - + do ! trim high end of l1 until only 1 > last l0 if (l1_last == l1_first) exit if (l1(l1_last-1) <= l0(l0_last)) exit l1_last = l1_last - 1 end do if (dbg) write(*,2) 'l1_last after trim', l1_last - + l0_seq_n = l0_last - l0_first + 1 l1_seq_n = l1_last - l1_first + 1 n = l0_seq_n - 2 if (dbg) write(*,2) 'n', n - + if (l0_seq_n /= l1_seq_n .or. n < 1) then return end if - - do i = 1, n + + do i = 1, n i0 = i + l0_first i1 = i + l1_first d01 = (l0(i0-1) - 4*l1(i1-1) + 6*l0(i0) - 4*l1(i1) + l0(i0+1))/8d0 @@ -419,30 +419,30 @@ subroutine get_frequency_ratios( & i, r01(i), r10(i), sigmas_r01(i), sigmas_r10(i) end if end do - + end subroutine get_frequency_ratios - - + + subroutine get_r02_frequency_ratios(init, nl0, l0, nl1, l1, nl2, l2, r02) logical, intent(in) :: init integer, intent(in) :: nl0, nl1, nl2 real(dp), intent(in) :: l0(:), l1(:), l2(:) real(dp), intent(out) :: r02(:) - + integer :: i, i0, i1, i2, jmin, j real(dp) :: d02, sd02, dnu, sdnu, df, f0, f2, fmin, fmax, dfmin - + logical :: dbg - + include 'formats' - + dbg = .false. call fill_with_NaNs(r02) - + if (init) then ! set i2_for_r02 - do i = 1, ratios_n + do i = 1, ratios_n i0 = i + ratios_l0_first - i1 = i + ratios_l1_first + i1 = i + ratios_l1_first dnu = l1(i1) - l1(i1-1) df = 0.25*dnu f0 = l0(i0) @@ -467,13 +467,13 @@ subroutine get_r02_frequency_ratios(init, nl0, l0, nl1, l1, nl2, l2, r02) end if !write(*,2) 'ratios_n', ratios_n !stop - + do i = 1, ratios_n if ((.not. init) .and. sigmas_r02(i) == 0d0) cycle i2 = i2_for_r02(i) if (i2 == 0) cycle i0 = i + ratios_l0_first - i1 = i + ratios_l1_first + i1 = i + ratios_l1_first d02 = l0(i0) - l2(i2) dnu = l1(i1) - l1(i1-1) r02(i) = d02/dnu @@ -487,10 +487,10 @@ subroutine get_r02_frequency_ratios(init, nl0, l0, nl1, l1, nl2, l2, r02) i, r02(i), sigmas_r02(i) end if end do - + end subroutine get_r02_frequency_ratios - - + + real(dp) function interpolate_ratio_r010( & freq, first, model_freqs, model_ratios) result(ratio) real(dp), intent(in) :: freq @@ -521,7 +521,7 @@ real(dp) function interpolate_ratio_r010( & end do end function interpolate_ratio_r010 - + real(dp) function interpolate_ratio_r02( & freq, model_freqs, model_ratios) result(ratio) real(dp), intent(in) :: freq @@ -559,15 +559,15 @@ subroutine get_max_sequence(nl, l_obs, max_seq_i, max_seq_n) integer, intent(in) :: nl real(dp), intent(in) :: l_obs(:) integer, intent(out) :: max_seq_i, max_seq_n - + integer :: i, j, seq_i, seq_n - + max_seq_i = 0 max_seq_n = 0 seq_i = 0 seq_n = 0 - - do + + do i = seq_i + seq_n + 1 ! start of next sequence if (i >= nl) exit seq_i = i @@ -583,35 +583,35 @@ subroutine get_max_sequence(nl, l_obs, max_seq_i, max_seq_n) seq_n = seq_n + 1 end do end do - + if (seq_n > max_seq_n) then max_seq_i = seq_i max_seq_n = seq_n end if - + end subroutine get_max_sequence - + subroutine init_obs_data(ierr) integer, intent(out) :: ierr - + integer :: i, cnt, norders real(dp) :: sum_1, sum_2, range, nmax real(dp) :: x, y, isig2, sum_xy, sum_x, sum_y, sum_x2, sum_isig2, d - + logical, parameter :: dbg = .false. - + include 'formats' - + ierr = 0 - + !call test_get_frequency_ratios - + if (nl(0) <= 0) return - + sigmas_r02 = 0d0 ratios_r02 = 0d0 - + if (chi2_seismo_r_010_fraction > 0 .or. & chi2_seismo_r_02_fraction > 0) then call get_frequency_ratios( & @@ -625,7 +625,7 @@ subroutine init_obs_data(ierr) nl(1), freq_target(1,:), & nl(2), freq_target(2,:), ratios_r02) end if - + if (delta_nu <= 0 .and. nl(0) > 1 .and. l0_n_obs(1) > 0) then sum_xy = 0 sum_x = 0 @@ -644,12 +644,12 @@ subroutine init_obs_data(ierr) end do d = sum_isig2*sum_x2 - sum_x*sum_x delta_nu = (sum_isig2*sum_xy - sum_x*sum_y)/d - if (delta_nu_sigma <= 0) delta_nu_sigma = sqrt(sum_isig2/d) + if (delta_nu_sigma <= 0) delta_nu_sigma = sqrt(sum_isig2/d) end if - + ! if (correction_factor <= 0) return if (correction_scheme /= 'kjeldsen') return - + if (l0_n_obs(1) <= 0) then if (delta_nu <= 0) then write(*,*) 'must supply value for delta_nu' @@ -659,7 +659,7 @@ subroutine init_obs_data(ierr) ! set l0_n_obs(i) to order of freq_target(0,i) range = freq_target(0,nl(0)) - freq_target(0,1) norders = int(range/delta_nu + 0.5d0) + 1 - nmax = (nu_max/delta_nu)*(delta_nu_sun/nu_max_sun)*22.6 - 1.6 + nmax = (nu_max/delta_nu)*(delta_nu_sun/nu_max_sun)*22.6 - 1.6 l0_n_obs(1) = int(nmax - (norders-1)/2) if (dbg) write(*,3) 'l0_n_obs(i)', 1, l0_n_obs(1), freq_target(0,1) do i=2,norders @@ -676,9 +676,9 @@ subroutine init_obs_data(ierr) write(*,'(A)') !stop end if - end if - - + end if + + cnt = 0 sum_1 = 0 sum_2 = 0 @@ -690,7 +690,7 @@ subroutine init_obs_data(ierr) end do avg_nu_obs = sum_1/cnt avg_radial_n = sum_2/cnt - + if (dbg) then write(*,1) 'avg_nu_obs', avg_nu_obs write(*,1) 'avg_radial_n', avg_radial_n @@ -700,10 +700,10 @@ subroutine init_obs_data(ierr) write(*,'(A)') call mesa_error(__FILE__,__LINE__,'init_obs_data') end if - + end subroutine init_obs_data - - + + real(dp) function interpolate_l0_inertia(freq) result(inertia) real(dp), intent(in) :: freq integer :: i @@ -727,8 +727,8 @@ real(dp) function interpolate_l0_inertia(freq) result(inertia) end if end do end function interpolate_l0_inertia - - + + subroutine get_kjeldsen_radial_freq_corr( & a_div_r, b, nu_max, correction_factor, check_obs, & nl0, l0_obs, l0_freq, l0_freq_corr, l0_inertia) @@ -751,8 +751,8 @@ subroutine get_kjeldsen_radial_freq_corr( & correction_factor*(a_div_r/Qnl)*pow(l0_freq(i)/nu_max,b) end do end subroutine get_kjeldsen_radial_freq_corr - - + + subroutine get_kjeldsen_nonradial_freq_corr( & a_div_r, b, nu_max, correction_factor, check_obs, & nl1, l1_obs, l1_freq, l1_freq_corr, l1_inertia, l0_inertia) @@ -781,17 +781,17 @@ subroutine get_kjeldsen_nonradial_freq_corr( & end do end subroutine get_kjeldsen_nonradial_freq_corr - + subroutine get_kjeldsen_nonradial_freq_corr_alt_up !call mesa_error(__FILE__,__LINE__,'get_kjeldsen_nonradial_freq_corr_alt_up') end subroutine get_kjeldsen_nonradial_freq_corr_alt_up - - subroutine get_kjeldsen_nonradial_freq_corr_alt_down + + subroutine get_kjeldsen_nonradial_freq_corr_alt_down !call mesa_error(__FILE__,__LINE__,'get_kjeldsen_nonradial_freq_corr_alt_down') end subroutine get_kjeldsen_nonradial_freq_corr_alt_down - + subroutine get_kjeldsen_freq_corr integer :: l @@ -807,7 +807,7 @@ subroutine get_kjeldsen_freq_corr end subroutine get_kjeldsen_freq_corr - + subroutine get_kjeldsen_freq_corr_alt_up integer :: l @@ -820,8 +820,8 @@ subroutine get_kjeldsen_freq_corr_alt_up end subroutine get_kjeldsen_freq_corr_alt_up - - subroutine get_kjeldsen_freq_corr_alt_down + + subroutine get_kjeldsen_freq_corr_alt_down integer :: l do l = 1, 3 @@ -832,8 +832,8 @@ subroutine get_kjeldsen_freq_corr_alt_down end do end subroutine get_kjeldsen_freq_corr_alt_down - - + + subroutine get_no_freq_corr integer :: i, l @@ -843,8 +843,8 @@ subroutine get_no_freq_corr end do end do end subroutine get_no_freq_corr - - + + subroutine get_no_freq_corr_alt_up integer :: i, l @@ -854,8 +854,8 @@ subroutine get_no_freq_corr_alt_up end do end do end subroutine get_no_freq_corr_alt_up - - + + subroutine get_no_freq_corr_alt_down integer :: i, l @@ -869,7 +869,7 @@ end subroutine get_no_freq_corr_alt_down subroutine get_cubic_all_freq_corr(a3, radial_only, & nl, obs, sigma, freq, freq_corr, inertia) - + integer, intent(in) :: nl(0:) real(dp), intent(in), dimension(0:,:) :: & obs, sigma, freq, inertia @@ -878,30 +878,26 @@ subroutine get_cubic_all_freq_corr(a3, radial_only, & logical :: radial_only real(dp) :: X, y, XtX, Xty - integer :: i, l + integer :: i, l, lmax XtX = 0d0 Xty = 0d0 - do i = 1, nl(0) - X = pow3(freq(0,i))/inertia(0,i)/sigma(0,i) - y = (obs(0,i) - freq(0,i))/sigma(0,i) - - XtX = XtX + X*X - Xty = Xty + X*y - end do + if (radial_only) then + lmax = 0 + else + lmax = 3 + end if - if (.not. radial_only) then - do l = 1, 3 - do i = 1, nl(l) - X = pow3(freq(l,i))/inertia(l,i)/sigma(l,i) - y = (obs(l,i) - freq(l,i))/sigma(l,i) + do l = 0, lmax + do i = 1, nl(l) + X = pow3(freq(l,i))/inertia(l,i)/sigma(l,i) + y = (obs(l,i) - freq(l,i))/sigma(l,i) - XtX = XtX + X*X - Xty = Xty + X*y - end do + XtX = XtX + X*X + Xty = Xty + X*y end do - end if + end do a3 = Xty/XtX @@ -919,15 +915,15 @@ subroutine get_cubic_freq_corr(radial_only) call get_cubic_all_freq_corr(a3, radial_only, & nl, freq_target, freq_sigma, model_freq, model_freq_corr, model_inertia) end subroutine get_cubic_freq_corr - - + + subroutine get_cubic_freq_corr_alt_up(radial_only) logical, intent(in) :: radial_only call get_cubic_all_freq_corr(a3, radial_only, & nl, freq_target, freq_sigma, model_freq_alt_up, model_freq_corr, model_inertia_alt_up) end subroutine get_cubic_freq_corr_alt_up - - + + subroutine get_cubic_freq_corr_alt_down(radial_only) logical, intent(in) :: radial_only call get_cubic_all_freq_corr(a3, radial_only, & @@ -944,41 +940,33 @@ subroutine get_combined_all_freq_corr(a3, a1, radial_only, & real(dp), intent(inout), dimension(0:,:) :: freq_corr real(dp), intent(out) :: a3, a1 logical :: radial_only - - integer :: i, l + + integer :: i, l, lmax real(dp) :: X(2), XtX(2,2), XtXi(2,2), Xty(2), y real(dp) :: detXtX XtX = 0d0 Xty = 0d0 - do i = 1, nl(0) - X(1) = powm1(freq(0,i))/inertia(0,i)/sigma(0,i) - X(2) = pow3(freq(0,i))/inertia(0,i)/sigma(0,i) - y = (obs(0,i) - freq(0,i))/sigma(0,i) - - XtX(1,1) = XtX(1,1) + X(1)*X(1) - XtX(1,2) = XtX(1,2) + X(1)*X(2) - XtX(2,2) = XtX(2,2) + X(2)*X(2) - Xty(1) = Xty(1) + X(1)*y - Xty(2) = Xty(2) + X(2)*y - end do + if (radial_only) then + lmax = 0 + else + lmax = 3 + end if - if (.not. radial_only) then - do l = 1, 3 - do i = 1, nl(l) - X(1) = powm1(freq(l,i))/inertia(l,i)/sigma(l,i) - X(2) = pow3(freq(l,i))/inertia(l,i)/sigma(l,i) - y = (obs(l,i) - freq(l,i))/sigma(l,i) + do l = 0, lmax + do i = 1, nl(l) + X(1) = powm1(freq(l,i))/inertia(l,i)/sigma(l,i) + X(2) = pow3(freq(l,i))/inertia(l,i)/sigma(l,i) + y = (obs(l,i) - freq(l,i))/sigma(l,i) - XtX(1,1) = XtX(1,1) + X(1)*X(1) - XtX(1,2) = XtX(1,2) + X(1)*X(2) - XtX(2,2) = XtX(2,2) + X(2)*X(2) - Xty(1) = Xty(1) + X(1)*y - Xty(2) = Xty(2) + X(2)*y - end do + XtX(1,1) = XtX(1,1) + X(1)*X(1) + XtX(1,2) = XtX(1,2) + X(1)*X(2) + XtX(2,2) = XtX(2,2) + X(2)*X(2) + Xty(1) = Xty(1) + X(1)*y + Xty(2) = Xty(2) + X(2)*y end do - end if + end do XtX(2,1) = XtX(1,2) @@ -1008,22 +996,22 @@ subroutine get_combined_freq_corr(radial_only) call get_combined_all_freq_corr(a3, a1, radial_only, & nl, freq_target, freq_sigma, model_freq, model_freq_corr, model_inertia) end subroutine get_combined_freq_corr - - + + subroutine get_combined_freq_corr_alt_up(radial_only) logical, intent(in) :: radial_only call get_combined_all_freq_corr(a3, a1, radial_only, & nl, freq_target, freq_sigma, model_freq_alt_up, model_freq_corr_alt_up, model_inertia_alt_up) end subroutine get_combined_freq_corr_alt_up - - + + subroutine get_combined_freq_corr_alt_down(radial_only) logical, intent(in) :: radial_only call get_combined_all_freq_corr(a3, a1, radial_only, & nl, freq_target, freq_sigma, model_freq_alt_down, model_freq_corr_alt_down, model_inertia_alt_down) end subroutine get_combined_freq_corr_alt_down - - + + type(auto_diff_real_2var_order1) function power_law(freq, freq_ref, a, b) real(dp), intent(in) :: freq, freq_ref, a, b type(auto_diff_real_2var_order1) :: a_ad, b_ad @@ -1033,11 +1021,11 @@ type(auto_diff_real_2var_order1) function power_law(freq, freq_ref, a, b) b_ad = b b_ad%d1val2 = 1.0_dp - + power_law = a_ad*pow(freq/freq_ref, b_ad) end function power_law - - + + subroutine get_power_law_all_freq_corr(a, b, radial_only, freq_ref, & nl, obs, sigma, freq, freq_corr, inertia) @@ -1049,7 +1037,7 @@ subroutine get_power_law_all_freq_corr(a, b, radial_only, freq_ref, & real(dp), intent(out) :: a, b logical :: radial_only - integer :: i, l, iter + integer :: i, l, lmax, iter real(dp) :: X(2), XtX(2,2), XtXi(2,2), Xty(2), y real(dp) :: detXtX, da, db real(dp) :: Q(0:3,max_nl) @@ -1063,61 +1051,49 @@ subroutine get_power_law_all_freq_corr(a, b, radial_only, freq_ref, & a = -5.25d0 b = 5.37d0 + if (radial_only) then + lmax = 0 + else + lmax = 3 + end if + do iter=1,1000 XtX = 0d0 Xty = 0d0 - do i = 1, nl(0) - Q(0,i) = 1 + do l = 0, lmax + do i = 1, nl(l) + Q(l,i) = inertia(l,i)/interpolate_l0_inertia(freq(l,i)) - power_law_ad = power_law(freq(0,i), freq_ref, a, b) + power_law_ad = power_law(freq(l,i), freq_ref, a, b) - X(1) = -power_law_ad%d1val1/sigma(0,i) ! dpower_law/da - X(2) = -power_law_ad%d1val2/sigma(0,i) ! dpower_law/db - y = (obs(0,i) - freq(0,i) - power_law_ad%val)/sigma(0,i) - - XtX(1,1) = XtX(1,1) + X(1)*X(1) - XtX(1,2) = XtX(1,2) + X(1)*X(2) - XtX(2,2) = XtX(2,2) + X(2)*X(2) - Xty(1) = Xty(1) + X(1)*y - Xty(2) = Xty(2) + X(2)*y - end do + X(1) = -power_law_ad%d1val1/sigma(l,i) + X(2) = -power_law_ad%d1val2/sigma(l,i) + y = ((obs(l,i) - freq(l,i))*Q(l,i) - power_law_ad%val)/sigma(l,i) - if (.not. radial_only) then - do l = 1, 3 - do i = 1, nl(l) - Q(l,i) = inertia(l,i)/interpolate_l0_inertia(freq(l,i)) - - power_law_ad = power_law(freq(l,i), freq_ref, a, b) - - X(1) = -power_law_ad%d1val1/sigma(l,i) - X(2) = -power_law_ad%d1val2/sigma(l,i) - y = ((obs(l,i) - freq(l,i))*Q(l,i) - power_law_ad%val)/sigma(l,i) - - XtX(1,1) = XtX(1,1) + X(1)*X(1) - XtX(1,2) = XtX(1,2) + X(1)*X(2) - XtX(2,2) = XtX(2,2) + X(2)*X(2) - Xty(1) = Xty(1) + X(1)*y - Xty(2) = Xty(2) + X(2)*y - end do + XtX(1,1) = XtX(1,1) + X(1)*X(1) + XtX(1,2) = XtX(1,2) + X(1)*X(2) + XtX(2,2) = XtX(2,2) + X(2)*X(2) + Xty(1) = Xty(1) + X(1)*y + Xty(2) = Xty(2) + X(2)*y end do - end if + end do XtX(2,1) = XtX(1,2) - + XtXi(1,1) = XtX(2,2) XtXi(2,2) = XtX(1,1) XtXi(1,2) = -XtX(1,2) XtXi(2,1) = -XtX(2,1) - + detXtX = XtX(1,1)*XtX(2,2) - XtX(1,2)*XtX(2,1) XtXi = XtXi/detXtX - + da = XtXi(1,1)*Xty(1) + XtXi(1,2)*Xty(2) db = XtXi(2,1)*Xty(1) + XtXi(2,2)*Xty(2) - + if ((da /= da) .or. (db /= db)) exit - + a = a - da b = b - db @@ -1148,24 +1124,24 @@ subroutine get_power_law_freq_corr(radial_only, freq_ref) call get_power_law_all_freq_corr(power_law_a, power_law_b, radial_only, freq_ref, & nl, freq_target, freq_sigma, model_freq, model_freq_corr, model_inertia) end subroutine get_power_law_freq_corr - - + + subroutine get_power_law_freq_corr_alt_up(radial_only, freq_ref) logical, intent(in) :: radial_only real(dp), intent(in) :: freq_ref call get_power_law_all_freq_corr(power_law_a, power_law_b, radial_only, freq_ref, & nl, freq_target, freq_sigma, model_freq_alt_up, model_freq_corr_alt_up, model_inertia_alt_up) end subroutine get_power_law_freq_corr_alt_up - - + + subroutine get_power_law_freq_corr_alt_down(radial_only, freq_ref) logical, intent(in) :: radial_only real(dp), intent(in) :: freq_ref call get_power_law_all_freq_corr(power_law_a, power_law_b, radial_only, freq_ref, & nl, freq_target, freq_sigma, model_freq_alt_down, model_freq_corr_alt_down, model_inertia_alt_down) end subroutine get_power_law_freq_corr_alt_down - - + + type(auto_diff_real_2var_order1) function sonoi(freq, freq_ref, a, b) real(dp), intent(in) :: freq, freq_ref, a, b type(auto_diff_real_2var_order1) :: a_ad, b_ad @@ -1175,7 +1151,7 @@ type(auto_diff_real_2var_order1) function sonoi(freq, freq_ref, a, b) b_ad = b b_ad%d1val2 = 1.0_dp - + sonoi = a_ad*freq_ref*(1d0 - 1d0/(1d0+pow(freq/freq_ref, b_ad))) end function sonoi @@ -1191,7 +1167,7 @@ subroutine get_sonoi_all_freq_corr(a, b, radial_only, freq_ref, & real(dp), intent(out) :: a, b logical :: radial_only - integer :: i, l, iter + integer :: i, l, lmax, iter real(dp) :: X(2), XtX(2,2), XtXi(2,2), Xty(2), y real(dp) :: detXtX, da, db real(dp) :: Q(0:3,max_nl) @@ -1204,61 +1180,49 @@ subroutine get_sonoi_all_freq_corr(a, b, radial_only, freq_ref, & a = -3.59d-3 b = 11.26d0 + if (radial_only) then + lmax = 0 + else + lmax = 3 + end if + do iter=1,1000 XtX = 0d0 Xty = 0d0 - do i = 1, nl(0) - Q(0,i) = 1 + do l = 0, lmax + do i = 1, nl(l) + Q(l,i) = inertia(l,i)/interpolate_l0_inertia(freq(l,i)) - sonoi_ad = sonoi(freq(0,i), freq_ref, a, b) + sonoi_ad = sonoi(freq(l,i), freq_ref, a, b) - X(1) = -sonoi_ad%d1val1/sigma(0,i) - X(2) = -sonoi_ad%d1val2/sigma(0,i) - y = (obs(0,i) - freq(0,i) - sonoi_ad%val)/sigma(0,i) - - XtX(1,1) = XtX(1,1) + X(1)*X(1) - XtX(1,2) = XtX(1,2) + X(1)*X(2) - XtX(2,2) = XtX(2,2) + X(2)*X(2) - Xty(1) = Xty(1) + X(1)*y - Xty(2) = Xty(2) + X(2)*y - end do + X(1) = -sonoi_ad%d1val1/sigma(l,i) + X(2) = -sonoi_ad%d1val2/sigma(l,i) + y = ((obs(l,i) - freq(l,i))*Q(l,i) - sonoi_ad%val)/sigma(l,i) - if (.not. radial_only) then - do l = 1, 3 - do i = 1, nl(l) - Q(l,i) = inertia(l,i)/interpolate_l0_inertia(freq(l,i)) - - sonoi_ad = sonoi(freq(l,i), freq_ref, a, b) - - X(1) = -sonoi_ad%d1val1/sigma(l,i) - X(2) = -sonoi_ad%d1val2/sigma(l,i) - y = ((obs(l,i) - freq(l,i))*Q(l,i) - sonoi_ad%val)/sigma(l,i) - - XtX(1,1) = XtX(1,1) + X(1)*X(1) - XtX(1,2) = XtX(1,2) + X(1)*X(2) - XtX(2,2) = XtX(2,2) + X(2)*X(2) - Xty(1) = Xty(1) + X(1)*y - Xty(2) = Xty(2) + X(2)*y - end do + XtX(1,1) = XtX(1,1) + X(1)*X(1) + XtX(1,2) = XtX(1,2) + X(1)*X(2) + XtX(2,2) = XtX(2,2) + X(2)*X(2) + Xty(1) = Xty(1) + X(1)*y + Xty(2) = Xty(2) + X(2)*y end do - end if + end do XtX(2,1) = XtX(1,2) - + XtXi(1,1) = XtX(2,2) XtXi(2,2) = XtX(1,1) XtXi(1,2) = -XtX(1,2) XtXi(2,1) = -XtX(2,1) - + detXtX = XtX(1,1)*XtX(2,2) - XtX(1,2)*XtX(2,1) XtXi = XtXi/detXtX - + da = XtXi(1,1)*Xty(1) + XtXi(1,2)*Xty(2) db = XtXi(2,1)*Xty(1) + XtXi(2,2)*Xty(2) - + if ((da /= da) .or. (db /= db)) exit - + a = a - da b = b - db @@ -1291,25 +1255,25 @@ subroutine get_sonoi_freq_corr(radial_only, freq_ref) call get_sonoi_all_freq_corr(sonoi_a, sonoi_b, radial_only, freq_ref, & nl, freq_target, freq_sigma, model_freq, model_freq_corr, model_inertia) end subroutine get_sonoi_freq_corr - - + + subroutine get_sonoi_freq_corr_alt_up(radial_only, freq_ref) logical, intent(in) :: radial_only real(dp), intent(in) :: freq_ref call get_sonoi_all_freq_corr(sonoi_a, sonoi_b, radial_only, freq_ref, & nl, freq_target, freq_sigma, model_freq_alt_up, model_freq_corr_alt_up, model_inertia_alt_up) end subroutine get_sonoi_freq_corr_alt_up - - + + subroutine get_sonoi_freq_corr_alt_down(radial_only, freq_ref) logical, intent(in) :: radial_only real(dp), intent(in) :: freq_ref call get_sonoi_all_freq_corr(sonoi_a, sonoi_b, radial_only, freq_ref, & nl, freq_target, freq_sigma, model_freq_alt_down, model_freq_corr_alt_down, model_inertia_alt_down) end subroutine get_sonoi_freq_corr_alt_down - - - subroutine get_freq_corr(s, radial_only, ierr) + + + subroutine get_freq_corr(s, radial_only, ierr) type (star_info), pointer :: s logical, intent(in) :: radial_only integer, intent(out) :: ierr @@ -1322,7 +1286,7 @@ subroutine get_freq_corr(s, radial_only, ierr) call get_kjeldsen_freq_corr surf_coef1 = a_div_r surf_coef2 = correction_r - + if (save_next_best_at_higher_frequency) & call get_kjeldsen_freq_corr_alt_up if (save_next_best_at_lower_frequency) & @@ -1332,7 +1296,7 @@ subroutine get_freq_corr(s, radial_only, ierr) call get_cubic_freq_corr(radial_only) surf_coef1 = a3*pow3(5000.*s%nu_max/s% nu_max_sun) surf_coef2 = 0 - + if (save_next_best_at_higher_frequency) & call get_cubic_freq_corr_alt_up(radial_only) if (save_next_best_at_lower_frequency) & @@ -1342,7 +1306,7 @@ subroutine get_freq_corr(s, radial_only, ierr) call get_combined_freq_corr(radial_only) surf_coef1 = a3*pow3(5000.*s%nu_max/s% nu_max_sun) surf_coef2 = a1/(5000.*s%nu_max/s% nu_max_sun) - + if (save_next_best_at_higher_frequency) & call get_combined_freq_corr_alt_up(radial_only) if (save_next_best_at_lower_frequency) & @@ -1352,7 +1316,7 @@ subroutine get_freq_corr(s, radial_only, ierr) call get_sonoi_freq_corr(radial_only, s% nu_max) surf_coef1 = sonoi_a surf_coef2 = sonoi_b - + if (save_next_best_at_higher_frequency) & call get_sonoi_freq_corr_alt_up(radial_only, s% nu_max) if (save_next_best_at_lower_frequency) & @@ -1362,17 +1326,17 @@ subroutine get_freq_corr(s, radial_only, ierr) call get_power_law_freq_corr(radial_only, s% nu_max) surf_coef1 = power_law_a surf_coef2 = power_law_b - + if (save_next_best_at_higher_frequency) & call get_power_law_freq_corr_alt_up(radial_only, s% nu_max) if (save_next_best_at_lower_frequency) & call get_power_law_freq_corr_alt_down(radial_only, s% nu_max) call get_power_law_freq_corr(radial_only, s% nu_max) - else + else call get_no_freq_corr surf_coef1 = 0 surf_coef2 = 0 - + if (save_next_best_at_higher_frequency) & call get_no_freq_corr_alt_up if (save_next_best_at_lower_frequency) & @@ -1380,7 +1344,7 @@ subroutine get_freq_corr(s, radial_only, ierr) call get_no_freq_corr end if end subroutine get_freq_corr - + ! chi2 = chi2_seismo*chi2_seismo_fraction & ! + chi2_spectro*(1 - chi2_seismo_fraction) @@ -1393,19 +1357,19 @@ real(dp) function get_chi2(s, max_el, trace_okay, ierr) integer :: i, l, n, chi2N1, chi2N2 real(dp) :: chi2term, chi2sum1, chi2sum2, frac, & model_r01, model_r10, model_r02 - + ! calculate chi^2 following Brandao et al, 2011, eqn 11 include 'formats' - + ierr = 0 chi2sum1 = 0 chi2N1 = 0 chi2_r_010_ratios = 0 chi2_r_02_ratios = 0 chi2_frequencies = 0 - + if (chi2_seismo_freq_fraction > 0) then - + if (trace_okay .and. trace_chi2_seismo_frequencies_info) & write(*,'(4a6,99a20)') & 'model', 'i', 'l', 'n', 'chi2term', 'freq', 'corr', & @@ -1447,7 +1411,7 @@ real(dp) function get_chi2(s, max_el, trace_okay, ierr) end if end if - + if (chi2_seismo_r_010_fraction > 0 .and. max_el >= 1) then if (ratios_n == 0) then @@ -1455,7 +1419,7 @@ real(dp) function get_chi2(s, max_el, trace_okay, ierr) ierr = -1 return end if - + chi2sum1 = 0 do i=1,ratios_n model_r01 = interpolate_ratio_r010( & @@ -1486,11 +1450,11 @@ real(dp) function get_chi2(s, max_el, trace_okay, ierr) else chi2_r_010_ratios = chi2sum1 end if - + end if - + if (chi2_seismo_r_02_fraction > 0 .and. max_el >= 2) then - + chi2sum1 = 0 n = 0 do i=1,nl(0) @@ -1515,7 +1479,7 @@ real(dp) function get_chi2(s, max_el, trace_okay, ierr) else chi2_r_02_ratios = chi2sum1 end if - + end if chi2_seismo = & @@ -1524,10 +1488,10 @@ real(dp) function get_chi2(s, max_el, trace_okay, ierr) chi2_seismo_freq_fraction*chi2_frequencies + & chi2_seismo_delta_nu_fraction*chi2_delta_nu + & chi2_seismo_nu_max_fraction*chi2_nu_max - + chi2sum2 = 0 chi2N2 = 0 - + if (age_sigma > 0 .and. include_age_in_chi2_spectro) then chi2term = pow2((s% star_age - age_target)/age_sigma) if (trace_okay .and. trace_chi2_spectro_info) & @@ -1552,19 +1516,19 @@ real(dp) function get_chi2(s, max_el, trace_okay, ierr) else chi2_spectro = chi2sum2 end if - + frac = chi2_seismo_fraction - chi2 = frac*chi2_seismo + (1-frac)*chi2_spectro + chi2 = frac*chi2_seismo + (1-frac)*chi2_spectro get_chi2 = chi2 - + if (chi2_seismo_fraction < 0 .or. chi2_seismo_fraction > 1) then write(*,1) 'ERROR: bad chi2_seismo_fraction', chi2_seismo_fraction stop end if - + !if (is_bad(chi2)) call mesa_error(__FILE__,__LINE__,'get_chi2') - + end function get_chi2 diff --git a/astero/private/extras_support.f90 b/astero/private/extras_support.f90 index c6490b9b2..57e7c7714 100644 --- a/astero/private/extras_support.f90 +++ b/astero/private/extras_support.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module extras_support use star_lib @@ -34,8 +34,8 @@ module extras_support contains - - + + subroutine get_all_el_info(s, ierr) type (star_info), pointer :: s integer, intent(out) :: ierr @@ -57,21 +57,21 @@ subroutine get_all_el_info(s, ierr) end do end subroutine get_all_el_info - + integer function do_astero_extras_check_model(s, id) type (star_info), pointer :: s integer, intent(in) :: id - + integer :: max_el_for_chi2, ierr, i, j, l, n logical :: store_model, checking_age real(dp) :: age_limit, model_limit, & frac, chi2_freq_and_ratios_fraction, & remaining_years, prev_max_years, min_max - + include 'formats' - + do_astero_extras_check_model = keep_going astero_max_dt_next = 1d99 chi2 = -1 @@ -83,7 +83,7 @@ integer function do_astero_extras_check_model(s, id) correction_r = -1 checking_age = & eval_chi2_at_target_age_only .or. include_age_in_chi2_spectro - + if (checking_age) then if (num_smaller_steps_before_age_target <= 0 .or. & dt_for_smaller_steps_before_age_target <= 0) then @@ -128,7 +128,7 @@ integer function do_astero_extras_check_model(s, id) i = floor(remaining_years/s% max_years_for_timestep + 1d-6) write(*,3) 'remaining steps and years until age target', & s% model_number, i, remaining_years - else + else write(*,2) 'remaining_years until age target', & s% model_number, remaining_years end if @@ -153,12 +153,12 @@ integer function do_astero_extras_check_model(s, id) s% max_years_for_timestep = max_yrs_dt_when_cold end if - if (include_age_in_chi2_spectro .and. s% star_age < min_age_for_chi2) return + if (include_age_in_chi2_spectro .and. s% star_age < min_age_for_chi2) return if (eval_chi2_at_target_age_only .and. s% star_age < age_target) return - + delta_nu_model = s% delta_nu nu_max_model = s% nu_max - + chi2_seismo_delta_nu_fraction = & min(1d0, max(0d0, chi2_seismo_delta_nu_fraction)) chi2_seismo_nu_max_fraction = & @@ -172,14 +172,14 @@ integer function do_astero_extras_check_model(s, id) chi2_seismo_r_02_fraction + & chi2_seismo_delta_nu_fraction + & chi2_seismo_nu_max_fraction))) - + if (s% L_nuc_burn_total < s% L_phot*Lnuc_div_L_limit .or. & s% star_age < min_age_limit) then return end if - + if (.not. checking_age) then - + age_limit = avg_age_top_samples + avg_age_sigma_limit*avg_age_sigma if (s% star_age > age_limit) then write(*,1) 'star age > limit from top samples', s% star_age, age_limit @@ -189,7 +189,7 @@ integer function do_astero_extras_check_model(s, id) do_astero_extras_check_model = terminate return end if - + model_limit = & avg_model_number_top_samples + & avg_model_number_sigma_limit*avg_model_number_sigma @@ -204,18 +204,18 @@ integer function do_astero_extras_check_model(s, id) end if end if - + ! must set constraint values before checking limits do i = 1, max_constraints if (constraint_name(i) == '') cycle call star_astero_procs% set_constraint_value(id, constraint_name(i), constraint_value(i), ierr) if (ierr /= 0) call mesa_error(__FILE__, __LINE__, 'ierr /=0 in set_constraint_value') end do - + call check_limits if (do_astero_extras_check_model /= keep_going) return - chi2_spectro = get_chi2_spectro(s) + chi2_spectro = get_chi2_spectro(s) if (is_bad(chi2_spectro)) then write(*,1) 'bad chi2_spectro', chi2_spectro @@ -228,7 +228,7 @@ integer function do_astero_extras_check_model(s, id) return !stop end if - + have_radial = .false. have_nonradial = .false. model_ratios_n = 0 @@ -236,7 +236,7 @@ integer function do_astero_extras_check_model(s, id) do l = 0, 3 model_freq(l,1:nl(l)) = 0 end do - + if (delta_nu_sigma > 0) then chi2_delta_nu = pow2((delta_nu - delta_nu_model)/delta_nu_sigma) if (trace_chi2_seismo_delta_nu_info) & @@ -244,14 +244,14 @@ integer function do_astero_extras_check_model(s, id) else chi2_delta_nu = 0 end if - + chi2_nu_max = 0 if (chi2_seismo_nu_max_fraction > 0) then if (nu_max <= 0) then write(*,2) 'must supply nu_max' do_astero_extras_check_model = terminate return - end if + end if if (nu_max_sigma <= 0) then write(*,2) 'must supply nu_max_sigma' do_astero_extras_check_model = terminate @@ -259,21 +259,21 @@ integer function do_astero_extras_check_model(s, id) end if chi2_nu_max = pow2((nu_max - nu_max_model)/nu_max_sigma) if (trace_chi2_seismo_nu_max_info) & - write(*,1) 'chi2_nu_max', chi2_nu_max + write(*,1) 'chi2_nu_max', chi2_nu_max end if - + chi2_freq_and_ratios_fraction = & chi2_seismo_freq_fraction + & chi2_seismo_r_010_fraction + & chi2_seismo_r_02_fraction - + if (chi2_seismo_fraction <= 0d0) then ! no need to get frequencies chi2_seismo = & chi2_seismo_delta_nu_fraction*chi2_delta_nu + & chi2_seismo_nu_max_fraction*chi2_nu_max frac = chi2_seismo_fraction - chi2 = frac*chi2_seismo + (1-frac)*chi2_spectro + chi2 = frac*chi2_seismo + (1-frac)*chi2_spectro write(*,'(a50,i6,99f16.2)') 'chi^2 combined, chi^2 seismo, chi^2 spectro', & s% model_number, chi2, chi2_seismo, chi2_spectro if (best_chi2 < 0 .or. chi2 < best_chi2) call save_best_info(s) @@ -289,7 +289,7 @@ integer function do_astero_extras_check_model(s, id) call check_too_many_bad return end if - + if (chi2_delta_nu > chi2_delta_nu_limit) then write(*,'(a50,i6,99f16.2)') 'chi2_delta_nu > limit', & s% model_number, chi2_delta_nu, chi2_delta_nu_limit, & @@ -298,7 +298,7 @@ integer function do_astero_extras_check_model(s, id) return end if - ! chi2_spectro <= limit and chi2_delta_nu <= limit + ! chi2_spectro <= limit and chi2_delta_nu <= limit if (.not. checking_age) then s% max_years_for_timestep = max_yrs_dt_when_warm @@ -310,11 +310,11 @@ integer function do_astero_extras_check_model(s, id) s% model_number, max_yrs_dt_when_warm do_astero_extras_check_model = redo return - end if + end if end if - + if (.not. checking_age) then - s% max_years_for_timestep = max_yrs_dt_when_hot + s% max_years_for_timestep = max_yrs_dt_when_hot if (s% dt > max_yrs_dt_when_hot*secyer) then s% dt = max_yrs_dt_when_hot*secyer s% timestep_hold = s% model_number + 10 @@ -325,7 +325,7 @@ integer function do_astero_extras_check_model(s, id) return end if end if - + store_model = .true. if (nl(0) > 0 .and. chi2_freq_and_ratios_fraction > 0d0) then if (.not. get_radial(oscillation_code)) then @@ -341,7 +341,7 @@ integer function do_astero_extras_check_model(s, id) write(*,'(A)') end if call check_too_many_bad - return + return end if store_model = .false. have_radial = .true. @@ -374,9 +374,9 @@ integer function do_astero_extras_check_model(s, id) store_model = .false. end if end do - + have_nonradial = .true. - + if (chi2_freq_and_ratios_fraction > 0d0) then call get_freq_corr(s, .false., ierr) if (ierr /= 0) then @@ -395,7 +395,7 @@ integer function do_astero_extras_check_model(s, id) else max_el_for_chi2 = -1 end if - + !write(*,2) 'max_el_for_chi2', max_el_for_chi2 if (chi2_seismo_r_010_fraction > 0 .and. max_el_for_chi2 >= 1) then @@ -403,7 +403,7 @@ integer function do_astero_extras_check_model(s, id) .false., nl(0), model_freq_corr(0,:), nl(1), model_freq_corr(1,:), & model_ratios_n, model_ratios_l0_first, model_ratios_l1_first, & model_ratios_r01, model_ratios_r10) - + if (model_ratios_n /= ratios_n .or. & model_ratios_l0_first /= ratios_l0_first .or. & model_ratios_l1_first /= ratios_l1_first) then @@ -418,16 +418,16 @@ integer function do_astero_extras_check_model(s, id) write(*,*) 'model_ratios_l1_first /= ratios_l1_first', & model_ratios_l1_first, ratios_l1_first call check_too_many_bad - return + return end if - + end if - + if (chi2_seismo_r_02_fraction > 0 .and. max_el_for_chi2 >= 2) then call get_r02_frequency_ratios( & .false., nl(0), model_freq_corr(0,:), nl(1), model_freq_corr(1,:), nl(2), model_freq_corr(2,:), model_ratios_r02) end if - + chi2 = get_chi2(s, max_el_for_chi2, .true., ierr) if (ierr /= 0) then write(*,'(a40,i6)') 'failed to calculate chi^2', s% model_number @@ -436,7 +436,7 @@ integer function do_astero_extras_check_model(s, id) end if write(*,'(a50,i6,99f16.2)') 'chi^2 total, chi^2 radial', & s% model_number, chi2, chi2_radial - + if (use_other_after_get_chi2) then ierr = 0 call astero_other_procs% other_after_get_chi2(s% id, ierr) @@ -445,11 +445,11 @@ integer function do_astero_extras_check_model(s, id) return end if end if - + if (checking_age) then ! leave max_years_for_timestep as is else if (chi2 <= chi2_limit_for_smallest_timesteps) then - s% max_years_for_timestep = max_yrs_dt_chi2_smallest_limit + s% max_years_for_timestep = max_yrs_dt_chi2_smallest_limit if (s% dt > max_yrs_dt_chi2_smallest_limit*secyer) then s% dt = max_yrs_dt_chi2_smallest_limit*secyer s% timestep_hold = s% model_number + 10 @@ -458,9 +458,9 @@ integer function do_astero_extras_check_model(s, id) max_yrs_dt_chi2_smallest_limit do_astero_extras_check_model = redo return - end if + end if else if (chi2 <= chi2_limit_for_smaller_timesteps) then - s% max_years_for_timestep = max_yrs_dt_chi2_smaller_limit + s% max_years_for_timestep = max_yrs_dt_chi2_smaller_limit if (s% dt > max_yrs_dt_chi2_smaller_limit*secyer) then s% dt = max_yrs_dt_chi2_smaller_limit*secyer s% timestep_hold = s% model_number + 10 @@ -469,9 +469,9 @@ integer function do_astero_extras_check_model(s, id) max_yrs_dt_chi2_smaller_limit do_astero_extras_check_model = redo return - end if + end if else if (chi2 <= chi2_limit_for_small_timesteps) then - s% max_years_for_timestep = max_yrs_dt_chi2_small_limit + s% max_years_for_timestep = max_yrs_dt_chi2_small_limit if (s% dt > max_yrs_dt_chi2_small_limit*secyer) then s% dt = max_yrs_dt_chi2_small_limit*secyer s% timestep_hold = s% model_number + 10 @@ -480,19 +480,19 @@ integer function do_astero_extras_check_model(s, id) max_yrs_dt_chi2_small_limit do_astero_extras_check_model = redo return - end if + end if end if - + if (best_chi2 <= 0 .or. chi2 < best_chi2) then call save_best_info(s) end if - + call final_checks - + contains - - + + subroutine check_too_many_bad if (best_chi2 > 0) then num_chi2_too_big = num_chi2_too_big + 1 @@ -504,8 +504,8 @@ subroutine check_too_many_bad end if num_chi2_too_big = 0 end subroutine check_too_many_bad - - + + subroutine final_checks if (include_age_in_chi2_spectro .and. s% star_age >= max_age_for_chi2) then write(*,*) 'have reached max_age_for_chi2' @@ -533,7 +533,7 @@ subroutine final_checks num_chi2_too_big = 0 end if end subroutine final_checks - + logical function get_radial(code) character (len=*), intent(in) :: code @@ -599,8 +599,8 @@ logical function get_radial(code) end if get_radial = .true. end function get_radial - - + + logical function have_all_l0_freqs() integer :: i, cnt real(dp) :: prev @@ -620,8 +620,8 @@ logical function have_all_l0_freqs() end do if (cnt > 0) write(*,*) end function have_all_l0_freqs - - + + subroutine check_limits real(dp) :: delta_nu_limit, constraint_limit integer :: nz, i @@ -667,12 +667,12 @@ subroutine check_limits end if end if end do - - end subroutine check_limits + + end subroutine check_limits end function do_astero_extras_check_model - - + + real(dp) function get_chi2_spectro(s) type (star_info), pointer :: s integer :: cnt, i @@ -700,23 +700,23 @@ real(dp) function get_chi2_spectro(s) get_chi2_spectro = sum end if end function get_chi2_spectro - - + + subroutine store_best_info(s) type (star_info), pointer :: s integer :: i, l - + best_chi2 = chi2 best_chi2_seismo = chi2_seismo best_chi2_spectro = chi2_spectro - + best_age = s% star_age best_model_number = s% model_number best_constraint_value(1:max_constraints) = constraint_value(1:max_constraints) best_param(1:max_parameters) = param(1:max_parameters) - + best_delta_nu = delta_nu_model best_nu_max = nu_max_model best_surf_coef1 = surf_coef1 @@ -730,7 +730,7 @@ subroutine store_best_info(s) best_inertia(l,i) = model_inertia(l,i) end do end do - + best_ratios_r01(:) = 0d0 best_ratios_r10(:) = 0d0 best_ratios_r02(:) = 0d0 @@ -739,22 +739,22 @@ subroutine store_best_info(s) best_ratios_r01(i) = model_ratios_r01(i) best_ratios_r10(i) = model_ratios_r10(i) end do - + do i=1,nl(0) best_ratios_r02(i) = model_ratios_r02(i) end do - + end subroutine store_best_info subroutine set_current_from_best(s) type (star_info), pointer :: s integer :: i, l - + chi2 = best_chi2 chi2_seismo = best_chi2_seismo chi2_spectro = best_chi2_spectro - + delta_nu_model = best_delta_nu nu_max_model = best_nu_max surf_coef1 = best_surf_coef1 @@ -768,28 +768,28 @@ subroutine set_current_from_best(s) model_inertia(l,i) = best_inertia(l,i) end do end do - + do i=1,ratios_n model_ratios_r01(i) = best_ratios_r01(i) model_ratios_r10(i) = best_ratios_r10(i) end do - + do i=1,nl(0) model_ratios_r02(i) = best_ratios_r02(i) end do - + end subroutine set_current_from_best - - - subroutine save_best_info(s) + + + subroutine save_best_info(s) use pgstar_astero_plots, only: write_plot_to_file type (star_info), pointer :: s integer :: ierr logical :: write_controls_info_with_profile character (len=256) :: filename - + include 'formats' - + if (save_model_for_best_model) then ierr = 0 filename = trim(astero_results_directory) // '/' // trim(best_model_save_model_filename) @@ -801,7 +801,7 @@ subroutine save_best_info(s) end if write(*, '(a,i7)') 'save ' // filename, s% model_number end if - + if (write_fgong_for_best_model) then ierr = 0 filename = trim(astero_results_directory) // '/' // trim(best_model_fgong_filename) @@ -813,7 +813,7 @@ subroutine save_best_info(s) call mesa_error(__FILE__,__LINE__) end if end if - + if (write_gyre_for_best_model) then ierr = 0 filename = trim(astero_results_directory) // '/' // trim(best_model_gyre_filename) @@ -825,7 +825,7 @@ subroutine save_best_info(s) call mesa_error(__FILE__,__LINE__) end if end if - + if (write_profile_for_best_model) then ierr = 0 filename = trim(astero_results_directory) // '/' // trim(best_model_profile_filename) @@ -843,30 +843,30 @@ subroutine save_best_info(s) write(*,*) 'failed in save_profile' call mesa_error(__FILE__,__LINE__) end if - end if - + end if + if (len_trim(echelle_best_model_file_prefix) > 0) then ! note: sample_number hasn't been incremented yet so must add 1 call write_plot_to_file( & - s, p_echelle, echelle_best_model_file_prefix, sample_number+1, ierr) + s, p_echelle, echelle_best_model_file_prefix, sample_number+1, ierr) end if - + if (len_trim(ratios_best_model_file_prefix) > 0) then ! note: sample_number hasn't been incremented yet so must add 1 call write_plot_to_file( & - s, p_ratios, ratios_best_model_file_prefix, sample_number+1, ierr) + s, p_ratios, ratios_best_model_file_prefix, sample_number+1, ierr) end if - + call store_best_info(s) - + end subroutine save_best_info - - + + subroutine write_best(num) integer, intent(in) :: num integer :: ierr, iounit character (len=256) :: format_string, num_string, filename - integer, parameter :: max_len_out = 2000 + integer, parameter :: max_len_out = 2000 ierr = 0 iounit = alloc_iounit(ierr) if (ierr /= 0) return @@ -889,11 +889,11 @@ end subroutine write_best integer function astero_extras_check_model(id) - + integer, intent(in) :: id integer :: other_check, ierr type (star_info), pointer :: s - + include 'formats' ierr = 0 call star_ptr(id, s, ierr) @@ -909,14 +909,14 @@ integer function astero_extras_check_model(id) if (other_check > astero_extras_check_model) & astero_extras_check_model = other_check end if - + star_model_number = s% model_number if (star_model_number /= save_mode_model_number) return call get_all_el_info(s,ierr) - + end function astero_extras_check_model - + integer function astero_extras_finish_step(id) integer, intent(in) :: id integer :: ierr @@ -934,11 +934,11 @@ integer function astero_extras_finish_step(id) end if astero_extras_finish_step = star_astero_procs% extras_finish_step(id) call store_extra_info(s) - + s% dt_next = min(s% dt_next, astero_max_dt_next) - + end function astero_extras_finish_step - + subroutine astero_extras_controls(id, ierr) !use run_star_extras, only: extras_controls, set_param @@ -953,13 +953,13 @@ subroutine astero_extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + write(*,*) 'enter astero_extras_controls' - + call star_astero_procs% extras_controls(id, ierr) if (ierr /= 0) return - - + + s% extras_startup => astero_extras_startup s% extras_check_model => astero_extras_check_model s% extras_finish_step => astero_extras_finish_step @@ -967,13 +967,13 @@ subroutine astero_extras_controls(id, ierr) s% how_many_extra_history_columns => astero_how_many_extra_history_columns s% data_for_extra_history_columns => astero_data_for_extra_history_columns s% how_many_extra_profile_columns => astero_how_many_extra_profile_columns - s% data_for_extra_profile_columns => astero_data_for_extra_profile_columns - + s% data_for_extra_profile_columns => astero_data_for_extra_profile_columns + if (s% job% astero_just_call_my_extras_check_model) return - + s% other_pgstar_plots_info => astero_pgstar_plots_info s% use_other_pgstar_plots = .true. - + do i = 1, max_parameters if (param_name(i) /= '') then if (vary_param(i)) then @@ -989,12 +989,12 @@ subroutine astero_extras_controls(id, ierr) end if end if end do - + current_param(1:max_parameters) = param(1:max_parameters) - + end subroutine astero_extras_controls - - + + subroutine astero_extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -1025,8 +1025,8 @@ integer function astero_how_many_extra_history_columns(id) astero_how_many_extra_history_columns = & astero_how_many_extra_history_columns + num_extra_history_columns end function astero_how_many_extra_history_columns - - + + subroutine astero_data_for_extra_history_columns(id, n, astero_names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: astero_names(n) @@ -1034,37 +1034,37 @@ subroutine astero_data_for_extra_history_columns(id, n, astero_names, vals, ierr integer, intent(out) :: ierr integer :: i, num_extra type (star_info), pointer :: s - + include 'formats' - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + call star_astero_procs% data_for_extra_history_columns( & id, n, astero_names, vals, ierr) if (ierr /= 0) return if (s% job% astero_just_call_my_extras_check_model) return - + num_extra = star_astero_procs% how_many_extra_history_columns(id) - + i = num_extra+1 - astero_names(i) = 'chi2' + astero_names(i) = 'chi2' i = i+1 - astero_names(i) = 'delta_nu' + astero_names(i) = 'delta_nu' i = i+1 - astero_names(i) = 'delta_nu_model' + astero_names(i) = 'delta_nu_model' i = i+1 astero_names(i) = trim(surf_coef1_name) i = i+1 astero_names(i) = trim(surf_coef2_name) - + if (i /= (num_extra_history_columns + num_extra)) then write(*,2) 'i', i write(*,2) 'num_extra_history_columns', num_extra_history_columns call mesa_error(__FILE__,__LINE__,'bad num_extra_history_columns') end if - + i = num_extra+1 vals(i) = chi2 i = i+1 @@ -1075,18 +1075,18 @@ subroutine astero_data_for_extra_history_columns(id, n, astero_names, vals, ierr vals(i) = surf_coef1 i = i+1 vals(i) = surf_coef2 - - + + end subroutine astero_data_for_extra_history_columns - + integer function astero_how_many_extra_profile_columns(id) integer, intent(in) :: id astero_how_many_extra_profile_columns = & star_astero_procs% how_many_extra_profile_columns(id) end function astero_how_many_extra_profile_columns - - + + subroutine astero_data_for_extra_profile_columns( & id, n, nz, astero_names, vals, ierr) integer, intent(in) :: id, n, nz @@ -1098,7 +1098,7 @@ subroutine astero_data_for_extra_profile_columns( & id, n, nz, astero_names, vals, ierr) end subroutine astero_data_for_extra_profile_columns - + subroutine astero_extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -1115,7 +1115,7 @@ subroutine astero_extras_after_evolve(id, ierr) !write(*,*) 'call do_astero_extras_check_model before terminate' ckm = do_astero_extras_check_model(s, id) !write(*,*) 'done do_astero_extras_check_model before terminate' - end if + end if call star_astero_procs% extras_after_evolve(id, ierr) if (save_info_for_last_model) then write(*,1) 'chi2', chi2 @@ -1139,55 +1139,55 @@ subroutine astero_extras_after_evolve(id, ierr) write(*,*) 'done show_best' call free_iounit(iounit) end if - + if (s% job% astero_just_call_my_extras_check_model) return end subroutine astero_extras_after_evolve - - + + ! routines for saving and restoring extra data so can do restarts - + subroutine alloc_extra_info(s) integer, parameter :: extra_info_alloc = 1 type (star_info), pointer :: s call move_extra_info(s,extra_info_alloc) end subroutine alloc_extra_info - - + + subroutine unpack_extra_info(s) integer, parameter :: extra_info_get = 2 type (star_info), pointer :: s call move_extra_info(s,extra_info_get) end subroutine unpack_extra_info - - + + subroutine store_extra_info(s) integer, parameter :: extra_info_put = 3 type (star_info), pointer :: s call move_extra_info(s,extra_info_put) end subroutine store_extra_info - - + + subroutine move_extra_info(s,op) integer, parameter :: extra_info_alloc = 1 integer, parameter :: extra_info_get = 2 integer, parameter :: extra_info_put = 3 type (star_info), pointer :: s integer, intent(in) :: op - + integer :: i, num_ints, num_dbls, ierr - + i = 0 - ! call move_int or move_flg + ! call move_int or move_flg num_ints = i - + i = 0 ! call move_dbl num_dbls = i - + if (op /= extra_info_alloc) return if (num_ints == 0 .and. num_dbls == 0) return - + ierr = 0 call star_alloc_extras(s% id, num_ints, num_dbls, ierr) if (ierr /= 0) then @@ -1196,9 +1196,9 @@ subroutine move_extra_info(s,op) write(*,*) 'alloc_extras num_dbls', num_dbls call mesa_error(__FILE__,__LINE__) end if - + contains - + subroutine move_dbl(dbl) real(dp) :: dbl i = i+1 @@ -1209,7 +1209,7 @@ subroutine move_dbl(dbl) s% extra_work(i) = dbl end select end subroutine move_dbl - + subroutine move_int(int) integer :: int i = i+1 @@ -1220,7 +1220,7 @@ subroutine move_int(int) s% extra_iwork(i) = int end select end subroutine move_int - + subroutine move_flg(flg) logical :: flg i = i+1 @@ -1235,7 +1235,7 @@ subroutine move_flg(flg) end if end select end subroutine move_flg - + end subroutine move_extra_info diff --git a/astero/private/gyre_support.f90 b/astero/private/gyre_support.f90 index 19235571b..31cbae1f7 100644 --- a/astero/private/gyre_support.f90 +++ b/astero/private/gyre_support.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,11 +19,11 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module gyre_support ! Uses - + use astero_def use star_lib use star_def @@ -33,11 +33,11 @@ module gyre_support use gyre_mesa_m ! No implicit typing - + implicit none ! Module variables - + logical, parameter :: GYRE_IS_ENABLED = .true. ! Access specifiers @@ -51,11 +51,11 @@ module gyre_support public :: store_model_for_gyre public :: gyre_call_back public :: save_gyre_mode_info - + ! Procedures contains - + subroutine init_gyre (gyre_file, ierr) use const_def @@ -90,7 +90,7 @@ subroutine init_gyre (gyre_file, ierr) end subroutine init_gyre !**** - + subroutine do_gyre_get_modes (s, el, store_model, ierr) type (star_info), pointer :: s @@ -102,13 +102,13 @@ subroutine do_gyre_get_modes (s, el, store_model, ierr) real(dp) :: rpar(1) integer(8) :: time0, time1, clock_rate real(dp) :: time - + include 'formats' - + ierr = 0 ! If necessary, store the model - + if (store_model) then call store_model_for_gyre( & s, add_center_point, keep_surface_point, add_atmosphere, ierr) @@ -119,13 +119,13 @@ subroutine do_gyre_get_modes (s, el, store_model, ierr) end if ! Get modes - + if (trace_time_in_oscillation_code) then call system_clock(time0, clock_rate) end if - + call get_modes(el, gyre_call_back, ipar, rpar) - + if (trace_time_in_oscillation_code) then call system_clock(time1, clock_rate) time = dble(time1-time0)/clock_rate @@ -140,8 +140,8 @@ subroutine do_gyre_get_modes (s, el, store_model, ierr) end subroutine do_gyre_get_modes !**** - - subroutine null_gyre_call_back (md, ipar, rpar, ierr) + + subroutine null_gyre_call_back (md, ipar, rpar, ierr) type(mode_t), intent(in) :: md integer, intent(inout) :: ipar(:) real(dp), intent(inout) :: rpar(:) @@ -150,9 +150,9 @@ subroutine null_gyre_call_back (md, ipar, rpar, ierr) end subroutine null_gyre_call_back !**** - + subroutine store_model_for_gyre (s, add_center_point, keep_surface_point, add_atmosphere, ierr) - + type (star_info), intent(in) :: s logical, intent(in) :: add_center_point logical, intent(in) :: keep_surface_point @@ -163,13 +163,13 @@ subroutine store_model_for_gyre (s, add_center_point, keep_surface_point, add_at real(dp), allocatable :: point_data(:,:) !character(:), allocatable :: filename character (len=1000) :: filename ! temporary until gfortran stops giving bogus warning - + logical, parameter :: dbg = .false. - + include 'formats' ! If necessary, write an FGONG file - + if (write_fgong_for_each_model) then if (.not. folder_exists(trim(astero_results_directory))) call mkdir(trim(astero_results_directory)) @@ -201,7 +201,7 @@ subroutine store_model_for_gyre (s, add_center_point, keep_surface_point, add_at if (dbg) write(*,2) 'done star_pulse_data (GYRE)', s%model_number ! Pass the data to GYRE - + if (dbg) write(*,2) 'call gyre_set_model', s%model_number call set_model(global_data, point_data, s%gyre_data_schema) @@ -209,7 +209,7 @@ subroutine store_model_for_gyre (s, add_center_point, keep_surface_point, add_at if (dbg) write(*,2) 'done gyre_set_model', s%model_number ! If necessary, write a GYRE file - + if (write_gyre_for_each_model) then if (.not. folder_exists(trim(astero_results_directory))) call mkdir(trim(astero_results_directory)) @@ -243,7 +243,7 @@ function num_string (n) write(format_string, 100) model_num_digits, model_num_digits 100 format('I',I2.2,'.',I2.2) - + write(num_string, format_string) s%model_number ! Finish @@ -259,15 +259,15 @@ end subroutine store_model_for_gyre subroutine gyre_call_back(md, ipar, rpar, ierr) use astero_def, only: store_new_oscillation_results - + type(mode_t), intent(in) :: md integer, intent(inout) :: ipar(:) real(dp), intent(inout) :: rpar(:) integer, intent(out) :: ierr - + integer :: new_el, new_order, new_em real(dp) :: new_inertia, new_cyclic_freq, new_growth_rate - + include 'formats' ierr = 0 @@ -278,10 +278,10 @@ subroutine gyre_call_back(md, ipar, rpar, ierr) new_cyclic_freq = REAL(md% freq('UHZ')) new_growth_rate = AIMAG(md% freq('RAD_PER_SEC')) new_em = 0 - + call store_new_oscillation_results( & new_el, new_order, new_em, new_inertia, new_cyclic_freq, new_growth_rate, ierr) - + call save_gyre_mode_info( & new_el, new_order, new_em, new_inertia, new_cyclic_freq, new_growth_rate, & md, ipar, rpar, ierr) @@ -293,7 +293,7 @@ subroutine gyre_call_back(md, ipar, rpar, ierr) end subroutine gyre_call_back !**** - + subroutine save_gyre_mode_info( & new_el, new_order, new_em, new_inertia, new_cyclic_freq, new_growth_rate, & md, ipar, rpar, ierr) @@ -308,14 +308,14 @@ subroutine save_gyre_mode_info( & integer :: iounit include 'formats' - + !if (use_other_gyre_mode_info) then ! call astero_other_procs% other_gyre_mode_info(md, ipar, rpar, ierr) !end if - + if (star_model_number /= save_mode_model_number) return if (new_el /= el_to_save .or. new_order /= order_to_save) return - + if (len_trim(save_mode_filename) <= 0) save_mode_filename = 'save_mode.data' write(*,*) 'save eigenfunction info to file ' // trim(save_mode_filename) write(*,'(3a8,99a20)') 'el', 'order', 'em', 'freq (microHz)', 'inertia', 'growth rate (s)' @@ -332,7 +332,7 @@ subroutine save_gyre_mode_info( & close(iounit) - call free_iounit(iounit) + call free_iounit(iounit) end subroutine save_gyre_mode_info diff --git a/astero/private/gyre_support_stub.f90 b/astero/private/gyre_support_stub.f90 index 61d21cecc..39c55fbad 100644 --- a/astero/private/gyre_support_stub.f90 +++ b/astero/private/gyre_support_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,36 +19,36 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module gyre_support use star_lib use star_def - + implicit none - + logical, parameter :: GYRE_IS_ENABLED = .false. - + contains - - + + subroutine init_gyre(gyre_file,ierr) character(*), intent(in) :: gyre_file integer, intent(out) :: ierr ierr = -1 end subroutine init_gyre - - - + + + subroutine do_gyre_get_modes (s, el, store_model, ierr) - + type (star_info), pointer :: s integer, intent(in) :: el logical, intent(in) :: store_model integer, intent(out) :: ierr - + ierr = -1 end subroutine do_gyre_get_modes diff --git a/astero/private/pgstar_astero_plots.f90 b/astero/private/pgstar_astero_plots.f90 index 154e7bc1f..9d897ca48 100644 --- a/astero/private/pgstar_astero_plots.f90 +++ b/astero/private/pgstar_astero_plots.f90 @@ -22,7 +22,7 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module pgstar_astero_plots use star_lib use star_def @@ -30,15 +30,15 @@ module pgstar_astero_plots use star_pgstar implicit none - + contains - - + + subroutine astero_pgstar_plots_info(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - + integer :: i, plot_id type (pgstar_win_file_data), pointer :: p type (star_info), pointer :: s @@ -46,7 +46,7 @@ subroutine astero_pgstar_plots_info(id, ierr) ierr = 0 call get_star_ptr(id, s, ierr) if (ierr /= 0) return - + i = 1 plot_id = i_Other + i - 1 p => s% pg% pgstar_win_file_ptr(plot_id) @@ -65,7 +65,7 @@ subroutine astero_pgstar_plots_info(id, ierr) p% file_interval = echelle_file_interval p% file_width = echelle_file_width p% file_aspect_ratio = echelle_file_aspect_ratio - + if (nl(1) > 0) then i = i+1 plot_id = i_Other + i - 1 @@ -86,9 +86,9 @@ subroutine astero_pgstar_plots_info(id, ierr) p% file_width = ratios_file_width p% file_aspect_ratio = ratios_file_aspect_ratio end if - + end subroutine astero_pgstar_plots_info - + subroutine echelle_plot(id, device_id, ierr) integer, intent(in) :: id, device_id @@ -99,23 +99,23 @@ subroutine echelle_plot(id, device_id, ierr) ierr = 0 call get_star_ptr(id, s, ierr) if (ierr /= 0) return - + call pgslct(device_id) call pgbbuf() call pgeras() - + call do_echelle_plot(id, device_id, & echelle_xleft, echelle_xright, & echelle_ybot, echelle_ytop, & .false., echelle_title, echelle_txt_scale, ierr) call pgebuf() - + end subroutine echelle_plot subroutine do_echelle_plot_in_grid( & - id, device_id, xleft, xright, ybot, ytop, txt_scale, ierr) + id, device_id, xleft, xright, ybot, ytop, txt_scale, ierr) integer, intent(in) :: id, device_id real, intent(in) :: xleft, xright, ybot, ytop, txt_scale integer, intent(out) :: ierr @@ -126,10 +126,10 @@ end subroutine do_echelle_plot_in_grid subroutine do_echelle_plot( & id, device_id, xleft, xright, ybot, ytop, subplot, title, txt_scale, ierr) - + use utils_lib use const_def - + integer, intent(in) :: id, device_id real, intent(in) :: xleft, xright, ybot, ytop, txt_scale logical, intent(in) :: subplot @@ -140,12 +140,12 @@ subroutine do_echelle_plot( & real :: xmin, xmax, ymin, ymax, dx, dy, plot_delta_nu, marker_scale, & x_obs, y_obs, x_model, y_model, y_txt, xpt_min, xpt_max, xmargin integer :: i, l, freq_color(0:3), freq_shape(0:3), model_color, model_shape - + include 'formats' ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + plot_delta_nu = echelle_delta_nu if (plot_delta_nu <= 0) plot_delta_nu = delta_nu if (plot_delta_nu <= 0) then @@ -153,7 +153,7 @@ subroutine do_echelle_plot( & ierr = -1 return end if - + xpt_min = 1e9 xpt_max = -1e9 ymin = 1e9 @@ -176,9 +176,9 @@ subroutine do_echelle_plot( & xmargin = max(plot_delta_nu/5, (plot_delta_nu - (xpt_max - xpt_min))/2) xmin = -xmargin xmax = 2*plot_delta_nu + xmargin - + call pgsave - + call pgsch(txt_scale) call pgsvp(xleft, xright, ybot, ytop) call pgswin(xmin, xmax, ymin, ymax) @@ -193,9 +193,9 @@ subroutine do_echelle_plot( & call pgstar_show_age(s) end if call pgstar_show_title(s, title) - + call pgslw(1) - + ! label y_obs = ymin + dy*0.12 y_txt = ymin + dy*0.17 @@ -204,23 +204,23 @@ subroutine do_echelle_plot( & else dx = (xmax-xmin)/3d0 end if - + freq_color(0) = clr_Teal freq_shape(0) = 0840 ! circle - + freq_color(1) = clr_Crimson freq_shape(1) = 0842 ! triangle - + freq_color(2) = clr_BrightBlue freq_shape(2) = 0841 ! square - + freq_color(3) = clr_Coral freq_shape(3) = 0843 ! diamond - + model_color = clr_Silver model_shape = 0828 ! bullet - - + + x_obs = xmin + dx/2 call pgsci(freq_color(0)) call pgsch(1.6*txt_scale) @@ -228,7 +228,7 @@ subroutine do_echelle_plot( & call pgsci(1) call pgsch(txt_scale) call pgptxt(x_obs, y_txt, 0.0, 0.5, 'l=0') - + x_obs = x_obs+dx call pgsci(freq_color(1)) call pgsch(1.6*txt_scale) @@ -236,7 +236,7 @@ subroutine do_echelle_plot( & call pgsci(1) call pgsch(1.0*txt_scale) call pgptxt(x_obs, y_txt, 0.0, 0.5, 'l=1') - + x_obs = x_obs+dx call pgsci(freq_color(2)) call pgsch(1.6*txt_scale) @@ -244,7 +244,7 @@ subroutine do_echelle_plot( & call pgsci(1) call pgsch(1.0*txt_scale) call pgptxt(x_obs, y_txt, 0.0, 0.5, 'l=2') - + if (nl(3) > 0) then x_obs = x_obs+dx call pgsci(freq_color(3)) @@ -254,7 +254,7 @@ subroutine do_echelle_plot( & call pgsch(1.0*txt_scale) call pgptxt(x_obs, y_txt, 0.0, 0.5, 'l=3') end if - + marker_scale = 2.4*txt_scale call pgsch(marker_scale) @@ -278,29 +278,29 @@ subroutine do_echelle_plot( & end do end if end do - - + + call pgsci(clr_SlateGray) call pgsls(1) call pgslw(8) - + call pgmove(0., ymax - dy*0.08) call pgdraw(0., ymax) call pgmove(plot_delta_nu, ymax - dy*0.08) call pgdraw(plot_delta_nu, ymax) call pgmove(2*plot_delta_nu, ymax - dy*0.08) call pgdraw(2*plot_delta_nu, ymax) - + call pgmove(0., ymin + dy*0.08) call pgdraw(0., ymin) call pgmove(plot_delta_nu, ymin + dy*0.08) call pgdraw(plot_delta_nu, ymin) call pgmove(2*plot_delta_nu, ymin + dy*0.08) call pgdraw(2*plot_delta_nu, ymin) - + call pgunsa - + call show_pgstar_annotations(s, & show_echelle_annotation1, & show_echelle_annotation2, & @@ -308,18 +308,18 @@ subroutine do_echelle_plot( & contains - - + + subroutine show_obs(freq, color, shape) real(dp), intent(in) :: freq integer, intent(in) :: color, shape y_obs = freq - x_obs = mod(freq,plot_delta_nu) + x_obs = mod(freq,plot_delta_nu) call pgsci(color) call pgpt1(x_obs, y_obs, shape) call pgpt1(x_obs + plot_delta_nu, y_obs, shape) end subroutine show_obs - + subroutine show_model( & freq_obs, freq, freq_alt_up, freq_alt_down, & inertia, inertia_alt_up, inertia_alt_down, color) @@ -340,7 +340,7 @@ subroutine show_model( & call pgdraw(x_model, y_model) call pgpt1(x_model + plot_delta_nu, y_model, model_shape) call pgmove(x_obs + plot_delta_nu, y_obs) - call pgdraw(x_model + plot_delta_nu, y_model) + call pgdraw(x_model + plot_delta_nu, y_model) if (freq_alt_up > 0d0 .and. show_echelle_next_best_at_higher_frequency) then y_model_alt_up = freq_alt_up + y_model_alt_shift x_model_alt_up = (freq_alt_up - freq_obs) + x_obs @@ -348,7 +348,7 @@ subroutine show_model( & call pgpt1(x_model_alt_up, y_model_alt_up, model_shape) call pgpt1(x_model_alt_up + plot_delta_nu, y_model_alt_up, model_shape) call pgsch(marker_scale) - end if + end if if (freq_alt_down > 0d0 .and. show_echelle_next_best_at_lower_frequency) then y_model_alt_down = freq_alt_down - y_model_alt_shift x_model_alt_down = (freq_alt_down - freq_obs) + x_obs @@ -356,11 +356,11 @@ subroutine show_model( & call pgpt1(x_model_alt_down, y_model_alt_down, model_shape) call pgpt1(x_model_alt_down + plot_delta_nu, y_model_alt_down, model_shape) call pgsch(marker_scale) - end if + end if end subroutine show_model - + end subroutine do_echelle_plot - + subroutine ratios_plot(id, device_id, ierr) integer, intent(in) :: id, device_id @@ -371,23 +371,23 @@ subroutine ratios_plot(id, device_id, ierr) ierr = 0 call get_star_ptr(id, s, ierr) if (ierr /= 0) return - + call pgslct(device_id) call pgbbuf() call pgeras() - + call do_ratios_plot(id, device_id, & ratios_xleft, ratios_xright, & ratios_ybot, ratios_ytop, & .false., ratios_title, ratios_txt_scale, ierr) call pgebuf() - + end subroutine ratios_plot subroutine do_ratios_plot_in_grid( & - id, device_id, xleft, xright, ybot, ytop, txt_scale, ierr) + id, device_id, xleft, xright, ybot, ytop, txt_scale, ierr) integer, intent(in) :: id, device_id real, intent(in) :: xleft, xright, ybot, ytop, txt_scale integer, intent(out) :: ierr @@ -398,10 +398,10 @@ end subroutine do_ratios_plot_in_grid subroutine do_ratios_plot( & id, device_id, xleft, xright, ybot, ytop, subplot, title, txt_scale, ierr) - + use utils_lib use const_def - + integer, intent(in) :: id, device_id real, intent(in) :: xleft, xright, ybot, ytop, txt_scale logical, intent(in) :: subplot @@ -415,21 +415,21 @@ subroutine do_ratios_plot( & integer :: i, n, i0, i1, l0_first, l1_first, & r01_color, r01_shape, r10_color, r10_shape, & r02_color, r02_shape, model_color, model_shape - + include 'formats' ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + if (chi2_seismo_r_010_fraction <= 0d0 .and. & chi2_seismo_r_02_fraction <= 0d0) then return end if - + if (nl(1) <= 0 .or. ratios_n <= 0) then return end if - + n = ratios_n l0_first = ratios_l0_first l1_first = ratios_l1_first @@ -438,7 +438,7 @@ subroutine do_ratios_plot( & xmin = HUGE(xmin) do i=1,n i0 = i + l0_first - i1 = i + l1_first + i1 = i + l1_first if (ratios_r01(i) > xmax) xmax = ratios_r01(i) if (ratios_r01(i) < xmin) xmin = ratios_r01(i) if (ratios_r10(i) > xmax) xmax = ratios_r10(i) @@ -457,7 +457,7 @@ subroutine do_ratios_plot( & dx = max(dx, 0.02) xmin = xmin - dx*0.1 xmax = xmax + dx*0.1 - + ymin = freq_target(0,1 + l0_first) ymax = freq_target(1,n + l1_first) do i=2,nl(0) @@ -469,7 +469,7 @@ subroutine do_ratios_plot( & dy = max(dy, 1.0) ymin = ymin - dy*0.25 ymax = ymax + dy*0.12 - + call pgsave call pgsvp(xleft, xright, ybot, ytop) @@ -484,26 +484,26 @@ subroutine do_ratios_plot( & call pgstar_show_age(s) end if call pgstar_show_title(s, title) - + call pgslw(1) - + r01_color = clr_Teal r01_shape = 0840 ! circle - + r10_color = clr_Crimson r10_shape = 0842 ! triangle - + r02_color = clr_BrightBlue r02_shape = 0841 ! square - + model_color = clr_Silver model_shape = 0828 ! bullet - + ! label y_obs = ymin + dy*0.06 y_txt = ymin + dy*0.10 dx = (xmax-xmin)/4d0 - + x_obs = xmin+dx call pgsci(r01_color) call pgsch(1.6*txt_scale) @@ -511,7 +511,7 @@ subroutine do_ratios_plot( & call pgsci(1) call pgsch(1.0*txt_scale) call pgptxt(x_obs, y_txt, 0.0, 0.5, 'r01') - + x_obs = x_obs+dx call pgsci(r10_color) call pgsch(1.6*txt_scale) @@ -519,7 +519,7 @@ subroutine do_ratios_plot( & call pgsci(1) call pgsch(1.0*txt_scale) call pgptxt(x_obs, y_txt, 0.0, 0.5, 'r10') - + x_obs = x_obs+dx call pgsci(r02_color) call pgsch(1.6*txt_scale) @@ -527,31 +527,31 @@ subroutine do_ratios_plot( & call pgsci(1) call pgsch(1.0*txt_scale) call pgptxt(x_obs, y_txt, 0.0, 0.5, 'r02') - + show_model = & (model_ratios_n == ratios_n .and. & model_ratios_l0_first == ratios_l0_first .and. & model_ratios_l1_first == ratios_l1_first) - + call pgsch(2.4*txt_scale) do i=1,n call show_r01(i) call show_r10(i) end do - + do i=1,nl(0) call show_r02(i) end do - + call pgunsa - + call show_pgstar_annotations(s, & show_ratios_annotation1, & show_ratios_annotation2, & show_ratios_annotation3) contains - + subroutine show_r01(i) integer, intent(in) :: i real :: x_obs, y_obs, sig_obs, x_model, y_model @@ -571,7 +571,7 @@ subroutine show_r01(i) end if call pgpt1(x_obs, y_obs, r01_shape) end subroutine show_r01 - + subroutine show_r10(i) integer, intent(in) :: i real :: x_obs, y_obs, sig_obs, x_model, y_model @@ -591,7 +591,7 @@ subroutine show_r10(i) end if call pgpt1(x_obs, y_obs, r10_shape) end subroutine show_r10 - + subroutine show_r02(i) integer, intent(in) :: i real :: x_obs, y_obs, sig_obs, x_model, y_model @@ -612,10 +612,10 @@ subroutine show_r02(i) end if call pgpt1(x_obs, y_obs, r02_shape) end subroutine show_r02 - + end subroutine do_ratios_plot - - + + subroutine write_plot_to_file(s, p, file_prefix, number, ierr) use star_lib, only: pgstar_write_plot_to_file type (star_info), pointer :: s @@ -625,31 +625,31 @@ subroutine write_plot_to_file(s, p, file_prefix, number, ierr) integer, intent(out) :: ierr character (len=256) :: format_string, num_str, name, extension - + ierr = 0 - + if (len_trim(file_prefix) == 0 .or. .not. associated(p)) return - + write(format_string, '( "(i",i2.2,".",i2.2,")" )') num_digits, num_digits write(num_str, format_string) number - + if (len_trim(p% file_dir) > 0) then name = trim(p% file_dir) // '/' // trim(file_prefix) else name = file_prefix end if - + extension = 'png' ! s% file_extension name = trim(name) // '_sample' // trim(num_str) // '.' // trim(extension) - + write(*,'(a)') 'write plot to file ' // trim(name) call pgstar_write_plot_to_file(s, p, name, ierr) - + end subroutine write_plot_to_file - + end module pgstar_astero_plots - - - - + + + + diff --git a/astero/private/pgstar_astero_plots_stub.f90 b/astero/private/pgstar_astero_plots_stub.f90 index c4da7598f..25fce39ab 100644 --- a/astero/private/pgstar_astero_plots_stub.f90 +++ b/astero/private/pgstar_astero_plots_stub.f90 @@ -22,18 +22,18 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module pgstar_astero_plots use star_lib use star_def use star_pgstar implicit none - + contains - - + + subroutine astero_pgstar_plots_info(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -52,7 +52,7 @@ end subroutine write_plot_to_file end module pgstar_astero_plots - - - - + + + + diff --git a/astero/public/astero_def.f90 b/astero/public/astero_def.f90 index ede83e7dd..cd202cadf 100644 --- a/astero/public/astero_def.f90 +++ b/astero/public/astero_def.f90 @@ -30,20 +30,20 @@ module astero_def use math_lib use utils_lib use star_pgstar - + implicit none - + ! oscillation code results - + integer :: num_results integer, pointer, dimension(:) :: el, order, em real(dp), pointer, dimension(:) :: inertia, cyclic_freq, growth_rate - real(dp) :: total_time_in_oscillation_code + real(dp) :: total_time_in_oscillation_code + - ! interfaces for procedure pointers abstract interface - + subroutine other_proc_interface(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -58,24 +58,24 @@ subroutine other_adipls_mode_info_interface( & real(dp), intent(in) :: x(1:nn), y(1:iy,1:nn), aa(1:iaa,1:nn), data(8) integer, intent(out) :: ierr end subroutine other_adipls_mode_info_interface - + end interface - + type astero_info - + procedure(other_proc_interface), pointer, nopass :: & other_after_get_chi2 => null() - + procedure(other_adipls_mode_info_interface), pointer, nopass :: & other_adipls_mode_info => null() - + end type astero_info - + type (astero_info), save :: astero_other_procs - + logical :: use_other_after_get_chi2 = .false. logical :: use_other_adipls_mode_info = .false. - + ! chi2 = chi2_seismo*chi2_seismo_fraction & ! + chi2_spectroscopic_and_photometric*(1 - chi2_seismo_fraction) @@ -86,7 +86,7 @@ end subroutine other_adipls_mode_info_interface real(dp) :: chi2_seismo_nu_max_fraction real(dp) :: chi2_seismo_r_010_fraction real(dp) :: chi2_seismo_r_02_fraction - + logical :: & trace_chi2_seismo_delta_nu_info, & trace_chi2_seismo_nu_max_info, & @@ -117,7 +117,7 @@ end subroutine other_adipls_mode_info_interface real(dp) :: sigmas_coeff_for_constraint_limit(max_constraints) character (len=strlen) :: constraint_name(max_constraints) - + real(dp) :: Z_div_X_solar integer, parameter :: max_nl = 1000 ! increase this if necessary @@ -129,9 +129,9 @@ end subroutine other_adipls_mode_info_interface integer, parameter :: max_parameters = 100 integer :: num_parameters - + character (len=100) :: search_type - + logical :: eval_chi2_at_target_age_only real(dp) :: min_age_for_chi2, max_age_for_chi2 @@ -140,7 +140,7 @@ end subroutine other_adipls_mode_info_interface character (len=256) :: bobyqa_output_filename real(dp) :: bobyqa_rhoend ! search control for bobyqa - + character (len=256) :: simplex_output_filename integer :: simplex_itermax, & simplex_fcn_calls_max, simplex_seed @@ -156,14 +156,14 @@ end subroutine other_adipls_mode_info_interface simplex_x_rtol, & simplex_chi2_tol, & simplex_centroid_weight_power - + character (len=256) :: scan_grid_output_filename logical :: restart_scan_grid_from_file character (len=256) :: filename_for_parameters integer :: max_num_from_file integer :: file_column_for_param(max_parameters) character (len=256) :: from_file_output_filename - + logical :: Y_depends_on_Z real(dp) :: Y0, dYdZ @@ -171,10 +171,10 @@ end subroutine other_adipls_mode_info_interface real(dp), dimension(max_parameters) :: & first_param, min_param, max_param, delta_param character (len=strlen) :: param_name(max_parameters) - + real(dp) :: f0_ov_div_f_ov, Lnuc_div_L_limit, & chi2_spectroscopic_limit, chi2_radial_limit, chi2_delta_nu_limit - + real(dp) :: max_yrs_dt_when_cold, max_yrs_dt_when_warm, max_yrs_dt_when_hot, & max_yrs_dt_chi2_small_limit, chi2_limit_for_small_timesteps, & max_yrs_dt_chi2_smaller_limit, chi2_limit_for_smaller_timesteps, & @@ -183,25 +183,25 @@ end subroutine other_adipls_mode_info_interface avg_age_sigma_limit, avg_model_number_sigma_limit real(dp) :: sigmas_coeff_for_delta_nu_limit - + integer :: min_num_samples_for_avg, max_num_samples_for_avg, & limit_num_chi2_too_big - + real(dp) :: min_age_limit - + character(len=32) :: correction_scheme, & surf_coef1_name, surf_coef2_name - + real(dp) :: correction_b, correction_factor integer :: l0_n_obs(max_nl) - + ! frequency ratios for observations integer :: ratios_n, ratios_l0_first, ratios_l1_first real(dp), dimension(max_nl) :: & ratios_r01, sigmas_r01, & ratios_r10, sigmas_r10, & ratios_r02, sigmas_r02 - + ! output controls character (len=256) :: astero_results_directory @@ -212,30 +212,30 @@ end subroutine other_adipls_mode_info_interface logical :: write_best_model_data_for_each_sample integer :: num_digits character (len=256) :: sample_results_prefix, sample_results_postfix - + integer :: model_num_digits logical :: write_fgong_for_each_model - character (len=256) :: fgong_prefix, fgong_postfix + character (len=256) :: fgong_prefix, fgong_postfix logical :: write_fgong_for_best_model character (len=256) :: best_model_fgong_filename - + logical :: write_gyre_for_each_model - character (len=256) :: gyre_prefix, gyre_postfix + character (len=256) :: gyre_prefix, gyre_postfix logical :: write_gyre_for_best_model character (len=256) :: best_model_gyre_filename integer :: max_num_gyre_points - + logical :: write_profile_for_best_model character (len=256) :: best_model_profile_filename - + logical :: save_model_for_best_model character (len=256) :: best_model_save_model_filename - + logical :: save_info_for_last_model character (len=256) :: last_model_save_info_filename - - + + ! miscellaneous logical :: save_next_best_at_higher_frequency, & @@ -245,35 +245,35 @@ end subroutine other_adipls_mode_info_interface logical :: save_controls character (len=256) :: save_controls_filename - + real(dp) :: Y_frac_he3 - + integer :: save_mode_model_number = -1 character (len=256) :: save_mode_filename integer :: el_to_save = -1 integer :: order_to_save = -1 integer :: em_to_save = -1 - + character (len=256) :: & oscillation_code, & gyre_input_file logical :: gyre_non_ad - - logical :: trace_time_in_oscillation_code - - logical :: add_atmosphere - logical :: keep_surface_point + + logical :: trace_time_in_oscillation_code + + logical :: add_atmosphere + logical :: keep_surface_point logical :: add_center_point logical :: do_redistribute_mesh ! note: number of zones for redistribute is set in the redistrb.c input file - + integer :: iscan_factor(0:3) ! iscan for adipls = this factor times expected number of modes real(dp) :: nu_lower_factor, nu_upper_factor - ! frequency range for adipls is set from observed frequencies times these + ! frequency range for adipls is set from observed frequencies times these integer :: & ! misc adipls parameters adipls_irotkr, adipls_nprtkr, adipls_igm1kr, adipls_npgmkr - + logical, dimension(max_extra_inlists) :: read_extra_astero_search_inlist character (len=strlen), dimension(max_extra_inlists) :: extra_astero_search_inlist_name @@ -294,7 +294,7 @@ end subroutine other_adipls_mode_info_interface normalize_chi2_seismo_r_02, & delta_nu, delta_nu_sigma, & nu_max, nu_max_sigma, & - + include_age_in_chi2_spectro, & age_target, age_sigma, & num_smaller_steps_before_age_target, & @@ -302,18 +302,18 @@ end subroutine other_adipls_mode_info_interface include_constraint_in_chi2_spectro, & constraint_target, constraint_sigma, constraint_name, & - + Z_div_X_solar, & nl, & freq_target, & freq_sigma, & - + search_type, & - + eval_chi2_at_target_age_only, & min_age_for_chi2, & max_age_for_chi2, & - + simplex_output_filename, & simplex_itermax, & simplex_fcn_calls_max, simplex_seed, & @@ -331,7 +331,7 @@ end subroutine other_adipls_mode_info_interface newuoa_rhoend, & bobyqa_output_filename, & bobyqa_rhoend, & - + scan_grid_output_filename, & restart_scan_grid_from_file, & filename_for_parameters, & @@ -374,16 +374,16 @@ end subroutine other_adipls_mode_info_interface num_digits, & sample_results_prefix, sample_results_postfix, & model_num_digits, & - + write_fgong_for_each_model, & fgong_prefix, fgong_postfix, & write_fgong_for_best_model, best_model_fgong_filename, & - + write_gyre_for_each_model, & gyre_prefix, gyre_postfix, & write_gyre_for_best_model, best_model_gyre_filename, & max_num_gyre_points, & - + write_profile_for_best_model, best_model_profile_filename, & save_model_for_best_model, best_model_save_model_filename, & save_info_for_last_model, last_model_save_info_filename, & @@ -392,11 +392,11 @@ end subroutine other_adipls_mode_info_interface save_mode_model_number, save_mode_filename, & save_next_best_at_higher_frequency, & save_next_best_at_lower_frequency, & - + oscillation_code, & gyre_input_file, & gyre_non_ad, & - + el_to_save, & order_to_save, & em_to_save, & @@ -410,8 +410,8 @@ end subroutine other_adipls_mode_info_interface nu_lower_factor, nu_upper_factor, & read_extra_astero_search_inlist, & extra_astero_search_inlist_name - - + + ! pgstar plots logical :: echelle_win_flag, echelle_file_flag @@ -428,7 +428,7 @@ end subroutine other_adipls_mode_info_interface show_echelle_next_best_at_lower_frequency, & show_echelle_annotation1, & show_echelle_annotation2, & - show_echelle_annotation3 + show_echelle_annotation3 logical :: ratios_win_flag, ratios_file_flag integer :: ratios_file_interval @@ -442,11 +442,11 @@ end subroutine other_adipls_mode_info_interface logical :: & show_ratios_annotation1, & show_ratios_annotation2, & - show_ratios_annotation3 - + show_ratios_annotation3 + logical, dimension(max_extra_inlists) :: read_extra_astero_pgstar_inlist character (len=strlen), dimension(max_extra_inlists) :: extra_astero_pgstar_inlist_name - + namelist /astero_pgstar_controls/ & echelle_win_flag, echelle_file_flag, & echelle_file_interval, & @@ -476,8 +476,8 @@ end subroutine other_adipls_mode_info_interface ! private data - - + + ! working storage for models and search results real(dp) :: model_freq(0:3,max_nl) real(dp) :: model_freq_corr(0:3,max_nl) @@ -492,7 +492,7 @@ end subroutine other_adipls_mode_info_interface real(dp) :: model_freq_corr_alt_up(0:3,max_nl) real(dp) :: model_inertia_alt_up(0:3,max_nl) integer :: model_order_alt_up(0:3,max_nl) - + ! next best fit at lower frequency real(dp) :: model_freq_alt_down(0:3,max_nl) real(dp) :: model_freq_corr_alt_down(0:3,max_nl) @@ -507,12 +507,12 @@ end subroutine other_adipls_mode_info_interface model_ratios_r01, & model_ratios_r10, & model_ratios_r02 - + logical :: have_radial, have_nonradial - + real(dp) :: min_sample_chi2_so_far = -1 integer :: sample_number, nvar, num_chi2_too_big - + integer :: i_param(max_parameters) real(dp) :: final_param(max_parameters) @@ -541,10 +541,10 @@ end subroutine other_adipls_mode_info_interface best_surf_coef1, & best_surf_coef2, & best_constraint_value(max_constraints) - + integer :: & best_model_number - + integer :: best_order(0:3,max_nl) real(dp) :: best_freq(0:3,max_nl) real(dp) :: best_freq_corr(0:3,max_nl) @@ -554,10 +554,10 @@ end subroutine other_adipls_mode_info_interface best_ratios_r01, & best_ratios_r10, & best_ratios_r02 - + integer :: max_num_samples integer :: scan_grid_skip_number - + real(dp), pointer, dimension(:) :: & sample_chi2, & sample_chi2_seismo, & @@ -570,12 +570,12 @@ end subroutine other_adipls_mode_info_interface real(dp), pointer, dimension(:,:) :: sample_constraint_value real(dp), pointer, dimension(:,:) :: sample_param - + integer, pointer, dimension(:) :: & sample_index_by_chi2, & sample_model_number, & sample_op_code - + integer, pointer, dimension(:,:,:) :: sample_order real(dp), pointer, dimension(:,:,:) :: sample_freq real(dp), pointer, dimension(:,:,:) :: sample_freq_corr @@ -587,7 +587,7 @@ end subroutine other_adipls_mode_info_interface sample_ratios_r02 real(dp) :: astero_max_dt_next - + real(dp) :: avg_age_top_samples, avg_age_sigma, & avg_model_number_top_samples, avg_model_number_sigma @@ -602,7 +602,7 @@ end subroutine other_adipls_mode_info_interface integer :: star_id, star_model_number integer :: num_chi2_seismo_terms, num_chi2_spectro_terms - + ! current values for parameters set by adipls_extras_controls real(dp) :: current_param(max_parameters) @@ -655,9 +655,9 @@ end subroutine extras_controls_interface type (astero_procs), target, save :: star_astero_procs ! gfortran seems to require "save" here. at least it did once upon a time. - + contains - + subroutine init_astero_def star_astero_procs% set_constraint_value => null() star_astero_procs% set_param => null() @@ -672,18 +672,18 @@ subroutine init_astero_def star_astero_procs% data_for_extra_profile_columns => null() end subroutine init_astero_def - - + + subroutine store_new_oscillation_results( & new_el, new_order, new_em, new_inertia, new_cyclic_freq, new_growth_rate, ierr) integer, intent(in) :: new_el, new_order, new_em real(dp), intent(in) :: new_inertia, new_cyclic_freq, new_growth_rate integer, intent(out) :: ierr - + integer :: n - + include 'formats' - + ierr = 0 n = num_results*3/2 + 50 if (.not. associated(el)) allocate(el(n)) @@ -692,7 +692,7 @@ subroutine store_new_oscillation_results( & if (.not. associated(cyclic_freq)) allocate(cyclic_freq(n)) if (.not. associated(growth_rate)) allocate(growth_rate(n)) if (.not. associated(inertia)) allocate(inertia(n)) - + if (num_results >= size(el,dim=1)) then ! enlarge call realloc_integer(el,n,ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) @@ -708,7 +708,7 @@ subroutine store_new_oscillation_results( & if (ierr /= 0) call mesa_error(__FILE__,__LINE__) end if num_results = num_results+1 - + n = num_results el(n) = new_el order(n) = new_order @@ -716,10 +716,10 @@ subroutine store_new_oscillation_results( & growth_rate(n) = new_growth_rate inertia(n) = new_inertia em(n) = new_em - + end subroutine store_new_oscillation_results - + subroutine init_sample_ptrs nullify( & sample_chi2, & @@ -743,14 +743,14 @@ subroutine init_sample_ptrs sample_ratios_r10, & sample_ratios_r02) end subroutine init_sample_ptrs - - + + subroutine alloc_sample_ptrs(ierr) use utils_lib integer, intent(out) :: ierr ierr = 0 max_num_samples = 1.5*max_num_samples + 200 - + call realloc_double(sample_chi2,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_chi2_seismo,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_chi2_spectro,max_num_samples,ierr); if (ierr /= 0) return @@ -759,14 +759,14 @@ subroutine alloc_sample_ptrs(ierr) call realloc_double2(sample_param,max_parameters,max_num_samples,ierr); if (ierr /= 0) return call realloc_double2(sample_constraint_value,max_constraints,max_num_samples,ierr); if (ierr /= 0) return - + call realloc_double(sample_delta_nu,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_nu_max,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_surf_coef1,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_surf_coef2,max_num_samples,ierr); if (ierr /= 0) return call realloc_integer(sample_index_by_chi2,max_num_samples,ierr); if (ierr /= 0) return - + call realloc_integer(sample_op_code,max_num_samples,ierr); if (ierr /= 0) return call realloc_integer(sample_model_number,max_num_samples,ierr); if (ierr /= 0) return @@ -781,7 +781,7 @@ subroutine alloc_sample_ptrs(ierr) end subroutine alloc_sample_ptrs - + ! for the frequency arrays sample_{order,freq,freq_corr,inertia}, the first index ! is 0:3, so here are some specific realloc routines for that case ! basically copied from utils/public/utils_lib.f @@ -851,33 +851,33 @@ subroutine read_astero_search_controls(filename, ierr) ierr = 0 call read1_astero_search_inlist(filename, 1, ierr) end subroutine read_astero_search_controls - - + + recursive subroutine read1_astero_search_inlist(filename, level, ierr) character (len=*), intent(in) :: filename - integer, intent(in) :: level + integer, intent(in) :: level integer, intent(out) :: ierr - + logical, dimension(max_extra_inlists) :: read_extra character (len=strlen) :: message character (len=strlen), dimension(max_extra_inlists) :: extra integer :: unit, i - + if (level >= 10) then write(*,*) 'ERROR: too many levels of nested extra star_job inlist files' ierr = -1 return end if - + ierr = 0 unit=alloc_iounit(ierr) if (ierr /= 0) return - + open(unit=unit, file=trim(filename), action='read', delim='quote', iostat=ierr) if (ierr /= 0) then write(*, *) 'Failed to open astero search inlist file ', trim(filename) else - read(unit, nml=astero_search_controls, iostat=ierr) + read(unit, nml=astero_search_controls, iostat=ierr) close(unit) if (ierr /= 0) then write(*, *) & @@ -885,30 +885,30 @@ recursive subroutine read1_astero_search_inlist(filename, level, ierr) write(*, '(a)') trim(message) write(*, '(a)') & 'The following runtime error message might help you find the problem' - write(*, *) + write(*, *) open(unit=unit, file=trim(filename), & action='read', delim='quote', status='old', iostat=ierr) read(unit, nml=astero_search_controls) close(unit) - end if + end if end if call free_iounit(unit) if (ierr /= 0) return - + ! recursive calls to read other inlists do i=1, max_extra_inlists read_extra(i) = read_extra_astero_search_inlist(i) read_extra_astero_search_inlist(i) = .false. extra(i) = extra_astero_search_inlist_name(i) extra_astero_search_inlist_name(i) = 'undefined' - + if (read_extra(i)) then call read1_astero_search_inlist(extra(i), level+1, ierr) if (ierr /= 0) return end if end do - - + + end subroutine read1_astero_search_inlist @@ -935,81 +935,81 @@ subroutine write_astero_search_controls(filename_in, ierr) close(unit) end if call free_iounit(unit) - + write(*,'(A)') write(*,*) 'saved initial &astero_search_controls to ' // trim(filename) write(*,'(A)') write(*,'(A)') end subroutine write_astero_search_controls - - + + subroutine read_astero_pgstar_controls(filename, ierr) character (len=*), intent(in) :: filename integer, intent(out) :: ierr - + ! initialize controls to default values include 'astero_pgstar.defaults' - + ierr = 0 call read1_astero_pgstar_inlist(filename, 1, ierr) - + end subroutine read_astero_pgstar_controls - - + + recursive subroutine read1_astero_pgstar_inlist(filename, level, ierr) character (len=*), intent(in) :: filename - integer, intent(in) :: level + integer, intent(in) :: level integer, intent(out) :: ierr - + logical, dimension(max_extra_inlists) :: read_extra character (len=strlen), dimension(max_extra_inlists) :: extra integer :: unit, i - + if (level >= 10) then write(*,*) 'ERROR: too many levels of nested extra star_job inlist files' ierr = -1 return end if - + ierr = 0 unit=alloc_iounit(ierr) if (ierr /= 0) return - + open(unit=unit, file=trim(filename), action='read', delim='quote', iostat=ierr) if (ierr /= 0) then write(*, *) 'Failed to open astero pgstar inlist file ', trim(filename) else - read(unit, nml=astero_pgstar_controls, iostat=ierr) + read(unit, nml=astero_pgstar_controls, iostat=ierr) close(unit) if (ierr /= 0) then write(*, *) & 'Failed while trying to read astero pgstar inlist file ', trim(filename) write(*, '(a)') & 'The following runtime error message might help you find the problem' - write(*, *) + write(*, *) open(unit=unit, file=trim(filename), & action='read', delim='quote', status='old', iostat=ierr) read(unit, nml=astero_pgstar_controls) close(unit) - end if + end if end if call free_iounit(unit) if (ierr /= 0) return - + ! recursive calls to read other inlists do i=1, max_extra_inlists read_extra(i) = read_extra_astero_pgstar_inlist(i) read_extra_astero_pgstar_inlist(i) = .false. extra(i) = extra_astero_pgstar_inlist_name(i) extra_astero_pgstar_inlist_name(i) = 'undefined' - + if (read_extra(i)) then call read1_astero_pgstar_inlist(extra(i), level+1, ierr) if (ierr /= 0) return end if end do - + end subroutine read1_astero_pgstar_inlist @@ -1026,10 +1026,10 @@ subroutine save_sample_results_to_file(i_total, results_fname, ierr) if (ierr /= 0) return call show_all_sample_results(iounit, i_total, ierr) close(iounit) - call free_iounit(iounit) + call free_iounit(iounit) end subroutine save_sample_results_to_file - - + + subroutine set_sample_index_by_chi2 use num_lib, only: qsort if (sample_number <= 0) return @@ -1039,11 +1039,11 @@ subroutine set_sample_index_by_chi2 end if call qsort(sample_index_by_chi2, sample_number, sample_chi2) end subroutine set_sample_index_by_chi2 - - + + subroutine show_sample_header(iounit) integer, intent(in) :: iounit - + integer :: i, j, k, l character (len=strlen) :: fmt character (len=10) :: str @@ -1102,7 +1102,7 @@ subroutine show_sample_header(iounit) trim(surf_coef2_name), & 'chi2_seismo', & 'chi2_spectro', & - + 'nl0', & 'nl1', & 'nl2', & @@ -1110,7 +1110,7 @@ subroutine show_sample_header(iounit) 'ratios_n', & 'ratios_l0_first', & 'ratios_l1_first' - + if (chi2_seismo_fraction > 0) then do l=0,3 @@ -1150,28 +1150,28 @@ subroutine show_sample_header(iounit) 'r02_' // trim(str) end do end if - + end if if (search_type == 'simplex') then write(iounit, astero_results_txt_format, advance='no') 'step_type' end if - + write(iounit, '(a)') ! end of column names line - + end subroutine show_sample_header - - + + subroutine show1_sample_results(i, iounit) use num_lib, only: simplex_info_str integer, intent(in) :: i, iounit - + integer :: k, l, op_code, ierr character (len=256) :: info_str, fmt - + ierr = 0 - op_code = sample_op_code(i) + op_code = sample_op_code(i) if (op_code <= 0) then info_str = '' else @@ -1209,7 +1209,7 @@ subroutine show1_sample_results(i, iounit) call write1_int(ratios_n) call write1_int(ratios_l0_first) call write1_int(ratios_l1_first) - + if (iounit == 6) return if (chi2_seismo_fraction > 0) then @@ -1239,7 +1239,7 @@ subroutine show1_sample_results(i, iounit) ratios_r02(k), sigmas_r02(k), sample_ratios_r02(k,i) end do end if - + end if if (search_type == 'simplex') then @@ -1261,10 +1261,10 @@ subroutine write1_int(i) write(iounit, astero_results_int_format, advance='no', iostat=ierr) i end subroutine write1_int - + end subroutine show1_sample_results - - + + subroutine show_all_sample_results(iounit, i_total, ierr) integer, intent(in) :: iounit, i_total integer, intent(out) :: ierr @@ -1337,17 +1337,17 @@ subroutine write_int(name, val) end subroutine write_int end subroutine show_all_sample_results - - + + subroutine show_best_el_info(io) integer, intent(in) :: io - + real(dp) :: chi2term integer :: i, l ! elaborate shenanigans to preserve header format character(len=8), dimension(5) :: header - + do l = 0, 3 if (nl(l) > 0) then write(header(1), '(a2,i1)') 'l=', l @@ -1368,19 +1368,19 @@ subroutine show_best_el_info(io) end do end if end do - + end subroutine show_best_el_info - - + + subroutine show_best_r010_ratios_info(io) integer, intent(in) :: io - + real(dp) :: chi2term integer :: i, l0_first, l1_first l0_first = ratios_l0_first l1_first = ratios_l1_first - + write(io,'(/,2a6,99a20)') & 'r01', 'l=0 n', 'chi2term', 'r01', 'r01_obs', 'r01_sigma', 'l0_obs' do i=1,ratios_n @@ -1390,7 +1390,7 @@ subroutine show_best_r010_ratios_info(io) chi2term, model_ratios_r01(i), ratios_r01(i), sigmas_r01(i), & freq_target(0,i + l0_first) end do - + write(io,'(/,2a6,99a20)') & 'r10', 'l=1 n', 'chi2term', 'r10', 'r10_obs', 'r10_sigma', 'l1_obs' do i=1,ratios_n @@ -1400,16 +1400,16 @@ subroutine show_best_r010_ratios_info(io) chi2term, model_ratios_r10(i), ratios_r10(i), sigmas_r10(i), & freq_target(1,i + l1_first) end do - + end subroutine show_best_r010_ratios_info - + subroutine show_best_r02_ratios_info(io) integer, intent(in) :: io - + real(dp) :: chi2term integer :: i - + write(io,'(/,2a6,99a20)') & 'r02', 'l=0 n', 'chi2term', 'r02', 'r02_obs', 'r02_sigma', 'l0_obs' do i=1,nl(0) @@ -1420,21 +1420,21 @@ subroutine show_best_r02_ratios_info(io) chi2term, model_ratios_r02(i), ratios_r02(i), sigmas_r02(i), & freq_target(0,i) end do - + end subroutine show_best_r02_ratios_info - - + + subroutine show_best(io) integer, intent(in) :: io - + real(dp) :: chi2term integer :: i include 'formats' - + if (chi2_seismo_fraction > 0) then - call show_best_el_info(io) + call show_best_el_info(io) if (chi2_seismo_r_010_fraction > 0) & - call show_best_r010_ratios_info(io) + call show_best_r010_ratios_info(io) if (chi2_seismo_r_02_fraction > 0) & call show_best_r02_ratios_info(io) end if @@ -1462,14 +1462,14 @@ subroutine show_best(io) call write1(trim(constraint_name(i)) // ' chi2term', chi2term) end if end do - + write(io,'(A)') call write1('delta_nu', best_delta_nu) call write1('nu_max', best_nu_max) - write(io,*) + write(io,*) write(io,'(a40,1pes20.10)') trim(surf_coef1_name), best_surf_coef1 write(io,'(a40,1pes20.10)') trim(surf_coef2_name), best_surf_coef2 - write(io,*) + write(io,*) do i = 1, max_parameters if (param_name(i) /= '') call write1(trim(param_name(i)), current_param(i)) @@ -1491,9 +1491,9 @@ subroutine show_best(io) write(io,'(a40,i16)') 'model number', best_model_number write(io,'(A)') write(io,'(A)') - + contains - + subroutine write1(str,x) character (len=*), intent(in) :: str real(dp), intent(in) :: x @@ -1513,31 +1513,31 @@ subroutine read_samples_from_file(results_fname, ierr) integer, intent(out) :: ierr integer :: iounit, num, j character (len=strlen) :: line - + include 'formats' - - ierr = 0 + + ierr = 0 write(*,*) 'read samples from file ' // trim(results_fname) - + iounit = alloc_iounit(ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'alloc_iounit failed') open(unit=iounit, file=trim(results_fname), action='read', status='old', iostat=ierr) if (ierr /= 0) then write(*,*) 'failed to open ' // trim(results_fname) - call free_iounit(iounit) + call free_iounit(iounit) return end if read(iounit, fmt='(a)') line read(iounit, fmt='(a)') line - + read(iounit, fmt=astero_results_int_format, iostat=ierr) num if (ierr /= 0) then write(*,*) 'failed to read number of samples on line 3 of ' // trim(results_fname) call done return end if - + write(*,2) 'number of samples in file', num do j = 4, 6 @@ -1549,7 +1549,7 @@ subroutine read_samples_from_file(results_fname, ierr) return end if end do - + do while (max_num_samples < num) call alloc_sample_ptrs(ierr) if (ierr /= 0) then @@ -1558,7 +1558,7 @@ subroutine read_samples_from_file(results_fname, ierr) return end if end do - + do j = 1, num call read1_sample_from_file(j, iounit, ierr) if (ierr /= 0) then @@ -1567,35 +1567,35 @@ subroutine read_samples_from_file(results_fname, ierr) return end if end do - + sample_number = num write(*,2) 'number of samples read from file', num - + call done - + contains - - + + subroutine done close(iounit) - call free_iounit(iounit) + call free_iounit(iounit) end subroutine done - + end subroutine read_samples_from_file - - + + subroutine read1_sample_from_file(j, iounit, ierr) use num_lib, only: simplex_op_code integer, intent(in) :: j, iounit integer, intent(out) :: ierr - + integer :: i, k, l character (len=256) :: info_str, fmt - + include 'formats' - + ierr = 0 call read1_int(i) if (ierr /= 0) return @@ -1631,7 +1631,7 @@ subroutine read1_sample_from_file(j, iounit, ierr) call read1_int(ratios_l1_first) if (failed('results')) return - + if (chi2_seismo_fraction > 0) then write(fmt,'(a)') '(' // trim(astero_results_int_format) // & @@ -1662,16 +1662,16 @@ subroutine read1_sample_from_file(j, iounit, ierr) if (failed('ratios_r02')) return end do end if - + end if - + read(iounit, '(a12)', iostat=ierr) info_str if (ierr /= 0) then ierr = 0 sample_op_code(i) = 0 return end if - + if (len_trim(info_str) == 0) then sample_op_code(i) = 0 else @@ -1682,11 +1682,11 @@ subroutine read1_sample_from_file(j, iounit, ierr) return end if end if - - + + contains - - + + logical function failed(str) character (len=*), intent(in) :: str include 'formats' @@ -1707,8 +1707,8 @@ subroutine read1_int(i) read(iounit, astero_results_int_format, advance='no', iostat=ierr) i end subroutine read1_int - - + + end subroutine read1_sample_from_file diff --git a/astero/public/astero_lib.f90 b/astero/public/astero_lib.f90 index 8f810043f..629d6daf1 100644 --- a/astero/public/astero_lib.f90 +++ b/astero/public/astero_lib.f90 @@ -25,7 +25,7 @@ module astero_lib ! library for calculation of asteroseismic variables - + use const_def, only: dp use gyre_support, only: GYRE_IS_ENABLED use adipls_support, only: ADIPLS_IS_ENABLED @@ -36,7 +36,7 @@ module astero_lib astero_get_power_law_all_freq_corr => get_power_law_all_freq_corr, & astero_get_sonoi_all_freq_corr => get_sonoi_all_freq_corr implicit none - + logical, parameter :: astero_gyre_is_enabled = GYRE_IS_ENABLED logical, parameter :: astero_adipls_is_enabled = ADIPLS_IS_ENABLED @@ -52,7 +52,7 @@ subroutine run_star_astero( & subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - end subroutine extras_controls + end subroutine extras_controls end interface character (len=256) :: inlist_astero_search_controls_fname optional inlist_astero_search_controls_fname @@ -60,8 +60,8 @@ end subroutine extras_controls call do_run_star_astero( & extras_controls, inlist_astero_search_controls_fname) end subroutine run_star_astero - - + + ! this can be called from user run_star_extras check model routine subroutine adipls_get_one_el_info( & s, l, nu1, nu2, iscan, R, G, M, & @@ -90,8 +90,8 @@ subroutine adipls_get_one_el_info( & save_mode_info, order_to_save_in, save_mode_filename_in, & num, l_freq, l_inertia, l_order, l_em, ierr) end subroutine adipls_get_one_el_info - - + + subroutine astero_gyre_get_modes(id, el, store_model, ierr) use star_def, only: star_ptr, star_info use gyre_support, only: do_gyre_get_modes @@ -104,8 +104,8 @@ subroutine astero_gyre_get_modes(id, el, store_model, ierr) if (ierr /= 0) return call do_gyre_get_modes(s, el, store_model, ierr) end subroutine astero_gyre_get_modes - - + + ! for surface_effects test case @@ -122,15 +122,15 @@ subroutine astero_get_one_el_info( & call get_one_el_info( & s, l, nu1, nu2, iscan, i1, i2, store_model, code, ierr) end subroutine astero_get_one_el_info - - + + real(dp) function astero_interpolate_l0_inertia(freq) use astero_support, only: interpolate_l0_inertia real(dp), intent(in) :: freq astero_interpolate_l0_inertia = interpolate_l0_inertia(freq) end function astero_interpolate_l0_inertia - - + + subroutine astero_get_kjeldsen_radial_freq_corr( & a_div_r, b, nu_max, correction_factor, check_obs, & nl0, l0_obs, l0_freq, l0_freq_corr, l0_inertia) @@ -145,7 +145,7 @@ subroutine astero_get_kjeldsen_radial_freq_corr( & a_div_r, b, nu_max, correction_factor, check_obs, & nl0, l0_obs, l0_freq, l0_freq_corr, l0_inertia) end subroutine astero_get_kjeldsen_radial_freq_corr - - + + end module astero_lib diff --git a/astero/test_suite/astero_adipls/src/run_star_extras.f90 b/astero/test_suite/astero_adipls/src/run_star_extras.f90 index 57ecec8a4..d7b59904a 100644 --- a/astero/test_suite/astero_adipls/src/run_star_extras.f90 +++ b/astero/test_suite/astero_adipls/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,25 +19,25 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def use math_lib - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) use astero_def, only: star_astero_procs integer, intent(in) :: id @@ -53,11 +53,11 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns include 'set_star_astero_procs.inc' end subroutine extras_controls - + subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero code integer, intent(in) :: id character(len=strlen), intent(in) :: name @@ -84,8 +84,8 @@ subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero c end select end subroutine set_constraint_value - - + + subroutine set_param(id, name, val, ierr) ! called from star_astero code !use astero_search_data, only: vary_param1 integer, intent(in) :: id @@ -109,8 +109,8 @@ subroutine my_other_adipls_mode_info( & ierr = 0 write(*,*) 'astero called my_other_adipls_mode_info' end subroutine my_other_adipls_mode_info - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -121,25 +121,25 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use astero_lib, only: astero_adipls_is_enabled integer, intent(in) :: id integer, intent(out) :: ierr type (star_info), pointer :: s - + real(dp) :: dt, expected_freq, freq logical :: okay, store_for_adipls, save_mode_info integer :: l_to_match, order_to_match, order_to_save character (len=256) :: save_mode_filename - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% x_ctrl(1) > 0d0) then - + store_for_adipls = .true. l_to_match = 0 order_to_match = 4 @@ -148,7 +148,7 @@ subroutine extras_after_evolve(id, ierr) save_mode_info = .true. order_to_save = 5 save_mode_filename = 'eigen.data' - + if(astero_adipls_is_enabled) then call get_adipls_frequency_info( & s, store_for_adipls, l_to_match, order_to_match, expected_freq, & @@ -162,12 +162,12 @@ subroutine extras_after_evolve(id, ierr) else write(*,*) 'not using adipls: pretend got ok match for expected frequency.' end if - + end if call test_suite_after_evolve(s, ierr) - + end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -183,7 +183,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + extras_check_model = keep_going @@ -191,12 +191,12 @@ integer function extras_check_model(id) extras_check_model = terminate return end if - + if (s% x_ctrl(1) > 0d0) then - + ! get frequencies for certain models if (mod(s% model_number,50) /= 0) return - + store_for_adipls = .true. l_to_match = 0 order_to_match = 5 @@ -204,17 +204,17 @@ integer function extras_check_model(id) save_mode_info = .false. order_to_save = 0 save_mode_filename = '' - + call get_adipls_frequency_info( & s, store_for_adipls, l_to_match, order_to_match, expected_freq, & save_mode_info, order_to_save, save_mode_filename, freq, okay, ierr) if (ierr /= 0) extras_check_model = terminate - + end if - + end function extras_check_model - - + + subroutine get_adipls_frequency_info( & s, store_for_adipls, l_to_match, order_to_match, expected_freq, & save_mode_info, order_to_save, save_mode_filename, freq, okay, ierr) @@ -227,7 +227,7 @@ subroutine get_adipls_frequency_info( & real(dp), intent(out) :: freq logical, intent(out) :: okay ! true if expected_freq is okay integer, intent(out) :: ierr - + integer :: l, iscan, i, num real(dp) :: nu1, nu2, R, G, M real(dp), pointer, dimension(:) :: l_freq, l_inertia @@ -247,7 +247,7 @@ subroutine get_adipls_frequency_info( & add_atmosphere = .true. do_restribute_mesh = .false. l = l_to_match - + nullify(l_freq) nullify(l_inertia) nullify(l_order) @@ -256,7 +256,7 @@ subroutine get_adipls_frequency_info( & nu1 = 50 nu2 = 1000 iscan = 200 - + !write(*,*) 'call adipls_get_one_el_info' call adipls_get_one_el_info( & s, l, nu1, nu2, iscan, R, G, M, & @@ -280,7 +280,7 @@ subroutine get_adipls_frequency_info( & end if end do deallocate(l_freq, l_inertia, l_order, l_em) - + end subroutine get_adipls_frequency_info @@ -293,8 +293,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -306,7 +306,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -317,8 +317,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -332,7 +332,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -345,8 +345,8 @@ integer function extras_finish_step(id) extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/astero/test_suite/astero_gyre/src/run_star_extras.f90 b/astero/test_suite/astero_gyre/src/run_star_extras.f90 index fdcbbfb1a..81e558756 100644 --- a/astero/test_suite/astero_gyre/src/run_star_extras.f90 +++ b/astero/test_suite/astero_gyre/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,29 +19,29 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def use math_lib - + implicit none real(dp) :: expected_freq, actual_freq integer :: i, l_to_match !, order_to_match - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) use astero_def, only: star_astero_procs @@ -58,11 +58,11 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns include 'set_star_astero_procs.inc' end subroutine extras_controls - + subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero code integer, intent(in) :: id character(len=strlen), intent(in) :: name @@ -89,8 +89,8 @@ subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero c end select end subroutine set_constraint_value - - + + subroutine set_param(id, name, val, ierr) ! called from star_astero code integer, intent(in) :: id character(len=strlen), intent(in) :: name ! which of param's will be set @@ -102,7 +102,7 @@ subroutine set_param(id, name, val, ierr) ! called from star_astero code end subroutine set_param - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -113,25 +113,25 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use astero_lib, only: astero_gyre_is_enabled integer, intent(in) :: id integer, intent(out) :: ierr - + type (star_info), pointer :: s logical :: okay real(dp) :: dt - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% x_ctrl(1) > 0d0) then if (astero_gyre_is_enabled) then call get_gyre_frequency_info(s, .true., okay, ierr) - + if (ierr /= 0) call mesa_error(__FILE__,__LINE__) if (okay) then write(*,'(a,2f20.2)') 'got ok match for expected frequency', actual_freq, expected_freq @@ -145,7 +145,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -165,21 +165,21 @@ integer function extras_check_model(id) call star_ptr(id, s, ierr) if (ierr /= 0) return - + extras_check_model = keep_going - + if (s% x_ctrl(1) > 0d0) then - + ! get frequencies for certain models if (mod(s% model_number,50) /= 0) return - + write(*,*) 'get gyre frequency info' - + call get_gyre_frequency_info(s, .false., okay, ierr) if (ierr /= 0) extras_check_model = terminate - + end if - + end function extras_check_model @@ -191,24 +191,24 @@ subroutine get_gyre_frequency_info(s, check_match, okay, ierr) logical, intent(in) :: check_match logical, intent(out) :: okay integer, intent(out) :: ierr - + integer :: i, order_to_match logical :: store_model - + include 'formats' ierr = 0 okay = .false. - + ! change the following for your specific case l_to_match = 0 order_to_match = 4 expected_freq = s% x_ctrl(1) - + ! get values for gyre_input_file and gyre_non_ad from the astero controls inlist ! store_model must be .true. since this is the 1st call on gyre for this model. store_model = .true. - + num_results = 0 ! initialize this counter before calling gyre call astero_gyre_get_modes( & @@ -217,7 +217,7 @@ subroutine get_gyre_frequency_info(s, check_match, okay, ierr) write(*,*) 'failed in do_gyre_get_modes' call mesa_error(__FILE__,__LINE__) end if - + write(*,'(A)') write(*,'(2a8,99a20)') 'el', 'order', 'freq (microHz)', 'inertia', 'growth rate (s)' do i = 1, num_results @@ -240,8 +240,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -253,7 +253,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -264,8 +264,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -279,7 +279,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -291,8 +291,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/astero/test_suite/example_astero/src/run_star_extras.f90 b/astero/test_suite/example_astero/src/run_star_extras.f90 index 69b466057..0478123d0 100644 --- a/astero/test_suite/example_astero/src/run_star_extras.f90 +++ b/astero/test_suite/example_astero/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,25 +19,25 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def use math_lib - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) use astero_def, only: star_astero_procs integer, intent(in) :: id @@ -53,11 +53,11 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns include 'set_star_astero_procs.inc' end subroutine extras_controls - + subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero code use astero_def, only: Z_div_X_solar @@ -113,8 +113,8 @@ subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero c end select end subroutine set_constraint_value - - + + subroutine set_param(id, name, val, ierr) ! called from star_astero code use astero_def, only: f0_ov_div_f_ov, Y_frac_he3, Z_div_X_solar, & Y_depends_on_Z, dYdZ, Y0 @@ -185,8 +185,8 @@ subroutine set_param(id, name, val, ierr) ! called from star_astero code end select end subroutine set_param - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -197,8 +197,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use astero_def, only: best_chi2 integer, intent(in) :: id @@ -228,17 +228,17 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + integer function extras_check_model(id) integer, intent(in) :: id integer :: ierr type (star_info), pointer :: s - extras_check_model = keep_going + extras_check_model = keep_going ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + include 'formats' ! if you want to check multiple conditions, it can be useful @@ -263,8 +263,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -276,7 +276,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -287,8 +287,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -302,7 +302,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -314,8 +314,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/astero/test_suite/fast_from_file/src/run_star_extras.f90 b/astero/test_suite/fast_from_file/src/run_star_extras.f90 index ef5da249f..d283ebf65 100644 --- a/astero/test_suite/fast_from_file/src/run_star_extras.f90 +++ b/astero/test_suite/fast_from_file/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,25 +19,25 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def use math_lib - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) use astero_def, only: star_astero_procs integer, intent(in) :: id @@ -54,7 +54,7 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% how_many_extra_history_header_items => how_many_extra_history_header_items s% data_for_extra_history_header_items => data_for_extra_history_header_items @@ -64,7 +64,7 @@ subroutine extras_controls(id, ierr) include 'set_star_astero_procs.inc' end subroutine extras_controls - + subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero code use astero_def, only: Z_div_X_solar @@ -120,8 +120,8 @@ subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero c end select end subroutine set_constraint_value - - + + subroutine set_param(id, name, val, ierr) ! called from star_astero code use astero_def, only: f0_ov_div_f_ov, Y_frac_he3, Z_div_X_solar, & Y_depends_on_Z, dYdZ, Y0 @@ -200,8 +200,8 @@ subroutine set_param(id, name, val, ierr) ! called from star_astero code end select end subroutine set_param - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -212,8 +212,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use astero_def use utils_lib, only: mv @@ -254,7 +254,7 @@ subroutine move(filename, extension) end subroutine move end subroutine extras_after_evolve - + integer function extras_check_model(id) use astero_lib, only: astero_gyre_is_enabled @@ -262,11 +262,11 @@ integer function extras_check_model(id) integer, intent(in) :: id integer :: ierr type (star_info), pointer :: s - extras_check_model = keep_going + extras_check_model = keep_going ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + include 'formats' if (.not. astero_gyre_is_enabled) then @@ -298,8 +298,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -311,7 +311,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -322,8 +322,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -395,7 +395,7 @@ subroutine data_for_extra_profile_header_items(id, n, names, vals, ierr) ! vals(1) = s% mixing_length_alpha end subroutine data_for_extra_profile_header_items - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -407,8 +407,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/astero/test_suite/fast_newuoa/src/run_star_extras.f90 b/astero/test_suite/fast_newuoa/src/run_star_extras.f90 index b1201e43c..a9677686f 100644 --- a/astero/test_suite/fast_newuoa/src/run_star_extras.f90 +++ b/astero/test_suite/fast_newuoa/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,25 +19,25 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def use math_lib - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) use astero_def, only: star_astero_procs integer, intent(in) :: id @@ -53,11 +53,11 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns include 'set_star_astero_procs.inc' end subroutine extras_controls - + subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero code use astero_def, only: Z_div_X_solar @@ -113,8 +113,8 @@ subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero c end select end subroutine set_constraint_value - - + + subroutine set_param(id, name, val, ierr) ! called from star_astero code use astero_def, only: f0_ov_div_f_ov, Y_frac_he3, Z_div_X_solar, & Y_depends_on_Z, dYdZ, Y0 @@ -185,8 +185,8 @@ subroutine set_param(id, name, val, ierr) ! called from star_astero code end select end subroutine set_param - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -197,8 +197,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use astero_def, only: best_chi2 integer, intent(in) :: id @@ -212,17 +212,17 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + integer function extras_check_model(id) integer, intent(in) :: id integer :: i, ierr type (star_info), pointer :: s - extras_check_model = keep_going + extras_check_model = keep_going ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + include 'formats' ! if you want to check multiple conditions, it can be useful @@ -237,7 +237,7 @@ integer function extras_check_model(id) if (extras_check_model == terminate) s% termination_code = t_extras_check_model end function extras_check_model - + integer function how_many_extra_history_columns(id) integer, intent(in) :: id integer :: ierr @@ -247,8 +247,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -260,7 +260,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -271,8 +271,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -286,7 +286,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -298,8 +298,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/astero/test_suite/fast_scan_grid/src/run_star_extras.f90 b/astero/test_suite/fast_scan_grid/src/run_star_extras.f90 index 175541c0b..2de18bf9d 100644 --- a/astero/test_suite/fast_scan_grid/src/run_star_extras.f90 +++ b/astero/test_suite/fast_scan_grid/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,25 +19,25 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def use math_lib - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) use astero_def, only: star_astero_procs integer, intent(in) :: id @@ -54,7 +54,7 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% how_many_extra_history_header_items => how_many_extra_history_header_items s% data_for_extra_history_header_items => data_for_extra_history_header_items @@ -64,7 +64,7 @@ subroutine extras_controls(id, ierr) include 'set_star_astero_procs.inc' end subroutine extras_controls - + subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero code use astero_def, only: Z_div_X_solar @@ -120,8 +120,8 @@ subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero c end select end subroutine set_constraint_value - - + + subroutine set_param(id, name, val, ierr) ! called from star_astero code use astero_def, only: f0_ov_div_f_ov, Y_frac_he3, Z_div_X_solar, & Y_depends_on_Z, dYdZ, Y0 @@ -192,8 +192,8 @@ subroutine set_param(id, name, val, ierr) ! called from star_astero code end select end subroutine set_param - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -204,8 +204,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use astero_def use utils_lib, only: mv @@ -246,17 +246,17 @@ subroutine move(filename, extension) end subroutine move end subroutine extras_after_evolve - + integer function extras_check_model(id) integer, intent(in) :: id integer :: ierr type (star_info), pointer :: s - extras_check_model = keep_going + extras_check_model = keep_going ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + include 'formats' ! if you want to check multiple conditions, it can be useful @@ -281,8 +281,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -294,7 +294,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -305,8 +305,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -378,7 +378,7 @@ subroutine data_for_extra_profile_header_items(id, n, names, vals, ierr) ! vals(1) = s% mixing_length_alpha end subroutine data_for_extra_profile_header_items - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -390,8 +390,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/astero/test_suite/fast_simplex/src/run_star_extras.f90 b/astero/test_suite/fast_simplex/src/run_star_extras.f90 index 175541c0b..2de18bf9d 100644 --- a/astero/test_suite/fast_simplex/src/run_star_extras.f90 +++ b/astero/test_suite/fast_simplex/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,25 +19,25 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def use math_lib - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) use astero_def, only: star_astero_procs integer, intent(in) :: id @@ -54,7 +54,7 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% how_many_extra_history_header_items => how_many_extra_history_header_items s% data_for_extra_history_header_items => data_for_extra_history_header_items @@ -64,7 +64,7 @@ subroutine extras_controls(id, ierr) include 'set_star_astero_procs.inc' end subroutine extras_controls - + subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero code use astero_def, only: Z_div_X_solar @@ -120,8 +120,8 @@ subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero c end select end subroutine set_constraint_value - - + + subroutine set_param(id, name, val, ierr) ! called from star_astero code use astero_def, only: f0_ov_div_f_ov, Y_frac_he3, Z_div_X_solar, & Y_depends_on_Z, dYdZ, Y0 @@ -192,8 +192,8 @@ subroutine set_param(id, name, val, ierr) ! called from star_astero code end select end subroutine set_param - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -204,8 +204,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use astero_def use utils_lib, only: mv @@ -246,17 +246,17 @@ subroutine move(filename, extension) end subroutine move end subroutine extras_after_evolve - + integer function extras_check_model(id) integer, intent(in) :: id integer :: ierr type (star_info), pointer :: s - extras_check_model = keep_going + extras_check_model = keep_going ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + include 'formats' ! if you want to check multiple conditions, it can be useful @@ -281,8 +281,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -294,7 +294,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -305,8 +305,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -378,7 +378,7 @@ subroutine data_for_extra_profile_header_items(id, n, names, vals, ierr) ! vals(1) = s% mixing_length_alpha end subroutine data_for_extra_profile_header_items - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -390,8 +390,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/astero/test_suite/surface_effects/src/run_star_extras.f90 b/astero/test_suite/surface_effects/src/run_star_extras.f90 index 7ef21a241..2a52b29ec 100644 --- a/astero/test_suite/surface_effects/src/run_star_extras.f90 +++ b/astero/test_suite/surface_effects/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,9 +27,9 @@ module run_star_extras use const_def use math_lib use utils_lib, only: mesa_error - + implicit none - + include "test_suite_extras_def.inc" integer :: iounit @@ -37,13 +37,13 @@ module run_star_extras real(dp) :: target_p0, target_p1, target_s0, target_s1 real(dp), parameter :: perfect_tol = 1d-12 real(dp), parameter :: solar_tol = 1d1 - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) use astero_def, only: star_astero_procs integer, intent(in) :: id @@ -51,7 +51,7 @@ subroutine extras_controls(id, ierr) type (star_info), pointer :: s ierr = 0 call star_ptr(id, s, ierr) - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -59,11 +59,11 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns include 'set_star_astero_procs.inc' end subroutine extras_controls - + subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero code integer, intent(in) :: id character(len=strlen), intent(in) :: name @@ -90,8 +90,8 @@ subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero c end select end subroutine set_constraint_value - - + + subroutine set_param(id, name, val, ierr) ! called from star_astero code !use astero_search_data, only: vary_param1 integer, intent(in) :: id @@ -102,7 +102,7 @@ subroutine set_param(id, name, val, ierr) ! called from star_astero code ierr = 0 end subroutine set_param - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -116,7 +116,7 @@ subroutine extras_startup(id, restart, ierr) ! after the test case has run, targets can be generated by the ! Python script get_targets.py include 'targets.inc' - + end subroutine extras_startup @@ -134,13 +134,13 @@ subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr type (star_info), pointer :: s - + logical :: store_model, okay, ignore integer :: i, l real(dp) :: test_freq(0:3,max_nl) character(50) :: fmt - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return @@ -162,13 +162,13 @@ subroutine extras_after_evolve(id, ierr) end do ! save the data in case we need to recreate target values - + open(newunit=iounit, file='freqs.dat', status='replace', iostat=ierr) if (ierr /= 0) then write(*,*) 'failed to open iounit' call mesa_error(__FILE__,__LINE__) end if - + write(iounit, '(a5,4a26)') 'l', 'obs', 'obs_sigma', 'freq', 'inertia' fmt = '(i5,4es26.16)' @@ -279,7 +279,7 @@ subroutine extras_after_evolve(id, ierr) write(*,'(a)') '' if (okay) write(*,*) 'all tests are within tolerances' write(*,'(a)') '' - + call test_suite_after_evolve(s, ierr) contains @@ -325,7 +325,7 @@ logical function check_positive(name, val) end function check_positive end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -335,7 +335,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going if (.false. .and. s% star_mass_h1 < 0.35d0) then ! stop when star hydrogen mass drops to specified level extras_check_model = terminate @@ -355,8 +355,8 @@ integer function extras_check_model(id) ! by default, indicate where (in the code) MESA terminated if (extras_check_model == terminate) s% termination_code = t_extras_check_model end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id integer :: ierr @@ -366,8 +366,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -379,7 +379,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -390,8 +390,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -405,7 +405,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -417,7 +417,7 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras diff --git a/astero/work/src/run_star_extras.f90 b/astero/work/src/run_star_extras.f90 index a2922b203..d878e08b9 100644 --- a/astero/work/src/run_star_extras.f90 +++ b/astero/work/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,20 +19,20 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def use math_lib - + implicit none - + ! these routines are called by the standard run_star check_model contains - + subroutine extras_controls(id, ierr) use astero_def, only: star_astero_procs integer, intent(in) :: id @@ -59,7 +59,7 @@ subroutine extras_controls(id, ierr) include 'set_star_astero_procs.inc' end subroutine extras_controls - + subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero code use astero_def, only: Z_div_X_solar @@ -114,8 +114,8 @@ subroutine set_constraint_value(id, name, val, ierr) ! called from star_astero c end select end subroutine set_constraint_value - - + + subroutine set_param(id, name, val, ierr) ! called from star_astero code use astero_def, only: f0_ov_div_f_ov, Y_frac_he3, Z_div_X_solar, & Y_depends_on_Z, dYdZ, Y0 @@ -186,8 +186,8 @@ subroutine set_param(id, name, val, ierr) ! called from star_astero code end select end subroutine set_param - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -197,8 +197,8 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -207,17 +207,17 @@ subroutine extras_after_evolve(id, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine extras_after_evolve - + integer function extras_check_model(id) integer, intent(in) :: id integer :: ierr type (star_info), pointer :: s - extras_check_model = keep_going + extras_check_model = keep_going ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + include 'formats' ! if you want to check multiple conditions, it can be useful @@ -232,7 +232,7 @@ integer function extras_check_model(id) if (extras_check_model == terminate) s% termination_code = t_extras_check_model end function extras_check_model - + integer function how_many_extra_history_columns(id) integer, intent(in) :: id integer :: ierr @@ -242,8 +242,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -255,7 +255,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -266,8 +266,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -339,7 +339,7 @@ subroutine data_for_extra_profile_header_items(id, n, names, vals, ierr) ! vals(1) = s% mixing_length_alpha end subroutine data_for_extra_profile_header_items - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -351,6 +351,6 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras diff --git a/atm/private/atm_irradiated.f90 b/atm/private/atm_irradiated.f90 index fbdb3075b..0902beff7 100644 --- a/atm/private/atm_irradiated.f90 +++ b/atm/private/atm_irradiated.f90 @@ -25,7 +25,7 @@ ! *********************************************************************** module atm_irradiated - + ! Uses use const_def @@ -99,16 +99,16 @@ subroutine eval_irradiated( & real(dp) :: dlnkap_dlnT_P include 'formats' - + ierr = 0 - + ! Sanity checks if (L <= 0._dp .OR. R <= 0._dp .OR. M <= 0._dp) then ierr = -1 return endif - + ! Evaluate the 'interior' temperature & gravity call eval_Teff_g(L, R, M, cgrav, T_int, g) @@ -208,7 +208,7 @@ end subroutine eval_irradiated !**** ! Evaluate atmosphere data - + subroutine eval_data( & T_int, g, L, T_eq, P_surf, kap, kap_v, gamma, skip_partials, & tau, lnT, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, & @@ -265,7 +265,7 @@ subroutine eval_data( & ! Calculate the optical depth corresponding to P_surf tau = P_surf*kap/g - + ! Evaluate irradiation terms [cf. eq. 6 of Guillot & Havel (2011, ! A&A 527, A20)] @@ -287,7 +287,7 @@ subroutine eval_data( & T4_int = T_int*T_int*T_int*T_int T4_eq = T_eq*T_eq*T_eq*T_eq - + T4 = 0.75_dp*(T4_int*(tau + 2._dp/3._dp) + T4_eq*(f_1 + f_2 + 2._dp/3._dp)) lnT = 0.25_dp*log(T4) @@ -305,7 +305,7 @@ subroutine eval_data( & dlnT_dlnT_int = 0.75_dp*(tau + 2._dp/3._dp)*T4_int/T4 dlnT_dlntau = 0.75_dp*(T4_int + T4_eq*(df_1_dtau + df_2_dtau))*tau/(4._dp*T4) dlnT_dlnx = 0.75_dp*T4_eq*(df_1_dx + df_2_dx)*x/(4._dp*T4) - + dlnT_int_dlnL = 0.25_dp dlnT_int_dlnR = -0.5_dp dlnT_int_dlnM = 0._dp diff --git a/atm/private/atm_t_tau_relations.f90 b/atm/private/atm_t_tau_relations.f90 index 300aa6c02..c05826e36 100644 --- a/atm/private/atm_t_tau_relations.f90 +++ b/atm/private/atm_t_tau_relations.f90 @@ -87,7 +87,7 @@ end subroutine get_T_tau_base !**** subroutine eval_T_tau (id, tau, Teff, lnT, ierr) - + use atm_def, only: & ATM_T_TAU_EDDINGTON, & ATM_T_TAU_SOLAR_HOPF, & @@ -134,14 +134,14 @@ subroutine eval_Eddington (tau, Teff, lnT) real(dp) :: Teff4 real(dp) :: T4 - + ! Evaluate the Eddington T-tau relation Teff4 = Teff*Teff*Teff*Teff T4 = 0.75d0*Teff4*(tau + two_thirds) lnT = log(T4)*0.25d0 - + ! Finish return @@ -180,7 +180,7 @@ subroutine eval_solar_Hopf (tau, Teff, lnT) T4 = 0.75d0*Teff4*(tau + Q1 + Q2*e1 + Q4*e2) lnT = log(T4)*0.25d0 - + ! Finish return @@ -211,12 +211,12 @@ subroutine eval_Krishna_Swamy (tau, Teff, lnT) e1 = exp(-Q3*tau) e2 = exp(-Q5*tau) - + Teff4 = Teff*Teff*Teff*Teff T4 = 0.75d0*Teff4*(tau + Q1 + Q2*e1 + Q4*e2) lnT = log(T4)*0.25d0 - + ! Finish return @@ -265,7 +265,7 @@ end subroutine eval_Trampedach_solar !**** subroutine eval_T_tau_dq_dtau (id, tau, dq_dtau, ierr) - + use atm_def, only: & ATM_T_TAU_EDDINGTON, & ATM_T_TAU_SOLAR_HOPF, & @@ -311,7 +311,7 @@ subroutine eval_Eddington_dq_dtau (tau, dq_dtau) real(dp), intent(in) :: tau real(dp), intent(out) :: dq_dtau - + ! Evaluate the Eddington q'(τ) dq_dtau = 0.0_dp @@ -347,7 +347,7 @@ subroutine eval_solar_Hopf_dq_dtau (tau, dq_dtau) e2 = exp(-Q5*tau) dq_dtau = - Q2*Q3*e1 - Q4*Q5*e2 - + ! Finish return @@ -376,7 +376,7 @@ subroutine eval_Krishna_Swamy_dq_dtau (tau, dq_dtau) e2 = exp(-Q5*tau) dq_dtau = - Q2*Q3*e1 - Q4*Q5*e2 - + ! Finish return diff --git a/atm/private/atm_t_tau_uniform.f90 b/atm/private/atm_t_tau_uniform.f90 index d2ccf4d76..644df97a2 100644 --- a/atm/private/atm_t_tau_uniform.f90 +++ b/atm/private/atm_t_tau_uniform.f90 @@ -108,7 +108,7 @@ subroutine eval_T_tau_uniform( & real(dp) :: dlnT_dlnR_ real(dp) :: dlnP_dlnM_ real(dp) :: dlnT_dlnM_ - + include 'formats' ierr = 0 @@ -374,11 +374,11 @@ subroutine build_T_tau_uniform( & call dopri5( & NUM_VARS, build_fcn, lntau_surf, y, lntau_outer, & - dlntau, dlntau_max, MAX_STEPS, & - rtol, atol, 1, & - build_solout, IOUT, & - work, lwork, iwork, liwork, & - LRPAR, rpar, LIPAR, ipar, & + dlntau, dlntau_max, MAX_STEPS, & + rtol, atol, 1, & + build_solout, IOUT, & + work, lwork, iwork, liwork, & + LRPAR, rpar, LIPAR, ipar, & LOUT, idid) if (idid < 0) then write(*,*) 'atm: Call to dopri5 failed in build_T_tau_uniform: idid=', idid @@ -638,7 +638,7 @@ subroutine eval_data( & real(dp) :: dlnTeff_dL real(dp) :: dlnTeff_dlnR real(dp) :: dlnT_dlnTeff - + include 'formats' ierr = 0 @@ -670,7 +670,7 @@ subroutine eval_data( & call eval_T_tau(T_tau_id, tau, Teff, lnT, ierr) if (ierr /= 0) then - write(*,*) 'atm: Call to eval_T_tau failed in eval_data' + write(*,*) 'atm: Call to eval_T_tau failed in eval_data' return end if diff --git a/atm/private/atm_t_tau_varying.f90 b/atm/private/atm_t_tau_varying.f90 index db972a940..527154a8a 100644 --- a/atm/private/atm_t_tau_varying.f90 +++ b/atm/private/atm_t_tau_varying.f90 @@ -25,7 +25,7 @@ ! *********************************************************************** module atm_T_tau_varying - + ! Uses use const_def @@ -48,7 +48,7 @@ module atm_T_tau_varying contains ! Evaluate atmosphere data from T-tau relation with varying opacity - + subroutine eval_T_tau_varying( & tau_surf, L, R, M, cgrav, & T_tau_id, eos_proc, kap_proc, & @@ -102,9 +102,9 @@ subroutine eval_T_tau_varying( & real(dp) :: dlnP_dlnTeff ierr = 0 - + ! Sanity checks - + if (L <= 0._dp .OR. R <= 0._dp .OR. M <= 0._dp) then ierr = -1 return @@ -141,7 +141,7 @@ subroutine eval_T_tau_varying( & dlnP_dlnkap = 0._dp else - + ! Partials required, use finite differencing in Teff (we could ! in principle get dlnT_dlnTeff from the T-tau relation, but ! for consistency with dln_dlnTeff we use the same finite @@ -155,12 +155,12 @@ subroutine eval_T_tau_varying( & !$OMP SECTIONS !$OMP SECTION - + call eval_data( & tau_surf, exp(lnTeff), g, & T_tau_id, eos_proc, kap_proc, errtol, max_steps, & lnT, lnP, ierr) - + !$OMP SECTION call eval_data( & @@ -188,7 +188,7 @@ subroutine eval_T_tau_varying( & dlnTeff_dlnR = -0.5_dp dlnTeff_dL = 0.25_dp/L - + dlnT_dlnTeff = (lnT_p - lnT_m) / (lnTeff_p - lnTeff_m) dlnT_dL = dlnT_dlnTeff*dlnTeff_dL dlnT_dlnR = dlnT_dlnTeff*dlnTeff_dlnR @@ -202,7 +202,7 @@ subroutine eval_T_tau_varying( & dlnP_dlnkap = 0._dp endif - + ! Finish return @@ -210,9 +210,9 @@ subroutine eval_T_tau_varying( & end subroutine eval_T_tau_varying !**** - + ! Evaluate atmosphere data from T-tau relation with varying opacity - + subroutine eval_data( & tau_surf, Teff, g, & T_tau_id, eos_proc, kap_proc, errtol, max_steps, & @@ -322,7 +322,7 @@ subroutine eval_data_try( & integer :: idid ierr = 0 - + ! Allocate work arrays for the integrator call dopri5_work_sizes(NUM_VARS, NRDENS, liwork, lwork) @@ -346,20 +346,20 @@ subroutine eval_data_try( & ! Pgas from low-density ideal gas law) lnTeff = log(Teff) - + call eval_T_tau(T_tau_id, tau_outer, Teff, lnT, ierr) if (ierr /= 0) then write(*,*) 'atm: Call to eval_T_tau failed in eval_data_try' return end if - + T_outer = exp(lnT) Pgas_outer = cgas*RHO_OUTER*T_outer P_outer = Pgas_outer + radiation_pressure(T_outer) lnP = log(P_outer) y(1) = lnP - + ! Integrate inward from tau_outer to tau_surf lntau_outer = log(tau_outer) @@ -372,11 +372,11 @@ subroutine eval_data_try( & call dopri5( & NUM_VARS, eval_fcn, lntau_outer, y, lntau_surf, & - dlntau, DLNTAU_MAX, max_steps, & - rtol, atol, 1, & - eval_solout, IOUT, & - work, lwork, iwork, liwork, & - LRPAR, rpar, LIPAR, ipar, & + dlntau, DLNTAU_MAX, max_steps, & + rtol, atol, 1, & + eval_solout, IOUT, & + work, lwork, iwork, liwork, & + LRPAR, rpar, LIPAR, ipar, & LOUT, idid) if (idid < 0) then write(*,*) 'Call to dopri5 failed in eval_data_try: idid=', idid @@ -387,7 +387,7 @@ subroutine eval_data_try( & ! Store the final pressure and temperature lnP = y(1) - + call eval_T_tau(T_tau_id, tau_surf, Teff, lnT, ierr) if (ierr /= 0) then write(*,*) 'atm: Call to eval_T_tau failed in eval_data_try' @@ -463,7 +463,7 @@ subroutine eval_fcn(n, x, h, y, f, lr, rpar, li, ipar, ierr) write(*,*) 'atm: Call to kap_proc failed in eval_fcn' return end if - + ! Set up the rhs for the hydrostatic eqm equation ! dlnP/dlntau = tau*g/P*kappa @@ -633,11 +633,11 @@ subroutine build_T_tau_varying( & call dopri5( & NUM_VARS, build_fcn, lntau_surf, y, lntau_outer, & - dlntau, dlntau_max, MAX_STEPS, & - rtol, atol, 1, & - build_solout, IOUT, & - work, lwork, iwork, liwork, & - LRPAR, rpar, LIPAR, ipar, & + dlntau, dlntau_max, MAX_STEPS, & + rtol, atol, 1, & + build_solout, IOUT, & + work, lwork, iwork, liwork, & + LRPAR, rpar, LIPAR, ipar, & LOUT, idid) if (idid < 0) then write(*,*) 'atm: Call to dopri5 failed in build_T_tau_varying: idid=', idid @@ -688,7 +688,7 @@ subroutine build_fcn(n, x, h, y, f, lr, rpar, li, ipar, ierr) ! Set up the rhs for the optical depth and hydrostatic ! equilibrium equations ! dr/dlntau = -tau/(kappa*rho) - ! + ! tau = exp(x) P = exp(y(2)) @@ -822,7 +822,7 @@ subroutine build_data(lntau, delta_r, lnP, atm_structure_sgl, ierr) write(*,*) 'atm: Call to kap_proc failed in build_data' return end if - + ! Evaluate radiative temperature gradient gradr = eval_Paczynski_gradr(exp(lnT), exp(lnP), exp(lnRho), tau, kap, L, M, R, cgrav) diff --git a/atm/private/atm_table.f90 b/atm/private/atm_table.f90 index 68b985405..25032198a 100644 --- a/atm/private/atm_table.f90 +++ b/atm/private/atm_table.f90 @@ -25,7 +25,7 @@ ! *********************************************************************** module atm_table - + ! Uses use const_def @@ -147,7 +147,7 @@ subroutine eval_table( & ! Set up partials if (.NOT. skip_partials) then - + dlnTeff_dlnR = -0.5_dp dlnTeff_dL = 0.25_dp/L dTeff_dlnR = Teff*dlnTeff_dlnR @@ -183,7 +183,7 @@ subroutine eval_table( & dlnP_dlnR = 0._dp dlnP_dlnM = 0._dp dlnP_dlnkap = 0._dp - + dlnT_dL = 0._dp dlnT_dlnR = 0._dp dlnT_dlnM = 0._dp @@ -210,7 +210,7 @@ subroutine eval_table( & end subroutine eval_table !**** - + subroutine get_table_alfa_beta( & L, Teff, R, M, cgrav, id, alfa, beta, ierr) @@ -418,7 +418,7 @@ subroutine get_table_alfa_beta( & alfa = min(1d0, sqrt(c_dx*c_dx + c_dy*c_dy)) beta = 1 - alfa case default - write(*,*) 'Invalid iregion in get_table_alfa_beta:', iregion + write(*,*) 'Invalid iregion in get_table_alfa_beta:', iregion call mesa_error(__FILE__,__LINE__) end select diff --git a/atm/private/atm_utils.f90 b/atm/private/atm_utils.f90 index 3ce656813..a4ef0e082 100644 --- a/atm/private/atm_utils.f90 +++ b/atm/private/atm_utils.f90 @@ -103,7 +103,7 @@ subroutine eval_Teff_g(L, R, M, cgrav, Teff, g) ! Evaluate the effective temperature and surface gravity Teff = pow(L/(4._dp*pi*R*R*boltz_sigma), 0.25_dp) - + g = cgrav * M / (R*R) end subroutine eval_Teff_g @@ -114,7 +114,7 @@ function eval_Paczynski_gradr( & T, P, rho, tau, kap, L, M, R, cgrav) result (gradr) use eos_lib, only: radiation_pressure - + real(dp), intent(in) :: T real(dp), intent(in) :: P real(dp), intent(in) :: rho @@ -125,7 +125,7 @@ function eval_Paczynski_gradr( & real(dp), intent(in) :: M real(dp), intent(in) :: cgrav real(dp) :: gradr - + real(dp) :: Prad real(dp) :: dilution_factor real(dp) :: s @@ -159,7 +159,7 @@ function eval_Paczynski_gradr( & return end function eval_Paczynski_gradr - + !**** subroutine eval_E2(x, E2, dE2_dx, ierr) @@ -195,9 +195,9 @@ subroutine eval_E2(x, E2, dE2_dx, ierr) dE2_dx = slope*ln10*E2 end subroutine eval_E2 - + !**** - + subroutine create_E2_interpolant(ierr) use interp_1d_lib diff --git a/atm/private/table_atm.f90 b/atm/private/table_atm.f90 index 0f83e86f3..8dbe5c64e 100644 --- a/atm/private/table_atm.f90 +++ b/atm/private/table_atm.f90 @@ -29,7 +29,7 @@ module table_atm use const_def, only: dp use math_lib use utils_lib, only: mesa_error - + implicit none @@ -40,23 +40,23 @@ module table_atm - !reads in table_summary file from atm_data, initializes logZ, Teff_array, + !reads in table_summary file from atm_data, initializes logZ, Teff_array, ! logg_array, and Teff_bound arrays; sets some flags subroutine table_atm_init(use_cache, ierr) implicit none logical, intent(in) :: use_cache integer, intent(out) :: ierr - + integer :: nZ, ng, nT, i, j, iounit integer, pointer :: ibound(:,:), tmp_version(:) character(len=256) :: filename - + if (table_atm_is_initialized) call table_atm_shutdown() - + ierr = 0 call load_table_summary(ATM_TABLE_PHOTOSPHERE, 'table_summary.txt', ai_two_thirds, ierr) - if (ierr /= 0) return + if (ierr /= 0) return call load_table_summary(ATM_TABLE_TAU_100, 'table100_summary.txt', ai_100, ierr) if (ierr /= 0) return call load_table_summary(ATM_TABLE_TAU_10, 'table10_summary.txt', ai_10, ierr) @@ -69,29 +69,29 @@ subroutine table_atm_init(use_cache, ierr) if (ierr /= 0) return call load_table_summary(ATM_TABLE_DB_WD_TAU_25, 'table_db_wd_25_summary.txt', ai_db_wd_25, ierr) if (ierr /= 0) return - + table_atm_is_initialized = .true. - - + + contains - - + + subroutine load_table_summary(id, fname, ai, ierr) use const_def, only: mesa_data_dir integer, intent(in) :: id character(len=*), intent(in) :: fname type(atm_info), intent(inout) :: ai integer, intent(out) :: ierr - + real(dp), target :: vec_ary(20) real(dp), pointer :: vec(:) vec => vec_ary - + filename = trim(mesa_data_dir)//'/atm_data/' // trim(fname) - + if (dbg) write(*,*) 'read ' // trim(filename) - + open(newunit=iounit,file=trim(filename),action='read',status='old',iostat=ierr) if (ierr/= 0) then write(*,*) 'table_atm_init: missing atm data' @@ -111,7 +111,7 @@ subroutine load_table_summary(id, fname, ai, ierr) !read first line and (nZ, nT, ng) read(iounit,*) !first line is text, skip it read(iounit,*) nZ, nT, ng - + ai% nZ = nZ ai% nT = nT ai% ng = ng @@ -122,7 +122,7 @@ subroutine load_table_summary(id, fname, ai, ierr) ai% logZ(nZ), ai% alphaFe(nZ), & ai% Pgas_interp1(4*ng*nT*nZ), ai% T_interp1(4*ng*nT*nZ), & ai% have_atm_table(nZ), ai% atm_mix(nZ), ai% table_atm_files(nZ)) - + ai% Pgas_interp(1:4,1:ng,1:nT,1:nZ) => ai% Pgas_interp1(1:4*ng*nT*nZ) ai% T_interp(1:4,1:ng,1:nT,1:nZ) => ai% T_interp1(1:4*ng*nT*nZ) @@ -145,7 +145,7 @@ subroutine load_table_summary(id, fname, ai, ierr) !read logg_array read(iounit,*) !text read(iounit,3) ai% logg_array(:) - + close(iounit) 1 format(13x,f5.2,8x,f4.1,1x,a8,1x,15x,99i4) @@ -159,13 +159,13 @@ subroutine load_table_summary(id, fname, ai, ierr) ai% Teff_bound(i) = min( ai% Teff_bound(i) , ai% Teff_array(ibound(i,j)) ) enddo enddo - - + + if (dbg) write(*,*) 'ai% logg_array(:)', ai% logg_array(:) deallocate(ibound, tmp_version) - + end subroutine load_table_summary @@ -175,7 +175,7 @@ end subroutine table_atm_init subroutine table_atm_shutdown() if (.NOT. table_atm_is_initialized) return - + call free_table_summary(ai_two_thirds) call free_table_summary(ai_100) call free_table_summary(ai_10) @@ -197,12 +197,12 @@ subroutine free_table_summary(ai) ai% logZ, ai% alphaFe, & ai% Pgas_interp1, ai% T_interp1, & ai% have_atm_table, ai% atm_mix, ai% table_atm_files) - + end subroutine free_table_summary end subroutine table_atm_shutdown - + !interpolate in Z, logg, & Teff: 4pt in Z; bicubic spline in Teff,logg subroutine get_table_values( & id, newZ, newlogg_in, newTeff_in, & @@ -214,9 +214,9 @@ subroutine get_table_values( & use interp_1d_def use interp_2d_lib_db, only: interp_evbicub_db use utils_lib, only: is_bad - + implicit none - + integer, intent(in) :: id real(dp), intent(in) :: newZ, newlogg_in, newTeff_in real(dp), intent(out) :: newPgas, dPgas_dTeff, dPgas_dlogg @@ -233,14 +233,14 @@ subroutine get_table_values( & logical :: clip_Teff, clip_logg, gtv_dbg type (Atm_Info), pointer :: ai - + include 'formats' - + gtv_dbg = dbg - + fZ1 => fZ1_ary fZ(1:4,1:4) => fZ1(1:4*4) - + ierr = 0 work => work_ary @@ -273,11 +273,11 @@ subroutine get_table_values( & ierr = -1 return end select - + nZ = ai% nZ nT = ai% nT ng = ai% ng - + clip_Teff = .false. if (newTeff_in < ai% Teff_array(1)) then newTeff = ai% Teff_array(1) ! clip to table in T @@ -288,7 +288,7 @@ subroutine get_table_values( & else newTeff = newTeff_in end if - + clip_logg = .false. if (newlogg_in < ai% logg_array(1)) then newlogg = ai% logg_array(1) ! clip to table in logg @@ -351,7 +351,7 @@ subroutine get_table_values( & end if if (clip_logg) dPgas_dlogg = 0 if (clip_Teff) dPgas_dTeff = 0 - + if (id == ATM_TABLE_PHOTOSPHERE) then newT = newTeff if (clip_Teff) then @@ -360,7 +360,7 @@ subroutine get_table_values( & dT_dTeff = 1 end if dT_dlogg = 0 - return + return end if if (gtv_dbg) write(*,*) 'do_interp for Temp', id @@ -371,7 +371,7 @@ subroutine get_table_values( & end if if (clip_logg) dT_dlogg = 0 if (clip_Teff) dT_dTeff = 0 - + if (dbg .or. is_bad(newPgas) .or. is_bad(newT)) then write(*,1) 'newPgas', newPgas write(*,1) 'dPgas_dTeff', dPgas_dTeff @@ -385,9 +385,9 @@ subroutine get_table_values( & return !if (is_bad(newPgas) .or. is_bad(newT)) call mesa_error(__FILE__,__LINE__,'get_table_values') end if - + !if (dbg) write(*,*) 'loaded tables: ', ai% have_atm_table(:) - + deallocate(result_2D) contains @@ -396,15 +396,15 @@ subroutine do_interp(f1, newval, dval_dlogg, dval_dTeff, ierr) real(dp), dimension(:), pointer :: f1 real(dp), intent(out) :: newval, dval_dlogg, dval_dTeff integer, intent(out) :: ierr - + real(dp) :: res(6) integer :: j real(dp), pointer :: f(:) - + include 'formats' - + ierr = 0 - + do i = Zlo, Zhi if (.not. ai% have_atm_table(i)) then call load_atm_table(i,ierr) !<-load on demand @@ -413,11 +413,11 @@ subroutine do_interp(f1, newval, dval_dlogg, dval_dTeff, ierr) if (gtv_dbg) write(*,*) 'load_atm_table failed' return end if - + f(1:4*ng*nT) => f1(1+4*ng*nT*(i-1):4*ng*nT*i) call interp_evbicub_db(newlogg, newTeff, ai% logg_array, ng, ai% Teff_array, nT, & ai% iling, ai% ilinT, f, ng, ict, res, ierr) - do j=1,6 + do j=1,6 result_2D(j,i) = res(j) end do if (ierr /= 0) then @@ -439,13 +439,13 @@ subroutine do_interp(f1, newval, dval_dlogg, dval_dTeff, ierr) enddo ! now we have val, dval_dTeff, and dval_dlogg in result_2D for each Z - + if (numZs == 1) then - + newval = result_2D(1,Zlo) dval_dlogg = result_2D(2,Zlo) dval_dTeff = result_2D(3,Zlo) - + else ! Z interpolation fZ(1,1:numZs) = result_2D(1,Zlo:Zhi) @@ -486,9 +486,9 @@ subroutine do_interp(f1, newval, dval_dlogg, dval_dTeff, ierr) return end if dval_dTeff = result_Z(1) - + end if - + end subroutine do_interp @@ -530,7 +530,7 @@ subroutine load_atm_table(iZ,ierr) write(*,'(A)') call mesa_error(__FILE__,__LINE__) endif - + read(iounit,'(14x,i4)',iostat=ierr) text_file_version if (failed(1)) return if (text_file_version /= table_atm_version) then @@ -550,7 +550,7 @@ subroutine load_atm_table(iZ,ierr) write(*,'(A)') call mesa_error(__FILE__,__LINE__) endif - + ibound_tmp = -1 read(iounit,1,iostat=ierr) ai% logZ(iZ), ai% alphaFe(iZ), ai% atm_mix(iZ), ibound_tmp(1:ng) if (ierr /= 0) then @@ -589,10 +589,10 @@ subroutine load_atm_table(iZ,ierr) Teff_tmp(j) = vec(1) do i=1,ng data_tmp(i,j) = vec(i+1) - end do + end do enddo ai% Pgas_interp(1,:,:,iZ) = data_tmp(:,:) - + if (ai% id /= ATM_TABLE_PHOTOSPHERE) then ! read T read(iounit,2,iostat=ierr) ! skip line if (failed(5)) return @@ -609,10 +609,10 @@ subroutine load_atm_table(iZ,ierr) Teff_tmp(j) = vec(1) do i=1,ng data_tmp(i,j) = vec(i+1) - end do + end do enddo ai% T_interp(1,:,:,iZ) = data_tmp(:,:) - end if + end if close(iounit) @@ -649,7 +649,7 @@ subroutine load_atm_table(iZ,ierr) do i=1,ng ai% Teff_bound(i) = min( ai% Teff_bound(i), Teff_tmp(ibound_tmp(i)) ) enddo - + ! use "not a knot" bc's ibcTmin = 0; bcTmin(:) = 0d0 ibcTmax = 0; bcTmax(:) = 0d0 @@ -665,7 +665,7 @@ subroutine load_atm_table(iZ,ierr) if (gtv_dbg) write(*,*) 'interp_mkbicub_db failed for Pgas_interp' return end if - + if (ai% id /= ATM_TABLE_PHOTOSPHERE) then f1(1:4*ng*nT) => ai% T_interp1(1+4*ng*nT*(iZ-1):4*ng*nT*iZ) call interp_mkbicub_db(ai% logg_array, ng, ai% Teff_array, nT, & @@ -679,10 +679,10 @@ subroutine load_atm_table(iZ,ierr) !this file has been loaded and processed ai% have_atm_table(iZ) = .true. - + end subroutine load_atm_table - - + + logical function failed(i) integer, intent(in) :: i failed = (ierr /= 0) @@ -692,7 +692,7 @@ logical function failed(i) !call mesa_error(__FILE__,__LINE__,'get_table_values') end if end function failed - + end subroutine get_table_values diff --git a/atm/public/atm_def.f90 b/atm/public/atm_def.f90 index 804edb2ed..1e19307ad 100644 --- a/atm/public/atm_def.f90 +++ b/atm/public/atm_def.f90 @@ -52,7 +52,7 @@ module atm_def integer, parameter :: ATM_TABLE_PHOTOSPHERE = 104 integer, parameter :: ATM_TABLE_WD_TAU_25 = 105 integer, parameter :: ATM_TABLE_DB_WD_TAU_25 = 106 - + integer, parameter :: table_atm_version = 5 ! Atmosphere structure info @@ -77,7 +77,7 @@ module atm_def integer, parameter :: atm_tau = atm_lnPgas+1 integer, parameter :: atm_gradr = atm_tau+1 - integer, parameter :: num_results_for_build_atm = atm_gradr + integer, parameter :: num_results_for_build_atm = atm_gradr ! Derived-type definitions @@ -139,7 +139,7 @@ subroutine atm_eos_iface( & end subroutine atm_eos_iface ! Callback routine for opacity evaluation - + subroutine atm_kap_iface( & lnRho, lnT, res, dres_dlnRho, dres_dlnT, & kap, dlnkap_dlnRho, dlnkap_dlnT, & diff --git a/atm/public/atm_lib.f90 b/atm/public/atm_lib.f90 index 662750aa5..713b365cf 100644 --- a/atm/public/atm_lib.f90 +++ b/atm/public/atm_lib.f90 @@ -27,7 +27,7 @@ module atm_lib ! Uses - + use const_def, only: dp use atm_utils, only: & @@ -51,7 +51,7 @@ module atm_lib use atm_irradiated, only: & atm_eval_irradiated => eval_irradiated - + ! No implicit typing implicit none @@ -102,6 +102,6 @@ real(dp) function atm_black_body_T(L, R) real(dp), intent(in) :: L, R atm_black_body_T = pow(L / (4d0*pi*R*R*boltz_sigma), 0.25d0) end function atm_black_body_T - + end module atm_lib diff --git a/auto_diff/private/auto_diff_real_15var_order1_module.f90 b/auto_diff/private/auto_diff_real_15var_order1_module.f90 index 06da648a3..ba61ee0d3 100644 --- a/auto_diff/private/auto_diff_real_15var_order1_module.f90 +++ b/auto_diff/private/auto_diff_real_15var_order1_module.f90 @@ -3,7 +3,7 @@ module auto_diff_real_15var_order1_module use utils_lib use support_functions use math_lib - + implicit none private public :: auto_diff_real_15var_order1, & @@ -54,13 +54,13 @@ module auto_diff_real_15var_order1_module real(dp) :: val real(dp) :: d1Array(15) end type auto_diff_real_15var_order1 - + interface assignment(=) module procedure assign_from_self module procedure assign_from_real_dp module procedure assign_from_int end interface assignment(=) - + interface operator(.eq.) module procedure equal_self module procedure equal_auto_diff_real_15var_order1_real_dp @@ -68,7 +68,7 @@ module auto_diff_real_15var_order1_module module procedure equal_auto_diff_real_15var_order1_int module procedure equal_int_auto_diff_real_15var_order1 end interface operator(.eq.) - + interface operator(.ne.) module procedure neq_self module procedure neq_auto_diff_real_15var_order1_real_dp @@ -76,7 +76,7 @@ module auto_diff_real_15var_order1_module module procedure neq_auto_diff_real_15var_order1_int module procedure neq_int_auto_diff_real_15var_order1 end interface operator(.ne.) - + interface operator(.gt.) module procedure greater_self module procedure greater_auto_diff_real_15var_order1_real_dp @@ -84,7 +84,7 @@ module auto_diff_real_15var_order1_module module procedure greater_auto_diff_real_15var_order1_int module procedure greater_int_auto_diff_real_15var_order1 end interface operator(.gt.) - + interface operator(.lt.) module procedure less_self module procedure less_auto_diff_real_15var_order1_real_dp @@ -92,7 +92,7 @@ module auto_diff_real_15var_order1_module module procedure less_auto_diff_real_15var_order1_int module procedure less_int_auto_diff_real_15var_order1 end interface operator(.lt.) - + interface operator(.le.) module procedure leq_self module procedure leq_auto_diff_real_15var_order1_real_dp @@ -100,7 +100,7 @@ module auto_diff_real_15var_order1_module module procedure leq_auto_diff_real_15var_order1_int module procedure leq_int_auto_diff_real_15var_order1 end interface operator(.le.) - + interface operator(.ge.) module procedure geq_self module procedure geq_auto_diff_real_15var_order1_real_dp @@ -108,119 +108,119 @@ module auto_diff_real_15var_order1_module module procedure geq_auto_diff_real_15var_order1_int module procedure geq_int_auto_diff_real_15var_order1 end interface operator(.ge.) - + interface make_unop module procedure make_unary_operator end interface make_unop - + interface make_binop module procedure make_binary_operator end interface make_binop - + interface operator(-) module procedure unary_minus_self end interface operator(-) - + interface exp module procedure exp_self end interface exp - + interface log module procedure log_self end interface log - + interface safe_log module procedure safe_log_self end interface safe_log - + interface log10 module procedure log10_self end interface log10 - + interface safe_log10 module procedure safe_log10_self end interface safe_log10 - + interface sin module procedure sin_self end interface sin - + interface cos module procedure cos_self end interface cos - + interface tan module procedure tan_self end interface tan - + interface sinh module procedure sinh_self end interface sinh - + interface cosh module procedure cosh_self end interface cosh - + interface tanh module procedure tanh_self end interface tanh - + interface asin module procedure asin_self end interface asin - + interface acos module procedure acos_self end interface acos - + interface atan module procedure atan_self end interface atan - + interface asinh module procedure asinh_self end interface asinh - + interface acosh module procedure acosh_self end interface acosh - + interface atanh module procedure atanh_self end interface atanh - + interface sqrt module procedure sqrt_self end interface sqrt - + interface pow2 module procedure pow2_self end interface pow2 - + interface pow3 module procedure pow3_self end interface pow3 - + interface pow4 module procedure pow4_self end interface pow4 - + interface pow5 module procedure pow5_self end interface pow5 - + interface pow6 module procedure pow6_self end interface pow6 - + interface pow7 module procedure pow7_self end interface pow7 - + interface abs module procedure abs_self end interface abs - + interface operator(+) module procedure add_self module procedure add_self_real @@ -228,7 +228,7 @@ module auto_diff_real_15var_order1_module module procedure add_self_int module procedure add_int_self end interface operator(+) - + interface operator(-) module procedure sub_self module procedure sub_self_real @@ -236,7 +236,7 @@ module auto_diff_real_15var_order1_module module procedure sub_self_int module procedure sub_int_self end interface operator(-) - + interface operator(*) module procedure mul_self module procedure mul_self_real @@ -244,7 +244,7 @@ module auto_diff_real_15var_order1_module module procedure mul_self_int module procedure mul_int_self end interface operator(*) - + interface operator(/) module procedure div_self module procedure div_self_real @@ -252,7 +252,7 @@ module auto_diff_real_15var_order1_module module procedure div_self_int module procedure div_int_self end interface operator(/) - + interface operator(**) module procedure pow_self module procedure pow_self_real @@ -260,7 +260,7 @@ module auto_diff_real_15var_order1_module module procedure pow_self_int module procedure pow_int_self end interface operator(**) - + interface max module procedure max_self module procedure max_self_real @@ -268,7 +268,7 @@ module auto_diff_real_15var_order1_module module procedure max_self_int module procedure max_int_self end interface max - + interface min module procedure min_self module procedure min_self_real @@ -276,7 +276,7 @@ module auto_diff_real_15var_order1_module module procedure min_self_int module procedure min_int_self end interface min - + interface dim module procedure dim_self module procedure dim_self_real @@ -284,7 +284,7 @@ module auto_diff_real_15var_order1_module module procedure dim_self_int module procedure dim_int_self end interface dim - + interface pow module procedure pow_self module procedure pow_self_real @@ -292,7 +292,7 @@ module auto_diff_real_15var_order1_module module procedure pow_self_int module procedure pow_int_self end interface pow - + contains subroutine assign_from_self(this, other) @@ -301,231 +301,231 @@ subroutine assign_from_self(this, other) this%val = other%val this%d1Array = other%d1Array end subroutine assign_from_self - + subroutine assign_from_real_dp(this, other) type(auto_diff_real_15var_order1), intent(out) :: this real(dp), intent(in) :: other this%val = other this%d1Array = 0.0_dp end subroutine assign_from_real_dp - + subroutine assign_from_int(this, other) type(auto_diff_real_15var_order1), intent(out) :: this integer, intent(in) :: other this%val = other this%d1Array = 0.0_dp end subroutine assign_from_int - + function equal_self(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this%val .eq. other%val) end function equal_self - + function equal_auto_diff_real_15var_order1_real_dp(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_15var_order1_real_dp - + function equal_real_dp_auto_diff_real_15var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_real_dp_auto_diff_real_15var_order1 - + function equal_auto_diff_real_15var_order1_int(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_15var_order1_int - + function equal_int_auto_diff_real_15var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_int_auto_diff_real_15var_order1 - + function neq_self(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this%val .ne. other%val) end function neq_self - + function neq_auto_diff_real_15var_order1_real_dp(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_15var_order1_real_dp - + function neq_real_dp_auto_diff_real_15var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_real_dp_auto_diff_real_15var_order1 - + function neq_auto_diff_real_15var_order1_int(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_15var_order1_int - + function neq_int_auto_diff_real_15var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_int_auto_diff_real_15var_order1 - + function greater_self(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this%val .gt. other%val) end function greater_self - + function greater_auto_diff_real_15var_order1_real_dp(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_15var_order1_real_dp - + function greater_real_dp_auto_diff_real_15var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_real_dp_auto_diff_real_15var_order1 - + function greater_auto_diff_real_15var_order1_int(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_15var_order1_int - + function greater_int_auto_diff_real_15var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_int_auto_diff_real_15var_order1 - + function less_self(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this%val .lt. other%val) end function less_self - + function less_auto_diff_real_15var_order1_real_dp(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_15var_order1_real_dp - + function less_real_dp_auto_diff_real_15var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_real_dp_auto_diff_real_15var_order1 - + function less_auto_diff_real_15var_order1_int(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_15var_order1_int - + function less_int_auto_diff_real_15var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_int_auto_diff_real_15var_order1 - + function leq_self(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this%val .le. other%val) end function leq_self - + function leq_auto_diff_real_15var_order1_real_dp(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_15var_order1_real_dp - + function leq_real_dp_auto_diff_real_15var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_real_dp_auto_diff_real_15var_order1 - + function leq_auto_diff_real_15var_order1_int(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_15var_order1_int - + function leq_int_auto_diff_real_15var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_int_auto_diff_real_15var_order1 - + function geq_self(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this%val .ge. other%val) end function geq_self - + function geq_auto_diff_real_15var_order1_real_dp(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_15var_order1_real_dp - + function geq_real_dp_auto_diff_real_15var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_real_dp_auto_diff_real_15var_order1 - + function geq_auto_diff_real_15var_order1_int(this, other) result(z) type(auto_diff_real_15var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_15var_order1_int - + function geq_int_auto_diff_real_15var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_15var_order1), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_int_auto_diff_real_15var_order1 - + function make_unary_operator(x, z_val, z_d1x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x real(dp), intent(in) :: z_val @@ -534,7 +534,7 @@ function make_unary_operator(x, z_val, z_d1x) result(unary) unary%val = z_val unary%d1Array(1:15) = x%d1Array(1:15)*z_d1x end function make_unary_operator - + function make_binary_operator(x, y, z_val, z_d1x, z_d1y) result(binary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1), intent(in) :: y @@ -545,14 +545,14 @@ function make_binary_operator(x, y, z_val, z_d1x, z_d1y) result(binary) binary%val = z_val binary%d1Array(1:15) = x%d1Array(1:15)*z_d1x + y%d1Array(1:15)*z_d1y end function make_binary_operator - + function unary_minus_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = -x%val unary%d1Array(1:15) = -x%d1Array(1:15) end function unary_minus_self - + function exp_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary @@ -561,21 +561,21 @@ function exp_self(x) result(unary) unary%val = q0 unary%d1Array(1:15) = q0*x%d1Array(1:15) end function exp_self - + function log_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = log(x%val) unary%d1Array(1:15) = x%d1Array(1:15)*powm1(x%val) end function log_self - + function safe_log_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = safe_log(x%val) unary%d1Array(1:15) = x%d1Array(1:15)*powm1(x%val) end function safe_log_self - + function log10_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary @@ -584,7 +584,7 @@ function log10_self(x) result(unary) unary%val = q0*log(x%val) unary%d1Array(1:15) = q0*x%d1Array(1:15)*powm1(x%val) end function log10_self - + function safe_log10_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary @@ -593,91 +593,91 @@ function safe_log10_self(x) result(unary) unary%val = q0*safe_log(x%val) unary%d1Array(1:15) = q0*x%d1Array(1:15)*powm1(x%val) end function safe_log10_self - + function sin_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = sin(x%val) unary%d1Array(1:15) = x%d1Array(1:15)*cos(x%val) end function sin_self - + function cos_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = cos(x%val) unary%d1Array(1:15) = -x%d1Array(1:15)*sin(x%val) end function cos_self - + function tan_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = tan(x%val) unary%d1Array(1:15) = x%d1Array(1:15)*powm1(pow2(cos(x%val))) end function tan_self - + function sinh_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = sinh(x%val) unary%d1Array(1:15) = x%d1Array(1:15)*cosh(x%val) end function sinh_self - + function cosh_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = cosh(x%val) unary%d1Array(1:15) = x%d1Array(1:15)*sinh(x%val) end function cosh_self - + function tanh_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = tanh(x%val) unary%d1Array(1:15) = x%d1Array(1:15)*powm1(pow2(cosh(x%val))) end function tanh_self - + function asin_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = asin(x%val) unary%d1Array(1:15) = x%d1Array(1:15)*powm1(sqrt(1 - pow2(x%val))) end function asin_self - + function acos_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = acos(x%val) unary%d1Array(1:15) = -x%d1Array(1:15)*powm1(sqrt(1 - pow2(x%val))) end function acos_self - + function atan_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = atan(x%val) unary%d1Array(1:15) = x%d1Array(1:15)*powm1(pow2(x%val) + 1) end function atan_self - + function asinh_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = asinh(x%val) unary%d1Array(1:15) = x%d1Array(1:15)*powm1(sqrt(pow2(x%val) + 1)) end function asinh_self - + function acosh_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = acosh(x%val) unary%d1Array(1:15) = x%d1Array(1:15)*powm1(sqrt(pow2(x%val) - 1)) end function acosh_self - + function atanh_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = atanh(x%val) unary%d1Array(1:15) = -x%d1Array(1:15)*powm1(pow2(x%val) - 1) end function atanh_self - + function sqrt_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary @@ -686,56 +686,56 @@ function sqrt_self(x) result(unary) unary%val = q0 unary%d1Array(1:15) = 0.5_dp*x%d1Array(1:15)*powm1(q0) end function sqrt_self - + function pow2_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = pow2(x%val) unary%d1Array(1:15) = 2*x%d1Array(1:15)*x%val end function pow2_self - + function pow3_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = pow3(x%val) unary%d1Array(1:15) = 3*x%d1Array(1:15)*pow2(x%val) end function pow3_self - + function pow4_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = pow4(x%val) unary%d1Array(1:15) = 4*x%d1Array(1:15)*pow3(x%val) end function pow4_self - + function pow5_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = pow5(x%val) unary%d1Array(1:15) = 5*x%d1Array(1:15)*pow4(x%val) end function pow5_self - + function pow6_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = pow6(x%val) unary%d1Array(1:15) = 6*x%d1Array(1:15)*pow5(x%val) end function pow6_self - + function pow7_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = pow7(x%val) unary%d1Array(1:15) = 7*x%d1Array(1:15)*pow6(x%val) end function pow7_self - + function abs_self(x) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1) :: unary unary%val = Abs(x%val) unary%d1Array(1:15) = x%d1Array(1:15)*sgn(x%val) end function abs_self - + function add_self(x, y) result(binary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1), intent(in) :: y @@ -743,7 +743,7 @@ function add_self(x, y) result(binary) binary%val = x%val + y%val binary%d1Array(1:15) = x%d1Array(1:15) + y%d1Array(1:15) end function add_self - + function add_self_real(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -751,7 +751,7 @@ function add_self_real(x, y) result(unary) unary%val = x%val + y unary%d1Array(1:15) = x%d1Array(1:15) end function add_self_real - + function add_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -759,7 +759,7 @@ function add_real_self(z, x) result(unary) unary%val = x%val + z unary%d1Array(1:15) = x%d1Array(1:15) end function add_real_self - + function add_self_int(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x integer, intent(in) :: y @@ -769,7 +769,7 @@ function add_self_int(x, y) result(unary) unary%val = x%val + y_dp unary%d1Array(1:15) = x%d1Array(1:15) end function add_self_int - + function add_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -779,7 +779,7 @@ function add_int_self(z, x) result(unary) unary%val = x%val + y_dp unary%d1Array(1:15) = x%d1Array(1:15) end function add_int_self - + function sub_self(x, y) result(binary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1), intent(in) :: y @@ -787,7 +787,7 @@ function sub_self(x, y) result(binary) binary%val = x%val - y%val binary%d1Array(1:15) = x%d1Array(1:15) - y%d1Array(1:15) end function sub_self - + function sub_self_real(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -795,7 +795,7 @@ function sub_self_real(x, y) result(unary) unary%val = x%val - y unary%d1Array(1:15) = x%d1Array(1:15) end function sub_self_real - + function sub_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -803,7 +803,7 @@ function sub_real_self(z, x) result(unary) unary%val = -x%val + z unary%d1Array(1:15) = -x%d1Array(1:15) end function sub_real_self - + function sub_self_int(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x integer, intent(in) :: y @@ -813,7 +813,7 @@ function sub_self_int(x, y) result(unary) unary%val = x%val - y_dp unary%d1Array(1:15) = x%d1Array(1:15) end function sub_self_int - + function sub_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -823,7 +823,7 @@ function sub_int_self(z, x) result(unary) unary%val = -x%val + y_dp unary%d1Array(1:15) = -x%d1Array(1:15) end function sub_int_self - + function mul_self(x, y) result(binary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1), intent(in) :: y @@ -831,7 +831,7 @@ function mul_self(x, y) result(binary) binary%val = x%val*y%val binary%d1Array(1:15) = x%d1Array(1:15)*y%val + x%val*y%d1Array(1:15) end function mul_self - + function mul_self_real(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -839,7 +839,7 @@ function mul_self_real(x, y) result(unary) unary%val = x%val*y unary%d1Array(1:15) = x%d1Array(1:15)*y end function mul_self_real - + function mul_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -847,7 +847,7 @@ function mul_real_self(z, x) result(unary) unary%val = x%val*z unary%d1Array(1:15) = x%d1Array(1:15)*z end function mul_real_self - + function mul_self_int(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x integer, intent(in) :: y @@ -857,7 +857,7 @@ function mul_self_int(x, y) result(unary) unary%val = x%val*y_dp unary%d1Array(1:15) = x%d1Array(1:15)*y_dp end function mul_self_int - + function mul_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -867,7 +867,7 @@ function mul_int_self(z, x) result(unary) unary%val = x%val*y_dp unary%d1Array(1:15) = x%d1Array(1:15)*y_dp end function mul_int_self - + function div_self(x, y) result(binary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1), intent(in) :: y @@ -877,7 +877,7 @@ function div_self(x, y) result(binary) binary%val = q0*x%val binary%d1Array(1:15) = q0*x%d1Array(1:15) - x%val*y%d1Array(1:15)*powm1(pow2(y%val)) end function div_self - + function div_self_real(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -887,7 +887,7 @@ function div_self_real(x, y) result(unary) unary%val = q0*x%val unary%d1Array(1:15) = q0*x%d1Array(1:15) end function div_self_real - + function div_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -895,7 +895,7 @@ function div_real_self(z, x) result(unary) unary%val = z*powm1(x%val) unary%d1Array(1:15) = -x%d1Array(1:15)*z*powm1(pow2(x%val)) end function div_real_self - + function div_self_int(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x integer, intent(in) :: y @@ -907,7 +907,7 @@ function div_self_int(x, y) result(unary) unary%val = q0*x%val unary%d1Array(1:15) = q0*x%d1Array(1:15) end function div_self_int - + function div_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -917,7 +917,7 @@ function div_int_self(z, x) result(unary) unary%val = y_dp*powm1(x%val) unary%d1Array(1:15) = -x%d1Array(1:15)*y_dp*powm1(pow2(x%val)) end function div_int_self - + function pow_self(x, y) result(binary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1), intent(in) :: y @@ -927,7 +927,7 @@ function pow_self(x, y) result(binary) binary%val = q0 binary%d1Array(1:15) = q0*(x%d1Array(1:15)*y%val*powm1(x%val) + y%d1Array(1:15)*log(x%val)) end function pow_self - + function pow_self_real(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -935,7 +935,7 @@ function pow_self_real(x, y) result(unary) unary%val = pow(x%val, y) unary%d1Array(1:15) = x%d1Array(1:15)*y*pow(x%val, y - 1) end function pow_self_real - + function pow_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -945,7 +945,7 @@ function pow_real_self(z, x) result(unary) unary%val = q0 unary%d1Array(1:15) = q0*x%d1Array(1:15)*log(z) end function pow_real_self - + function pow_self_int(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x integer, intent(in) :: y @@ -955,7 +955,7 @@ function pow_self_int(x, y) result(unary) unary%val = pow(x%val, y_dp) unary%d1Array(1:15) = x%d1Array(1:15)*y_dp*pow(x%val, y_dp - 1) end function pow_self_int - + function pow_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -967,7 +967,7 @@ function pow_int_self(z, x) result(unary) unary%val = q0 unary%d1Array(1:15) = q0*x%d1Array(1:15)*log(y_dp) end function pow_int_self - + function max_self(x, y) result(binary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1), intent(in) :: y @@ -975,7 +975,7 @@ function max_self(x, y) result(binary) binary%val = Max(x%val, y%val) binary%d1Array(1:15) = x%d1Array(1:15)*Heaviside(x%val - y%val) + y%d1Array(1:15)*Heaviside(-x%val + y%val) end function max_self - + function max_self_real(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -983,7 +983,7 @@ function max_self_real(x, y) result(unary) unary%val = Max(x%val, y) unary%d1Array(1:15) = x%d1Array(1:15)*Heaviside(x%val - y) end function max_self_real - + function max_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -991,7 +991,7 @@ function max_real_self(z, x) result(unary) unary%val = Max(x%val, z) unary%d1Array(1:15) = x%d1Array(1:15)*Heaviside(x%val - z) end function max_real_self - + function max_self_int(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x integer, intent(in) :: y @@ -1001,7 +1001,7 @@ function max_self_int(x, y) result(unary) unary%val = Max(x%val, y_dp) unary%d1Array(1:15) = x%d1Array(1:15)*Heaviside(x%val - y_dp) end function max_self_int - + function max_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -1011,7 +1011,7 @@ function max_int_self(z, x) result(unary) unary%val = Max(x%val, y_dp) unary%d1Array(1:15) = x%d1Array(1:15)*Heaviside(x%val - y_dp) end function max_int_self - + function min_self(x, y) result(binary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1), intent(in) :: y @@ -1019,7 +1019,7 @@ function min_self(x, y) result(binary) binary%val = Min(x%val, y%val) binary%d1Array(1:15) = x%d1Array(1:15)*Heaviside(-x%val + y%val) + y%d1Array(1:15)*Heaviside(x%val - y%val) end function min_self - + function min_self_real(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1027,7 +1027,7 @@ function min_self_real(x, y) result(unary) unary%val = Min(x%val, y) unary%d1Array(1:15) = x%d1Array(1:15)*Heaviside(-x%val + y) end function min_self_real - + function min_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -1035,7 +1035,7 @@ function min_real_self(z, x) result(unary) unary%val = Min(x%val, z) unary%d1Array(1:15) = x%d1Array(1:15)*Heaviside(-x%val + z) end function min_real_self - + function min_self_int(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x integer, intent(in) :: y @@ -1045,7 +1045,7 @@ function min_self_int(x, y) result(unary) unary%val = Min(x%val, y_dp) unary%d1Array(1:15) = x%d1Array(1:15)*Heaviside(-x%val + y_dp) end function min_self_int - + function min_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -1055,7 +1055,7 @@ function min_int_self(z, x) result(unary) unary%val = Min(x%val, y_dp) unary%d1Array(1:15) = x%d1Array(1:15)*Heaviside(-x%val + y_dp) end function min_int_self - + function dim_self(x, y) result(binary) type(auto_diff_real_15var_order1), intent(in) :: x type(auto_diff_real_15var_order1), intent(in) :: y @@ -1065,7 +1065,7 @@ function dim_self(x, y) result(binary) binary%val = -0.5_dp*y%val + 0.5_dp*x%val + 0.5_dp*Abs(q0) binary%d1Array(1:15) = -0.5_dp*y%d1Array(1:15) + 0.5_dp*x%d1Array(1:15) + 0.5_dp*(x%d1Array(1:15) - y%d1Array(1:15))*sgn(q0) end function dim_self - + function dim_self_real(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1075,7 +1075,7 @@ function dim_self_real(x, y) result(unary) unary%val = -0.5_dp*y + 0.5_dp*x%val + 0.5_dp*Abs(q0) unary%d1Array(1:15) = 0.5_dp*x%d1Array(1:15)*(sgn(q0) + 1) end function dim_self_real - + function dim_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -1085,7 +1085,7 @@ function dim_real_self(z, x) result(unary) unary%val = -0.5_dp*x%val + 0.5_dp*z + 0.5_dp*Abs(q0) unary%d1Array(1:15) = 0.5_dp*x%d1Array(1:15)*(sgn(q0) - 1) end function dim_real_self - + function dim_self_int(x, y) result(unary) type(auto_diff_real_15var_order1), intent(in) :: x integer, intent(in) :: y @@ -1097,7 +1097,7 @@ function dim_self_int(x, y) result(unary) unary%val = -0.5_dp*y_dp + 0.5_dp*x%val + 0.5_dp*Abs(q0) unary%d1Array(1:15) = 0.5_dp*x%d1Array(1:15)*(sgn(q0) + 1) end function dim_self_int - + function dim_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_15var_order1), intent(in) :: x @@ -1109,5 +1109,5 @@ function dim_int_self(z, x) result(unary) unary%val = -0.5_dp*x%val + 0.5_dp*y_dp + 0.5_dp*Abs(q0) unary%d1Array(1:15) = 0.5_dp*x%d1Array(1:15)*(sgn(q0) - 1) end function dim_int_self - + end module auto_diff_real_15var_order1_module \ No newline at end of file diff --git a/auto_diff/private/auto_diff_real_1var_order1_module.f90 b/auto_diff/private/auto_diff_real_1var_order1_module.f90 index 9b86f2efe..4d35a3842 100644 --- a/auto_diff/private/auto_diff_real_1var_order1_module.f90 +++ b/auto_diff/private/auto_diff_real_1var_order1_module.f90 @@ -3,7 +3,7 @@ module auto_diff_real_1var_order1_module use utils_lib use support_functions use math_lib - + implicit none private public :: auto_diff_real_1var_order1, & @@ -68,13 +68,13 @@ module auto_diff_real_1var_order1_module real(dp) :: val real(dp) :: d1val1 end type auto_diff_real_1var_order1 - + interface assignment(=) module procedure assign_from_self module procedure assign_from_real_dp module procedure assign_from_int end interface assignment(=) - + interface operator(.eq.) module procedure equal_self module procedure equal_auto_diff_real_1var_order1_real_dp @@ -82,7 +82,7 @@ module auto_diff_real_1var_order1_module module procedure equal_auto_diff_real_1var_order1_int module procedure equal_int_auto_diff_real_1var_order1 end interface operator(.eq.) - + interface operator(.ne.) module procedure neq_self module procedure neq_auto_diff_real_1var_order1_real_dp @@ -90,7 +90,7 @@ module auto_diff_real_1var_order1_module module procedure neq_auto_diff_real_1var_order1_int module procedure neq_int_auto_diff_real_1var_order1 end interface operator(.ne.) - + interface operator(.gt.) module procedure greater_self module procedure greater_auto_diff_real_1var_order1_real_dp @@ -98,7 +98,7 @@ module auto_diff_real_1var_order1_module module procedure greater_auto_diff_real_1var_order1_int module procedure greater_int_auto_diff_real_1var_order1 end interface operator(.gt.) - + interface operator(.lt.) module procedure less_self module procedure less_auto_diff_real_1var_order1_real_dp @@ -106,7 +106,7 @@ module auto_diff_real_1var_order1_module module procedure less_auto_diff_real_1var_order1_int module procedure less_int_auto_diff_real_1var_order1 end interface operator(.lt.) - + interface operator(.le.) module procedure leq_self module procedure leq_auto_diff_real_1var_order1_real_dp @@ -114,7 +114,7 @@ module auto_diff_real_1var_order1_module module procedure leq_auto_diff_real_1var_order1_int module procedure leq_int_auto_diff_real_1var_order1 end interface operator(.le.) - + interface operator(.ge.) module procedure geq_self module procedure geq_auto_diff_real_1var_order1_real_dp @@ -122,175 +122,175 @@ module auto_diff_real_1var_order1_module module procedure geq_auto_diff_real_1var_order1_int module procedure geq_int_auto_diff_real_1var_order1 end interface operator(.ge.) - + interface make_unop module procedure make_unary_operator end interface make_unop - + interface make_binop module procedure make_binary_operator end interface make_binop - + interface sign module procedure sign_self end interface sign - + interface safe_sqrt module procedure safe_sqrt_self end interface safe_sqrt - + interface operator(-) module procedure unary_minus_self end interface operator(-) - + interface exp module procedure exp_self end interface exp - + interface expm1 module procedure expm1_self end interface expm1 - + interface exp10 module procedure exp10_self end interface exp10 - + interface powm1 module procedure powm1_self end interface powm1 - + interface log module procedure log_self end interface log - + interface log1p module procedure log1p_self end interface log1p - + interface safe_log module procedure safe_log_self end interface safe_log - + interface log10 module procedure log10_self end interface log10 - + interface safe_log10 module procedure safe_log10_self end interface safe_log10 - + interface log2 module procedure log2_self end interface log2 - + interface sin module procedure sin_self end interface sin - + interface cos module procedure cos_self end interface cos - + interface tan module procedure tan_self end interface tan - + interface sinpi module procedure sinpi_self end interface sinpi - + interface cospi module procedure cospi_self end interface cospi - + interface tanpi module procedure tanpi_self end interface tanpi - + interface sinh module procedure sinh_self end interface sinh - + interface cosh module procedure cosh_self end interface cosh - + interface tanh module procedure tanh_self end interface tanh - + interface asin module procedure asin_self end interface asin - + interface acos module procedure acos_self end interface acos - + interface atan module procedure atan_self end interface atan - + interface asinpi module procedure asinpi_self end interface asinpi - + interface acospi module procedure acospi_self end interface acospi - + interface atanpi module procedure atanpi_self end interface atanpi - + interface asinh module procedure asinh_self end interface asinh - + interface acosh module procedure acosh_self end interface acosh - + interface atanh module procedure atanh_self end interface atanh - + interface sqrt module procedure sqrt_self end interface sqrt - + interface pow2 module procedure pow2_self end interface pow2 - + interface pow3 module procedure pow3_self end interface pow3 - + interface pow4 module procedure pow4_self end interface pow4 - + interface pow5 module procedure pow5_self end interface pow5 - + interface pow6 module procedure pow6_self end interface pow6 - + interface pow7 module procedure pow7_self end interface pow7 - + interface pow8 module procedure pow8_self end interface pow8 - + interface abs module procedure abs_self end interface abs - + interface operator(+) module procedure add_self module procedure add_self_real @@ -298,7 +298,7 @@ module auto_diff_real_1var_order1_module module procedure add_self_int module procedure add_int_self end interface operator(+) - + interface operator(-) module procedure sub_self module procedure sub_self_real @@ -306,7 +306,7 @@ module auto_diff_real_1var_order1_module module procedure sub_self_int module procedure sub_int_self end interface operator(-) - + interface operator(*) module procedure mul_self module procedure mul_self_real @@ -314,7 +314,7 @@ module auto_diff_real_1var_order1_module module procedure mul_self_int module procedure mul_int_self end interface operator(*) - + interface operator(/) module procedure div_self module procedure div_self_real @@ -322,7 +322,7 @@ module auto_diff_real_1var_order1_module module procedure div_self_int module procedure div_int_self end interface operator(/) - + interface pow module procedure pow_self module procedure pow_self_real @@ -330,7 +330,7 @@ module auto_diff_real_1var_order1_module module procedure pow_self_int module procedure pow_int_self end interface pow - + interface max module procedure max_self module procedure max_self_real @@ -338,7 +338,7 @@ module auto_diff_real_1var_order1_module module procedure max_self_int module procedure max_int_self end interface max - + interface min module procedure min_self module procedure min_self_real @@ -346,7 +346,7 @@ module auto_diff_real_1var_order1_module module procedure min_self_int module procedure min_int_self end interface min - + interface dim module procedure dim_self module procedure dim_self_real @@ -354,11 +354,11 @@ module auto_diff_real_1var_order1_module module procedure dim_self_int module procedure dim_int_self end interface dim - + interface differentiate_1 module procedure differentiate_auto_diff_real_1var_order1_1 end interface differentiate_1 - + contains subroutine assign_from_self(this, other) @@ -367,231 +367,231 @@ subroutine assign_from_self(this, other) this%val = other%val this%d1val1 = other%d1val1 end subroutine assign_from_self - + subroutine assign_from_real_dp(this, other) type(auto_diff_real_1var_order1), intent(out) :: this real(dp), intent(in) :: other this%val = other this%d1val1 = 0.0_dp end subroutine assign_from_real_dp - + subroutine assign_from_int(this, other) type(auto_diff_real_1var_order1), intent(out) :: this integer, intent(in) :: other this%val = other this%d1val1 = 0.0_dp end subroutine assign_from_int - + function equal_self(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this%val .eq. other%val) end function equal_self - + function equal_auto_diff_real_1var_order1_real_dp(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_1var_order1_real_dp - + function equal_real_dp_auto_diff_real_1var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_real_dp_auto_diff_real_1var_order1 - + function equal_auto_diff_real_1var_order1_int(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_1var_order1_int - + function equal_int_auto_diff_real_1var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_int_auto_diff_real_1var_order1 - + function neq_self(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this%val .ne. other%val) end function neq_self - + function neq_auto_diff_real_1var_order1_real_dp(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_1var_order1_real_dp - + function neq_real_dp_auto_diff_real_1var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_real_dp_auto_diff_real_1var_order1 - + function neq_auto_diff_real_1var_order1_int(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_1var_order1_int - + function neq_int_auto_diff_real_1var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_int_auto_diff_real_1var_order1 - + function greater_self(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this%val .gt. other%val) end function greater_self - + function greater_auto_diff_real_1var_order1_real_dp(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_1var_order1_real_dp - + function greater_real_dp_auto_diff_real_1var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_real_dp_auto_diff_real_1var_order1 - + function greater_auto_diff_real_1var_order1_int(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_1var_order1_int - + function greater_int_auto_diff_real_1var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_int_auto_diff_real_1var_order1 - + function less_self(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this%val .lt. other%val) end function less_self - + function less_auto_diff_real_1var_order1_real_dp(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_1var_order1_real_dp - + function less_real_dp_auto_diff_real_1var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_real_dp_auto_diff_real_1var_order1 - + function less_auto_diff_real_1var_order1_int(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_1var_order1_int - + function less_int_auto_diff_real_1var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_int_auto_diff_real_1var_order1 - + function leq_self(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this%val .le. other%val) end function leq_self - + function leq_auto_diff_real_1var_order1_real_dp(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_1var_order1_real_dp - + function leq_real_dp_auto_diff_real_1var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_real_dp_auto_diff_real_1var_order1 - + function leq_auto_diff_real_1var_order1_int(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_1var_order1_int - + function leq_int_auto_diff_real_1var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_int_auto_diff_real_1var_order1 - + function geq_self(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this%val .ge. other%val) end function geq_self - + function geq_auto_diff_real_1var_order1_real_dp(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_1var_order1_real_dp - + function geq_real_dp_auto_diff_real_1var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_real_dp_auto_diff_real_1var_order1 - + function geq_auto_diff_real_1var_order1_int(this, other) result(z) type(auto_diff_real_1var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_1var_order1_int - + function geq_int_auto_diff_real_1var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_1var_order1), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_int_auto_diff_real_1var_order1 - + function make_unary_operator(x, z_val, z_d1x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x real(dp), intent(in) :: z_val @@ -600,7 +600,7 @@ function make_unary_operator(x, z_val, z_d1x) result(unary) unary%val = z_val unary%d1val1 = x%d1val1*z_d1x end function make_unary_operator - + function make_binary_operator(x, y, z_val, z_d1x, z_d1y) result(binary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1), intent(in) :: y @@ -611,14 +611,14 @@ function make_binary_operator(x, y, z_val, z_d1x, z_d1y) result(binary) binary%val = z_val binary%d1val1 = x%d1val1*z_d1x + y%d1val1*z_d1y end function make_binary_operator - + function sign_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = sgn(x%val) unary%d1val1 = 0.0_dp end function sign_self - + function safe_sqrt_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -627,14 +627,14 @@ function safe_sqrt_self(x) result(unary) unary%val = q0 unary%d1val1 = 0.5_dp*q0*x%d1val1*powm1(x%val) end function safe_sqrt_self - + function unary_minus_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = -x%val unary%d1val1 = -x%d1val1 end function unary_minus_self - + function exp_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -643,14 +643,14 @@ function exp_self(x) result(unary) unary%val = q0 unary%d1val1 = q0*x%d1val1 end function exp_self - + function expm1_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = expm1(x%val) unary%d1val1 = x%d1val1*exp(x%val) end function expm1_self - + function exp10_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -659,35 +659,35 @@ function exp10_self(x) result(unary) unary%val = q0 unary%d1val1 = q0*x%d1val1*ln10 end function exp10_self - + function powm1_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = powm1(x%val) unary%d1val1 = -x%d1val1*powm1(pow2(x%val)) end function powm1_self - + function log_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = log(x%val) unary%d1val1 = x%d1val1*powm1(x%val) end function log_self - + function log1p_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = log1p(x%val) unary%d1val1 = x%d1val1*powm1(x%val + 1) end function log1p_self - + function safe_log_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = safe_log(x%val) unary%d1val1 = x%d1val1*powm1(x%val) end function safe_log_self - + function log10_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -696,7 +696,7 @@ function log10_self(x) result(unary) unary%val = q0*log(x%val) unary%d1val1 = q0*x%d1val1*powm1(x%val) end function log10_self - + function safe_log10_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -705,7 +705,7 @@ function safe_log10_self(x) result(unary) unary%val = q0*safe_log(x%val) unary%d1val1 = q0*x%d1val1*powm1(x%val) end function safe_log10_self - + function log2_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -714,21 +714,21 @@ function log2_self(x) result(unary) unary%val = q0*log(x%val) unary%d1val1 = q0*x%d1val1*powm1(x%val) end function log2_self - + function sin_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = sin(x%val) unary%d1val1 = x%d1val1*cos(x%val) end function sin_self - + function cos_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = cos(x%val) unary%d1val1 = -x%d1val1*sin(x%val) end function cos_self - + function tan_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -737,7 +737,7 @@ function tan_self(x) result(unary) unary%val = q0 unary%d1val1 = x%d1val1*(pow2(q0) + 1) end function tan_self - + function sinpi_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -746,7 +746,7 @@ function sinpi_self(x) result(unary) unary%val = sin(q0) unary%d1val1 = pi*x%d1val1*cos(q0) end function sinpi_self - + function cospi_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -755,7 +755,7 @@ function cospi_self(x) result(unary) unary%val = cos(q0) unary%d1val1 = -pi*x%d1val1*sin(q0) end function cospi_self - + function tanpi_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -764,21 +764,21 @@ function tanpi_self(x) result(unary) unary%val = q0 unary%d1val1 = pi*x%d1val1*(pow2(q0) + 1) end function tanpi_self - + function sinh_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = sinh(x%val) unary%d1val1 = x%d1val1*cosh(x%val) end function sinh_self - + function cosh_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = cosh(x%val) unary%d1val1 = x%d1val1*sinh(x%val) end function cosh_self - + function tanh_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -787,28 +787,28 @@ function tanh_self(x) result(unary) unary%val = q0 unary%d1val1 = -x%d1val1*(pow2(q0) - 1) end function tanh_self - + function asin_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = asin(x%val) unary%d1val1 = x%d1val1*powm1(sqrt(1 - pow2(x%val))) end function asin_self - + function acos_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = acos(x%val) unary%d1val1 = -x%d1val1*powm1(sqrt(1 - pow2(x%val))) end function acos_self - + function atan_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = atan(x%val) unary%d1val1 = x%d1val1*powm1(pow2(x%val) + 1) end function atan_self - + function asinpi_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -817,7 +817,7 @@ function asinpi_self(x) result(unary) unary%val = q0*asin(x%val) unary%d1val1 = q0*x%d1val1*powm1(sqrt(1 - pow2(x%val))) end function asinpi_self - + function acospi_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -826,35 +826,35 @@ function acospi_self(x) result(unary) unary%val = q0*acos(x%val) unary%d1val1 = -q0*x%d1val1*powm1(sqrt(1 - pow2(x%val))) end function acospi_self - + function atanpi_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = powm1(pi)*atan(x%val) unary%d1val1 = x%d1val1*powm1(pi*pow2(x%val) + pi) end function atanpi_self - + function asinh_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = asinh(x%val) unary%d1val1 = x%d1val1*powm1(sqrt(pow2(x%val) + 1)) end function asinh_self - + function acosh_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = acosh(x%val) unary%d1val1 = x%d1val1*powm1(sqrt(pow2(x%val) - 1)) end function acosh_self - + function atanh_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = atanh(x%val) unary%d1val1 = -x%d1val1*powm1(pow2(x%val) - 1) end function atanh_self - + function sqrt_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary @@ -863,63 +863,63 @@ function sqrt_self(x) result(unary) unary%val = q0 unary%d1val1 = 0.5_dp*x%d1val1*powm1(q0) end function sqrt_self - + function pow2_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = pow2(x%val) unary%d1val1 = 2.0_dp*x%d1val1*x%val end function pow2_self - + function pow3_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = pow3(x%val) unary%d1val1 = 3.0_dp*x%d1val1*pow2(x%val) end function pow3_self - + function pow4_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = pow4(x%val) unary%d1val1 = 4.0_dp*x%d1val1*pow3(x%val) end function pow4_self - + function pow5_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = pow5(x%val) unary%d1val1 = 5.0_dp*x%d1val1*pow4(x%val) end function pow5_self - + function pow6_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = pow6(x%val) unary%d1val1 = 6.0_dp*x%d1val1*pow5(x%val) end function pow6_self - + function pow7_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = pow7(x%val) unary%d1val1 = 7.0_dp*x%d1val1*pow6(x%val) end function pow7_self - + function pow8_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = pow8(x%val) unary%d1val1 = 8.0_dp*x%d1val1*pow7(x%val) end function pow8_self - + function abs_self(x) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1) :: unary unary%val = Abs(x%val) unary%d1val1 = x%d1val1*sgn(x%val) end function abs_self - + function add_self(x, y) result(binary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1), intent(in) :: y @@ -927,7 +927,7 @@ function add_self(x, y) result(binary) binary%val = x%val + y%val binary%d1val1 = x%d1val1 + y%d1val1 end function add_self - + function add_self_real(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -935,7 +935,7 @@ function add_self_real(x, y) result(unary) unary%val = x%val + y unary%d1val1 = x%d1val1 end function add_self_real - + function add_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -943,7 +943,7 @@ function add_real_self(z, x) result(unary) unary%val = x%val + z unary%d1val1 = x%d1val1 end function add_real_self - + function add_self_int(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x integer, intent(in) :: y @@ -953,7 +953,7 @@ function add_self_int(x, y) result(unary) unary%val = x%val + y_dp unary%d1val1 = x%d1val1 end function add_self_int - + function add_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -963,7 +963,7 @@ function add_int_self(z, x) result(unary) unary%val = x%val + y_dp unary%d1val1 = x%d1val1 end function add_int_self - + function sub_self(x, y) result(binary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1), intent(in) :: y @@ -971,7 +971,7 @@ function sub_self(x, y) result(binary) binary%val = x%val - y%val binary%d1val1 = x%d1val1 - y%d1val1 end function sub_self - + function sub_self_real(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -979,7 +979,7 @@ function sub_self_real(x, y) result(unary) unary%val = x%val - y unary%d1val1 = x%d1val1 end function sub_self_real - + function sub_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -987,7 +987,7 @@ function sub_real_self(z, x) result(unary) unary%val = -x%val + z unary%d1val1 = -x%d1val1 end function sub_real_self - + function sub_self_int(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x integer, intent(in) :: y @@ -997,7 +997,7 @@ function sub_self_int(x, y) result(unary) unary%val = x%val - y_dp unary%d1val1 = x%d1val1 end function sub_self_int - + function sub_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1007,7 +1007,7 @@ function sub_int_self(z, x) result(unary) unary%val = -x%val + y_dp unary%d1val1 = -x%d1val1 end function sub_int_self - + function mul_self(x, y) result(binary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1), intent(in) :: y @@ -1015,7 +1015,7 @@ function mul_self(x, y) result(binary) binary%val = x%val*y%val binary%d1val1 = x%d1val1*y%val + x%val*y%d1val1 end function mul_self - + function mul_self_real(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1023,7 +1023,7 @@ function mul_self_real(x, y) result(unary) unary%val = x%val*y unary%d1val1 = x%d1val1*y end function mul_self_real - + function mul_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1031,7 +1031,7 @@ function mul_real_self(z, x) result(unary) unary%val = x%val*z unary%d1val1 = x%d1val1*z end function mul_real_self - + function mul_self_int(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x integer, intent(in) :: y @@ -1041,7 +1041,7 @@ function mul_self_int(x, y) result(unary) unary%val = x%val*y_dp unary%d1val1 = x%d1val1*y_dp end function mul_self_int - + function mul_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1051,7 +1051,7 @@ function mul_int_self(z, x) result(unary) unary%val = x%val*y_dp unary%d1val1 = x%d1val1*y_dp end function mul_int_self - + function div_self(x, y) result(binary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1), intent(in) :: y @@ -1059,7 +1059,7 @@ function div_self(x, y) result(binary) binary%val = x%val*powm1(y%val) binary%d1val1 = (x%d1val1*y%val - x%val*y%d1val1)*powm1(pow2(y%val)) end function div_self - + function div_self_real(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1069,7 +1069,7 @@ function div_self_real(x, y) result(unary) unary%val = q0*x%val unary%d1val1 = q0*x%d1val1 end function div_self_real - + function div_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1077,7 +1077,7 @@ function div_real_self(z, x) result(unary) unary%val = z*powm1(x%val) unary%d1val1 = -x%d1val1*z*powm1(pow2(x%val)) end function div_real_self - + function div_self_int(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x integer, intent(in) :: y @@ -1089,7 +1089,7 @@ function div_self_int(x, y) result(unary) unary%val = q0*x%val unary%d1val1 = q0*x%d1val1 end function div_self_int - + function div_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1099,7 +1099,7 @@ function div_int_self(z, x) result(unary) unary%val = y_dp*powm1(x%val) unary%d1val1 = -x%d1val1*y_dp*powm1(pow2(x%val)) end function div_int_self - + function pow_self(x, y) result(binary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1), intent(in) :: y @@ -1107,7 +1107,7 @@ function pow_self(x, y) result(binary) binary%val = pow(x%val, y%val) binary%d1val1 = (x%d1val1*y%val + x%val*y%d1val1*log(x%val))*pow(x%val, y%val - 1) end function pow_self - + function pow_self_real(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1115,7 +1115,7 @@ function pow_self_real(x, y) result(unary) unary%val = pow(x%val, y) unary%d1val1 = x%d1val1*y*pow(x%val, y - 1) end function pow_self_real - + function pow_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1125,7 +1125,7 @@ function pow_real_self(z, x) result(unary) unary%val = q0 unary%d1val1 = q0*x%d1val1*log(z) end function pow_real_self - + function pow_self_int(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x integer, intent(in) :: y @@ -1135,7 +1135,7 @@ function pow_self_int(x, y) result(unary) unary%val = pow(x%val, y_dp) unary%d1val1 = x%d1val1*y_dp*pow(x%val, y_dp - 1) end function pow_self_int - + function pow_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1147,7 +1147,7 @@ function pow_int_self(z, x) result(unary) unary%val = q0 unary%d1val1 = q0*x%d1val1*log(y_dp) end function pow_int_self - + function max_self(x, y) result(binary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1), intent(in) :: y @@ -1155,7 +1155,7 @@ function max_self(x, y) result(binary) binary%val = Max(x%val, y%val) binary%d1val1 = x%d1val1*Heaviside(x%val - y%val) + y%d1val1*Heaviside(-x%val + y%val) end function max_self - + function max_self_real(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1163,7 +1163,7 @@ function max_self_real(x, y) result(unary) unary%val = Max(x%val, y) unary%d1val1 = x%d1val1*Heaviside(x%val - y) end function max_self_real - + function max_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1171,7 +1171,7 @@ function max_real_self(z, x) result(unary) unary%val = Max(x%val, z) unary%d1val1 = x%d1val1*Heaviside(x%val - z) end function max_real_self - + function max_self_int(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x integer, intent(in) :: y @@ -1181,7 +1181,7 @@ function max_self_int(x, y) result(unary) unary%val = Max(x%val, y_dp) unary%d1val1 = x%d1val1*Heaviside(x%val - y_dp) end function max_self_int - + function max_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1191,7 +1191,7 @@ function max_int_self(z, x) result(unary) unary%val = Max(x%val, y_dp) unary%d1val1 = x%d1val1*Heaviside(x%val - y_dp) end function max_int_self - + function min_self(x, y) result(binary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1), intent(in) :: y @@ -1199,7 +1199,7 @@ function min_self(x, y) result(binary) binary%val = Min(x%val, y%val) binary%d1val1 = x%d1val1*Heaviside(-x%val + y%val) + y%d1val1*Heaviside(x%val - y%val) end function min_self - + function min_self_real(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1207,7 +1207,7 @@ function min_self_real(x, y) result(unary) unary%val = Min(x%val, y) unary%d1val1 = x%d1val1*Heaviside(-x%val + y) end function min_self_real - + function min_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1215,7 +1215,7 @@ function min_real_self(z, x) result(unary) unary%val = Min(x%val, z) unary%d1val1 = x%d1val1*Heaviside(-x%val + z) end function min_real_self - + function min_self_int(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x integer, intent(in) :: y @@ -1225,7 +1225,7 @@ function min_self_int(x, y) result(unary) unary%val = Min(x%val, y_dp) unary%d1val1 = x%d1val1*Heaviside(-x%val + y_dp) end function min_self_int - + function min_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1235,7 +1235,7 @@ function min_int_self(z, x) result(unary) unary%val = Min(x%val, y_dp) unary%d1val1 = x%d1val1*Heaviside(-x%val + y_dp) end function min_int_self - + function dim_self(x, y) result(binary) type(auto_diff_real_1var_order1), intent(in) :: x type(auto_diff_real_1var_order1), intent(in) :: y @@ -1245,7 +1245,7 @@ function dim_self(x, y) result(binary) binary%val = -0.5_dp*y%val + 0.5_dp*x%val + 0.5_dp*Abs(q0) binary%d1val1 = -0.5_dp*y%d1val1 + 0.5_dp*x%d1val1 + 0.5_dp*(x%d1val1 - y%d1val1)*sgn(q0) end function dim_self - + function dim_self_real(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1255,7 +1255,7 @@ function dim_self_real(x, y) result(unary) unary%val = -0.5_dp*y + 0.5_dp*x%val + 0.5_dp*Abs(q0) unary%d1val1 = 0.5_dp*x%d1val1*(sgn(q0) + 1) end function dim_self_real - + function dim_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1265,7 +1265,7 @@ function dim_real_self(z, x) result(unary) unary%val = -0.5_dp*x%val + 0.5_dp*z + 0.5_dp*Abs(q0) unary%d1val1 = 0.5_dp*x%d1val1*(sgn(q0) - 1) end function dim_real_self - + function dim_self_int(x, y) result(unary) type(auto_diff_real_1var_order1), intent(in) :: x integer, intent(in) :: y @@ -1277,7 +1277,7 @@ function dim_self_int(x, y) result(unary) unary%val = -0.5_dp*y_dp + 0.5_dp*x%val + 0.5_dp*Abs(q0) unary%d1val1 = 0.5_dp*x%d1val1*(sgn(q0) + 1) end function dim_self_int - + function dim_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_1var_order1), intent(in) :: x @@ -1289,12 +1289,12 @@ function dim_int_self(z, x) result(unary) unary%val = -0.5_dp*x%val + 0.5_dp*y_dp + 0.5_dp*Abs(q0) unary%d1val1 = 0.5_dp*x%d1val1*(sgn(q0) - 1) end function dim_int_self - + function differentiate_auto_diff_real_1var_order1_1(this) result(derivative) type(auto_diff_real_1var_order1), intent(in) :: this type(auto_diff_real_1var_order1) :: derivative derivative%val = this%d1val1 derivative%d1val1 = 0.0_dp end function differentiate_auto_diff_real_1var_order1_1 - + end module auto_diff_real_1var_order1_module \ No newline at end of file diff --git a/auto_diff/private/auto_diff_real_2var_order1_module.f90 b/auto_diff/private/auto_diff_real_2var_order1_module.f90 index 257939d9f..bc071069d 100644 --- a/auto_diff/private/auto_diff_real_2var_order1_module.f90 +++ b/auto_diff/private/auto_diff_real_2var_order1_module.f90 @@ -3,7 +3,7 @@ module auto_diff_real_2var_order1_module use utils_lib use support_functions use math_lib - + implicit none private public :: auto_diff_real_2var_order1, & @@ -70,13 +70,13 @@ module auto_diff_real_2var_order1_module real(dp) :: d1val1 real(dp) :: d1val2 end type auto_diff_real_2var_order1 - + interface assignment(=) module procedure assign_from_self module procedure assign_from_real_dp module procedure assign_from_int end interface assignment(=) - + interface operator(.eq.) module procedure equal_self module procedure equal_auto_diff_real_2var_order1_real_dp @@ -84,7 +84,7 @@ module auto_diff_real_2var_order1_module module procedure equal_auto_diff_real_2var_order1_int module procedure equal_int_auto_diff_real_2var_order1 end interface operator(.eq.) - + interface operator(.ne.) module procedure neq_self module procedure neq_auto_diff_real_2var_order1_real_dp @@ -92,7 +92,7 @@ module auto_diff_real_2var_order1_module module procedure neq_auto_diff_real_2var_order1_int module procedure neq_int_auto_diff_real_2var_order1 end interface operator(.ne.) - + interface operator(.gt.) module procedure greater_self module procedure greater_auto_diff_real_2var_order1_real_dp @@ -100,7 +100,7 @@ module auto_diff_real_2var_order1_module module procedure greater_auto_diff_real_2var_order1_int module procedure greater_int_auto_diff_real_2var_order1 end interface operator(.gt.) - + interface operator(.lt.) module procedure less_self module procedure less_auto_diff_real_2var_order1_real_dp @@ -108,7 +108,7 @@ module auto_diff_real_2var_order1_module module procedure less_auto_diff_real_2var_order1_int module procedure less_int_auto_diff_real_2var_order1 end interface operator(.lt.) - + interface operator(.le.) module procedure leq_self module procedure leq_auto_diff_real_2var_order1_real_dp @@ -116,7 +116,7 @@ module auto_diff_real_2var_order1_module module procedure leq_auto_diff_real_2var_order1_int module procedure leq_int_auto_diff_real_2var_order1 end interface operator(.le.) - + interface operator(.ge.) module procedure geq_self module procedure geq_auto_diff_real_2var_order1_real_dp @@ -124,175 +124,175 @@ module auto_diff_real_2var_order1_module module procedure geq_auto_diff_real_2var_order1_int module procedure geq_int_auto_diff_real_2var_order1 end interface operator(.ge.) - + interface make_unop module procedure make_unary_operator end interface make_unop - + interface make_binop module procedure make_binary_operator end interface make_binop - + interface sign module procedure sign_self end interface sign - + interface safe_sqrt module procedure safe_sqrt_self end interface safe_sqrt - + interface operator(-) module procedure unary_minus_self end interface operator(-) - + interface exp module procedure exp_self end interface exp - + interface expm1 module procedure expm1_self end interface expm1 - + interface exp10 module procedure exp10_self end interface exp10 - + interface powm1 module procedure powm1_self end interface powm1 - + interface log module procedure log_self end interface log - + interface log1p module procedure log1p_self end interface log1p - + interface safe_log module procedure safe_log_self end interface safe_log - + interface log10 module procedure log10_self end interface log10 - + interface safe_log10 module procedure safe_log10_self end interface safe_log10 - + interface log2 module procedure log2_self end interface log2 - + interface sin module procedure sin_self end interface sin - + interface cos module procedure cos_self end interface cos - + interface tan module procedure tan_self end interface tan - + interface sinpi module procedure sinpi_self end interface sinpi - + interface cospi module procedure cospi_self end interface cospi - + interface tanpi module procedure tanpi_self end interface tanpi - + interface sinh module procedure sinh_self end interface sinh - + interface cosh module procedure cosh_self end interface cosh - + interface tanh module procedure tanh_self end interface tanh - + interface asin module procedure asin_self end interface asin - + interface acos module procedure acos_self end interface acos - + interface atan module procedure atan_self end interface atan - + interface asinpi module procedure asinpi_self end interface asinpi - + interface acospi module procedure acospi_self end interface acospi - + interface atanpi module procedure atanpi_self end interface atanpi - + interface asinh module procedure asinh_self end interface asinh - + interface acosh module procedure acosh_self end interface acosh - + interface atanh module procedure atanh_self end interface atanh - + interface sqrt module procedure sqrt_self end interface sqrt - + interface pow2 module procedure pow2_self end interface pow2 - + interface pow3 module procedure pow3_self end interface pow3 - + interface pow4 module procedure pow4_self end interface pow4 - + interface pow5 module procedure pow5_self end interface pow5 - + interface pow6 module procedure pow6_self end interface pow6 - + interface pow7 module procedure pow7_self end interface pow7 - + interface pow8 module procedure pow8_self end interface pow8 - + interface abs module procedure abs_self end interface abs - + interface operator(+) module procedure add_self module procedure add_self_real @@ -300,7 +300,7 @@ module auto_diff_real_2var_order1_module module procedure add_self_int module procedure add_int_self end interface operator(+) - + interface operator(-) module procedure sub_self module procedure sub_self_real @@ -308,7 +308,7 @@ module auto_diff_real_2var_order1_module module procedure sub_self_int module procedure sub_int_self end interface operator(-) - + interface operator(*) module procedure mul_self module procedure mul_self_real @@ -316,7 +316,7 @@ module auto_diff_real_2var_order1_module module procedure mul_self_int module procedure mul_int_self end interface operator(*) - + interface operator(/) module procedure div_self module procedure div_self_real @@ -324,7 +324,7 @@ module auto_diff_real_2var_order1_module module procedure div_self_int module procedure div_int_self end interface operator(/) - + interface pow module procedure pow_self module procedure pow_self_real @@ -332,7 +332,7 @@ module auto_diff_real_2var_order1_module module procedure pow_self_int module procedure pow_int_self end interface pow - + interface max module procedure max_self module procedure max_self_real @@ -340,7 +340,7 @@ module auto_diff_real_2var_order1_module module procedure max_self_int module procedure max_int_self end interface max - + interface min module procedure min_self module procedure min_self_real @@ -348,7 +348,7 @@ module auto_diff_real_2var_order1_module module procedure min_self_int module procedure min_int_self end interface min - + interface dim module procedure dim_self module procedure dim_self_real @@ -356,15 +356,15 @@ module auto_diff_real_2var_order1_module module procedure dim_self_int module procedure dim_int_self end interface dim - + interface differentiate_1 module procedure differentiate_auto_diff_real_2var_order1_1 end interface differentiate_1 - + interface differentiate_2 module procedure differentiate_auto_diff_real_2var_order1_2 end interface differentiate_2 - + contains subroutine assign_from_self(this, other) @@ -374,7 +374,7 @@ subroutine assign_from_self(this, other) this%d1val1 = other%d1val1 this%d1val2 = other%d1val2 end subroutine assign_from_self - + subroutine assign_from_real_dp(this, other) type(auto_diff_real_2var_order1), intent(out) :: this real(dp), intent(in) :: other @@ -382,7 +382,7 @@ subroutine assign_from_real_dp(this, other) this%d1val1 = 0.0_dp this%d1val2 = 0.0_dp end subroutine assign_from_real_dp - + subroutine assign_from_int(this, other) type(auto_diff_real_2var_order1), intent(out) :: this integer, intent(in) :: other @@ -390,217 +390,217 @@ subroutine assign_from_int(this, other) this%d1val1 = 0.0_dp this%d1val2 = 0.0_dp end subroutine assign_from_int - + function equal_self(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this%val .eq. other%val) end function equal_self - + function equal_auto_diff_real_2var_order1_real_dp(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_2var_order1_real_dp - + function equal_real_dp_auto_diff_real_2var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_real_dp_auto_diff_real_2var_order1 - + function equal_auto_diff_real_2var_order1_int(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_2var_order1_int - + function equal_int_auto_diff_real_2var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_int_auto_diff_real_2var_order1 - + function neq_self(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this%val .ne. other%val) end function neq_self - + function neq_auto_diff_real_2var_order1_real_dp(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_2var_order1_real_dp - + function neq_real_dp_auto_diff_real_2var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_real_dp_auto_diff_real_2var_order1 - + function neq_auto_diff_real_2var_order1_int(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_2var_order1_int - + function neq_int_auto_diff_real_2var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_int_auto_diff_real_2var_order1 - + function greater_self(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this%val .gt. other%val) end function greater_self - + function greater_auto_diff_real_2var_order1_real_dp(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_2var_order1_real_dp - + function greater_real_dp_auto_diff_real_2var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_real_dp_auto_diff_real_2var_order1 - + function greater_auto_diff_real_2var_order1_int(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_2var_order1_int - + function greater_int_auto_diff_real_2var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_int_auto_diff_real_2var_order1 - + function less_self(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this%val .lt. other%val) end function less_self - + function less_auto_diff_real_2var_order1_real_dp(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_2var_order1_real_dp - + function less_real_dp_auto_diff_real_2var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_real_dp_auto_diff_real_2var_order1 - + function less_auto_diff_real_2var_order1_int(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_2var_order1_int - + function less_int_auto_diff_real_2var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_int_auto_diff_real_2var_order1 - + function leq_self(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this%val .le. other%val) end function leq_self - + function leq_auto_diff_real_2var_order1_real_dp(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_2var_order1_real_dp - + function leq_real_dp_auto_diff_real_2var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_real_dp_auto_diff_real_2var_order1 - + function leq_auto_diff_real_2var_order1_int(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_2var_order1_int - + function leq_int_auto_diff_real_2var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_int_auto_diff_real_2var_order1 - + function geq_self(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this%val .ge. other%val) end function geq_self - + function geq_auto_diff_real_2var_order1_real_dp(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_2var_order1_real_dp - + function geq_real_dp_auto_diff_real_2var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_real_dp_auto_diff_real_2var_order1 - + function geq_auto_diff_real_2var_order1_int(this, other) result(z) type(auto_diff_real_2var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_2var_order1_int - + function geq_int_auto_diff_real_2var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order1), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_int_auto_diff_real_2var_order1 - + function make_unary_operator(x, z_val, z_d1x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x real(dp), intent(in) :: z_val @@ -610,7 +610,7 @@ function make_unary_operator(x, z_val, z_d1x) result(unary) unary%d1val1 = x%d1val1*z_d1x unary%d1val2 = x%d1val2*z_d1x end function make_unary_operator - + function make_binary_operator(x, y, z_val, z_d1x, z_d1y) result(binary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1), intent(in) :: y @@ -622,7 +622,7 @@ function make_binary_operator(x, y, z_val, z_d1x, z_d1y) result(binary) binary%d1val1 = x%d1val1*z_d1x + y%d1val1*z_d1y binary%d1val2 = x%d1val2*z_d1x + y%d1val2*z_d1y end function make_binary_operator - + function sign_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -630,7 +630,7 @@ function sign_self(x) result(unary) unary%d1val1 = 0.0_dp unary%d1val2 = 0.0_dp end function sign_self - + function safe_sqrt_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -642,7 +642,7 @@ function safe_sqrt_self(x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function safe_sqrt_self - + function unary_minus_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -650,7 +650,7 @@ function unary_minus_self(x) result(unary) unary%d1val1 = -x%d1val1 unary%d1val2 = -x%d1val2 end function unary_minus_self - + function exp_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -660,7 +660,7 @@ function exp_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function exp_self - + function expm1_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -670,7 +670,7 @@ function expm1_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function expm1_self - + function exp10_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -682,7 +682,7 @@ function exp10_self(x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function exp10_self - + function powm1_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -692,7 +692,7 @@ function powm1_self(x) result(unary) unary%d1val1 = -q0*x%d1val1 unary%d1val2 = -q0*x%d1val2 end function powm1_self - + function log_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -702,7 +702,7 @@ function log_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function log_self - + function log1p_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -712,7 +712,7 @@ function log1p_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function log1p_self - + function safe_log_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -722,7 +722,7 @@ function safe_log_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function safe_log_self - + function log10_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -734,7 +734,7 @@ function log10_self(x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function log10_self - + function safe_log10_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -746,7 +746,7 @@ function safe_log10_self(x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function safe_log10_self - + function log2_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -758,7 +758,7 @@ function log2_self(x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function log2_self - + function sin_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -768,7 +768,7 @@ function sin_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function sin_self - + function cos_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -778,7 +778,7 @@ function cos_self(x) result(unary) unary%d1val1 = -q0*x%d1val1 unary%d1val2 = -q0*x%d1val2 end function cos_self - + function tan_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -790,7 +790,7 @@ function tan_self(x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function tan_self - + function sinpi_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -802,7 +802,7 @@ function sinpi_self(x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function sinpi_self - + function cospi_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -814,7 +814,7 @@ function cospi_self(x) result(unary) unary%d1val1 = -q1*x%d1val1 unary%d1val2 = -q1*x%d1val2 end function cospi_self - + function tanpi_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -826,7 +826,7 @@ function tanpi_self(x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function tanpi_self - + function sinh_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -836,7 +836,7 @@ function sinh_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function sinh_self - + function cosh_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -846,7 +846,7 @@ function cosh_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function cosh_self - + function tanh_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -858,7 +858,7 @@ function tanh_self(x) result(unary) unary%d1val1 = -q1*x%d1val1 unary%d1val2 = -q1*x%d1val2 end function tanh_self - + function asin_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -868,7 +868,7 @@ function asin_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function asin_self - + function acos_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -878,7 +878,7 @@ function acos_self(x) result(unary) unary%d1val1 = -q0*x%d1val1 unary%d1val2 = -q0*x%d1val2 end function acos_self - + function atan_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -888,7 +888,7 @@ function atan_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function atan_self - + function asinpi_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -900,7 +900,7 @@ function asinpi_self(x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function asinpi_self - + function acospi_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -912,7 +912,7 @@ function acospi_self(x) result(unary) unary%d1val1 = -q1*x%d1val1 unary%d1val2 = -q1*x%d1val2 end function acospi_self - + function atanpi_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -922,7 +922,7 @@ function atanpi_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function atanpi_self - + function asinh_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -932,7 +932,7 @@ function asinh_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function asinh_self - + function acosh_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -942,7 +942,7 @@ function acosh_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function acosh_self - + function atanh_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -952,7 +952,7 @@ function atanh_self(x) result(unary) unary%d1val1 = -q0*x%d1val1 unary%d1val2 = -q0*x%d1val2 end function atanh_self - + function sqrt_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -964,7 +964,7 @@ function sqrt_self(x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function sqrt_self - + function pow2_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -974,7 +974,7 @@ function pow2_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function pow2_self - + function pow3_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -984,7 +984,7 @@ function pow3_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function pow3_self - + function pow4_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -994,7 +994,7 @@ function pow4_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function pow4_self - + function pow5_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -1004,7 +1004,7 @@ function pow5_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function pow5_self - + function pow6_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -1014,7 +1014,7 @@ function pow6_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function pow6_self - + function pow7_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -1024,7 +1024,7 @@ function pow7_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function pow7_self - + function pow8_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -1034,7 +1034,7 @@ function pow8_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function pow8_self - + function abs_self(x) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1) :: unary @@ -1044,7 +1044,7 @@ function abs_self(x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function abs_self - + function add_self(x, y) result(binary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1), intent(in) :: y @@ -1053,7 +1053,7 @@ function add_self(x, y) result(binary) binary%d1val1 = x%d1val1 + y%d1val1 binary%d1val2 = x%d1val2 + y%d1val2 end function add_self - + function add_self_real(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1062,7 +1062,7 @@ function add_self_real(x, y) result(unary) unary%d1val1 = x%d1val1 unary%d1val2 = x%d1val2 end function add_self_real - + function add_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1071,7 +1071,7 @@ function add_real_self(z, x) result(unary) unary%d1val1 = x%d1val1 unary%d1val2 = x%d1val2 end function add_real_self - + function add_self_int(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x integer, intent(in) :: y @@ -1082,7 +1082,7 @@ function add_self_int(x, y) result(unary) unary%d1val1 = x%d1val1 unary%d1val2 = x%d1val2 end function add_self_int - + function add_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1093,7 +1093,7 @@ function add_int_self(z, x) result(unary) unary%d1val1 = x%d1val1 unary%d1val2 = x%d1val2 end function add_int_self - + function sub_self(x, y) result(binary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1), intent(in) :: y @@ -1102,7 +1102,7 @@ function sub_self(x, y) result(binary) binary%d1val1 = x%d1val1 - y%d1val1 binary%d1val2 = x%d1val2 - y%d1val2 end function sub_self - + function sub_self_real(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1111,7 +1111,7 @@ function sub_self_real(x, y) result(unary) unary%d1val1 = x%d1val1 unary%d1val2 = x%d1val2 end function sub_self_real - + function sub_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1120,7 +1120,7 @@ function sub_real_self(z, x) result(unary) unary%d1val1 = -x%d1val1 unary%d1val2 = -x%d1val2 end function sub_real_self - + function sub_self_int(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x integer, intent(in) :: y @@ -1131,7 +1131,7 @@ function sub_self_int(x, y) result(unary) unary%d1val1 = x%d1val1 unary%d1val2 = x%d1val2 end function sub_self_int - + function sub_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1142,7 +1142,7 @@ function sub_int_self(z, x) result(unary) unary%d1val1 = -x%d1val1 unary%d1val2 = -x%d1val2 end function sub_int_self - + function mul_self(x, y) result(binary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1), intent(in) :: y @@ -1151,7 +1151,7 @@ function mul_self(x, y) result(binary) binary%d1val1 = x%d1val1*y%val + x%val*y%d1val1 binary%d1val2 = x%d1val2*y%val + x%val*y%d1val2 end function mul_self - + function mul_self_real(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1160,7 +1160,7 @@ function mul_self_real(x, y) result(unary) unary%d1val1 = x%d1val1*y unary%d1val2 = x%d1val2*y end function mul_self_real - + function mul_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1169,7 +1169,7 @@ function mul_real_self(z, x) result(unary) unary%d1val1 = x%d1val1*z unary%d1val2 = x%d1val2*z end function mul_real_self - + function mul_self_int(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x integer, intent(in) :: y @@ -1180,7 +1180,7 @@ function mul_self_int(x, y) result(unary) unary%d1val1 = x%d1val1*y_dp unary%d1val2 = x%d1val2*y_dp end function mul_self_int - + function mul_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1191,7 +1191,7 @@ function mul_int_self(z, x) result(unary) unary%d1val1 = x%d1val1*y_dp unary%d1val2 = x%d1val2*y_dp end function mul_int_self - + function div_self(x, y) result(binary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1), intent(in) :: y @@ -1202,7 +1202,7 @@ function div_self(x, y) result(binary) binary%d1val1 = q0*(x%d1val1*y%val - x%val*y%d1val1) binary%d1val2 = q0*(x%d1val2*y%val - x%val*y%d1val2) end function div_self - + function div_self_real(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1213,7 +1213,7 @@ function div_self_real(x, y) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function div_self_real - + function div_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1224,7 +1224,7 @@ function div_real_self(z, x) result(unary) unary%d1val1 = -q0*x%d1val1 unary%d1val2 = -q0*x%d1val2 end function div_real_self - + function div_self_int(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x integer, intent(in) :: y @@ -1237,7 +1237,7 @@ function div_self_int(x, y) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function div_self_int - + function div_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1250,7 +1250,7 @@ function div_int_self(z, x) result(unary) unary%d1val1 = -q0*x%d1val1 unary%d1val2 = -q0*x%d1val2 end function div_int_self - + function pow_self(x, y) result(binary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1), intent(in) :: y @@ -1263,7 +1263,7 @@ function pow_self(x, y) result(binary) binary%d1val1 = q0*(q1*y%d1val1 + x%d1val1*y%val) binary%d1val2 = q0*(q1*y%d1val2 + x%d1val2*y%val) end function pow_self - + function pow_self_real(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1274,7 +1274,7 @@ function pow_self_real(x, y) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function pow_self_real - + function pow_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1287,7 +1287,7 @@ function pow_real_self(z, x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function pow_real_self - + function pow_self_int(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x integer, intent(in) :: y @@ -1300,7 +1300,7 @@ function pow_self_int(x, y) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function pow_self_int - + function pow_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1315,7 +1315,7 @@ function pow_int_self(z, x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function pow_int_self - + function max_self(x, y) result(binary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1), intent(in) :: y @@ -1328,7 +1328,7 @@ function max_self(x, y) result(binary) binary%d1val1 = q0*x%d1val1 + q1*y%d1val1 binary%d1val2 = q0*x%d1val2 + q1*y%d1val2 end function max_self - + function max_self_real(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1339,7 +1339,7 @@ function max_self_real(x, y) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function max_self_real - + function max_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1350,7 +1350,7 @@ function max_real_self(z, x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function max_real_self - + function max_self_int(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x integer, intent(in) :: y @@ -1363,7 +1363,7 @@ function max_self_int(x, y) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function max_self_int - + function max_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1376,7 +1376,7 @@ function max_int_self(z, x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function max_int_self - + function min_self(x, y) result(binary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1), intent(in) :: y @@ -1389,7 +1389,7 @@ function min_self(x, y) result(binary) binary%d1val1 = q0*x%d1val1 + q1*y%d1val1 binary%d1val2 = q0*x%d1val2 + q1*y%d1val2 end function min_self - + function min_self_real(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1400,7 +1400,7 @@ function min_self_real(x, y) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function min_self_real - + function min_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1411,7 +1411,7 @@ function min_real_self(z, x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function min_real_self - + function min_self_int(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x integer, intent(in) :: y @@ -1424,7 +1424,7 @@ function min_self_int(x, y) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function min_self_int - + function min_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1437,7 +1437,7 @@ function min_int_self(z, x) result(unary) unary%d1val1 = q0*x%d1val1 unary%d1val2 = q0*x%d1val2 end function min_int_self - + function dim_self(x, y) result(binary) type(auto_diff_real_2var_order1), intent(in) :: x type(auto_diff_real_2var_order1), intent(in) :: y @@ -1450,7 +1450,7 @@ function dim_self(x, y) result(binary) binary%d1val1 = -0.5_dp*y%d1val1 + 0.5_dp*x%d1val1 + q1*(x%d1val1 - y%d1val1) binary%d1val2 = -0.5_dp*y%d1val2 + 0.5_dp*x%d1val2 + q1*(x%d1val2 - y%d1val2) end function dim_self - + function dim_self_real(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1463,7 +1463,7 @@ function dim_self_real(x, y) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function dim_self_real - + function dim_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1476,7 +1476,7 @@ function dim_real_self(z, x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function dim_real_self - + function dim_self_int(x, y) result(unary) type(auto_diff_real_2var_order1), intent(in) :: x integer, intent(in) :: y @@ -1491,7 +1491,7 @@ function dim_self_int(x, y) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function dim_self_int - + function dim_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order1), intent(in) :: x @@ -1506,7 +1506,7 @@ function dim_int_self(z, x) result(unary) unary%d1val1 = q1*x%d1val1 unary%d1val2 = q1*x%d1val2 end function dim_int_self - + function differentiate_auto_diff_real_2var_order1_1(this) result(derivative) type(auto_diff_real_2var_order1), intent(in) :: this type(auto_diff_real_2var_order1) :: derivative @@ -1514,7 +1514,7 @@ function differentiate_auto_diff_real_2var_order1_1(this) result(derivative) derivative%d1val1 = 0.0_dp derivative%d1val2 = 0.0_dp end function differentiate_auto_diff_real_2var_order1_1 - + function differentiate_auto_diff_real_2var_order1_2(this) result(derivative) type(auto_diff_real_2var_order1), intent(in) :: this type(auto_diff_real_2var_order1) :: derivative @@ -1522,5 +1522,5 @@ function differentiate_auto_diff_real_2var_order1_2(this) result(derivative) derivative%d1val1 = 0.0_dp derivative%d1val2 = 0.0_dp end function differentiate_auto_diff_real_2var_order1_2 - + end module auto_diff_real_2var_order1_module \ No newline at end of file diff --git a/auto_diff/private/auto_diff_real_2var_order2_module.f90 b/auto_diff/private/auto_diff_real_2var_order2_module.f90 index ebd151bf3..39a556aac 100644 --- a/auto_diff/private/auto_diff_real_2var_order2_module.f90 +++ b/auto_diff/private/auto_diff_real_2var_order2_module.f90 @@ -3,7 +3,7 @@ module auto_diff_real_2var_order2_module use utils_lib use support_functions use math_lib - + implicit none private public :: auto_diff_real_2var_order2, & @@ -73,13 +73,13 @@ module auto_diff_real_2var_order2_module real(dp) :: d1val1_d1val2 real(dp) :: d2val2 end type auto_diff_real_2var_order2 - + interface assignment(=) module procedure assign_from_self module procedure assign_from_real_dp module procedure assign_from_int end interface assignment(=) - + interface operator(.eq.) module procedure equal_self module procedure equal_auto_diff_real_2var_order2_real_dp @@ -87,7 +87,7 @@ module auto_diff_real_2var_order2_module module procedure equal_auto_diff_real_2var_order2_int module procedure equal_int_auto_diff_real_2var_order2 end interface operator(.eq.) - + interface operator(.ne.) module procedure neq_self module procedure neq_auto_diff_real_2var_order2_real_dp @@ -95,7 +95,7 @@ module auto_diff_real_2var_order2_module module procedure neq_auto_diff_real_2var_order2_int module procedure neq_int_auto_diff_real_2var_order2 end interface operator(.ne.) - + interface operator(.gt.) module procedure greater_self module procedure greater_auto_diff_real_2var_order2_real_dp @@ -103,7 +103,7 @@ module auto_diff_real_2var_order2_module module procedure greater_auto_diff_real_2var_order2_int module procedure greater_int_auto_diff_real_2var_order2 end interface operator(.gt.) - + interface operator(.lt.) module procedure less_self module procedure less_auto_diff_real_2var_order2_real_dp @@ -111,7 +111,7 @@ module auto_diff_real_2var_order2_module module procedure less_auto_diff_real_2var_order2_int module procedure less_int_auto_diff_real_2var_order2 end interface operator(.lt.) - + interface operator(.le.) module procedure leq_self module procedure leq_auto_diff_real_2var_order2_real_dp @@ -119,7 +119,7 @@ module auto_diff_real_2var_order2_module module procedure leq_auto_diff_real_2var_order2_int module procedure leq_int_auto_diff_real_2var_order2 end interface operator(.le.) - + interface operator(.ge.) module procedure geq_self module procedure geq_auto_diff_real_2var_order2_real_dp @@ -127,175 +127,175 @@ module auto_diff_real_2var_order2_module module procedure geq_auto_diff_real_2var_order2_int module procedure geq_int_auto_diff_real_2var_order2 end interface operator(.ge.) - + interface make_unop module procedure make_unary_operator end interface make_unop - + interface make_binop module procedure make_binary_operator end interface make_binop - + interface sign module procedure sign_self end interface sign - + interface safe_sqrt module procedure safe_sqrt_self end interface safe_sqrt - + interface operator(-) module procedure unary_minus_self end interface operator(-) - + interface exp module procedure exp_self end interface exp - + interface expm1 module procedure expm1_self end interface expm1 - + interface exp10 module procedure exp10_self end interface exp10 - + interface powm1 module procedure powm1_self end interface powm1 - + interface log module procedure log_self end interface log - + interface log1p module procedure log1p_self end interface log1p - + interface safe_log module procedure safe_log_self end interface safe_log - + interface log10 module procedure log10_self end interface log10 - + interface safe_log10 module procedure safe_log10_self end interface safe_log10 - + interface log2 module procedure log2_self end interface log2 - + interface sin module procedure sin_self end interface sin - + interface cos module procedure cos_self end interface cos - + interface tan module procedure tan_self end interface tan - + interface sinpi module procedure sinpi_self end interface sinpi - + interface cospi module procedure cospi_self end interface cospi - + interface tanpi module procedure tanpi_self end interface tanpi - + interface sinh module procedure sinh_self end interface sinh - + interface cosh module procedure cosh_self end interface cosh - + interface tanh module procedure tanh_self end interface tanh - + interface asin module procedure asin_self end interface asin - + interface acos module procedure acos_self end interface acos - + interface atan module procedure atan_self end interface atan - + interface asinpi module procedure asinpi_self end interface asinpi - + interface acospi module procedure acospi_self end interface acospi - + interface atanpi module procedure atanpi_self end interface atanpi - + interface asinh module procedure asinh_self end interface asinh - + interface acosh module procedure acosh_self end interface acosh - + interface atanh module procedure atanh_self end interface atanh - + interface sqrt module procedure sqrt_self end interface sqrt - + interface pow2 module procedure pow2_self end interface pow2 - + interface pow3 module procedure pow3_self end interface pow3 - + interface pow4 module procedure pow4_self end interface pow4 - + interface pow5 module procedure pow5_self end interface pow5 - + interface pow6 module procedure pow6_self end interface pow6 - + interface pow7 module procedure pow7_self end interface pow7 - + interface pow8 module procedure pow8_self end interface pow8 - + interface abs module procedure abs_self end interface abs - + interface operator(+) module procedure add_self module procedure add_self_real @@ -303,7 +303,7 @@ module auto_diff_real_2var_order2_module module procedure add_self_int module procedure add_int_self end interface operator(+) - + interface operator(-) module procedure sub_self module procedure sub_self_real @@ -311,7 +311,7 @@ module auto_diff_real_2var_order2_module module procedure sub_self_int module procedure sub_int_self end interface operator(-) - + interface operator(*) module procedure mul_self module procedure mul_self_real @@ -319,7 +319,7 @@ module auto_diff_real_2var_order2_module module procedure mul_self_int module procedure mul_int_self end interface operator(*) - + interface operator(/) module procedure div_self module procedure div_self_real @@ -327,7 +327,7 @@ module auto_diff_real_2var_order2_module module procedure div_self_int module procedure div_int_self end interface operator(/) - + interface pow module procedure pow_self module procedure pow_self_real @@ -335,7 +335,7 @@ module auto_diff_real_2var_order2_module module procedure pow_self_int module procedure pow_int_self end interface pow - + interface max module procedure max_self module procedure max_self_real @@ -343,7 +343,7 @@ module auto_diff_real_2var_order2_module module procedure max_self_int module procedure max_int_self end interface max - + interface min module procedure min_self module procedure min_self_real @@ -351,7 +351,7 @@ module auto_diff_real_2var_order2_module module procedure min_self_int module procedure min_int_self end interface min - + interface dim module procedure dim_self module procedure dim_self_real @@ -359,15 +359,15 @@ module auto_diff_real_2var_order2_module module procedure dim_self_int module procedure dim_int_self end interface dim - + interface differentiate_1 module procedure differentiate_auto_diff_real_2var_order2_1 end interface differentiate_1 - + interface differentiate_2 module procedure differentiate_auto_diff_real_2var_order2_2 end interface differentiate_2 - + contains subroutine assign_from_self(this, other) @@ -380,7 +380,7 @@ subroutine assign_from_self(this, other) this%d1val1_d1val2 = other%d1val1_d1val2 this%d2val2 = other%d2val2 end subroutine assign_from_self - + subroutine assign_from_real_dp(this, other) type(auto_diff_real_2var_order2), intent(out) :: this real(dp), intent(in) :: other @@ -391,7 +391,7 @@ subroutine assign_from_real_dp(this, other) this%d1val1_d1val2 = 0.0_dp this%d2val2 = 0.0_dp end subroutine assign_from_real_dp - + subroutine assign_from_int(this, other) type(auto_diff_real_2var_order2), intent(out) :: this integer, intent(in) :: other @@ -402,217 +402,217 @@ subroutine assign_from_int(this, other) this%d1val1_d1val2 = 0.0_dp this%d2val2 = 0.0_dp end subroutine assign_from_int - + function equal_self(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this%val .eq. other%val) end function equal_self - + function equal_auto_diff_real_2var_order2_real_dp(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_2var_order2_real_dp - + function equal_real_dp_auto_diff_real_2var_order2(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_real_dp_auto_diff_real_2var_order2 - + function equal_auto_diff_real_2var_order2_int(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_2var_order2_int - + function equal_int_auto_diff_real_2var_order2(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_int_auto_diff_real_2var_order2 - + function neq_self(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this%val .ne. other%val) end function neq_self - + function neq_auto_diff_real_2var_order2_real_dp(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_2var_order2_real_dp - + function neq_real_dp_auto_diff_real_2var_order2(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_real_dp_auto_diff_real_2var_order2 - + function neq_auto_diff_real_2var_order2_int(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_2var_order2_int - + function neq_int_auto_diff_real_2var_order2(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_int_auto_diff_real_2var_order2 - + function greater_self(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this%val .gt. other%val) end function greater_self - + function greater_auto_diff_real_2var_order2_real_dp(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_2var_order2_real_dp - + function greater_real_dp_auto_diff_real_2var_order2(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_real_dp_auto_diff_real_2var_order2 - + function greater_auto_diff_real_2var_order2_int(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_2var_order2_int - + function greater_int_auto_diff_real_2var_order2(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_int_auto_diff_real_2var_order2 - + function less_self(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this%val .lt. other%val) end function less_self - + function less_auto_diff_real_2var_order2_real_dp(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_2var_order2_real_dp - + function less_real_dp_auto_diff_real_2var_order2(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_real_dp_auto_diff_real_2var_order2 - + function less_auto_diff_real_2var_order2_int(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_2var_order2_int - + function less_int_auto_diff_real_2var_order2(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_int_auto_diff_real_2var_order2 - + function leq_self(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this%val .le. other%val) end function leq_self - + function leq_auto_diff_real_2var_order2_real_dp(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_2var_order2_real_dp - + function leq_real_dp_auto_diff_real_2var_order2(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_real_dp_auto_diff_real_2var_order2 - + function leq_auto_diff_real_2var_order2_int(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_2var_order2_int - + function leq_int_auto_diff_real_2var_order2(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_int_auto_diff_real_2var_order2 - + function geq_self(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this%val .ge. other%val) end function geq_self - + function geq_auto_diff_real_2var_order2_real_dp(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_2var_order2_real_dp - + function geq_real_dp_auto_diff_real_2var_order2(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_real_dp_auto_diff_real_2var_order2 - + function geq_auto_diff_real_2var_order2_int(this, other) result(z) type(auto_diff_real_2var_order2), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_2var_order2_int - + function geq_int_auto_diff_real_2var_order2(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order2), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_int_auto_diff_real_2var_order2 - + function make_unary_operator(x, z_val, z_d1x, z_d2x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x real(dp), intent(in) :: z_val @@ -626,7 +626,7 @@ function make_unary_operator(x, z_val, z_d1x, z_d2x) result(unary) unary%d1val1_d1val2 = x%d1val1*x%d1val2*z_d2x + x%d1val1_d1val2*z_d1x unary%d2val2 = x%d2val2*z_d1x + z_d2x*pow2(x%d1val2) end function make_unary_operator - + function make_binary_operator(x, y, z_val, z_d1x, z_d1y, z_d2x, z_d1x_d1y, z_d2y) result(binary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2), intent(in) :: y @@ -648,7 +648,7 @@ function make_binary_operator(x, y, z_val, z_d1x, z_d1y, z_d2x, z_d1x_d1y, z_d2y binary%d1val1_d1val2 = q0*y%d1val2 + q1*y%d1val1 + x%d1val1*x%d1val2*z_d2x + x%d1val1_d1val2*z_d1x + y%d1val1*y%d1val2*z_d2y + y%d1val1_d1val2*z_d1y binary%d2val2 = 2.0_dp*q1*y%d1val2 + x%d2val2*z_d1x + y%d2val2*z_d1y + z_d2x*pow2(x%d1val2) + z_d2y*pow2(y%d1val2) end function make_binary_operator - + function sign_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -659,7 +659,7 @@ function sign_self(x) result(unary) unary%d1val1_d1val2 = 0.0_dp unary%d2val2 = 0.0_dp end function sign_self - + function safe_sqrt_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -678,7 +678,7 @@ function safe_sqrt_self(x) result(unary) unary%d1val1_d1val2 = q3*(q2*x%d1val1_d1val2 - x%d1val1*x%d1val2) unary%d2val2 = q3*(q2*x%d2val2 - pow2(x%d1val2)) end function safe_sqrt_self - + function unary_minus_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -689,7 +689,7 @@ function unary_minus_self(x) result(unary) unary%d1val1_d1val2 = -x%d1val1_d1val2 unary%d2val2 = -x%d2val2 end function unary_minus_self - + function exp_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -702,7 +702,7 @@ function exp_self(x) result(unary) unary%d1val1_d1val2 = q0*(x%d1val1*x%d1val2 + x%d1val1_d1val2) unary%d2val2 = q0*(x%d2val2 + pow2(x%d1val2)) end function exp_self - + function expm1_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -715,7 +715,7 @@ function expm1_self(x) result(unary) unary%d1val1_d1val2 = q0*(x%d1val1*x%d1val2 + x%d1val1_d1val2) unary%d2val2 = q0*(x%d2val2 + pow2(x%d1val2)) end function expm1_self - + function exp10_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -732,7 +732,7 @@ function exp10_self(x) result(unary) unary%d1val1_d1val2 = q2*(q1*x%d1val1*x%d1val2 + x%d1val1_d1val2) unary%d2val2 = q2*(q1*pow2(x%d1val2) + x%d2val2) end function exp10_self - + function powm1_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -747,7 +747,7 @@ function powm1_self(x) result(unary) unary%d1val1_d1val2 = q1*(2.0_dp*x%d1val1*x%d1val2 - x%d1val1_d1val2*x%val) unary%d2val2 = q1*(2.0_dp*pow2(x%d1val2) - x%d2val2*x%val) end function powm1_self - + function log_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -762,7 +762,7 @@ function log_self(x) result(unary) unary%d1val1_d1val2 = q1*(-x%d1val1*x%d1val2 + x%d1val1_d1val2*x%val) unary%d2val2 = q1*(x%d2val2*x%val - pow2(x%d1val2)) end function log_self - + function log1p_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -779,7 +779,7 @@ function log1p_self(x) result(unary) unary%d1val1_d1val2 = q2*(q0*x%d1val1_d1val2 - x%d1val1*x%d1val2) unary%d2val2 = q2*(q0*x%d2val2 - pow2(x%d1val2)) end function log1p_self - + function safe_log_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -794,7 +794,7 @@ function safe_log_self(x) result(unary) unary%d1val1_d1val2 = q1*(-x%d1val1*x%d1val2 + x%d1val1_d1val2*x%val) unary%d2val2 = q1*(x%d2val2*x%val - pow2(x%d1val2)) end function safe_log_self - + function log10_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -811,7 +811,7 @@ function log10_self(x) result(unary) unary%d1val1_d1val2 = q2*(-x%d1val1*x%d1val2 + x%d1val1_d1val2*x%val) unary%d2val2 = q2*(x%d2val2*x%val - pow2(x%d1val2)) end function log10_self - + function safe_log10_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -828,7 +828,7 @@ function safe_log10_self(x) result(unary) unary%d1val1_d1val2 = q2*(-x%d1val1*x%d1val2 + x%d1val1_d1val2*x%val) unary%d2val2 = q2*(x%d2val2*x%val - pow2(x%d1val2)) end function safe_log10_self - + function log2_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -845,7 +845,7 @@ function log2_self(x) result(unary) unary%d1val1_d1val2 = q2*(-x%d1val1*x%d1val2 + x%d1val1_d1val2*x%val) unary%d2val2 = q2*(x%d2val2*x%val - pow2(x%d1val2)) end function log2_self - + function sin_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -860,7 +860,7 @@ function sin_self(x) result(unary) unary%d1val1_d1val2 = -q0*x%d1val1*x%d1val2 + q1*x%d1val1_d1val2 unary%d2val2 = -q0*pow2(x%d1val2) + q1*x%d2val2 end function sin_self - + function cos_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -875,7 +875,7 @@ function cos_self(x) result(unary) unary%d1val1_d1val2 = -q0*x%d1val1*x%d1val2 - q1*x%d1val1_d1val2 unary%d2val2 = -q0*pow2(x%d1val2) - q1*x%d2val2 end function cos_self - + function tan_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -892,7 +892,7 @@ function tan_self(x) result(unary) unary%d1val1_d1val2 = (q2*x%d1val1*x%d1val2 + x%d1val1_d1val2)*powm1(pow2(cos(x%val))) unary%d2val2 = q1*(q2*pow2(x%d1val2) + x%d2val2) end function tan_self - + function sinpi_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -913,7 +913,7 @@ function sinpi_self(x) result(unary) unary%d1val1_d1val2 = pi*(q2*x%d1val1_d1val2 - q4*x%d1val1*x%d1val2) unary%d2val2 = pi*(q2*x%d2val2 - q4*pow2(x%d1val2)) end function sinpi_self - + function cospi_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -934,7 +934,7 @@ function cospi_self(x) result(unary) unary%d1val1_d1val2 = -pi*(q2*x%d1val1_d1val2 + q4*x%d1val1*x%d1val2) unary%d2val2 = -pi*(q2*x%d2val2 + q4*pow2(x%d1val2)) end function cospi_self - + function tanpi_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -953,7 +953,7 @@ function tanpi_self(x) result(unary) unary%d1val1_d1val2 = pi*(q3*x%d1val1*x%d1val2 + x%d1val1_d1val2)*powm1(pow2(cos(q0))) unary%d2val2 = q2*(q3*pow2(x%d1val2) + x%d2val2) end function tanpi_self - + function sinh_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -968,7 +968,7 @@ function sinh_self(x) result(unary) unary%d1val1_d1val2 = q0*x%d1val1*x%d1val2 + q1*x%d1val1_d1val2 unary%d2val2 = q0*pow2(x%d1val2) + q1*x%d2val2 end function sinh_self - + function cosh_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -983,7 +983,7 @@ function cosh_self(x) result(unary) unary%d1val1_d1val2 = q0*x%d1val1*x%d1val2 + q1*x%d1val1_d1val2 unary%d2val2 = q0*pow2(x%d1val2) + q1*x%d2val2 end function cosh_self - + function tanh_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1000,7 +1000,7 @@ function tanh_self(x) result(unary) unary%d1val1_d1val2 = -(q2*x%d1val1*x%d1val2 - x%d1val1_d1val2)*powm1(pow2(cosh(x%val))) unary%d2val2 = q1*(q2*pow2(x%d1val2) - x%d2val2) end function tanh_self - + function asin_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1021,7 +1021,7 @@ function asin_self(x) result(unary) unary%d1val1_d1val2 = q3*(q1*x%d1val1_d1val2 + x%d1val1*x%d1val2*x%val) unary%d2val2 = q3*(-q4*x%d2val2 + x%val*pow2(x%d1val2)) end function asin_self - + function acos_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1042,7 +1042,7 @@ function acos_self(x) result(unary) unary%d1val1_d1val2 = -q3*(-q4*x%d1val1_d1val2 + x%d1val1*x%d1val2*x%val) unary%d2val2 = q3*(q4*x%d2val2 - x%val*pow2(x%d1val2)) end function acos_self - + function atan_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1061,7 +1061,7 @@ function atan_self(x) result(unary) unary%d1val1_d1val2 = q2*(q0*x%d1val1_d1val2 - q3*x%d1val1*x%d1val2) unary%d2val2 = q2*(q0*x%d2val2 - q3*pow2(x%d1val2)) end function atan_self - + function asinpi_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1084,7 +1084,7 @@ function asinpi_self(x) result(unary) unary%d1val1_d1val2 = q5*(q2*x%d1val1_d1val2 + x%d1val1*x%d1val2*x%val) unary%d2val2 = q5*(-q4*x%d2val2 + x%val*pow2(x%d1val2)) end function asinpi_self - + function acospi_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1107,7 +1107,7 @@ function acospi_self(x) result(unary) unary%d1val1_d1val2 = -q5*(-q4*x%d1val1_d1val2 + x%d1val1*x%d1val2*x%val) unary%d2val2 = q5*(q4*x%d2val2 - x%val*pow2(x%d1val2)) end function acospi_self - + function atanpi_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1128,7 +1128,7 @@ function atanpi_self(x) result(unary) unary%d1val1_d1val2 = q4*(q0*x%d1val1_d1val2 - q3*x%d1val1*x%d1val2 + x%d1val1_d1val2) unary%d2val2 = q4*(q0*x%d2val2 - q3*pow2(x%d1val2) + x%d2val2) end function atanpi_self - + function asinh_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1145,7 +1145,7 @@ function asinh_self(x) result(unary) unary%d1val1_d1val2 = q2*(q0*x%d1val1_d1val2 - x%d1val1*x%d1val2*x%val) unary%d2val2 = q2*(q0*x%d2val2 - x%val*pow2(x%d1val2)) end function asinh_self - + function acosh_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1162,7 +1162,7 @@ function acosh_self(x) result(unary) unary%d1val1_d1val2 = q2*(q0*x%d1val1_d1val2 - x%d1val1*x%d1val2*x%val) unary%d2val2 = q2*(q0*x%d2val2 - x%val*pow2(x%d1val2)) end function acosh_self - + function atanh_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1181,7 +1181,7 @@ function atanh_self(x) result(unary) unary%d1val1_d1val2 = q2*(-q0*x%d1val1_d1val2 + q3*x%d1val1*x%d1val2) unary%d2val2 = q2*(-q0*x%d2val2 + q3*pow2(x%d1val2)) end function atanh_self - + function sqrt_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1200,7 +1200,7 @@ function sqrt_self(x) result(unary) unary%d1val1_d1val2 = q3*(q2*x%d1val1_d1val2 - x%d1val1*x%d1val2) unary%d2val2 = q3*(q2*x%d2val2 - pow2(x%d1val2)) end function sqrt_self - + function pow2_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1213,7 +1213,7 @@ function pow2_self(x) result(unary) unary%d1val1_d1val2 = 2.0_dp*x%d1val1*x%d1val2 + q0*x%d1val1_d1val2 unary%d2val2 = 2.0_dp*pow2(x%d1val2) + q0*x%d2val2 end function pow2_self - + function pow3_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1228,7 +1228,7 @@ function pow3_self(x) result(unary) unary%d1val1_d1val2 = q1*(2.0_dp*x%d1val1*x%d1val2 + x%d1val1_d1val2*x%val) unary%d2val2 = q1*(2.0_dp*pow2(x%d1val2) + x%d2val2*x%val) end function pow3_self - + function pow4_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1243,7 +1243,7 @@ function pow4_self(x) result(unary) unary%d1val1_d1val2 = q1*(3.0_dp*x%d1val1*x%d1val2 + x%d1val1_d1val2*x%val) unary%d2val2 = q1*(3.0_dp*pow2(x%d1val2) + x%d2val2*x%val) end function pow4_self - + function pow5_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1258,7 +1258,7 @@ function pow5_self(x) result(unary) unary%d1val1_d1val2 = q1*(4.0_dp*x%d1val1*x%d1val2 + x%d1val1_d1val2*x%val) unary%d2val2 = q1*(4.0_dp*pow2(x%d1val2) + x%d2val2*x%val) end function pow5_self - + function pow6_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1273,7 +1273,7 @@ function pow6_self(x) result(unary) unary%d1val1_d1val2 = q1*(5.0_dp*x%d1val1*x%d1val2 + x%d1val1_d1val2*x%val) unary%d2val2 = q1*(5.0_dp*pow2(x%d1val2) + x%d2val2*x%val) end function pow6_self - + function pow7_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1288,7 +1288,7 @@ function pow7_self(x) result(unary) unary%d1val1_d1val2 = q1*(6.0_dp*x%d1val1*x%d1val2 + x%d1val1_d1val2*x%val) unary%d2val2 = q1*(6.0_dp*pow2(x%d1val2) + x%d2val2*x%val) end function pow7_self - + function pow8_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1303,7 +1303,7 @@ function pow8_self(x) result(unary) unary%d1val1_d1val2 = q1*(7.0_dp*x%d1val1*x%d1val2 + x%d1val1_d1val2*x%val) unary%d2val2 = q1*(7.0_dp*pow2(x%d1val2) + x%d2val2*x%val) end function pow8_self - + function abs_self(x) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2) :: unary @@ -1316,7 +1316,7 @@ function abs_self(x) result(unary) unary%d1val1_d1val2 = q0*x%d1val1_d1val2 unary%d2val2 = q0*x%d2val2 end function abs_self - + function add_self(x, y) result(binary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2), intent(in) :: y @@ -1328,7 +1328,7 @@ function add_self(x, y) result(binary) binary%d1val1_d1val2 = x%d1val1_d1val2 + y%d1val1_d1val2 binary%d2val2 = x%d2val2 + y%d2val2 end function add_self - + function add_self_real(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x real(dp), intent(in) :: y @@ -1340,7 +1340,7 @@ function add_self_real(x, y) result(unary) unary%d1val1_d1val2 = x%d1val1_d1val2 unary%d2val2 = x%d2val2 end function add_self_real - + function add_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1352,7 +1352,7 @@ function add_real_self(z, x) result(unary) unary%d1val1_d1val2 = x%d1val1_d1val2 unary%d2val2 = x%d2val2 end function add_real_self - + function add_self_int(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x integer, intent(in) :: y @@ -1366,7 +1366,7 @@ function add_self_int(x, y) result(unary) unary%d1val1_d1val2 = x%d1val1_d1val2 unary%d2val2 = x%d2val2 end function add_self_int - + function add_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1380,7 +1380,7 @@ function add_int_self(z, x) result(unary) unary%d1val1_d1val2 = x%d1val1_d1val2 unary%d2val2 = x%d2val2 end function add_int_self - + function sub_self(x, y) result(binary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2), intent(in) :: y @@ -1392,7 +1392,7 @@ function sub_self(x, y) result(binary) binary%d1val1_d1val2 = x%d1val1_d1val2 - y%d1val1_d1val2 binary%d2val2 = x%d2val2 - y%d2val2 end function sub_self - + function sub_self_real(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x real(dp), intent(in) :: y @@ -1404,7 +1404,7 @@ function sub_self_real(x, y) result(unary) unary%d1val1_d1val2 = x%d1val1_d1val2 unary%d2val2 = x%d2val2 end function sub_self_real - + function sub_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1416,7 +1416,7 @@ function sub_real_self(z, x) result(unary) unary%d1val1_d1val2 = -x%d1val1_d1val2 unary%d2val2 = -x%d2val2 end function sub_real_self - + function sub_self_int(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x integer, intent(in) :: y @@ -1430,7 +1430,7 @@ function sub_self_int(x, y) result(unary) unary%d1val1_d1val2 = x%d1val1_d1val2 unary%d2val2 = x%d2val2 end function sub_self_int - + function sub_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1444,7 +1444,7 @@ function sub_int_self(z, x) result(unary) unary%d1val1_d1val2 = -x%d1val1_d1val2 unary%d2val2 = -x%d2val2 end function sub_int_self - + function mul_self(x, y) result(binary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2), intent(in) :: y @@ -1456,7 +1456,7 @@ function mul_self(x, y) result(binary) binary%d1val1_d1val2 = x%d1val1*y%d1val2 + x%d1val1_d1val2*y%val + x%d1val2*y%d1val1 + x%val*y%d1val1_d1val2 binary%d2val2 = 2.0_dp*x%d1val2*y%d1val2 + x%d2val2*y%val + x%val*y%d2val2 end function mul_self - + function mul_self_real(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x real(dp), intent(in) :: y @@ -1468,7 +1468,7 @@ function mul_self_real(x, y) result(unary) unary%d1val1_d1val2 = x%d1val1_d1val2*y unary%d2val2 = x%d2val2*y end function mul_self_real - + function mul_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1480,7 +1480,7 @@ function mul_real_self(z, x) result(unary) unary%d1val1_d1val2 = x%d1val1_d1val2*z unary%d2val2 = x%d2val2*z end function mul_real_self - + function mul_self_int(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x integer, intent(in) :: y @@ -1494,7 +1494,7 @@ function mul_self_int(x, y) result(unary) unary%d1val1_d1val2 = x%d1val1_d1val2*y_dp unary%d2val2 = x%d2val2*y_dp end function mul_self_int - + function mul_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1508,7 +1508,7 @@ function mul_int_self(z, x) result(unary) unary%d1val1_d1val2 = x%d1val1_d1val2*y_dp unary%d2val2 = x%d2val2*y_dp end function mul_int_self - + function div_self(x, y) result(binary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2), intent(in) :: y @@ -1534,7 +1534,7 @@ function div_self(x, y) result(binary) binary%d1val1_d1val2 = q5*(q0*x%d1val1_d1val2 + q3*q6 - y%val*(x%d1val1*y%d1val2 + x%d1val2*y%d1val1 + x%val*y%d1val1_d1val2)) binary%d2val2 = q5*(q0*x%d2val2 - q4*q6 + x%val*(2.0_dp*pow2(y%d1val2) - y%d2val2*y%val)) end function div_self - + function div_self_real(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x real(dp), intent(in) :: y @@ -1548,7 +1548,7 @@ function div_self_real(x, y) result(unary) unary%d1val1_d1val2 = q0*x%d1val1_d1val2 unary%d2val2 = q0*x%d2val2 end function div_self_real - + function div_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1564,7 +1564,7 @@ function div_real_self(z, x) result(unary) unary%d1val1_d1val2 = q1*(2.0_dp*x%d1val1*x%d1val2 - x%d1val1_d1val2*x%val) unary%d2val2 = q1*(2.0_dp*pow2(x%d1val2) - x%d2val2*x%val) end function div_real_self - + function div_self_int(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x integer, intent(in) :: y @@ -1580,7 +1580,7 @@ function div_self_int(x, y) result(unary) unary%d1val1_d1val2 = q0*x%d1val1_d1val2 unary%d2val2 = q0*x%d2val2 end function div_self_int - + function div_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1598,7 +1598,7 @@ function div_int_self(z, x) result(unary) unary%d1val1_d1val2 = q1*(2.0_dp*x%d1val1*x%d1val2 - x%d1val1_d1val2*x%val) unary%d2val2 = q1*(2.0_dp*pow2(x%d1val2) - x%d2val2*x%val) end function div_int_self - + function pow_self(x, y) result(binary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2), intent(in) :: y @@ -1626,7 +1626,7 @@ function pow_self(x, y) result(binary) binary%d1val1_d1val2 = (-q1*x%d1val2 + q4*q5 + q7*y%d1val1_d1val2 + x%val*(x%d1val1*y%d1val2 + x%d1val1_d1val2*y%val + x%d1val2*y%d1val1))*pow(x%val, 3.0_dp + y%val)*powm1(pow5(x%val)) binary%d2val2 = q6*(q7*y%d2val2 + x%val*(2.0_dp*x%d1val2*y%d1val2 + x%d2val2*y%val) - y%val*pow2(x%d1val2) + pow2(q5)) end function pow_self - + function pow_self_real(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x real(dp), intent(in) :: y @@ -1648,7 +1648,7 @@ function pow_self_real(x, y) result(unary) unary%d1val1_d1val2 = q2*(q3*y - q3 + x%d1val1_d1val2*x%val) unary%d2val2 = q2*(q4*y - q4 + x%d2val2*x%val) end function pow_self_real - + function pow_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1666,7 +1666,7 @@ function pow_real_self(z, x) result(unary) unary%d1val1_d1val2 = q2*(q1*x%d1val1*x%d1val2 + x%d1val1_d1val2) unary%d2val2 = q2*(q1*pow2(x%d1val2) + x%d2val2) end function pow_real_self - + function pow_self_int(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x integer, intent(in) :: y @@ -1690,7 +1690,7 @@ function pow_self_int(x, y) result(unary) unary%d1val1_d1val2 = q2*(q3*y_dp - q3 + x%d1val1_d1val2*x%val) unary%d2val2 = q2*(q4*y_dp - q4 + x%d2val2*x%val) end function pow_self_int - + function pow_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1710,7 +1710,7 @@ function pow_int_self(z, x) result(unary) unary%d1val1_d1val2 = q2*(q1*x%d1val1*x%d1val2 + x%d1val1_d1val2) unary%d2val2 = q2*(q1*pow2(x%d1val2) + x%d2val2) end function pow_int_self - + function max_self(x, y) result(binary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2), intent(in) :: y @@ -1726,7 +1726,7 @@ function max_self(x, y) result(binary) binary%d1val1_d1val2 = q0*x%d1val1_d1val2 + q1*y%d1val1_d1val2 binary%d2val2 = q0*x%d2val2 + q1*y%d2val2 end function max_self - + function max_self_real(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x real(dp), intent(in) :: y @@ -1740,7 +1740,7 @@ function max_self_real(x, y) result(unary) unary%d1val1_d1val2 = q0*x%d1val1_d1val2 unary%d2val2 = q0*x%d2val2 end function max_self_real - + function max_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1754,7 +1754,7 @@ function max_real_self(z, x) result(unary) unary%d1val1_d1val2 = q0*x%d1val1_d1val2 unary%d2val2 = q0*x%d2val2 end function max_real_self - + function max_self_int(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x integer, intent(in) :: y @@ -1770,7 +1770,7 @@ function max_self_int(x, y) result(unary) unary%d1val1_d1val2 = q0*x%d1val1_d1val2 unary%d2val2 = q0*x%d2val2 end function max_self_int - + function max_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1786,7 +1786,7 @@ function max_int_self(z, x) result(unary) unary%d1val1_d1val2 = q0*x%d1val1_d1val2 unary%d2val2 = q0*x%d2val2 end function max_int_self - + function min_self(x, y) result(binary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2), intent(in) :: y @@ -1802,7 +1802,7 @@ function min_self(x, y) result(binary) binary%d1val1_d1val2 = q0*x%d1val1_d1val2 + q1*y%d1val1_d1val2 binary%d2val2 = q0*x%d2val2 + q1*y%d2val2 end function min_self - + function min_self_real(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x real(dp), intent(in) :: y @@ -1816,7 +1816,7 @@ function min_self_real(x, y) result(unary) unary%d1val1_d1val2 = q0*x%d1val1_d1val2 unary%d2val2 = q0*x%d2val2 end function min_self_real - + function min_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1830,7 +1830,7 @@ function min_real_self(z, x) result(unary) unary%d1val1_d1val2 = q0*x%d1val1_d1val2 unary%d2val2 = q0*x%d2val2 end function min_real_self - + function min_self_int(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x integer, intent(in) :: y @@ -1846,7 +1846,7 @@ function min_self_int(x, y) result(unary) unary%d1val1_d1val2 = q0*x%d1val1_d1val2 unary%d2val2 = q0*x%d2val2 end function min_self_int - + function min_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1862,7 +1862,7 @@ function min_int_self(z, x) result(unary) unary%d1val1_d1val2 = q0*x%d1val1_d1val2 unary%d2val2 = q0*x%d2val2 end function min_int_self - + function dim_self(x, y) result(binary) type(auto_diff_real_2var_order2), intent(in) :: x type(auto_diff_real_2var_order2), intent(in) :: y @@ -1878,7 +1878,7 @@ function dim_self(x, y) result(binary) binary%d1val1_d1val2 = -0.5_dp*y%d1val1_d1val2 + 0.5_dp*x%d1val1_d1val2 + q1*(x%d1val1_d1val2 - y%d1val1_d1val2) binary%d2val2 = -0.5_dp*y%d2val2 + 0.5_dp*x%d2val2 + q1*(x%d2val2 - y%d2val2) end function dim_self - + function dim_self_real(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x real(dp), intent(in) :: y @@ -1898,7 +1898,7 @@ function dim_self_real(x, y) result(unary) unary%d1val1_d1val2 = q1*q3 + q3 unary%d2val2 = q2*x%d2val2 end function dim_self_real - + function dim_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1918,7 +1918,7 @@ function dim_real_self(z, x) result(unary) unary%d1val1_d1val2 = q1*q3 - q3 unary%d2val2 = q2*x%d2val2 end function dim_real_self - + function dim_self_int(x, y) result(unary) type(auto_diff_real_2var_order2), intent(in) :: x integer, intent(in) :: y @@ -1940,7 +1940,7 @@ function dim_self_int(x, y) result(unary) unary%d1val1_d1val2 = q1*q3 + q3 unary%d2val2 = q2*x%d2val2 end function dim_self_int - + function dim_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order2), intent(in) :: x @@ -1962,7 +1962,7 @@ function dim_int_self(z, x) result(unary) unary%d1val1_d1val2 = q1*q3 - q3 unary%d2val2 = q2*x%d2val2 end function dim_int_self - + function differentiate_auto_diff_real_2var_order2_1(this) result(derivative) type(auto_diff_real_2var_order2), intent(in) :: this type(auto_diff_real_2var_order2) :: derivative @@ -1973,7 +1973,7 @@ function differentiate_auto_diff_real_2var_order2_1(this) result(derivative) derivative%d1val1_d1val2 = 0.0_dp derivative%d2val2 = 0.0_dp end function differentiate_auto_diff_real_2var_order2_1 - + function differentiate_auto_diff_real_2var_order2_2(this) result(derivative) type(auto_diff_real_2var_order2), intent(in) :: this type(auto_diff_real_2var_order2) :: derivative @@ -1984,5 +1984,5 @@ function differentiate_auto_diff_real_2var_order2_2(this) result(derivative) derivative%d1val1_d1val2 = 0.0_dp derivative%d2val2 = 0.0_dp end function differentiate_auto_diff_real_2var_order2_2 - + end module auto_diff_real_2var_order2_module \ No newline at end of file diff --git a/auto_diff/private/auto_diff_real_2var_order3_module.f90 b/auto_diff/private/auto_diff_real_2var_order3_module.f90 index 1cc5ff8e2..a2dbf3cb5 100644 --- a/auto_diff/private/auto_diff_real_2var_order3_module.f90 +++ b/auto_diff/private/auto_diff_real_2var_order3_module.f90 @@ -3,7 +3,7 @@ module auto_diff_real_2var_order3_module use utils_lib use support_functions use math_lib - + implicit none private public :: auto_diff_real_2var_order3, & @@ -77,13 +77,13 @@ module auto_diff_real_2var_order3_module real(dp) :: d1val1_d2val2 real(dp) :: d3val2 end type auto_diff_real_2var_order3 - + interface assignment(=) module procedure assign_from_self module procedure assign_from_real_dp module procedure assign_from_int end interface assignment(=) - + interface operator(.eq.) module procedure equal_self module procedure equal_auto_diff_real_2var_order3_real_dp @@ -91,7 +91,7 @@ module auto_diff_real_2var_order3_module module procedure equal_auto_diff_real_2var_order3_int module procedure equal_int_auto_diff_real_2var_order3 end interface operator(.eq.) - + interface operator(.ne.) module procedure neq_self module procedure neq_auto_diff_real_2var_order3_real_dp @@ -99,7 +99,7 @@ module auto_diff_real_2var_order3_module module procedure neq_auto_diff_real_2var_order3_int module procedure neq_int_auto_diff_real_2var_order3 end interface operator(.ne.) - + interface operator(.gt.) module procedure greater_self module procedure greater_auto_diff_real_2var_order3_real_dp @@ -107,7 +107,7 @@ module auto_diff_real_2var_order3_module module procedure greater_auto_diff_real_2var_order3_int module procedure greater_int_auto_diff_real_2var_order3 end interface operator(.gt.) - + interface operator(.lt.) module procedure less_self module procedure less_auto_diff_real_2var_order3_real_dp @@ -115,7 +115,7 @@ module auto_diff_real_2var_order3_module module procedure less_auto_diff_real_2var_order3_int module procedure less_int_auto_diff_real_2var_order3 end interface operator(.lt.) - + interface operator(.le.) module procedure leq_self module procedure leq_auto_diff_real_2var_order3_real_dp @@ -123,7 +123,7 @@ module auto_diff_real_2var_order3_module module procedure leq_auto_diff_real_2var_order3_int module procedure leq_int_auto_diff_real_2var_order3 end interface operator(.le.) - + interface operator(.ge.) module procedure geq_self module procedure geq_auto_diff_real_2var_order3_real_dp @@ -131,175 +131,175 @@ module auto_diff_real_2var_order3_module module procedure geq_auto_diff_real_2var_order3_int module procedure geq_int_auto_diff_real_2var_order3 end interface operator(.ge.) - + interface make_unop module procedure make_unary_operator end interface make_unop - + interface make_binop module procedure make_binary_operator end interface make_binop - + interface sign module procedure sign_self end interface sign - + interface safe_sqrt module procedure safe_sqrt_self end interface safe_sqrt - + interface operator(-) module procedure unary_minus_self end interface operator(-) - + interface exp module procedure exp_self end interface exp - + interface expm1 module procedure expm1_self end interface expm1 - + interface exp10 module procedure exp10_self end interface exp10 - + interface powm1 module procedure powm1_self end interface powm1 - + interface log module procedure log_self end interface log - + interface log1p module procedure log1p_self end interface log1p - + interface safe_log module procedure safe_log_self end interface safe_log - + interface log10 module procedure log10_self end interface log10 - + interface safe_log10 module procedure safe_log10_self end interface safe_log10 - + interface log2 module procedure log2_self end interface log2 - + interface sin module procedure sin_self end interface sin - + interface cos module procedure cos_self end interface cos - + interface tan module procedure tan_self end interface tan - + interface sinpi module procedure sinpi_self end interface sinpi - + interface cospi module procedure cospi_self end interface cospi - + interface tanpi module procedure tanpi_self end interface tanpi - + interface sinh module procedure sinh_self end interface sinh - + interface cosh module procedure cosh_self end interface cosh - + interface tanh module procedure tanh_self end interface tanh - + interface asin module procedure asin_self end interface asin - + interface acos module procedure acos_self end interface acos - + interface atan module procedure atan_self end interface atan - + interface asinpi module procedure asinpi_self end interface asinpi - + interface acospi module procedure acospi_self end interface acospi - + interface atanpi module procedure atanpi_self end interface atanpi - + interface asinh module procedure asinh_self end interface asinh - + interface acosh module procedure acosh_self end interface acosh - + interface atanh module procedure atanh_self end interface atanh - + interface sqrt module procedure sqrt_self end interface sqrt - + interface pow2 module procedure pow2_self end interface pow2 - + interface pow3 module procedure pow3_self end interface pow3 - + interface pow4 module procedure pow4_self end interface pow4 - + interface pow5 module procedure pow5_self end interface pow5 - + interface pow6 module procedure pow6_self end interface pow6 - + interface pow7 module procedure pow7_self end interface pow7 - + interface pow8 module procedure pow8_self end interface pow8 - + interface abs module procedure abs_self end interface abs - + interface operator(+) module procedure add_self module procedure add_self_real @@ -307,7 +307,7 @@ module auto_diff_real_2var_order3_module module procedure add_self_int module procedure add_int_self end interface operator(+) - + interface operator(-) module procedure sub_self module procedure sub_self_real @@ -315,7 +315,7 @@ module auto_diff_real_2var_order3_module module procedure sub_self_int module procedure sub_int_self end interface operator(-) - + interface operator(*) module procedure mul_self module procedure mul_self_real @@ -323,7 +323,7 @@ module auto_diff_real_2var_order3_module module procedure mul_self_int module procedure mul_int_self end interface operator(*) - + interface operator(/) module procedure div_self module procedure div_self_real @@ -331,7 +331,7 @@ module auto_diff_real_2var_order3_module module procedure div_self_int module procedure div_int_self end interface operator(/) - + interface pow module procedure pow_self module procedure pow_self_real @@ -339,7 +339,7 @@ module auto_diff_real_2var_order3_module module procedure pow_self_int module procedure pow_int_self end interface pow - + interface max module procedure max_self module procedure max_self_real @@ -347,7 +347,7 @@ module auto_diff_real_2var_order3_module module procedure max_self_int module procedure max_int_self end interface max - + interface min module procedure min_self module procedure min_self_real @@ -355,7 +355,7 @@ module auto_diff_real_2var_order3_module module procedure min_self_int module procedure min_int_self end interface min - + interface dim module procedure dim_self module procedure dim_self_real @@ -363,15 +363,15 @@ module auto_diff_real_2var_order3_module module procedure dim_self_int module procedure dim_int_self end interface dim - + interface differentiate_1 module procedure differentiate_auto_diff_real_2var_order3_1 end interface differentiate_1 - + interface differentiate_2 module procedure differentiate_auto_diff_real_2var_order3_2 end interface differentiate_2 - + contains subroutine assign_from_self(this, other) @@ -388,7 +388,7 @@ subroutine assign_from_self(this, other) this%d1val1_d2val2 = other%d1val1_d2val2 this%d3val2 = other%d3val2 end subroutine assign_from_self - + subroutine assign_from_real_dp(this, other) type(auto_diff_real_2var_order3), intent(out) :: this real(dp), intent(in) :: other @@ -403,7 +403,7 @@ subroutine assign_from_real_dp(this, other) this%d1val1_d2val2 = 0.0_dp this%d3val2 = 0.0_dp end subroutine assign_from_real_dp - + subroutine assign_from_int(this, other) type(auto_diff_real_2var_order3), intent(out) :: this integer, intent(in) :: other @@ -418,217 +418,217 @@ subroutine assign_from_int(this, other) this%d1val1_d2val2 = 0.0_dp this%d3val2 = 0.0_dp end subroutine assign_from_int - + function equal_self(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this%val .eq. other%val) end function equal_self - + function equal_auto_diff_real_2var_order3_real_dp(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_2var_order3_real_dp - + function equal_real_dp_auto_diff_real_2var_order3(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_real_dp_auto_diff_real_2var_order3 - + function equal_auto_diff_real_2var_order3_int(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_2var_order3_int - + function equal_int_auto_diff_real_2var_order3(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_int_auto_diff_real_2var_order3 - + function neq_self(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this%val .ne. other%val) end function neq_self - + function neq_auto_diff_real_2var_order3_real_dp(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_2var_order3_real_dp - + function neq_real_dp_auto_diff_real_2var_order3(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_real_dp_auto_diff_real_2var_order3 - + function neq_auto_diff_real_2var_order3_int(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_2var_order3_int - + function neq_int_auto_diff_real_2var_order3(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_int_auto_diff_real_2var_order3 - + function greater_self(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this%val .gt. other%val) end function greater_self - + function greater_auto_diff_real_2var_order3_real_dp(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_2var_order3_real_dp - + function greater_real_dp_auto_diff_real_2var_order3(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_real_dp_auto_diff_real_2var_order3 - + function greater_auto_diff_real_2var_order3_int(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_2var_order3_int - + function greater_int_auto_diff_real_2var_order3(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_int_auto_diff_real_2var_order3 - + function less_self(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this%val .lt. other%val) end function less_self - + function less_auto_diff_real_2var_order3_real_dp(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_2var_order3_real_dp - + function less_real_dp_auto_diff_real_2var_order3(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_real_dp_auto_diff_real_2var_order3 - + function less_auto_diff_real_2var_order3_int(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_2var_order3_int - + function less_int_auto_diff_real_2var_order3(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_int_auto_diff_real_2var_order3 - + function leq_self(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this%val .le. other%val) end function leq_self - + function leq_auto_diff_real_2var_order3_real_dp(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_2var_order3_real_dp - + function leq_real_dp_auto_diff_real_2var_order3(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_real_dp_auto_diff_real_2var_order3 - + function leq_auto_diff_real_2var_order3_int(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_2var_order3_int - + function leq_int_auto_diff_real_2var_order3(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_int_auto_diff_real_2var_order3 - + function geq_self(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this%val .ge. other%val) end function geq_self - + function geq_auto_diff_real_2var_order3_real_dp(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_2var_order3_real_dp - + function geq_real_dp_auto_diff_real_2var_order3(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_real_dp_auto_diff_real_2var_order3 - + function geq_auto_diff_real_2var_order3_int(this, other) result(z) type(auto_diff_real_2var_order3), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_2var_order3_int - + function geq_int_auto_diff_real_2var_order3(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_2var_order3), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_int_auto_diff_real_2var_order3 - + function make_unary_operator(x, z_val, z_d1x, z_d2x, z_d3x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x real(dp), intent(in) :: z_val @@ -657,7 +657,7 @@ function make_unary_operator(x, z_val, z_d1x, z_d2x, z_d3x) result(unary) unary%d1val1_d2val2 = q1*q4 + q2*x%d1val1*z_d3x + q3*x%d2val2 + x%d1val1_d2val2*z_d1x unary%d3val2 = 3.0_dp*q1*x%d2val2 + x%d3val2*z_d1x + z_d3x*pow3(x%d1val2) end function make_unary_operator - + function make_binary_operator(x, y, z_val, z_d1x, z_d1y, z_d2x, z_d1x_d1y, z_d2y, z_d3x, z_d2x_d1y, z_d1x_d2y, z_d3y) result(binary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3), intent(in) :: y @@ -737,7 +737,7 @@ function make_binary_operator(x, y, z_val, z_d1x, z_d1y, z_d2x, z_d1x_d1y, z_d2y binary%d1val1_d2val2 = 2.0_dp*q21*x%d1val1*y%d1val2 + 2.0_dp*q22*x%d1val2*y%d1val1 + q10*x%d1val1_d1val2 + q11*x%d2val2 + q14*x%d2val2 + q15*y%d2val2 + q18*q4 + q19*q6 + q19*q7 + q2*y%d2val2 + q23*x%d1val1 + q24*y%d1val1 + q8*x%d1val1*z_d3x + q9*y%d1val1*z_d3y + x%d1val1_d2val2*z_d1x + y%d1val1_d2val2*z_d1y binary%d3val2 = 3.0_dp*q23*x%d1val2 + 3.0_dp*q24*y%d1val2 + q25*q4 + q25*q5 + q26*q6 + q26*q7 + x%d3val2*z_d1x + y%d3val2*z_d1y + z_d3x*pow3(x%d1val2) + z_d3y*pow3(y%d1val2) end function make_binary_operator - + function sign_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -752,7 +752,7 @@ function sign_self(x) result(unary) unary%d1val1_d2val2 = 0.0_dp unary%d3val2 = 0.0_dp end function sign_self - + function safe_sqrt_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -799,7 +799,7 @@ function safe_sqrt_self(x) result(unary) unary%d1val1_d2val2 = q13*(3.0_dp*q10*x%d1val1 + q12*x%d1val1_d2val2 - q14*q15 - q9*x%d1val1) unary%d3val2 = q13*(-6.0_dp*q15*x%d2val2 + 3.0_dp*pow3(x%d1val2) + q12*x%d3val2) end function safe_sqrt_self - + function unary_minus_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -814,7 +814,7 @@ function unary_minus_self(x) result(unary) unary%d1val1_d2val2 = -x%d1val1_d2val2 unary%d3val2 = -x%d3val2 end function unary_minus_self - + function exp_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -837,7 +837,7 @@ function exp_self(x) result(unary) unary%d1val1_d2val2 = q0*(q2*x%d1val1 + q3*x%d1val2 + x%d1val1_d2val2) unary%d3val2 = q0*(3.0_dp*x%d1val2*x%d2val2 + x%d3val2 + pow3(x%d1val2)) end function exp_self - + function expm1_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -860,7 +860,7 @@ function expm1_self(x) result(unary) unary%d1val1_d2val2 = q0*(q2*x%d1val1 + q3*x%d1val2 + x%d1val1_d2val2) unary%d3val2 = q0*(3.0_dp*x%d1val2*x%d2val2 + x%d3val2 + pow3(x%d1val2)) end function expm1_self - + function exp10_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -893,7 +893,7 @@ function exp10_self(x) result(unary) unary%d1val1_d2val2 = q2*(q4*q8 + q5*q6 + x%d1val1_d2val2) unary%d3val2 = q2*(3.0_dp*q4*x%d2val2 + q7*pow3(x%d1val2) + x%d3val2) end function exp10_self - + function powm1_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -934,7 +934,7 @@ function powm1_self(x) result(unary) unary%d1val1_d2val2 = q10*(-q0*x%d1val1_d2val2 + q11*x%d1val2 - q5*(3.0_dp*q9 + q8)) unary%d3val2 = q10*(-6.0_dp*pow3(x%d1val2) - q0*x%d3val2 + q12*q7) end function powm1_self - + function log_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -969,7 +969,7 @@ function log_self(x) result(unary) unary%d1val1_d2val2 = q8*(q1*x%d1val1_d2val2 - q5*q9 + x%d1val1*(2.0_dp*q7 - q6)) unary%d3val2 = q8*(-3.0_dp*q6*x%d1val2 + 2.0_dp*pow3(x%d1val2) + q1*x%d3val2) end function log_self - + function log1p_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1006,7 +1006,7 @@ function log1p_self(x) result(unary) unary%d1val1_d2val2 = q9*(-q10*x%d1val2 + q2*x%d1val1_d2val2 + x%d1val1*(2.0_dp*q7 - q8)) unary%d3val2 = q9*(-3.0_dp*q8*x%d1val2 + 2.0_dp*pow3(x%d1val2) + q2*x%d3val2) end function log1p_self - + function safe_log_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1041,7 +1041,7 @@ function safe_log_self(x) result(unary) unary%d1val1_d2val2 = q8*(q1*x%d1val1_d2val2 - q5*q9 + x%d1val1*(2.0_dp*q7 - q6)) unary%d3val2 = q8*(-3.0_dp*q6*x%d1val2 + 2.0_dp*pow3(x%d1val2) + q1*x%d3val2) end function safe_log_self - + function log10_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1078,7 +1078,7 @@ function log10_self(x) result(unary) unary%d1val1_d2val2 = q9*(-q10*q6 + q4*x%d1val1_d2val2 + x%d1val1*(2.0_dp*q8 - q7)) unary%d3val2 = q9*(-3.0_dp*q7*x%d1val2 + 2.0_dp*pow3(x%d1val2) + q4*x%d3val2) end function log10_self - + function safe_log10_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1115,7 +1115,7 @@ function safe_log10_self(x) result(unary) unary%d1val1_d2val2 = q9*(-q10*q6 + q4*x%d1val1_d2val2 + x%d1val1*(2.0_dp*q8 - q7)) unary%d3val2 = q9*(-3.0_dp*q7*x%d1val2 + 2.0_dp*pow3(x%d1val2) + q4*x%d3val2) end function safe_log10_self - + function log2_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1152,7 +1152,7 @@ function log2_self(x) result(unary) unary%d1val1_d2val2 = q9*(-q10*q6 + q4*x%d1val1_d2val2 + x%d1val1*(2.0_dp*q8 - q7)) unary%d3val2 = q9*(-3.0_dp*q7*x%d1val2 + 2.0_dp*pow3(x%d1val2) + q4*x%d3val2) end function log2_self - + function sin_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1185,7 +1185,7 @@ function sin_self(x) result(unary) unary%d1val1_d2val2 = q1*x%d1val1_d2val2 - q4*q7 - x%d1val1*(q1*q5 + q8) unary%d3val2 = -3.0_dp*q8*x%d1val2 + q1*x%d3val2 - q1*pow3(x%d1val2) end function sin_self - + function cos_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1218,7 +1218,7 @@ function cos_self(x) result(unary) unary%d1val1_d2val2 = -q1*x%d1val1_d2val2 - q4*q7 + x%d1val1*(q1*q5 - q8) unary%d3val2 = -3.0_dp*q8*x%d1val2 - q1*x%d3val2 + q1*pow3(x%d1val2) end function cos_self - + function tan_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1265,7 +1265,7 @@ function tan_self(x) result(unary) unary%d1val1_d2val2 = q3*(2.0_dp*x%d1val1*(2.0_dp*q1*q8 + q14 + q3*q8) + q0*q13*x%d1val2 + x%d1val1_d2val2) unary%d3val2 = q3*(6.0_dp*q14*x%d1val2 + q11*q15 + q12*q15 + x%d3val2) end function tan_self - + function sinpi_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1304,7 +1304,7 @@ function sinpi_self(x) result(unary) unary%d1val1_d2val2 = -pi*(pi*x%d1val1*(q11 + q3*q7) + q10*q6 - q2*x%d1val1_d2val2) unary%d3val2 = pi*(-3.0_dp*pi*q11*x%d1val2 + q2*x%d3val2 - q9*pow3(x%d1val2)) end function sinpi_self - + function cospi_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1343,7 +1343,7 @@ function cospi_self(x) result(unary) unary%d1val1_d2val2 = -pi*(-pi*x%d1val1*(-q11 + q3*q7) + q10*q6 + q2*x%d1val1_d2val2) unary%d3val2 = pi*(-3.0_dp*pi*q11*x%d1val2 - q2*x%d3val2 + q9*pow3(x%d1val2)) end function cospi_self - + function tanpi_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1402,7 +1402,7 @@ function tanpi_self(x) result(unary) unary%d1val1_d2val2 = q4*(0.5_dp*q18*(4.0_dp*q12*q4 + 8.0_dp*pi*q12*q2 + q19*x%d2val2) + pi*q20*x%d1val2 + x%d1val1_d2val2) unary%d3val2 = q4*(q13*x%d1val2*x%d2val2 + q16*q21 + q17*q21 + x%d3val2) end function tanpi_self - + function sinh_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1435,7 +1435,7 @@ function sinh_self(x) result(unary) unary%d1val1_d2val2 = q1*x%d1val1_d2val2 + q4*q7 + x%d1val1*(q1*q5 + q8) unary%d3val2 = 3.0_dp*q8*x%d1val2 + q1*x%d3val2 + q1*pow3(x%d1val2) end function sinh_self - + function cosh_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1468,7 +1468,7 @@ function cosh_self(x) result(unary) unary%d1val1_d2val2 = q1*x%d1val1_d2val2 + q4*q7 + x%d1val1*(q1*q5 + q8) unary%d3val2 = 3.0_dp*q8*x%d1val2 + q1*x%d3val2 + q1*pow3(x%d1val2) end function cosh_self - + function tanh_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1515,7 +1515,7 @@ function tanh_self(x) result(unary) unary%d1val1_d2val2 = -q3*(2.0_dp*q13 - q11*q13 + q12*q14 + q5*x%d1val1*x%d2val2 - x%d1val1_d2val2) unary%d3val2 = q3*(-2.0_dp*q15 - 6.0_dp*q14*x%d2val2 + q11*q15 + x%d3val2) end function tanh_self - + function asin_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1562,7 +1562,7 @@ function asin_self(x) result(unary) unary%d1val1_d2val2 = q9*(q11*x%d1val1_d2val2 - q13*q14 - x%d1val1*(-q10*q8 + q5*(q15 + q8))) unary%d3val2 = q9*(q10*pow3(x%d1val2) + q11*x%d3val2 - q14*(3.0_dp*q15 + q8)) end function asin_self - + function acos_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1613,7 +1613,7 @@ function acos_self(x) result(unary) unary%d1val1_d2val2 = (-q15*x%d1val1_d2val2 + q16*q9*x%d1val2 + x%d1val1*(-q10*q13 + q6*(q10 + q17)))*powm1(pow5(sqrt(q1))) unary%d3val2 = q11*(q12*x%d3val2 - q14*pow3(x%d1val2) - q15*x%d1val2*(3.0_dp*q17 + q10)) end function acos_self - + function atan_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1664,7 +1664,7 @@ function atan_self(x) result(unary) unary%d1val1_d2val2 = q12*(-4.0_dp*q10*x%d1val2*x%val - q14*(q1*(q11 + q17) - q11*q16) + q3*x%d1val1_d2val2) unary%d3val2 = q12*(-2.0_dp*q1*x%d1val2*(3.0_dp*q17 + q11) + q13*pow3(x%d1val2) + q3*x%d3val2) end function atan_self - + function asinpi_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1717,7 +1717,7 @@ function asinpi_self(x) result(unary) unary%d1val1_d2val2 = q11*(q10*x%d1val1_d2val2 - q15*q5*q7 - x%d1val1*(q5*(q18 + q8) - q8*q9)) unary%d3val2 = q11*(q10*x%d3val2 - q5*x%d1val2*(3.0_dp*q18 + q8) + q9*pow3(x%d1val2)) end function asinpi_self - + function acospi_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1774,7 +1774,7 @@ function acospi_self(x) result(unary) unary%d1val1_d2val2 = q0*(2.0_dp*q7*q8 - q13*x%d1val1_d2val2 + x%d1val1*(-q11*q9 + q5*(q20 + q9)))*powm1(pow5(sqrt(q2))) unary%d3val2 = q14*(q10*x%d3val2 - q12*pow3(x%d1val2) - q13*x%d1val2*(3.0_dp*q20 + q9)) end function acospi_self - + function atanpi_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1839,7 +1839,7 @@ function atanpi_self(x) result(unary) unary%d1val1_d2val2 = q10*(q14*x%d1val1_d2val2 - q15*q20 + q17*q9*x%d1val1 - q20*x%val - q21*q22 - q21*q9 - q4*x%d1val1*x%d2val2 + q5*x%d1val1_d2val2 + x%d1val1_d2val2) unary%d3val2 = q10*(-2.0_dp*q23 + q14*x%d3val2 + q17*q23 - q22*q24 - q24*x%d2val2*x%val + q5*x%d3val2 + x%d3val2) end function atanpi_self - + function asinh_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1886,7 +1886,7 @@ function asinh_self(x) result(unary) unary%d1val1_d2val2 = q10*(-2.0_dp*q14*q8 + q12*x%d1val1_d2val2 - x%d1val1*(q1*(q15 + q9) - q11*q9)) unary%d3val2 = q10*(-q1*x%d1val2*(3.0_dp*q15 + q9) + q11*pow3(x%d1val2) + q12*x%d3val2) end function asinh_self - + function acosh_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1933,7 +1933,7 @@ function acosh_self(x) result(unary) unary%d1val1_d2val2 = q10*(-2.0_dp*q14*q8 + q12*x%d1val1_d2val2 - x%d1val1*(q1*(q15 + q9) - q11*q9)) unary%d3val2 = q10*(-q1*x%d1val2*(3.0_dp*q15 + q9) + q11*pow3(x%d1val2) + q12*x%d3val2) end function acosh_self - + function atanh_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -1984,7 +1984,7 @@ function atanh_self(x) result(unary) unary%d1val1_d2val2 = q15*(4.0_dp*q9*x%d1val2*x%val + q14*(q1*(q10 + q17) - q10*q16) - q3*x%d1val1_d2val2) unary%d3val2 = q11*(2.0_dp*q3*x%d1val2*(3.0_dp*q17 + q10) - q12*x%d3val2 + q13*pow3(x%d1val2)) end function atanh_self - + function sqrt_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -2025,7 +2025,7 @@ function sqrt_self(x) result(unary) unary%d1val1_d2val2 = q10*(-q11*q12 + q9*x%d1val1_d2val2 + x%d1val1*(3.0_dp*q7 - q6)) unary%d3val2 = q10*(-6.0_dp*q12*x%d2val2 + 3.0_dp*pow3(x%d1val2) + q9*x%d3val2) end function sqrt_self - + function pow2_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -2046,7 +2046,7 @@ function pow2_self(x) result(unary) unary%d1val1_d2val2 = 2.0_dp*x%d1val1*x%d2val2 + q0*x%d1val1_d2val2 + q2*x%d1val2 unary%d3val2 = 6.0_dp*x%d1val2*x%d2val2 + q0*x%d3val2 end function pow2_self - + function pow3_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -2075,7 +2075,7 @@ function pow3_self(x) result(unary) unary%d1val1_d2val2 = 12.0_dp*q4*x%d1val2 + 6.0_dp*x%d1val1*(q5 + q6) + q0*x%d1val1_d2val2 unary%d3val2 = 18.0_dp*q5*x%d1val2 + 6.0_dp*pow3(x%d1val2) + q0*x%d3val2 end function pow3_self - + function pow4_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -2110,7 +2110,7 @@ function pow4_self(x) result(unary) unary%d1val1_d2val2 = q9*(6.0_dp*q5*x%d1val2 + q3*x%d1val1_d2val2 + q6*(2.0_dp*q8 + q7)) unary%d3val2 = q9*(6.0_dp*pow3(x%d1val2) + 9.0_dp*q7*x%d1val2 + q3*x%d3val2) end function pow4_self - + function pow5_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -2145,7 +2145,7 @@ function pow5_self(x) result(unary) unary%d1val1_d2val2 = q9*(8.0_dp*q4*x%d1val2 + q5*(3.0_dp*q7 + q6) + q8*x%d1val1_d2val2) unary%d3val2 = q9*(12.0_dp*q6*x%d1val2 + 12.0_dp*pow3(x%d1val2) + q8*x%d3val2) end function pow5_self - + function pow6_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -2180,7 +2180,7 @@ function pow6_self(x) result(unary) unary%d1val1_d2val2 = q9*(10.0_dp*q4*x%d1val2 + q5*(4.0_dp*q7 + q6) + q8*x%d1val1_d2val2) unary%d3val2 = q9*(15.0_dp*q6*x%d1val2 + 20.0_dp*pow3(x%d1val2) + q8*x%d3val2) end function pow6_self - + function pow7_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -2215,7 +2215,7 @@ function pow7_self(x) result(unary) unary%d1val1_d2val2 = q9*(12.0_dp*q4*x%d1val2 + q5*(5.0_dp*q7 + q6) + q8*x%d1val1_d2val2) unary%d3val2 = q9*(18.0_dp*q6*x%d1val2 + 30.0_dp*pow3(x%d1val2) + q8*x%d3val2) end function pow7_self - + function pow8_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -2250,7 +2250,7 @@ function pow8_self(x) result(unary) unary%d1val1_d2val2 = q9*(14.0_dp*q4*x%d1val2 + q5*(6.0_dp*q7 + q6) + q8*x%d1val1_d2val2) unary%d3val2 = q9*(21.0_dp*q6*x%d1val2 + 42.0_dp*pow3(x%d1val2) + q8*x%d3val2) end function pow8_self - + function abs_self(x) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3) :: unary @@ -2267,7 +2267,7 @@ function abs_self(x) result(unary) unary%d1val1_d2val2 = q0*x%d1val1_d2val2 unary%d3val2 = q0*x%d3val2 end function abs_self - + function add_self(x, y) result(binary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3), intent(in) :: y @@ -2283,7 +2283,7 @@ function add_self(x, y) result(binary) binary%d1val1_d2val2 = x%d1val1_d2val2 + y%d1val1_d2val2 binary%d3val2 = x%d3val2 + y%d3val2 end function add_self - + function add_self_real(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x real(dp), intent(in) :: y @@ -2299,7 +2299,7 @@ function add_self_real(x, y) result(unary) unary%d1val1_d2val2 = x%d1val1_d2val2 unary%d3val2 = x%d3val2 end function add_self_real - + function add_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -2315,7 +2315,7 @@ function add_real_self(z, x) result(unary) unary%d1val1_d2val2 = x%d1val1_d2val2 unary%d3val2 = x%d3val2 end function add_real_self - + function add_self_int(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x integer, intent(in) :: y @@ -2333,7 +2333,7 @@ function add_self_int(x, y) result(unary) unary%d1val1_d2val2 = x%d1val1_d2val2 unary%d3val2 = x%d3val2 end function add_self_int - + function add_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -2351,7 +2351,7 @@ function add_int_self(z, x) result(unary) unary%d1val1_d2val2 = x%d1val1_d2val2 unary%d3val2 = x%d3val2 end function add_int_self - + function sub_self(x, y) result(binary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3), intent(in) :: y @@ -2367,7 +2367,7 @@ function sub_self(x, y) result(binary) binary%d1val1_d2val2 = x%d1val1_d2val2 - y%d1val1_d2val2 binary%d3val2 = x%d3val2 - y%d3val2 end function sub_self - + function sub_self_real(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x real(dp), intent(in) :: y @@ -2383,7 +2383,7 @@ function sub_self_real(x, y) result(unary) unary%d1val1_d2val2 = x%d1val1_d2val2 unary%d3val2 = x%d3val2 end function sub_self_real - + function sub_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -2399,7 +2399,7 @@ function sub_real_self(z, x) result(unary) unary%d1val1_d2val2 = -x%d1val1_d2val2 unary%d3val2 = -x%d3val2 end function sub_real_self - + function sub_self_int(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x integer, intent(in) :: y @@ -2417,7 +2417,7 @@ function sub_self_int(x, y) result(unary) unary%d1val1_d2val2 = x%d1val1_d2val2 unary%d3val2 = x%d3val2 end function sub_self_int - + function sub_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -2435,7 +2435,7 @@ function sub_int_self(z, x) result(unary) unary%d1val1_d2val2 = -x%d1val1_d2val2 unary%d3val2 = -x%d3val2 end function sub_int_self - + function mul_self(x, y) result(binary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3), intent(in) :: y @@ -2455,7 +2455,7 @@ function mul_self(x, y) result(binary) binary%d1val1_d2val2 = 2.0_dp*x%d1val2*y%d1val1_d1val2 + q1*x%d1val1_d1val2 + x%d1val1*y%d2val2 + x%d1val1_d2val2*y%val + x%d2val2*y%d1val1 + x%val*y%d1val1_d2val2 binary%d3val2 = 3.0_dp*x%d1val2*y%d2val2 + 3.0_dp*x%d2val2*y%d1val2 + x%d3val2*y%val + x%val*y%d3val2 end function mul_self - + function mul_self_real(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x real(dp), intent(in) :: y @@ -2471,7 +2471,7 @@ function mul_self_real(x, y) result(unary) unary%d1val1_d2val2 = x%d1val1_d2val2*y unary%d3val2 = x%d3val2*y end function mul_self_real - + function mul_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -2487,7 +2487,7 @@ function mul_real_self(z, x) result(unary) unary%d1val1_d2val2 = x%d1val1_d2val2*z unary%d3val2 = x%d3val2*z end function mul_real_self - + function mul_self_int(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x integer, intent(in) :: y @@ -2505,7 +2505,7 @@ function mul_self_int(x, y) result(unary) unary%d1val1_d2val2 = x%d1val1_d2val2*y_dp unary%d3val2 = x%d3val2*y_dp end function mul_self_int - + function mul_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -2523,7 +2523,7 @@ function mul_int_self(z, x) result(unary) unary%d1val1_d2val2 = x%d1val1_d2val2*y_dp unary%d3val2 = x%d3val2*y_dp end function mul_int_self - + function div_self(x, y) result(binary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3), intent(in) :: y @@ -2585,7 +2585,7 @@ function div_self(x, y) result(binary) binary%d1val1_d2val2 = q21*(-6.0_dp*q19*q3 + 2.0_dp*y%val*(q15*q16 + q19*x%d1val1 + q22*q5 + q3*y%d2val2) - q0*(q15*x%d1val1_d1val2 + q22*x%d1val2 + x%d1val1*y%d2val2 + x%d2val2*y%d1val1 + x%val*y%d1val1_d2val2) + q6*x%d1val1_d2val2) binary%d3val2 = q21*(-3.0_dp*q17*y%d1val2 + 3.0_dp*q20*q4 + q6*x%d3val2 - x%val*(-6.0_dp*q18*y%d1val2 + 6.0_dp*pow3(y%d1val2) + q0*y%d3val2)) end function div_self - + function div_self_real(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x real(dp), intent(in) :: y @@ -2603,7 +2603,7 @@ function div_self_real(x, y) result(unary) unary%d1val1_d2val2 = q0*x%d1val1_d2val2 unary%d3val2 = q0*x%d3val2 end function div_self_real - + function div_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -2645,7 +2645,7 @@ function div_real_self(z, x) result(unary) unary%d1val1_d2val2 = -q10*(q0*x%d1val1_d2val2 - q11*x%d1val2 + q5*(3.0_dp*q9 + q8)) unary%d3val2 = q10*(-6.0_dp*pow3(x%d1val2) - q0*x%d3val2 + q12*q7) end function div_real_self - + function div_self_int(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x integer, intent(in) :: y @@ -2665,7 +2665,7 @@ function div_self_int(x, y) result(unary) unary%d1val1_d2val2 = q0*x%d1val1_d2val2 unary%d3val2 = q0*x%d3val2 end function div_self_int - + function div_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -2709,7 +2709,7 @@ function div_int_self(z, x) result(unary) unary%d1val1_d2val2 = -q10*(q0*x%d1val1_d2val2 - q11*x%d1val2 + q5*(3.0_dp*q9 + q8)) unary%d3val2 = q10*(-6.0_dp*pow3(x%d1val2) - q0*x%d3val2 + q12*q7) end function div_int_self - + function pow_self(x, y) result(binary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3), intent(in) :: y @@ -2787,7 +2787,7 @@ function pow_self(x, y) result(binary) binary%d1val1_d2val2 = q23*(2.0_dp*q1*q18 + q22*q4 + q25*y%d1val1_d2val2 + q29*q6 + q9*(q27*x%d1val2 + q28*y%d1val2 + x%d1val1*y%d2val2 + x%d1val1_d2val2*y%val + x%d2val2*y%d1val1) - x%val*(2.0_dp*q15*x%d1val2 + q1*x%d2val2 + q18*y%d1val1 + q28*q5)) binary%d3val2 = q23*(3.0_dp*q21*q6 + q24*pow3(x%d1val2) + q25*y%d3val2 - q30*x%val*(q19 + q20) + q9*(3.0_dp*x%d2val2*y%d1val2 + q30*y%d2val2 + x%d3val2*y%val) + pow3(q6)) end function pow_self - + function pow_self_real(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x real(dp), intent(in) :: y @@ -2847,7 +2847,7 @@ function pow_self_real(x, y) result(unary) unary%d1val1_d2val2 = q16*(q0*q17*x%d1val2 + q13*x%d1val1_d2val2 - x%d1val1*(-2.0_dp*q10 + 2.0_dp*q11 - q12 + q9)) unary%d3val2 = q16*(q0*q21*q9 + q13*x%d3val2 + q15*pow3(x%d1val2)) end function pow_self_real - + function pow_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -2881,7 +2881,7 @@ function pow_real_self(z, x) result(unary) unary%d1val1_d2val2 = q2*(q4*q8 + q5*q6 + x%d1val1_d2val2) unary%d3val2 = q2*(3.0_dp*q4*x%d2val2 + q7*pow3(x%d1val2) + x%d3val2) end function pow_real_self - + function pow_self_int(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x integer, intent(in) :: y @@ -2943,7 +2943,7 @@ function pow_self_int(x, y) result(unary) unary%d1val1_d2val2 = q16*(q0*q17*x%d1val2 + q13*x%d1val1_d2val2 - x%d1val1*(-2.0_dp*q10 + 2.0_dp*q11 - q12 + q9)) unary%d3val2 = q16*(q0*q21*q9 + q13*x%d3val2 + q15*pow3(x%d1val2)) end function pow_self_int - + function pow_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -2979,7 +2979,7 @@ function pow_int_self(z, x) result(unary) unary%d1val1_d2val2 = q2*(q4*q8 + q5*q6 + x%d1val1_d2val2) unary%d3val2 = q2*(3.0_dp*q4*x%d2val2 + q7*pow3(x%d1val2) + x%d3val2) end function pow_int_self - + function max_self(x, y) result(binary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3), intent(in) :: y @@ -2999,7 +2999,7 @@ function max_self(x, y) result(binary) binary%d1val1_d2val2 = q0*x%d1val1_d2val2 + q1*y%d1val1_d2val2 binary%d3val2 = q0*x%d3val2 + q1*y%d3val2 end function max_self - + function max_self_real(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x real(dp), intent(in) :: y @@ -3017,7 +3017,7 @@ function max_self_real(x, y) result(unary) unary%d1val1_d2val2 = q0*x%d1val1_d2val2 unary%d3val2 = q0*x%d3val2 end function max_self_real - + function max_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -3035,7 +3035,7 @@ function max_real_self(z, x) result(unary) unary%d1val1_d2val2 = q0*x%d1val1_d2val2 unary%d3val2 = q0*x%d3val2 end function max_real_self - + function max_self_int(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x integer, intent(in) :: y @@ -3055,7 +3055,7 @@ function max_self_int(x, y) result(unary) unary%d1val1_d2val2 = q0*x%d1val1_d2val2 unary%d3val2 = q0*x%d3val2 end function max_self_int - + function max_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -3075,7 +3075,7 @@ function max_int_self(z, x) result(unary) unary%d1val1_d2val2 = q0*x%d1val1_d2val2 unary%d3val2 = q0*x%d3val2 end function max_int_self - + function min_self(x, y) result(binary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3), intent(in) :: y @@ -3095,7 +3095,7 @@ function min_self(x, y) result(binary) binary%d1val1_d2val2 = q0*x%d1val1_d2val2 + q1*y%d1val1_d2val2 binary%d3val2 = q0*x%d3val2 + q1*y%d3val2 end function min_self - + function min_self_real(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x real(dp), intent(in) :: y @@ -3113,7 +3113,7 @@ function min_self_real(x, y) result(unary) unary%d1val1_d2val2 = q0*x%d1val1_d2val2 unary%d3val2 = q0*x%d3val2 end function min_self_real - + function min_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -3131,7 +3131,7 @@ function min_real_self(z, x) result(unary) unary%d1val1_d2val2 = q0*x%d1val1_d2val2 unary%d3val2 = q0*x%d3val2 end function min_real_self - + function min_self_int(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x integer, intent(in) :: y @@ -3151,7 +3151,7 @@ function min_self_int(x, y) result(unary) unary%d1val1_d2val2 = q0*x%d1val1_d2val2 unary%d3val2 = q0*x%d3val2 end function min_self_int - + function min_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -3171,7 +3171,7 @@ function min_int_self(z, x) result(unary) unary%d1val1_d2val2 = q0*x%d1val1_d2val2 unary%d3val2 = q0*x%d3val2 end function min_int_self - + function dim_self(x, y) result(binary) type(auto_diff_real_2var_order3), intent(in) :: x type(auto_diff_real_2var_order3), intent(in) :: y @@ -3191,7 +3191,7 @@ function dim_self(x, y) result(binary) binary%d1val1_d2val2 = -0.5_dp*y%d1val1_d2val2 + 0.5_dp*x%d1val1_d2val2 + q1*(x%d1val1_d2val2 - y%d1val1_d2val2) binary%d3val2 = -0.5_dp*y%d3val2 + 0.5_dp*x%d3val2 + q1*(x%d3val2 - y%d3val2) end function dim_self - + function dim_self_real(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x real(dp), intent(in) :: y @@ -3219,7 +3219,7 @@ function dim_self_real(x, y) result(unary) unary%d1val1_d2val2 = q1*q5 + q5 unary%d3val2 = q2*x%d3val2 end function dim_self_real - + function dim_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -3247,7 +3247,7 @@ function dim_real_self(z, x) result(unary) unary%d1val1_d2val2 = q1*q5 - q5 unary%d3val2 = q2*x%d3val2 end function dim_real_self - + function dim_self_int(x, y) result(unary) type(auto_diff_real_2var_order3), intent(in) :: x integer, intent(in) :: y @@ -3277,7 +3277,7 @@ function dim_self_int(x, y) result(unary) unary%d1val1_d2val2 = q1*q5 + q5 unary%d3val2 = q2*x%d3val2 end function dim_self_int - + function dim_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_2var_order3), intent(in) :: x @@ -3307,7 +3307,7 @@ function dim_int_self(z, x) result(unary) unary%d1val1_d2val2 = q1*q5 - q5 unary%d3val2 = q2*x%d3val2 end function dim_int_self - + function differentiate_auto_diff_real_2var_order3_1(this) result(derivative) type(auto_diff_real_2var_order3), intent(in) :: this type(auto_diff_real_2var_order3) :: derivative @@ -3322,7 +3322,7 @@ function differentiate_auto_diff_real_2var_order3_1(this) result(derivative) derivative%d1val1_d2val2 = 0.0_dp derivative%d3val2 = 0.0_dp end function differentiate_auto_diff_real_2var_order3_1 - + function differentiate_auto_diff_real_2var_order3_2(this) result(derivative) type(auto_diff_real_2var_order3), intent(in) :: this type(auto_diff_real_2var_order3) :: derivative @@ -3337,5 +3337,5 @@ function differentiate_auto_diff_real_2var_order3_2(this) result(derivative) derivative%d1val1_d2val2 = 0.0_dp derivative%d3val2 = 0.0_dp end function differentiate_auto_diff_real_2var_order3_2 - + end module auto_diff_real_2var_order3_module \ No newline at end of file diff --git a/auto_diff/private/auto_diff_real_4var_order1_module.f90 b/auto_diff/private/auto_diff_real_4var_order1_module.f90 index 78001364f..98f1e5fdf 100644 --- a/auto_diff/private/auto_diff_real_4var_order1_module.f90 +++ b/auto_diff/private/auto_diff_real_4var_order1_module.f90 @@ -3,7 +3,7 @@ module auto_diff_real_4var_order1_module use utils_lib use support_functions use math_lib - + implicit none private public :: auto_diff_real_4var_order1, & @@ -74,13 +74,13 @@ module auto_diff_real_4var_order1_module real(dp) :: d1val3 real(dp) :: d1val4 end type auto_diff_real_4var_order1 - + interface assignment(=) module procedure assign_from_self module procedure assign_from_real_dp module procedure assign_from_int end interface assignment(=) - + interface operator(.eq.) module procedure equal_self module procedure equal_auto_diff_real_4var_order1_real_dp @@ -88,7 +88,7 @@ module auto_diff_real_4var_order1_module module procedure equal_auto_diff_real_4var_order1_int module procedure equal_int_auto_diff_real_4var_order1 end interface operator(.eq.) - + interface operator(.ne.) module procedure neq_self module procedure neq_auto_diff_real_4var_order1_real_dp @@ -96,7 +96,7 @@ module auto_diff_real_4var_order1_module module procedure neq_auto_diff_real_4var_order1_int module procedure neq_int_auto_diff_real_4var_order1 end interface operator(.ne.) - + interface operator(.gt.) module procedure greater_self module procedure greater_auto_diff_real_4var_order1_real_dp @@ -104,7 +104,7 @@ module auto_diff_real_4var_order1_module module procedure greater_auto_diff_real_4var_order1_int module procedure greater_int_auto_diff_real_4var_order1 end interface operator(.gt.) - + interface operator(.lt.) module procedure less_self module procedure less_auto_diff_real_4var_order1_real_dp @@ -112,7 +112,7 @@ module auto_diff_real_4var_order1_module module procedure less_auto_diff_real_4var_order1_int module procedure less_int_auto_diff_real_4var_order1 end interface operator(.lt.) - + interface operator(.le.) module procedure leq_self module procedure leq_auto_diff_real_4var_order1_real_dp @@ -120,7 +120,7 @@ module auto_diff_real_4var_order1_module module procedure leq_auto_diff_real_4var_order1_int module procedure leq_int_auto_diff_real_4var_order1 end interface operator(.le.) - + interface operator(.ge.) module procedure geq_self module procedure geq_auto_diff_real_4var_order1_real_dp @@ -128,175 +128,175 @@ module auto_diff_real_4var_order1_module module procedure geq_auto_diff_real_4var_order1_int module procedure geq_int_auto_diff_real_4var_order1 end interface operator(.ge.) - + interface make_unop module procedure make_unary_operator end interface make_unop - + interface make_binop module procedure make_binary_operator end interface make_binop - + interface sign module procedure sign_self end interface sign - + interface safe_sqrt module procedure safe_sqrt_self end interface safe_sqrt - + interface operator(-) module procedure unary_minus_self end interface operator(-) - + interface exp module procedure exp_self end interface exp - + interface expm1 module procedure expm1_self end interface expm1 - + interface exp10 module procedure exp10_self end interface exp10 - + interface powm1 module procedure powm1_self end interface powm1 - + interface log module procedure log_self end interface log - + interface log1p module procedure log1p_self end interface log1p - + interface safe_log module procedure safe_log_self end interface safe_log - + interface log10 module procedure log10_self end interface log10 - + interface safe_log10 module procedure safe_log10_self end interface safe_log10 - + interface log2 module procedure log2_self end interface log2 - + interface sin module procedure sin_self end interface sin - + interface cos module procedure cos_self end interface cos - + interface tan module procedure tan_self end interface tan - + interface sinpi module procedure sinpi_self end interface sinpi - + interface cospi module procedure cospi_self end interface cospi - + interface tanpi module procedure tanpi_self end interface tanpi - + interface sinh module procedure sinh_self end interface sinh - + interface cosh module procedure cosh_self end interface cosh - + interface tanh module procedure tanh_self end interface tanh - + interface asin module procedure asin_self end interface asin - + interface acos module procedure acos_self end interface acos - + interface atan module procedure atan_self end interface atan - + interface asinpi module procedure asinpi_self end interface asinpi - + interface acospi module procedure acospi_self end interface acospi - + interface atanpi module procedure atanpi_self end interface atanpi - + interface asinh module procedure asinh_self end interface asinh - + interface acosh module procedure acosh_self end interface acosh - + interface atanh module procedure atanh_self end interface atanh - + interface sqrt module procedure sqrt_self end interface sqrt - + interface pow2 module procedure pow2_self end interface pow2 - + interface pow3 module procedure pow3_self end interface pow3 - + interface pow4 module procedure pow4_self end interface pow4 - + interface pow5 module procedure pow5_self end interface pow5 - + interface pow6 module procedure pow6_self end interface pow6 - + interface pow7 module procedure pow7_self end interface pow7 - + interface pow8 module procedure pow8_self end interface pow8 - + interface abs module procedure abs_self end interface abs - + interface operator(+) module procedure add_self module procedure add_self_real @@ -304,7 +304,7 @@ module auto_diff_real_4var_order1_module module procedure add_self_int module procedure add_int_self end interface operator(+) - + interface operator(-) module procedure sub_self module procedure sub_self_real @@ -312,7 +312,7 @@ module auto_diff_real_4var_order1_module module procedure sub_self_int module procedure sub_int_self end interface operator(-) - + interface operator(*) module procedure mul_self module procedure mul_self_real @@ -320,7 +320,7 @@ module auto_diff_real_4var_order1_module module procedure mul_self_int module procedure mul_int_self end interface operator(*) - + interface operator(/) module procedure div_self module procedure div_self_real @@ -328,7 +328,7 @@ module auto_diff_real_4var_order1_module module procedure div_self_int module procedure div_int_self end interface operator(/) - + interface pow module procedure pow_self module procedure pow_self_real @@ -336,7 +336,7 @@ module auto_diff_real_4var_order1_module module procedure pow_self_int module procedure pow_int_self end interface pow - + interface max module procedure max_self module procedure max_self_real @@ -344,7 +344,7 @@ module auto_diff_real_4var_order1_module module procedure max_self_int module procedure max_int_self end interface max - + interface min module procedure min_self module procedure min_self_real @@ -352,7 +352,7 @@ module auto_diff_real_4var_order1_module module procedure min_self_int module procedure min_int_self end interface min - + interface dim module procedure dim_self module procedure dim_self_real @@ -360,23 +360,23 @@ module auto_diff_real_4var_order1_module module procedure dim_self_int module procedure dim_int_self end interface dim - + interface differentiate_1 module procedure differentiate_auto_diff_real_4var_order1_1 end interface differentiate_1 - + interface differentiate_2 module procedure differentiate_auto_diff_real_4var_order1_2 end interface differentiate_2 - + interface differentiate_3 module procedure differentiate_auto_diff_real_4var_order1_3 end interface differentiate_3 - + interface differentiate_4 module procedure differentiate_auto_diff_real_4var_order1_4 end interface differentiate_4 - + contains subroutine assign_from_self(this, other) @@ -388,7 +388,7 @@ subroutine assign_from_self(this, other) this%d1val3 = other%d1val3 this%d1val4 = other%d1val4 end subroutine assign_from_self - + subroutine assign_from_real_dp(this, other) type(auto_diff_real_4var_order1), intent(out) :: this real(dp), intent(in) :: other @@ -398,7 +398,7 @@ subroutine assign_from_real_dp(this, other) this%d1val3 = 0.0_dp this%d1val4 = 0.0_dp end subroutine assign_from_real_dp - + subroutine assign_from_int(this, other) type(auto_diff_real_4var_order1), intent(out) :: this integer, intent(in) :: other @@ -408,217 +408,217 @@ subroutine assign_from_int(this, other) this%d1val3 = 0.0_dp this%d1val4 = 0.0_dp end subroutine assign_from_int - + function equal_self(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this%val .eq. other%val) end function equal_self - + function equal_auto_diff_real_4var_order1_real_dp(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_4var_order1_real_dp - + function equal_real_dp_auto_diff_real_4var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_real_dp_auto_diff_real_4var_order1 - + function equal_auto_diff_real_4var_order1_int(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_4var_order1_int - + function equal_int_auto_diff_real_4var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_int_auto_diff_real_4var_order1 - + function neq_self(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this%val .ne. other%val) end function neq_self - + function neq_auto_diff_real_4var_order1_real_dp(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_4var_order1_real_dp - + function neq_real_dp_auto_diff_real_4var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_real_dp_auto_diff_real_4var_order1 - + function neq_auto_diff_real_4var_order1_int(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_4var_order1_int - + function neq_int_auto_diff_real_4var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_int_auto_diff_real_4var_order1 - + function greater_self(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this%val .gt. other%val) end function greater_self - + function greater_auto_diff_real_4var_order1_real_dp(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_4var_order1_real_dp - + function greater_real_dp_auto_diff_real_4var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_real_dp_auto_diff_real_4var_order1 - + function greater_auto_diff_real_4var_order1_int(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_4var_order1_int - + function greater_int_auto_diff_real_4var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_int_auto_diff_real_4var_order1 - + function less_self(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this%val .lt. other%val) end function less_self - + function less_auto_diff_real_4var_order1_real_dp(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_4var_order1_real_dp - + function less_real_dp_auto_diff_real_4var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_real_dp_auto_diff_real_4var_order1 - + function less_auto_diff_real_4var_order1_int(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_4var_order1_int - + function less_int_auto_diff_real_4var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_int_auto_diff_real_4var_order1 - + function leq_self(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this%val .le. other%val) end function leq_self - + function leq_auto_diff_real_4var_order1_real_dp(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_4var_order1_real_dp - + function leq_real_dp_auto_diff_real_4var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_real_dp_auto_diff_real_4var_order1 - + function leq_auto_diff_real_4var_order1_int(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_4var_order1_int - + function leq_int_auto_diff_real_4var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_int_auto_diff_real_4var_order1 - + function geq_self(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this%val .ge. other%val) end function geq_self - + function geq_auto_diff_real_4var_order1_real_dp(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_4var_order1_real_dp - + function geq_real_dp_auto_diff_real_4var_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_real_dp_auto_diff_real_4var_order1 - + function geq_auto_diff_real_4var_order1_int(this, other) result(z) type(auto_diff_real_4var_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_4var_order1_int - + function geq_int_auto_diff_real_4var_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_4var_order1), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_int_auto_diff_real_4var_order1 - + function make_unary_operator(x, z_val, z_d1x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x real(dp), intent(in) :: z_val @@ -630,7 +630,7 @@ function make_unary_operator(x, z_val, z_d1x) result(unary) unary%d1val3 = x%d1val3*z_d1x unary%d1val4 = x%d1val4*z_d1x end function make_unary_operator - + function make_binary_operator(x, y, z_val, z_d1x, z_d1y) result(binary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1), intent(in) :: y @@ -644,7 +644,7 @@ function make_binary_operator(x, y, z_val, z_d1x, z_d1y) result(binary) binary%d1val3 = x%d1val3*z_d1x + y%d1val3*z_d1y binary%d1val4 = x%d1val4*z_d1x + y%d1val4*z_d1y end function make_binary_operator - + function sign_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -654,7 +654,7 @@ function sign_self(x) result(unary) unary%d1val3 = 0.0_dp unary%d1val4 = 0.0_dp end function sign_self - + function safe_sqrt_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -668,7 +668,7 @@ function safe_sqrt_self(x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function safe_sqrt_self - + function unary_minus_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -678,7 +678,7 @@ function unary_minus_self(x) result(unary) unary%d1val3 = -x%d1val3 unary%d1val4 = -x%d1val4 end function unary_minus_self - + function exp_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -690,7 +690,7 @@ function exp_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function exp_self - + function expm1_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -702,7 +702,7 @@ function expm1_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function expm1_self - + function exp10_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -716,7 +716,7 @@ function exp10_self(x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function exp10_self - + function powm1_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -728,7 +728,7 @@ function powm1_self(x) result(unary) unary%d1val3 = -q0*x%d1val3 unary%d1val4 = -q0*x%d1val4 end function powm1_self - + function log_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -740,7 +740,7 @@ function log_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function log_self - + function log1p_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -752,7 +752,7 @@ function log1p_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function log1p_self - + function safe_log_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -764,7 +764,7 @@ function safe_log_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function safe_log_self - + function log10_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -778,7 +778,7 @@ function log10_self(x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function log10_self - + function safe_log10_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -792,7 +792,7 @@ function safe_log10_self(x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function safe_log10_self - + function log2_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -806,7 +806,7 @@ function log2_self(x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function log2_self - + function sin_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -818,7 +818,7 @@ function sin_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function sin_self - + function cos_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -830,7 +830,7 @@ function cos_self(x) result(unary) unary%d1val3 = -q0*x%d1val3 unary%d1val4 = -q0*x%d1val4 end function cos_self - + function tan_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -844,7 +844,7 @@ function tan_self(x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function tan_self - + function sinpi_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -858,7 +858,7 @@ function sinpi_self(x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function sinpi_self - + function cospi_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -872,7 +872,7 @@ function cospi_self(x) result(unary) unary%d1val3 = -q1*x%d1val3 unary%d1val4 = -q1*x%d1val4 end function cospi_self - + function tanpi_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -886,7 +886,7 @@ function tanpi_self(x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function tanpi_self - + function sinh_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -898,7 +898,7 @@ function sinh_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function sinh_self - + function cosh_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -910,7 +910,7 @@ function cosh_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function cosh_self - + function tanh_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -924,7 +924,7 @@ function tanh_self(x) result(unary) unary%d1val3 = -q1*x%d1val3 unary%d1val4 = -q1*x%d1val4 end function tanh_self - + function asin_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -936,7 +936,7 @@ function asin_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function asin_self - + function acos_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -948,7 +948,7 @@ function acos_self(x) result(unary) unary%d1val3 = -q0*x%d1val3 unary%d1val4 = -q0*x%d1val4 end function acos_self - + function atan_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -960,7 +960,7 @@ function atan_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function atan_self - + function asinpi_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -974,7 +974,7 @@ function asinpi_self(x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function asinpi_self - + function acospi_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -988,7 +988,7 @@ function acospi_self(x) result(unary) unary%d1val3 = -q1*x%d1val3 unary%d1val4 = -q1*x%d1val4 end function acospi_self - + function atanpi_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1000,7 +1000,7 @@ function atanpi_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function atanpi_self - + function asinh_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1012,7 +1012,7 @@ function asinh_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function asinh_self - + function acosh_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1024,7 +1024,7 @@ function acosh_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function acosh_self - + function atanh_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1036,7 +1036,7 @@ function atanh_self(x) result(unary) unary%d1val3 = -q0*x%d1val3 unary%d1val4 = -q0*x%d1val4 end function atanh_self - + function sqrt_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1050,7 +1050,7 @@ function sqrt_self(x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function sqrt_self - + function pow2_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1062,7 +1062,7 @@ function pow2_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function pow2_self - + function pow3_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1074,7 +1074,7 @@ function pow3_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function pow3_self - + function pow4_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1086,7 +1086,7 @@ function pow4_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function pow4_self - + function pow5_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1098,7 +1098,7 @@ function pow5_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function pow5_self - + function pow6_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1110,7 +1110,7 @@ function pow6_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function pow6_self - + function pow7_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1122,7 +1122,7 @@ function pow7_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function pow7_self - + function pow8_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1134,7 +1134,7 @@ function pow8_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function pow8_self - + function abs_self(x) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1) :: unary @@ -1146,7 +1146,7 @@ function abs_self(x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function abs_self - + function add_self(x, y) result(binary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1), intent(in) :: y @@ -1157,7 +1157,7 @@ function add_self(x, y) result(binary) binary%d1val3 = x%d1val3 + y%d1val3 binary%d1val4 = x%d1val4 + y%d1val4 end function add_self - + function add_self_real(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1168,7 +1168,7 @@ function add_self_real(x, y) result(unary) unary%d1val3 = x%d1val3 unary%d1val4 = x%d1val4 end function add_self_real - + function add_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1179,7 +1179,7 @@ function add_real_self(z, x) result(unary) unary%d1val3 = x%d1val3 unary%d1val4 = x%d1val4 end function add_real_self - + function add_self_int(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x integer, intent(in) :: y @@ -1192,7 +1192,7 @@ function add_self_int(x, y) result(unary) unary%d1val3 = x%d1val3 unary%d1val4 = x%d1val4 end function add_self_int - + function add_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1205,7 +1205,7 @@ function add_int_self(z, x) result(unary) unary%d1val3 = x%d1val3 unary%d1val4 = x%d1val4 end function add_int_self - + function sub_self(x, y) result(binary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1), intent(in) :: y @@ -1216,7 +1216,7 @@ function sub_self(x, y) result(binary) binary%d1val3 = x%d1val3 - y%d1val3 binary%d1val4 = x%d1val4 - y%d1val4 end function sub_self - + function sub_self_real(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1227,7 +1227,7 @@ function sub_self_real(x, y) result(unary) unary%d1val3 = x%d1val3 unary%d1val4 = x%d1val4 end function sub_self_real - + function sub_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1238,7 +1238,7 @@ function sub_real_self(z, x) result(unary) unary%d1val3 = -x%d1val3 unary%d1val4 = -x%d1val4 end function sub_real_self - + function sub_self_int(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x integer, intent(in) :: y @@ -1251,7 +1251,7 @@ function sub_self_int(x, y) result(unary) unary%d1val3 = x%d1val3 unary%d1val4 = x%d1val4 end function sub_self_int - + function sub_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1264,7 +1264,7 @@ function sub_int_self(z, x) result(unary) unary%d1val3 = -x%d1val3 unary%d1val4 = -x%d1val4 end function sub_int_self - + function mul_self(x, y) result(binary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1), intent(in) :: y @@ -1275,7 +1275,7 @@ function mul_self(x, y) result(binary) binary%d1val3 = x%d1val3*y%val + x%val*y%d1val3 binary%d1val4 = x%d1val4*y%val + x%val*y%d1val4 end function mul_self - + function mul_self_real(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1286,7 +1286,7 @@ function mul_self_real(x, y) result(unary) unary%d1val3 = x%d1val3*y unary%d1val4 = x%d1val4*y end function mul_self_real - + function mul_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1297,7 +1297,7 @@ function mul_real_self(z, x) result(unary) unary%d1val3 = x%d1val3*z unary%d1val4 = x%d1val4*z end function mul_real_self - + function mul_self_int(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x integer, intent(in) :: y @@ -1310,7 +1310,7 @@ function mul_self_int(x, y) result(unary) unary%d1val3 = x%d1val3*y_dp unary%d1val4 = x%d1val4*y_dp end function mul_self_int - + function mul_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1323,7 +1323,7 @@ function mul_int_self(z, x) result(unary) unary%d1val3 = x%d1val3*y_dp unary%d1val4 = x%d1val4*y_dp end function mul_int_self - + function div_self(x, y) result(binary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1), intent(in) :: y @@ -1336,7 +1336,7 @@ function div_self(x, y) result(binary) binary%d1val3 = q0*(x%d1val3*y%val - x%val*y%d1val3) binary%d1val4 = q0*(x%d1val4*y%val - x%val*y%d1val4) end function div_self - + function div_self_real(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1349,7 +1349,7 @@ function div_self_real(x, y) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function div_self_real - + function div_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1362,7 +1362,7 @@ function div_real_self(z, x) result(unary) unary%d1val3 = -q0*x%d1val3 unary%d1val4 = -q0*x%d1val4 end function div_real_self - + function div_self_int(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x integer, intent(in) :: y @@ -1377,7 +1377,7 @@ function div_self_int(x, y) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function div_self_int - + function div_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1392,7 +1392,7 @@ function div_int_self(z, x) result(unary) unary%d1val3 = -q0*x%d1val3 unary%d1val4 = -q0*x%d1val4 end function div_int_self - + function pow_self(x, y) result(binary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1), intent(in) :: y @@ -1407,7 +1407,7 @@ function pow_self(x, y) result(binary) binary%d1val3 = q0*(q1*y%d1val3 + x%d1val3*y%val) binary%d1val4 = q0*(q1*y%d1val4 + x%d1val4*y%val) end function pow_self - + function pow_self_real(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1420,7 +1420,7 @@ function pow_self_real(x, y) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function pow_self_real - + function pow_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1435,7 +1435,7 @@ function pow_real_self(z, x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function pow_real_self - + function pow_self_int(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x integer, intent(in) :: y @@ -1450,7 +1450,7 @@ function pow_self_int(x, y) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function pow_self_int - + function pow_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1467,7 +1467,7 @@ function pow_int_self(z, x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function pow_int_self - + function max_self(x, y) result(binary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1), intent(in) :: y @@ -1482,7 +1482,7 @@ function max_self(x, y) result(binary) binary%d1val3 = q0*x%d1val3 + q1*y%d1val3 binary%d1val4 = q0*x%d1val4 + q1*y%d1val4 end function max_self - + function max_self_real(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1495,7 +1495,7 @@ function max_self_real(x, y) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function max_self_real - + function max_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1508,7 +1508,7 @@ function max_real_self(z, x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function max_real_self - + function max_self_int(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x integer, intent(in) :: y @@ -1523,7 +1523,7 @@ function max_self_int(x, y) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function max_self_int - + function max_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1538,7 +1538,7 @@ function max_int_self(z, x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function max_int_self - + function min_self(x, y) result(binary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1), intent(in) :: y @@ -1553,7 +1553,7 @@ function min_self(x, y) result(binary) binary%d1val3 = q0*x%d1val3 + q1*y%d1val3 binary%d1val4 = q0*x%d1val4 + q1*y%d1val4 end function min_self - + function min_self_real(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1566,7 +1566,7 @@ function min_self_real(x, y) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function min_self_real - + function min_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1579,7 +1579,7 @@ function min_real_self(z, x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function min_real_self - + function min_self_int(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x integer, intent(in) :: y @@ -1594,7 +1594,7 @@ function min_self_int(x, y) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function min_self_int - + function min_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1609,7 +1609,7 @@ function min_int_self(z, x) result(unary) unary%d1val3 = q0*x%d1val3 unary%d1val4 = q0*x%d1val4 end function min_int_self - + function dim_self(x, y) result(binary) type(auto_diff_real_4var_order1), intent(in) :: x type(auto_diff_real_4var_order1), intent(in) :: y @@ -1624,7 +1624,7 @@ function dim_self(x, y) result(binary) binary%d1val3 = -0.5_dp*y%d1val3 + 0.5_dp*x%d1val3 + q1*(x%d1val3 - y%d1val3) binary%d1val4 = -0.5_dp*y%d1val4 + 0.5_dp*x%d1val4 + q1*(x%d1val4 - y%d1val4) end function dim_self - + function dim_self_real(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1639,7 +1639,7 @@ function dim_self_real(x, y) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function dim_self_real - + function dim_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1654,7 +1654,7 @@ function dim_real_self(z, x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function dim_real_self - + function dim_self_int(x, y) result(unary) type(auto_diff_real_4var_order1), intent(in) :: x integer, intent(in) :: y @@ -1671,7 +1671,7 @@ function dim_self_int(x, y) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function dim_self_int - + function dim_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_4var_order1), intent(in) :: x @@ -1688,7 +1688,7 @@ function dim_int_self(z, x) result(unary) unary%d1val3 = q1*x%d1val3 unary%d1val4 = q1*x%d1val4 end function dim_int_self - + function differentiate_auto_diff_real_4var_order1_1(this) result(derivative) type(auto_diff_real_4var_order1), intent(in) :: this type(auto_diff_real_4var_order1) :: derivative @@ -1698,7 +1698,7 @@ function differentiate_auto_diff_real_4var_order1_1(this) result(derivative) derivative%d1val3 = 0.0_dp derivative%d1val4 = 0.0_dp end function differentiate_auto_diff_real_4var_order1_1 - + function differentiate_auto_diff_real_4var_order1_2(this) result(derivative) type(auto_diff_real_4var_order1), intent(in) :: this type(auto_diff_real_4var_order1) :: derivative @@ -1708,7 +1708,7 @@ function differentiate_auto_diff_real_4var_order1_2(this) result(derivative) derivative%d1val3 = 0.0_dp derivative%d1val4 = 0.0_dp end function differentiate_auto_diff_real_4var_order1_2 - + function differentiate_auto_diff_real_4var_order1_3(this) result(derivative) type(auto_diff_real_4var_order1), intent(in) :: this type(auto_diff_real_4var_order1) :: derivative @@ -1718,7 +1718,7 @@ function differentiate_auto_diff_real_4var_order1_3(this) result(derivative) derivative%d1val3 = 0.0_dp derivative%d1val4 = 0.0_dp end function differentiate_auto_diff_real_4var_order1_3 - + function differentiate_auto_diff_real_4var_order1_4(this) result(derivative) type(auto_diff_real_4var_order1), intent(in) :: this type(auto_diff_real_4var_order1) :: derivative @@ -1728,5 +1728,5 @@ function differentiate_auto_diff_real_4var_order1_4(this) result(derivative) derivative%d1val3 = 0.0_dp derivative%d1val4 = 0.0_dp end function differentiate_auto_diff_real_4var_order1_4 - + end module auto_diff_real_4var_order1_module \ No newline at end of file diff --git a/auto_diff/private/auto_diff_real_star_order1_module.f90 b/auto_diff/private/auto_diff_real_star_order1_module.f90 index cc9df242d..0fecdc2aa 100644 --- a/auto_diff/private/auto_diff_real_star_order1_module.f90 +++ b/auto_diff/private/auto_diff_real_star_order1_module.f90 @@ -3,7 +3,7 @@ module auto_diff_real_star_order1_module use utils_lib use support_functions use math_lib - + implicit none private public :: auto_diff_real_star_order1, & @@ -67,13 +67,13 @@ module auto_diff_real_star_order1_module real(dp) :: val real(dp) :: d1Array(33) end type auto_diff_real_star_order1 - + interface assignment(=) module procedure assign_from_self module procedure assign_from_real_dp module procedure assign_from_int end interface assignment(=) - + interface operator(.eq.) module procedure equal_self module procedure equal_auto_diff_real_star_order1_real_dp @@ -81,7 +81,7 @@ module auto_diff_real_star_order1_module module procedure equal_auto_diff_real_star_order1_int module procedure equal_int_auto_diff_real_star_order1 end interface operator(.eq.) - + interface operator(.ne.) module procedure neq_self module procedure neq_auto_diff_real_star_order1_real_dp @@ -89,7 +89,7 @@ module auto_diff_real_star_order1_module module procedure neq_auto_diff_real_star_order1_int module procedure neq_int_auto_diff_real_star_order1 end interface operator(.ne.) - + interface operator(.gt.) module procedure greater_self module procedure greater_auto_diff_real_star_order1_real_dp @@ -97,7 +97,7 @@ module auto_diff_real_star_order1_module module procedure greater_auto_diff_real_star_order1_int module procedure greater_int_auto_diff_real_star_order1 end interface operator(.gt.) - + interface operator(.lt.) module procedure less_self module procedure less_auto_diff_real_star_order1_real_dp @@ -105,7 +105,7 @@ module auto_diff_real_star_order1_module module procedure less_auto_diff_real_star_order1_int module procedure less_int_auto_diff_real_star_order1 end interface operator(.lt.) - + interface operator(.le.) module procedure leq_self module procedure leq_auto_diff_real_star_order1_real_dp @@ -113,7 +113,7 @@ module auto_diff_real_star_order1_module module procedure leq_auto_diff_real_star_order1_int module procedure leq_int_auto_diff_real_star_order1 end interface operator(.le.) - + interface operator(.ge.) module procedure geq_self module procedure geq_auto_diff_real_star_order1_real_dp @@ -121,175 +121,175 @@ module auto_diff_real_star_order1_module module procedure geq_auto_diff_real_star_order1_int module procedure geq_int_auto_diff_real_star_order1 end interface operator(.ge.) - + interface make_unop module procedure make_unary_operator end interface make_unop - + interface make_binop module procedure make_binary_operator end interface make_binop - + interface sign module procedure sign_self end interface sign - + interface safe_sqrt module procedure safe_sqrt_self end interface safe_sqrt - + interface operator(-) module procedure unary_minus_self end interface operator(-) - + interface exp module procedure exp_self end interface exp - + interface expm1 module procedure expm1_self end interface expm1 - + interface exp10 module procedure exp10_self end interface exp10 - + interface powm1 module procedure powm1_self end interface powm1 - + interface log module procedure log_self end interface log - + interface log1p module procedure log1p_self end interface log1p - + interface safe_log module procedure safe_log_self end interface safe_log - + interface log10 module procedure log10_self end interface log10 - + interface safe_log10 module procedure safe_log10_self end interface safe_log10 - + interface log2 module procedure log2_self end interface log2 - + interface sin module procedure sin_self end interface sin - + interface cos module procedure cos_self end interface cos - + interface tan module procedure tan_self end interface tan - + interface sinpi module procedure sinpi_self end interface sinpi - + interface cospi module procedure cospi_self end interface cospi - + interface tanpi module procedure tanpi_self end interface tanpi - + interface sinh module procedure sinh_self end interface sinh - + interface cosh module procedure cosh_self end interface cosh - + interface tanh module procedure tanh_self end interface tanh - + interface asin module procedure asin_self end interface asin - + interface acos module procedure acos_self end interface acos - + interface atan module procedure atan_self end interface atan - + interface asinpi module procedure asinpi_self end interface asinpi - + interface acospi module procedure acospi_self end interface acospi - + interface atanpi module procedure atanpi_self end interface atanpi - + interface asinh module procedure asinh_self end interface asinh - + interface acosh module procedure acosh_self end interface acosh - + interface atanh module procedure atanh_self end interface atanh - + interface sqrt module procedure sqrt_self end interface sqrt - + interface pow2 module procedure pow2_self end interface pow2 - + interface pow3 module procedure pow3_self end interface pow3 - + interface pow4 module procedure pow4_self end interface pow4 - + interface pow5 module procedure pow5_self end interface pow5 - + interface pow6 module procedure pow6_self end interface pow6 - + interface pow7 module procedure pow7_self end interface pow7 - + interface pow8 module procedure pow8_self end interface pow8 - + interface abs module procedure abs_self end interface abs - + interface operator(+) module procedure add_self module procedure add_self_real @@ -297,7 +297,7 @@ module auto_diff_real_star_order1_module module procedure add_self_int module procedure add_int_self end interface operator(+) - + interface operator(-) module procedure sub_self module procedure sub_self_real @@ -305,7 +305,7 @@ module auto_diff_real_star_order1_module module procedure sub_self_int module procedure sub_int_self end interface operator(-) - + interface operator(*) module procedure mul_self module procedure mul_self_real @@ -313,7 +313,7 @@ module auto_diff_real_star_order1_module module procedure mul_self_int module procedure mul_int_self end interface operator(*) - + interface operator(/) module procedure div_self module procedure div_self_real @@ -321,7 +321,7 @@ module auto_diff_real_star_order1_module module procedure div_self_int module procedure div_int_self end interface operator(/) - + interface pow module procedure pow_self module procedure pow_self_real @@ -329,7 +329,7 @@ module auto_diff_real_star_order1_module module procedure pow_self_int module procedure pow_int_self end interface pow - + interface max module procedure max_self module procedure max_self_real @@ -337,7 +337,7 @@ module auto_diff_real_star_order1_module module procedure max_self_int module procedure max_int_self end interface max - + interface min module procedure min_self module procedure min_self_real @@ -345,7 +345,7 @@ module auto_diff_real_star_order1_module module procedure min_self_int module procedure min_int_self end interface min - + interface dim module procedure dim_self module procedure dim_self_real @@ -353,7 +353,7 @@ module auto_diff_real_star_order1_module module procedure dim_self_int module procedure dim_int_self end interface dim - + contains subroutine assign_from_self(this, other) @@ -362,231 +362,231 @@ subroutine assign_from_self(this, other) this%val = other%val this%d1Array = other%d1Array end subroutine assign_from_self - + subroutine assign_from_real_dp(this, other) type(auto_diff_real_star_order1), intent(out) :: this real(dp), intent(in) :: other this%val = other this%d1Array = 0.0_dp end subroutine assign_from_real_dp - + subroutine assign_from_int(this, other) type(auto_diff_real_star_order1), intent(out) :: this integer, intent(in) :: other this%val = other this%d1Array = 0.0_dp end subroutine assign_from_int - + function equal_self(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this%val .eq. other%val) end function equal_self - + function equal_auto_diff_real_star_order1_real_dp(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_star_order1_real_dp - + function equal_real_dp_auto_diff_real_star_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_real_dp_auto_diff_real_star_order1 - + function equal_auto_diff_real_star_order1_int(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_star_order1_int - + function equal_int_auto_diff_real_star_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_int_auto_diff_real_star_order1 - + function neq_self(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this%val .ne. other%val) end function neq_self - + function neq_auto_diff_real_star_order1_real_dp(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_star_order1_real_dp - + function neq_real_dp_auto_diff_real_star_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_real_dp_auto_diff_real_star_order1 - + function neq_auto_diff_real_star_order1_int(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_star_order1_int - + function neq_int_auto_diff_real_star_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_int_auto_diff_real_star_order1 - + function greater_self(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this%val .gt. other%val) end function greater_self - + function greater_auto_diff_real_star_order1_real_dp(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_star_order1_real_dp - + function greater_real_dp_auto_diff_real_star_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_real_dp_auto_diff_real_star_order1 - + function greater_auto_diff_real_star_order1_int(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_star_order1_int - + function greater_int_auto_diff_real_star_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_int_auto_diff_real_star_order1 - + function less_self(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this%val .lt. other%val) end function less_self - + function less_auto_diff_real_star_order1_real_dp(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_star_order1_real_dp - + function less_real_dp_auto_diff_real_star_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_real_dp_auto_diff_real_star_order1 - + function less_auto_diff_real_star_order1_int(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_star_order1_int - + function less_int_auto_diff_real_star_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_int_auto_diff_real_star_order1 - + function leq_self(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this%val .le. other%val) end function leq_self - + function leq_auto_diff_real_star_order1_real_dp(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_star_order1_real_dp - + function leq_real_dp_auto_diff_real_star_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_real_dp_auto_diff_real_star_order1 - + function leq_auto_diff_real_star_order1_int(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_star_order1_int - + function leq_int_auto_diff_real_star_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_int_auto_diff_real_star_order1 - + function geq_self(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this%val .ge. other%val) end function geq_self - + function geq_auto_diff_real_star_order1_real_dp(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_star_order1_real_dp - + function geq_real_dp_auto_diff_real_star_order1(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_real_dp_auto_diff_real_star_order1 - + function geq_auto_diff_real_star_order1_int(this, other) result(z) type(auto_diff_real_star_order1), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_star_order1_int - + function geq_int_auto_diff_real_star_order1(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_star_order1), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_int_auto_diff_real_star_order1 - + function make_unary_operator(x, z_val, z_d1x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x real(dp), intent(in) :: z_val @@ -595,7 +595,7 @@ function make_unary_operator(x, z_val, z_d1x) result(unary) unary%val = z_val unary%d1Array(1:33) = x%d1Array(1:33)*z_d1x end function make_unary_operator - + function make_binary_operator(x, y, z_val, z_d1x, z_d1y) result(binary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1), intent(in) :: y @@ -606,14 +606,14 @@ function make_binary_operator(x, y, z_val, z_d1x, z_d1y) result(binary) binary%val = z_val binary%d1Array(1:33) = x%d1Array(1:33)*z_d1x + y%d1Array(1:33)*z_d1y end function make_binary_operator - + function sign_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = sgn(x%val) unary%d1Array(1:33) = 0.0_dp end function sign_self - + function safe_sqrt_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -622,14 +622,14 @@ function safe_sqrt_self(x) result(unary) unary%val = q0 unary%d1Array(1:33) = 0.5_dp*q0*x%d1Array(1:33)*powm1(x%val) end function safe_sqrt_self - + function unary_minus_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = -x%val unary%d1Array(1:33) = -x%d1Array(1:33) end function unary_minus_self - + function exp_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -638,14 +638,14 @@ function exp_self(x) result(unary) unary%val = q0 unary%d1Array(1:33) = q0*x%d1Array(1:33) end function exp_self - + function expm1_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = expm1(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*exp(x%val) end function expm1_self - + function exp10_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -654,35 +654,35 @@ function exp10_self(x) result(unary) unary%val = q0 unary%d1Array(1:33) = q0*x%d1Array(1:33)*ln10 end function exp10_self - + function powm1_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = powm1(x%val) unary%d1Array(1:33) = -x%d1Array(1:33)*powm1(pow2(x%val)) end function powm1_self - + function log_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = log(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*powm1(x%val) end function log_self - + function log1p_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = log1p(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*powm1(x%val + 1) end function log1p_self - + function safe_log_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = safe_log(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*powm1(x%val) end function safe_log_self - + function log10_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -691,7 +691,7 @@ function log10_self(x) result(unary) unary%val = q0*log(x%val) unary%d1Array(1:33) = q0*x%d1Array(1:33)*powm1(x%val) end function log10_self - + function safe_log10_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -700,7 +700,7 @@ function safe_log10_self(x) result(unary) unary%val = q0*safe_log(x%val) unary%d1Array(1:33) = q0*x%d1Array(1:33)*powm1(x%val) end function safe_log10_self - + function log2_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -709,21 +709,21 @@ function log2_self(x) result(unary) unary%val = q0*log(x%val) unary%d1Array(1:33) = q0*x%d1Array(1:33)*powm1(x%val) end function log2_self - + function sin_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = sin(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*cos(x%val) end function sin_self - + function cos_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = cos(x%val) unary%d1Array(1:33) = -x%d1Array(1:33)*sin(x%val) end function cos_self - + function tan_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -732,7 +732,7 @@ function tan_self(x) result(unary) unary%val = q0 unary%d1Array(1:33) = x%d1Array(1:33)*(pow2(q0) + 1) end function tan_self - + function sinpi_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -741,7 +741,7 @@ function sinpi_self(x) result(unary) unary%val = sin(q0) unary%d1Array(1:33) = pi*x%d1Array(1:33)*cos(q0) end function sinpi_self - + function cospi_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -750,7 +750,7 @@ function cospi_self(x) result(unary) unary%val = cos(q0) unary%d1Array(1:33) = -pi*x%d1Array(1:33)*sin(q0) end function cospi_self - + function tanpi_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -759,21 +759,21 @@ function tanpi_self(x) result(unary) unary%val = q0 unary%d1Array(1:33) = pi*x%d1Array(1:33)*(pow2(q0) + 1) end function tanpi_self - + function sinh_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = sinh(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*cosh(x%val) end function sinh_self - + function cosh_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = cosh(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*sinh(x%val) end function cosh_self - + function tanh_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -782,28 +782,28 @@ function tanh_self(x) result(unary) unary%val = q0 unary%d1Array(1:33) = -x%d1Array(1:33)*(pow2(q0) - 1) end function tanh_self - + function asin_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = asin(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*powm1(sqrt(1 - pow2(x%val))) end function asin_self - + function acos_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = acos(x%val) unary%d1Array(1:33) = -x%d1Array(1:33)*powm1(sqrt(1 - pow2(x%val))) end function acos_self - + function atan_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = atan(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*powm1(pow2(x%val) + 1) end function atan_self - + function asinpi_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -812,7 +812,7 @@ function asinpi_self(x) result(unary) unary%val = q0*asin(x%val) unary%d1Array(1:33) = q0*x%d1Array(1:33)*powm1(sqrt(1 - pow2(x%val))) end function asinpi_self - + function acospi_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -821,35 +821,35 @@ function acospi_self(x) result(unary) unary%val = q0*acos(x%val) unary%d1Array(1:33) = -q0*x%d1Array(1:33)*powm1(sqrt(1 - pow2(x%val))) end function acospi_self - + function atanpi_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = powm1(pi)*atan(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*powm1(pi*pow2(x%val) + pi) end function atanpi_self - + function asinh_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = asinh(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*powm1(sqrt(pow2(x%val) + 1)) end function asinh_self - + function acosh_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = acosh(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*powm1(sqrt(pow2(x%val) - 1)) end function acosh_self - + function atanh_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = atanh(x%val) unary%d1Array(1:33) = -x%d1Array(1:33)*powm1(pow2(x%val) - 1) end function atanh_self - + function sqrt_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary @@ -858,63 +858,63 @@ function sqrt_self(x) result(unary) unary%val = q0 unary%d1Array(1:33) = 0.5_dp*x%d1Array(1:33)*powm1(q0) end function sqrt_self - + function pow2_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = pow2(x%val) unary%d1Array(1:33) = 2.0_dp*x%d1Array(1:33)*x%val end function pow2_self - + function pow3_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = pow3(x%val) unary%d1Array(1:33) = 3.0_dp*x%d1Array(1:33)*pow2(x%val) end function pow3_self - + function pow4_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = pow4(x%val) unary%d1Array(1:33) = 4.0_dp*x%d1Array(1:33)*pow3(x%val) end function pow4_self - + function pow5_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = pow5(x%val) unary%d1Array(1:33) = 5.0_dp*x%d1Array(1:33)*pow4(x%val) end function pow5_self - + function pow6_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = pow6(x%val) unary%d1Array(1:33) = 6.0_dp*x%d1Array(1:33)*pow5(x%val) end function pow6_self - + function pow7_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = pow7(x%val) unary%d1Array(1:33) = 7.0_dp*x%d1Array(1:33)*pow6(x%val) end function pow7_self - + function pow8_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = pow8(x%val) unary%d1Array(1:33) = 8.0_dp*x%d1Array(1:33)*pow7(x%val) end function pow8_self - + function abs_self(x) result(unary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1) :: unary unary%val = Abs(x%val) unary%d1Array(1:33) = x%d1Array(1:33)*sgn(x%val) end function abs_self - + function add_self(x, y) result(binary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1), intent(in) :: y @@ -922,7 +922,7 @@ function add_self(x, y) result(binary) binary%val = x%val + y%val binary%d1Array(1:33) = x%d1Array(1:33) + y%d1Array(1:33) end function add_self - + function add_self_real(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x real(dp), intent(in) :: y @@ -930,7 +930,7 @@ function add_self_real(x, y) result(unary) unary%val = x%val + y unary%d1Array(1:33) = x%d1Array(1:33) end function add_self_real - + function add_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -938,7 +938,7 @@ function add_real_self(z, x) result(unary) unary%val = x%val + z unary%d1Array(1:33) = x%d1Array(1:33) end function add_real_self - + function add_self_int(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x integer, intent(in) :: y @@ -948,7 +948,7 @@ function add_self_int(x, y) result(unary) unary%val = x%val + y_dp unary%d1Array(1:33) = x%d1Array(1:33) end function add_self_int - + function add_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -958,7 +958,7 @@ function add_int_self(z, x) result(unary) unary%val = x%val + y_dp unary%d1Array(1:33) = x%d1Array(1:33) end function add_int_self - + function sub_self(x, y) result(binary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1), intent(in) :: y @@ -966,7 +966,7 @@ function sub_self(x, y) result(binary) binary%val = x%val - y%val binary%d1Array(1:33) = x%d1Array(1:33) - y%d1Array(1:33) end function sub_self - + function sub_self_real(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x real(dp), intent(in) :: y @@ -974,7 +974,7 @@ function sub_self_real(x, y) result(unary) unary%val = x%val - y unary%d1Array(1:33) = x%d1Array(1:33) end function sub_self_real - + function sub_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -982,7 +982,7 @@ function sub_real_self(z, x) result(unary) unary%val = -x%val + z unary%d1Array(1:33) = -x%d1Array(1:33) end function sub_real_self - + function sub_self_int(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x integer, intent(in) :: y @@ -992,7 +992,7 @@ function sub_self_int(x, y) result(unary) unary%val = x%val - y_dp unary%d1Array(1:33) = x%d1Array(1:33) end function sub_self_int - + function sub_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1002,7 +1002,7 @@ function sub_int_self(z, x) result(unary) unary%val = -x%val + y_dp unary%d1Array(1:33) = -x%d1Array(1:33) end function sub_int_self - + function mul_self(x, y) result(binary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1), intent(in) :: y @@ -1010,7 +1010,7 @@ function mul_self(x, y) result(binary) binary%val = x%val*y%val binary%d1Array(1:33) = x%d1Array(1:33)*y%val + x%val*y%d1Array(1:33) end function mul_self - + function mul_self_real(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1018,7 +1018,7 @@ function mul_self_real(x, y) result(unary) unary%val = x%val*y unary%d1Array(1:33) = x%d1Array(1:33)*y end function mul_self_real - + function mul_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1026,7 +1026,7 @@ function mul_real_self(z, x) result(unary) unary%val = x%val*z unary%d1Array(1:33) = x%d1Array(1:33)*z end function mul_real_self - + function mul_self_int(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x integer, intent(in) :: y @@ -1036,7 +1036,7 @@ function mul_self_int(x, y) result(unary) unary%val = x%val*y_dp unary%d1Array(1:33) = x%d1Array(1:33)*y_dp end function mul_self_int - + function mul_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1046,7 +1046,7 @@ function mul_int_self(z, x) result(unary) unary%val = x%val*y_dp unary%d1Array(1:33) = x%d1Array(1:33)*y_dp end function mul_int_self - + function div_self(x, y) result(binary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1), intent(in) :: y @@ -1054,7 +1054,7 @@ function div_self(x, y) result(binary) binary%val = x%val*powm1(y%val) binary%d1Array(1:33) = (x%d1Array(1:33)*y%val - x%val*y%d1Array(1:33))*powm1(pow2(y%val)) end function div_self - + function div_self_real(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1064,7 +1064,7 @@ function div_self_real(x, y) result(unary) unary%val = q0*x%val unary%d1Array(1:33) = q0*x%d1Array(1:33) end function div_self_real - + function div_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1072,7 +1072,7 @@ function div_real_self(z, x) result(unary) unary%val = z*powm1(x%val) unary%d1Array(1:33) = -x%d1Array(1:33)*z*powm1(pow2(x%val)) end function div_real_self - + function div_self_int(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x integer, intent(in) :: y @@ -1084,7 +1084,7 @@ function div_self_int(x, y) result(unary) unary%val = q0*x%val unary%d1Array(1:33) = q0*x%d1Array(1:33) end function div_self_int - + function div_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1094,7 +1094,7 @@ function div_int_self(z, x) result(unary) unary%val = y_dp*powm1(x%val) unary%d1Array(1:33) = -x%d1Array(1:33)*y_dp*powm1(pow2(x%val)) end function div_int_self - + function pow_self(x, y) result(binary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1), intent(in) :: y @@ -1102,7 +1102,7 @@ function pow_self(x, y) result(binary) binary%val = pow(x%val, y%val) binary%d1Array(1:33) = (x%d1Array(1:33)*y%val + x%val*y%d1Array(1:33)*log(x%val))*pow(x%val, y%val - 1) end function pow_self - + function pow_self_real(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1110,7 +1110,7 @@ function pow_self_real(x, y) result(unary) unary%val = pow(x%val, y) unary%d1Array(1:33) = x%d1Array(1:33)*y*pow(x%val, y - 1) end function pow_self_real - + function pow_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1120,7 +1120,7 @@ function pow_real_self(z, x) result(unary) unary%val = q0 unary%d1Array(1:33) = q0*x%d1Array(1:33)*log(z) end function pow_real_self - + function pow_self_int(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x integer, intent(in) :: y @@ -1130,7 +1130,7 @@ function pow_self_int(x, y) result(unary) unary%val = pow(x%val, y_dp) unary%d1Array(1:33) = x%d1Array(1:33)*y_dp*pow(x%val, y_dp - 1) end function pow_self_int - + function pow_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1142,7 +1142,7 @@ function pow_int_self(z, x) result(unary) unary%val = q0 unary%d1Array(1:33) = q0*x%d1Array(1:33)*log(y_dp) end function pow_int_self - + function max_self(x, y) result(binary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1), intent(in) :: y @@ -1150,7 +1150,7 @@ function max_self(x, y) result(binary) binary%val = Max(x%val, y%val) binary%d1Array(1:33) = x%d1Array(1:33)*Heaviside(x%val - y%val) + y%d1Array(1:33)*Heaviside(-x%val + y%val) end function max_self - + function max_self_real(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1158,7 +1158,7 @@ function max_self_real(x, y) result(unary) unary%val = Max(x%val, y) unary%d1Array(1:33) = x%d1Array(1:33)*Heaviside(x%val - y) end function max_self_real - + function max_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1166,7 +1166,7 @@ function max_real_self(z, x) result(unary) unary%val = Max(x%val, z) unary%d1Array(1:33) = x%d1Array(1:33)*Heaviside(x%val - z) end function max_real_self - + function max_self_int(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x integer, intent(in) :: y @@ -1176,7 +1176,7 @@ function max_self_int(x, y) result(unary) unary%val = Max(x%val, y_dp) unary%d1Array(1:33) = x%d1Array(1:33)*Heaviside(x%val - y_dp) end function max_self_int - + function max_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1186,7 +1186,7 @@ function max_int_self(z, x) result(unary) unary%val = Max(x%val, y_dp) unary%d1Array(1:33) = x%d1Array(1:33)*Heaviside(x%val - y_dp) end function max_int_self - + function min_self(x, y) result(binary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1), intent(in) :: y @@ -1194,7 +1194,7 @@ function min_self(x, y) result(binary) binary%val = Min(x%val, y%val) binary%d1Array(1:33) = x%d1Array(1:33)*Heaviside(-x%val + y%val) + y%d1Array(1:33)*Heaviside(x%val - y%val) end function min_self - + function min_self_real(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1202,7 +1202,7 @@ function min_self_real(x, y) result(unary) unary%val = Min(x%val, y) unary%d1Array(1:33) = x%d1Array(1:33)*Heaviside(-x%val + y) end function min_self_real - + function min_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1210,7 +1210,7 @@ function min_real_self(z, x) result(unary) unary%val = Min(x%val, z) unary%d1Array(1:33) = x%d1Array(1:33)*Heaviside(-x%val + z) end function min_real_self - + function min_self_int(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x integer, intent(in) :: y @@ -1220,7 +1220,7 @@ function min_self_int(x, y) result(unary) unary%val = Min(x%val, y_dp) unary%d1Array(1:33) = x%d1Array(1:33)*Heaviside(-x%val + y_dp) end function min_self_int - + function min_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1230,7 +1230,7 @@ function min_int_self(z, x) result(unary) unary%val = Min(x%val, y_dp) unary%d1Array(1:33) = x%d1Array(1:33)*Heaviside(-x%val + y_dp) end function min_int_self - + function dim_self(x, y) result(binary) type(auto_diff_real_star_order1), intent(in) :: x type(auto_diff_real_star_order1), intent(in) :: y @@ -1240,7 +1240,7 @@ function dim_self(x, y) result(binary) binary%val = -0.5_dp*y%val + 0.5_dp*x%val + 0.5_dp*Abs(q0) binary%d1Array(1:33) = -0.5_dp*y%d1Array(1:33) + 0.5_dp*x%d1Array(1:33) + 0.5_dp*(x%d1Array(1:33) - y%d1Array(1:33))*sgn(q0) end function dim_self - + function dim_self_real(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x real(dp), intent(in) :: y @@ -1250,7 +1250,7 @@ function dim_self_real(x, y) result(unary) unary%val = -0.5_dp*y + 0.5_dp*x%val + 0.5_dp*Abs(q0) unary%d1Array(1:33) = 0.5_dp*x%d1Array(1:33)*(sgn(q0) + 1) end function dim_self_real - + function dim_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1260,7 +1260,7 @@ function dim_real_self(z, x) result(unary) unary%val = -0.5_dp*x%val + 0.5_dp*z + 0.5_dp*Abs(q0) unary%d1Array(1:33) = 0.5_dp*x%d1Array(1:33)*(sgn(q0) - 1) end function dim_real_self - + function dim_self_int(x, y) result(unary) type(auto_diff_real_star_order1), intent(in) :: x integer, intent(in) :: y @@ -1272,7 +1272,7 @@ function dim_self_int(x, y) result(unary) unary%val = -0.5_dp*y_dp + 0.5_dp*x%val + 0.5_dp*Abs(q0) unary%d1Array(1:33) = 0.5_dp*x%d1Array(1:33)*(sgn(q0) + 1) end function dim_self_int - + function dim_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_star_order1), intent(in) :: x @@ -1284,5 +1284,5 @@ function dim_int_self(z, x) result(unary) unary%val = -0.5_dp*x%val + 0.5_dp*y_dp + 0.5_dp*Abs(q0) unary%d1Array(1:33) = 0.5_dp*x%d1Array(1:33)*(sgn(q0) - 1) end function dim_int_self - + end module auto_diff_real_star_order1_module diff --git a/auto_diff/private/auto_diff_real_tdc_module.f90 b/auto_diff/private/auto_diff_real_tdc_module.f90 index 39a11feae..5820737a8 100644 --- a/auto_diff/private/auto_diff_real_tdc_module.f90 +++ b/auto_diff/private/auto_diff_real_tdc_module.f90 @@ -3,7 +3,7 @@ module auto_diff_real_tdc_module use utils_lib use support_functions use math_lib - + implicit none private public :: auto_diff_real_tdc, & @@ -70,13 +70,13 @@ module auto_diff_real_tdc_module real(dp) :: d1Array(33) real(dp) :: d1val1_d1Array(33) end type auto_diff_real_tdc - + interface assignment(=) module procedure assign_from_self module procedure assign_from_real_dp module procedure assign_from_int end interface assignment(=) - + interface operator(.eq.) module procedure equal_self module procedure equal_auto_diff_real_tdc_real_dp @@ -84,7 +84,7 @@ module auto_diff_real_tdc_module module procedure equal_auto_diff_real_tdc_int module procedure equal_int_auto_diff_real_tdc end interface operator(.eq.) - + interface operator(.ne.) module procedure neq_self module procedure neq_auto_diff_real_tdc_real_dp @@ -92,7 +92,7 @@ module auto_diff_real_tdc_module module procedure neq_auto_diff_real_tdc_int module procedure neq_int_auto_diff_real_tdc end interface operator(.ne.) - + interface operator(.gt.) module procedure greater_self module procedure greater_auto_diff_real_tdc_real_dp @@ -100,7 +100,7 @@ module auto_diff_real_tdc_module module procedure greater_auto_diff_real_tdc_int module procedure greater_int_auto_diff_real_tdc end interface operator(.gt.) - + interface operator(.lt.) module procedure less_self module procedure less_auto_diff_real_tdc_real_dp @@ -108,7 +108,7 @@ module auto_diff_real_tdc_module module procedure less_auto_diff_real_tdc_int module procedure less_int_auto_diff_real_tdc end interface operator(.lt.) - + interface operator(.le.) module procedure leq_self module procedure leq_auto_diff_real_tdc_real_dp @@ -116,7 +116,7 @@ module auto_diff_real_tdc_module module procedure leq_auto_diff_real_tdc_int module procedure leq_int_auto_diff_real_tdc end interface operator(.le.) - + interface operator(.ge.) module procedure geq_self module procedure geq_auto_diff_real_tdc_real_dp @@ -124,175 +124,175 @@ module auto_diff_real_tdc_module module procedure geq_auto_diff_real_tdc_int module procedure geq_int_auto_diff_real_tdc end interface operator(.ge.) - + interface make_unop module procedure make_unary_operator end interface make_unop - + interface make_binop module procedure make_binary_operator end interface make_binop - + interface sign module procedure sign_self end interface sign - + interface safe_sqrt module procedure safe_sqrt_self end interface safe_sqrt - + interface operator(-) module procedure unary_minus_self end interface operator(-) - + interface exp module procedure exp_self end interface exp - + interface expm1 module procedure expm1_self end interface expm1 - + interface exp10 module procedure exp10_self end interface exp10 - + interface powm1 module procedure powm1_self end interface powm1 - + interface log module procedure log_self end interface log - + interface log1p module procedure log1p_self end interface log1p - + interface safe_log module procedure safe_log_self end interface safe_log - + interface log10 module procedure log10_self end interface log10 - + interface safe_log10 module procedure safe_log10_self end interface safe_log10 - + interface log2 module procedure log2_self end interface log2 - + interface sin module procedure sin_self end interface sin - + interface cos module procedure cos_self end interface cos - + interface tan module procedure tan_self end interface tan - + interface sinpi module procedure sinpi_self end interface sinpi - + interface cospi module procedure cospi_self end interface cospi - + interface tanpi module procedure tanpi_self end interface tanpi - + interface sinh module procedure sinh_self end interface sinh - + interface cosh module procedure cosh_self end interface cosh - + interface tanh module procedure tanh_self end interface tanh - + interface asin module procedure asin_self end interface asin - + interface acos module procedure acos_self end interface acos - + interface atan module procedure atan_self end interface atan - + interface asinpi module procedure asinpi_self end interface asinpi - + interface acospi module procedure acospi_self end interface acospi - + interface atanpi module procedure atanpi_self end interface atanpi - + interface asinh module procedure asinh_self end interface asinh - + interface acosh module procedure acosh_self end interface acosh - + interface atanh module procedure atanh_self end interface atanh - + interface sqrt module procedure sqrt_self end interface sqrt - + interface pow2 module procedure pow2_self end interface pow2 - + interface pow3 module procedure pow3_self end interface pow3 - + interface pow4 module procedure pow4_self end interface pow4 - + interface pow5 module procedure pow5_self end interface pow5 - + interface pow6 module procedure pow6_self end interface pow6 - + interface pow7 module procedure pow7_self end interface pow7 - + interface pow8 module procedure pow8_self end interface pow8 - + interface abs module procedure abs_self end interface abs - + interface operator(+) module procedure add_self module procedure add_self_real @@ -300,7 +300,7 @@ module auto_diff_real_tdc_module module procedure add_self_int module procedure add_int_self end interface operator(+) - + interface operator(-) module procedure sub_self module procedure sub_self_real @@ -308,7 +308,7 @@ module auto_diff_real_tdc_module module procedure sub_self_int module procedure sub_int_self end interface operator(-) - + interface operator(*) module procedure mul_self module procedure mul_self_real @@ -316,7 +316,7 @@ module auto_diff_real_tdc_module module procedure mul_self_int module procedure mul_int_self end interface operator(*) - + interface operator(/) module procedure div_self module procedure div_self_real @@ -324,7 +324,7 @@ module auto_diff_real_tdc_module module procedure div_self_int module procedure div_int_self end interface operator(/) - + interface pow module procedure pow_self module procedure pow_self_real @@ -332,7 +332,7 @@ module auto_diff_real_tdc_module module procedure pow_self_int module procedure pow_int_self end interface pow - + interface max module procedure max_self module procedure max_self_real @@ -340,7 +340,7 @@ module auto_diff_real_tdc_module module procedure max_self_int module procedure max_int_self end interface max - + interface min module procedure min_self module procedure min_self_real @@ -348,7 +348,7 @@ module auto_diff_real_tdc_module module procedure min_self_int module procedure min_int_self end interface min - + interface dim module procedure dim_self module procedure dim_self_real @@ -356,11 +356,11 @@ module auto_diff_real_tdc_module module procedure dim_self_int module procedure dim_int_self end interface dim - + interface differentiate_1 module procedure differentiate_auto_diff_real_tdc_1 end interface differentiate_1 - + contains subroutine assign_from_self(this, other) @@ -371,7 +371,7 @@ subroutine assign_from_self(this, other) this%d1Array = other%d1Array this%d1val1_d1Array = other%d1val1_d1Array end subroutine assign_from_self - + subroutine assign_from_real_dp(this, other) type(auto_diff_real_tdc), intent(out) :: this real(dp), intent(in) :: other @@ -380,7 +380,7 @@ subroutine assign_from_real_dp(this, other) this%d1Array = 0.0_dp this%d1val1_d1Array = 0.0_dp end subroutine assign_from_real_dp - + subroutine assign_from_int(this, other) type(auto_diff_real_tdc), intent(out) :: this integer, intent(in) :: other @@ -389,217 +389,217 @@ subroutine assign_from_int(this, other) this%d1Array = 0.0_dp this%d1val1_d1Array = 0.0_dp end subroutine assign_from_int - + function equal_self(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this%val .eq. other%val) end function equal_self - + function equal_auto_diff_real_tdc_real_dp(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_tdc_real_dp - + function equal_real_dp_auto_diff_real_tdc(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_real_dp_auto_diff_real_tdc - + function equal_auto_diff_real_tdc_int(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .eq. other) end function equal_auto_diff_real_tdc_int - + function equal_int_auto_diff_real_tdc(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this .eq. other%val) end function equal_int_auto_diff_real_tdc - + function neq_self(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this%val .ne. other%val) end function neq_self - + function neq_auto_diff_real_tdc_real_dp(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_tdc_real_dp - + function neq_real_dp_auto_diff_real_tdc(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_real_dp_auto_diff_real_tdc - + function neq_auto_diff_real_tdc_int(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ne. other) end function neq_auto_diff_real_tdc_int - + function neq_int_auto_diff_real_tdc(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this .ne. other%val) end function neq_int_auto_diff_real_tdc - + function greater_self(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this%val .gt. other%val) end function greater_self - + function greater_auto_diff_real_tdc_real_dp(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_tdc_real_dp - + function greater_real_dp_auto_diff_real_tdc(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_real_dp_auto_diff_real_tdc - + function greater_auto_diff_real_tdc_int(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .gt. other) end function greater_auto_diff_real_tdc_int - + function greater_int_auto_diff_real_tdc(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this .gt. other%val) end function greater_int_auto_diff_real_tdc - + function less_self(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this%val .lt. other%val) end function less_self - + function less_auto_diff_real_tdc_real_dp(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_tdc_real_dp - + function less_real_dp_auto_diff_real_tdc(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_real_dp_auto_diff_real_tdc - + function less_auto_diff_real_tdc_int(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .lt. other) end function less_auto_diff_real_tdc_int - + function less_int_auto_diff_real_tdc(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this .lt. other%val) end function less_int_auto_diff_real_tdc - + function leq_self(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this%val .le. other%val) end function leq_self - + function leq_auto_diff_real_tdc_real_dp(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_tdc_real_dp - + function leq_real_dp_auto_diff_real_tdc(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_real_dp_auto_diff_real_tdc - + function leq_auto_diff_real_tdc_int(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .le. other) end function leq_auto_diff_real_tdc_int - + function leq_int_auto_diff_real_tdc(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this .le. other%val) end function leq_int_auto_diff_real_tdc - + function geq_self(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this%val .ge. other%val) end function geq_self - + function geq_auto_diff_real_tdc_real_dp(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this real(dp), intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_tdc_real_dp - + function geq_real_dp_auto_diff_real_tdc(this, other) result(z) real(dp), intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_real_dp_auto_diff_real_tdc - + function geq_auto_diff_real_tdc_int(this, other) result(z) type(auto_diff_real_tdc), intent(in) :: this integer, intent(in) :: other logical :: z z = (this%val .ge. other) end function geq_auto_diff_real_tdc_int - + function geq_int_auto_diff_real_tdc(this, other) result(z) integer, intent(in) :: this type(auto_diff_real_tdc), intent(in) :: other logical :: z z = (this .ge. other%val) end function geq_int_auto_diff_real_tdc - + function make_unary_operator(x, z_val, z_d1x, z_d2x) result(unary) type(auto_diff_real_tdc), intent(in) :: x real(dp), intent(in) :: z_val @@ -611,7 +611,7 @@ function make_unary_operator(x, z_val, z_d1x, z_d2x) result(unary) unary%d1Array(1:33) = x%d1Array(1:33)*z_d1x unary%d1val1_d1Array(1:33) = x%d1Array(1:33)*x%d1val1*z_d2x + x%d1val1_d1Array(1:33)*z_d1x end function make_unary_operator - + function make_binary_operator(x, y, z_val, z_d1x, z_d1y, z_d2x, z_d1x_d1y, z_d2y) result(binary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc), intent(in) :: y @@ -627,7 +627,7 @@ function make_binary_operator(x, y, z_val, z_d1x, z_d1y, z_d2x, z_d1x_d1y, z_d2y binary%d1Array(1:33) = x%d1Array(1:33)*z_d1x + y%d1Array(1:33)*z_d1y binary%d1val1_d1Array(1:33) = x%d1Array(1:33)*x%d1val1*z_d2x + x%d1Array(1:33)*y%d1val1*z_d1x_d1y + x%d1val1*y%d1Array(1:33)*z_d1x_d1y + x%d1val1_d1Array(1:33)*z_d1x + y%d1Array(1:33)*y%d1val1*z_d2y + y%d1val1_d1Array(1:33)*z_d1y end function make_binary_operator - + function sign_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -636,7 +636,7 @@ function sign_self(x) result(unary) unary%d1Array(1:33) = 0.0_dp unary%d1val1_d1Array(1:33) = 0.0_dp end function sign_self - + function safe_sqrt_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -649,7 +649,7 @@ function safe_sqrt_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = 0.25_dp*q0*(2.0_dp*x%d1val1_d1Array(1:33)*x%val - x%d1Array(1:33)*x%d1val1)*powm1(pow2(x%val)) end function safe_sqrt_self - + function unary_minus_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -658,7 +658,7 @@ function unary_minus_self(x) result(unary) unary%d1Array(1:33) = -x%d1Array(1:33) unary%d1val1_d1Array(1:33) = -x%d1val1_d1Array(1:33) end function unary_minus_self - + function exp_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -669,7 +669,7 @@ function exp_self(x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*(x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)) end function exp_self - + function expm1_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -680,7 +680,7 @@ function expm1_self(x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*(x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)) end function expm1_self - + function exp10_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -695,7 +695,7 @@ function exp10_self(x) result(unary) unary%d1Array(1:33) = q2*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q2*(q1*x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)) end function exp10_self - + function powm1_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -706,7 +706,7 @@ function powm1_self(x) result(unary) unary%d1Array(1:33) = -q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = (2.0_dp*x%d1Array(1:33)*x%d1val1 - x%d1val1_d1Array(1:33)*x%val)*powm1(pow3(x%val)) end function powm1_self - + function log_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -717,7 +717,7 @@ function log_self(x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = (-x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)*x%val)*powm1(pow2(x%val)) end function log_self - + function log1p_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -730,7 +730,7 @@ function log1p_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = (q0*x%d1val1_d1Array(1:33) - x%d1Array(1:33)*x%d1val1)*powm1(pow2(q0)) end function log1p_self - + function safe_log_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -741,7 +741,7 @@ function safe_log_self(x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = (-x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)*x%val)*powm1(pow2(x%val)) end function safe_log_self - + function log10_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -754,7 +754,7 @@ function log10_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*(-x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)*x%val)*powm1(pow2(x%val)) end function log10_self - + function safe_log10_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -767,7 +767,7 @@ function safe_log10_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*(-x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)*x%val)*powm1(pow2(x%val)) end function safe_log10_self - + function log2_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -780,7 +780,7 @@ function log2_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*(-x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)*x%val)*powm1(pow2(x%val)) end function log2_self - + function sin_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -793,7 +793,7 @@ function sin_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = -q0*x%d1Array(1:33)*x%d1val1 + q1*x%d1val1_d1Array(1:33) end function sin_self - + function cos_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -806,7 +806,7 @@ function cos_self(x) result(unary) unary%d1Array(1:33) = -q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = -q0*x%d1Array(1:33)*x%d1val1 - q1*x%d1val1_d1Array(1:33) end function cos_self - + function tan_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -819,7 +819,7 @@ function tan_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = (2.0_dp*q0*x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33))*powm1(pow2(cos(x%val))) end function tan_self - + function sinpi_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -836,7 +836,7 @@ function sinpi_self(x) result(unary) unary%d1Array(1:33) = q3*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = pi*(-pi*q1*x%d1Array(1:33)*x%d1val1 + q2*x%d1val1_d1Array(1:33)) end function sinpi_self - + function cospi_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -853,7 +853,7 @@ function cospi_self(x) result(unary) unary%d1Array(1:33) = -q3*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = -pi*(pi*q1*x%d1Array(1:33)*x%d1val1 + q2*x%d1val1_d1Array(1:33)) end function cospi_self - + function tanpi_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -868,7 +868,7 @@ function tanpi_self(x) result(unary) unary%d1Array(1:33) = q2*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = pi*(2.0_dp*pi*q1*x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33))*powm1(pow2(cos(q0))) end function tanpi_self - + function sinh_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -881,7 +881,7 @@ function sinh_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1Array(1:33)*x%d1val1 + q1*x%d1val1_d1Array(1:33) end function sinh_self - + function cosh_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -894,7 +894,7 @@ function cosh_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1Array(1:33)*x%d1val1 + q1*x%d1val1_d1Array(1:33) end function cosh_self - + function tanh_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -907,7 +907,7 @@ function tanh_self(x) result(unary) unary%d1Array(1:33) = -q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = -(2.0_dp*q0*x%d1Array(1:33)*x%d1val1 - x%d1val1_d1Array(1:33))*powm1(pow2(cosh(x%val))) end function tanh_self - + function asin_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -920,7 +920,7 @@ function asin_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = (q0*x%d1val1_d1Array(1:33) + x%d1Array(1:33)*x%d1val1*x%val)*powm1(pow3(sqrt(q0))) end function asin_self - + function acos_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -935,7 +935,7 @@ function acos_self(x) result(unary) unary%d1Array(1:33) = -q2*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = -(x%d1Array(1:33)*x%d1val1*x%val - x%d1val1_d1Array(1:33)*(q0 - 1))*powm1(pow3(sqrt(q1))) end function acos_self - + function atan_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -948,7 +948,7 @@ function atan_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = (-2.0_dp*x%d1Array(1:33)*x%d1val1*x%val + q0*x%d1val1_d1Array(1:33))*powm1(pow2(q0)) end function atan_self - + function asinpi_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -963,7 +963,7 @@ function asinpi_self(x) result(unary) unary%d1Array(1:33) = q2*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*(q1*x%d1val1_d1Array(1:33) + x%d1Array(1:33)*x%d1val1*x%val)*powm1(pow3(sqrt(q1))) end function asinpi_self - + function acospi_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -980,7 +980,7 @@ function acospi_self(x) result(unary) unary%d1Array(1:33) = -q3*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = -q0*(x%d1Array(1:33)*x%d1val1*x%val - x%d1val1_d1Array(1:33)*(q1 - 1))*powm1(pow3(sqrt(q2))) end function acospi_self - + function atanpi_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -995,7 +995,7 @@ function atanpi_self(x) result(unary) unary%d1Array(1:33) = q2*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = (-2.0_dp*x%d1Array(1:33)*x%d1val1*x%val + q0*x%d1val1_d1Array(1:33) + x%d1val1_d1Array(1:33))*powm1(2.0_dp*q1 + pi*pow4(x%val) + pi) end function atanpi_self - + function asinh_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -1008,7 +1008,7 @@ function asinh_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = (q0*x%d1val1_d1Array(1:33) - x%d1Array(1:33)*x%d1val1*x%val)*powm1(pow3(sqrt(q0))) end function asinh_self - + function acosh_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -1021,7 +1021,7 @@ function acosh_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = (q0*x%d1val1_d1Array(1:33) - x%d1Array(1:33)*x%d1val1*x%val)*powm1(pow3(sqrt(q0))) end function acosh_self - + function atanh_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -1034,7 +1034,7 @@ function atanh_self(x) result(unary) unary%d1Array(1:33) = -q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = (2.0_dp*x%d1Array(1:33)*x%d1val1*x%val - q0*x%d1val1_d1Array(1:33))*powm1(pow2(q0)) end function atanh_self - + function sqrt_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -1047,7 +1047,7 @@ function sqrt_self(x) result(unary) unary%d1Array(1:33) = q1*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = 0.25_dp*(2.0_dp*x%d1val1_d1Array(1:33)*x%val - x%d1Array(1:33)*x%d1val1)*powm1(pow3(sqrt(x%val))) end function sqrt_self - + function pow2_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -1058,7 +1058,7 @@ function pow2_self(x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = 2.0_dp*x%d1Array(1:33)*x%d1val1 + q0*x%d1val1_d1Array(1:33) end function pow2_self - + function pow3_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -1069,7 +1069,7 @@ function pow3_self(x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = 3.0_dp*x%val*(2.0_dp*x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)*x%val) end function pow3_self - + function pow4_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -1080,7 +1080,7 @@ function pow4_self(x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = 4.0_dp*(3.0_dp*x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)*x%val)*pow2(x%val) end function pow4_self - + function pow5_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -1091,7 +1091,7 @@ function pow5_self(x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = 5.0_dp*(4.0_dp*x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)*x%val)*pow3(x%val) end function pow5_self - + function pow6_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -1102,7 +1102,7 @@ function pow6_self(x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = 6.0_dp*(5.0_dp*x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)*x%val)*pow4(x%val) end function pow6_self - + function pow7_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -1113,7 +1113,7 @@ function pow7_self(x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = 7.0_dp*(6.0_dp*x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)*x%val)*pow5(x%val) end function pow7_self - + function pow8_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -1124,7 +1124,7 @@ function pow8_self(x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = 8.0_dp*(7.0_dp*x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)*x%val)*pow6(x%val) end function pow8_self - + function abs_self(x) result(unary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc) :: unary @@ -1135,7 +1135,7 @@ function abs_self(x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) end function abs_self - + function add_self(x, y) result(binary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc), intent(in) :: y @@ -1145,7 +1145,7 @@ function add_self(x, y) result(binary) binary%d1Array(1:33) = x%d1Array(1:33) + y%d1Array(1:33) binary%d1val1_d1Array(1:33) = x%d1val1_d1Array(1:33) + y%d1val1_d1Array(1:33) end function add_self - + function add_self_real(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x real(dp), intent(in) :: y @@ -1155,7 +1155,7 @@ function add_self_real(x, y) result(unary) unary%d1Array(1:33) = x%d1Array(1:33) unary%d1val1_d1Array(1:33) = x%d1val1_d1Array(1:33) end function add_self_real - + function add_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1165,7 +1165,7 @@ function add_real_self(z, x) result(unary) unary%d1Array(1:33) = x%d1Array(1:33) unary%d1val1_d1Array(1:33) = x%d1val1_d1Array(1:33) end function add_real_self - + function add_self_int(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x integer, intent(in) :: y @@ -1177,7 +1177,7 @@ function add_self_int(x, y) result(unary) unary%d1Array(1:33) = x%d1Array(1:33) unary%d1val1_d1Array(1:33) = x%d1val1_d1Array(1:33) end function add_self_int - + function add_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1189,7 +1189,7 @@ function add_int_self(z, x) result(unary) unary%d1Array(1:33) = x%d1Array(1:33) unary%d1val1_d1Array(1:33) = x%d1val1_d1Array(1:33) end function add_int_self - + function sub_self(x, y) result(binary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc), intent(in) :: y @@ -1199,7 +1199,7 @@ function sub_self(x, y) result(binary) binary%d1Array(1:33) = x%d1Array(1:33) - y%d1Array(1:33) binary%d1val1_d1Array(1:33) = x%d1val1_d1Array(1:33) - y%d1val1_d1Array(1:33) end function sub_self - + function sub_self_real(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x real(dp), intent(in) :: y @@ -1209,7 +1209,7 @@ function sub_self_real(x, y) result(unary) unary%d1Array(1:33) = x%d1Array(1:33) unary%d1val1_d1Array(1:33) = x%d1val1_d1Array(1:33) end function sub_self_real - + function sub_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1219,7 +1219,7 @@ function sub_real_self(z, x) result(unary) unary%d1Array(1:33) = -x%d1Array(1:33) unary%d1val1_d1Array(1:33) = -x%d1val1_d1Array(1:33) end function sub_real_self - + function sub_self_int(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x integer, intent(in) :: y @@ -1231,7 +1231,7 @@ function sub_self_int(x, y) result(unary) unary%d1Array(1:33) = x%d1Array(1:33) unary%d1val1_d1Array(1:33) = x%d1val1_d1Array(1:33) end function sub_self_int - + function sub_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1243,7 +1243,7 @@ function sub_int_self(z, x) result(unary) unary%d1Array(1:33) = -x%d1Array(1:33) unary%d1val1_d1Array(1:33) = -x%d1val1_d1Array(1:33) end function sub_int_self - + function mul_self(x, y) result(binary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc), intent(in) :: y @@ -1253,7 +1253,7 @@ function mul_self(x, y) result(binary) binary%d1Array(1:33) = x%d1Array(1:33)*y%val + x%val*y%d1Array(1:33) binary%d1val1_d1Array(1:33) = x%d1Array(1:33)*y%d1val1 + x%d1val1*y%d1Array(1:33) + x%d1val1_d1Array(1:33)*y%val + x%val*y%d1val1_d1Array(1:33) end function mul_self - + function mul_self_real(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x real(dp), intent(in) :: y @@ -1263,7 +1263,7 @@ function mul_self_real(x, y) result(unary) unary%d1Array(1:33) = x%d1Array(1:33)*y unary%d1val1_d1Array(1:33) = x%d1val1_d1Array(1:33)*y end function mul_self_real - + function mul_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1273,7 +1273,7 @@ function mul_real_self(z, x) result(unary) unary%d1Array(1:33) = x%d1Array(1:33)*z unary%d1val1_d1Array(1:33) = x%d1val1_d1Array(1:33)*z end function mul_real_self - + function mul_self_int(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x integer, intent(in) :: y @@ -1285,7 +1285,7 @@ function mul_self_int(x, y) result(unary) unary%d1Array(1:33) = x%d1Array(1:33)*y_dp unary%d1val1_d1Array(1:33) = x%d1val1_d1Array(1:33)*y_dp end function mul_self_int - + function mul_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1297,7 +1297,7 @@ function mul_int_self(z, x) result(unary) unary%d1Array(1:33) = x%d1Array(1:33)*y_dp unary%d1val1_d1Array(1:33) = x%d1val1_d1Array(1:33)*y_dp end function mul_int_self - + function div_self(x, y) result(binary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc), intent(in) :: y @@ -1313,7 +1313,7 @@ function div_self(x, y) result(binary) binary%d1Array(1:33) = q1*(x%d1Array(1:33)*y%val - x%val*y%d1Array(1:33)) binary%d1val1_d1Array(1:33) = (2.0_dp*q2*y%d1Array(1:33) + q0*x%d1val1_d1Array(1:33) - y%val*(x%d1Array(1:33)*y%d1val1 + x%d1val1*y%d1Array(1:33) + x%val*y%d1val1_d1Array(1:33)))*powm1(pow3(y%val)) end function div_self - + function div_self_real(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x real(dp), intent(in) :: y @@ -1325,7 +1325,7 @@ function div_self_real(x, y) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) end function div_self_real - + function div_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1337,7 +1337,7 @@ function div_real_self(z, x) result(unary) unary%d1Array(1:33) = -q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = z*(2.0_dp*x%d1Array(1:33)*x%d1val1 - x%d1val1_d1Array(1:33)*x%val)*powm1(pow3(x%val)) end function div_real_self - + function div_self_int(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x integer, intent(in) :: y @@ -1351,7 +1351,7 @@ function div_self_int(x, y) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) end function div_self_int - + function div_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1365,7 +1365,7 @@ function div_int_self(z, x) result(unary) unary%d1Array(1:33) = -q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = y_dp*(2.0_dp*x%d1Array(1:33)*x%d1val1 - x%d1val1_d1Array(1:33)*x%val)*powm1(pow3(x%val)) end function div_int_self - + function pow_self(x, y) result(binary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc), intent(in) :: y @@ -1387,7 +1387,7 @@ function pow_self(x, y) result(binary) binary%d1Array(1:33) = q0*q5 binary%d1val1_d1Array(1:33) = (-q1*x%d1Array(1:33) + q2*y%d1val1_d1Array(1:33)*pow2(x%val) + q4*q5 + x%val*(x%d1Array(1:33)*y%d1val1 + x%d1val1*y%d1Array(1:33) + x%d1val1_d1Array(1:33)*y%val))*pow(x%val, 3.0_dp + y%val)*powm1(pow5(x%val)) end function pow_self - + function pow_self_real(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x real(dp), intent(in) :: y @@ -1401,7 +1401,7 @@ function pow_self_real(x, y) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = y*(q1*y - q1 + x%d1val1_d1Array(1:33)*x%val)*pow(x%val, -2.0_dp + y) end function pow_self_real - + function pow_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1417,7 +1417,7 @@ function pow_real_self(z, x) result(unary) unary%d1Array(1:33) = q2*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q2*(q1*x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)) end function pow_real_self - + function pow_self_int(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x integer, intent(in) :: y @@ -1433,7 +1433,7 @@ function pow_self_int(x, y) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = y_dp*(q1*y_dp - q1 + x%d1val1_d1Array(1:33)*x%val)*pow(x%val, -2.0_dp + y_dp) end function pow_self_int - + function pow_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1451,7 +1451,7 @@ function pow_int_self(z, x) result(unary) unary%d1Array(1:33) = q2*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q2*(q1*x%d1Array(1:33)*x%d1val1 + x%d1val1_d1Array(1:33)) end function pow_int_self - + function max_self(x, y) result(binary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc), intent(in) :: y @@ -1465,7 +1465,7 @@ function max_self(x, y) result(binary) binary%d1Array(1:33) = q0*x%d1Array(1:33) + q1*y%d1Array(1:33) binary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) + q1*y%d1val1_d1Array(1:33) end function max_self - + function max_self_real(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x real(dp), intent(in) :: y @@ -1477,7 +1477,7 @@ function max_self_real(x, y) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) end function max_self_real - + function max_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1489,7 +1489,7 @@ function max_real_self(z, x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) end function max_real_self - + function max_self_int(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x integer, intent(in) :: y @@ -1503,7 +1503,7 @@ function max_self_int(x, y) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) end function max_self_int - + function max_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1517,7 +1517,7 @@ function max_int_self(z, x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) end function max_int_self - + function min_self(x, y) result(binary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc), intent(in) :: y @@ -1531,7 +1531,7 @@ function min_self(x, y) result(binary) binary%d1Array(1:33) = q0*x%d1Array(1:33) + q1*y%d1Array(1:33) binary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) + q1*y%d1val1_d1Array(1:33) end function min_self - + function min_self_real(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x real(dp), intent(in) :: y @@ -1543,7 +1543,7 @@ function min_self_real(x, y) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) end function min_self_real - + function min_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1555,7 +1555,7 @@ function min_real_self(z, x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) end function min_real_self - + function min_self_int(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x integer, intent(in) :: y @@ -1569,7 +1569,7 @@ function min_self_int(x, y) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) end function min_self_int - + function min_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1583,7 +1583,7 @@ function min_int_self(z, x) result(unary) unary%d1Array(1:33) = q0*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q0*x%d1val1_d1Array(1:33) end function min_int_self - + function dim_self(x, y) result(binary) type(auto_diff_real_tdc), intent(in) :: x type(auto_diff_real_tdc), intent(in) :: y @@ -1597,7 +1597,7 @@ function dim_self(x, y) result(binary) binary%d1Array(1:33) = -0.5_dp*y%d1Array(1:33) + 0.5_dp*x%d1Array(1:33) + q1*(x%d1Array(1:33) - y%d1Array(1:33)) binary%d1val1_d1Array(1:33) = -0.5_dp*y%d1val1_d1Array(1:33) + 0.5_dp*x%d1val1_d1Array(1:33) + q1*(x%d1val1_d1Array(1:33) - y%d1val1_d1Array(1:33)) end function dim_self - + function dim_self_real(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x real(dp), intent(in) :: y @@ -1615,7 +1615,7 @@ function dim_self_real(x, y) result(unary) unary%d1Array(1:33) = q2*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q1*q3 + q3 end function dim_self_real - + function dim_real_self(z, x) result(unary) real(dp), intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1633,7 +1633,7 @@ function dim_real_self(z, x) result(unary) unary%d1Array(1:33) = q2*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q1*q3 - q3 end function dim_real_self - + function dim_self_int(x, y) result(unary) type(auto_diff_real_tdc), intent(in) :: x integer, intent(in) :: y @@ -1653,7 +1653,7 @@ function dim_self_int(x, y) result(unary) unary%d1Array(1:33) = q2*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q1*q3 + q3 end function dim_self_int - + function dim_int_self(z, x) result(unary) integer, intent(in) :: z type(auto_diff_real_tdc), intent(in) :: x @@ -1673,7 +1673,7 @@ function dim_int_self(z, x) result(unary) unary%d1Array(1:33) = q2*x%d1Array(1:33) unary%d1val1_d1Array(1:33) = q1*q3 - q3 end function dim_int_self - + function differentiate_auto_diff_real_tdc_1(this) result(derivative) type(auto_diff_real_tdc), intent(in) :: this type(auto_diff_real_tdc) :: derivative @@ -1682,5 +1682,5 @@ function differentiate_auto_diff_real_tdc_1(this) result(derivative) derivative%d1Array = this%d1val1_d1Array derivative%d1val1_d1Array = 0.0_dp end function differentiate_auto_diff_real_tdc_1 - + end module auto_diff_real_tdc_module diff --git a/auto_diff/private/support_functions.f90 b/auto_diff/private/support_functions.f90 index 55e78e626..ee74f3c03 100644 --- a/auto_diff/private/support_functions.f90 +++ b/auto_diff/private/support_functions.f90 @@ -12,7 +12,7 @@ module support_functions module procedure log_int end interface log - interface max + interface max module procedure max_int_real module procedure max_real_int end interface max diff --git a/auto_diff/test/src/test_auto_diff.f90 b/auto_diff/test/src/test_auto_diff.f90 index 88f9b7531..5e3b01ff2 100644 --- a/auto_diff/test/src/test_auto_diff.f90 +++ b/auto_diff/test/src/test_auto_diff.f90 @@ -58,11 +58,11 @@ subroutine do_test_auto_diff_star_order1() x = 3d0 x%d1Array(4) = 1d0 do i=1,15 - if (i /= 4) then + if (i /= 4) then call should_print0('', 0d0, x%d1Array(i)) else call should_print0('', 1d0, x%d1Array(i)) - end if + end if end do call header('Testing unary operators') diff --git a/binary/job/run_binary.f90 b/binary/job/run_binary.f90 index 9085b6270..72b91d640 100644 --- a/binary/job/run_binary.f90 +++ b/binary/job/run_binary.f90 @@ -1,18 +1,18 @@ - + module run_binary implicit none - + contains - + subroutine do_run_binary(tst) use binary_lib, only: run1_binary use run_star_extras use run_binary_extras - + logical, intent(in) :: tst - + integer :: ierr - + call run1_binary(tst, & ! star extras extras_controls, & @@ -23,4 +23,4 @@ subroutine do_run_binary(tst) end subroutine do_run_binary end module run_binary - + diff --git a/binary/other/mod_other_accreted_material_j.f90 b/binary/other/mod_other_accreted_material_j.f90 index 2d948b9d1..57198d8aa 100644 --- a/binary/other/mod_other_accreted_material_j.f90 +++ b/binary/other/mod_other_accreted_material_j.f90 @@ -22,18 +22,18 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_accreted_material_j - + ! NOTE: remember to set true: ! use_other_accreted_material_j = .true. - + ! you can add your own routine for use instead of the default ones ! here's how to do it. ! Before doing anything, let's make sure your working copy of run_binary_extras works. -! edit the extras_binary_controls routine +! edit the extras_binary_controls routine ! subroutine extras_binary_controls(binary_id, ierr) ! integer :: binary_id ! integer, intent(out) :: ierr @@ -76,9 +76,9 @@ module mod_other_accreted_material_j ! end if ! b% accretion_mode = 0 ! b% acc_am_div_kep_am = 0.0d0 -! +! ! end subroutine my_accreted_material_j - + ! NOTE: if you'd like to have some inlist controls for your routine, ! you can use the x_ctrl array of real(dp) variables that is in &controls ! e.g., in the &controls inlist, you can set @@ -96,22 +96,22 @@ module mod_other_accreted_material_j ! end if ! ! To get the binary pointer using the provided binary_id, add these lines. - ! + ! ! type (binary_info), pointer :: b ! call binary_ptr(binary_id, b, ierr) ! if (ierr /= 0) then ! failure in binary_ptr ! return ! end if - ! + ! ! for integer control values, you can use x_integer_ctrl ! for logical control values, you can use x_logical_ctrl implicit none - - + + contains - + subroutine null_other_accreted_material_j(binary_id, ierr) use binary_def, only : binary_info, binary_ptr use const_def, only: dp @@ -126,7 +126,7 @@ subroutine null_other_accreted_material_j(binary_id, ierr) end if b% accretion_mode = 0 b% acc_am_div_kep_am = 0.0d0 - + end subroutine null_other_accreted_material_j end module mod_other_accreted_material_j diff --git a/binary/other/mod_other_adjust_mdots.f90 b/binary/other/mod_other_adjust_mdots.f90 index ee8153625..9560b9a5e 100644 --- a/binary/other/mod_other_adjust_mdots.f90 +++ b/binary/other/mod_other_adjust_mdots.f90 @@ -22,18 +22,18 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_adjust_mdots ! NOTE: remember to set true: ! use_other_adjust_mdots = .true. - + ! you can add your own routine for use instead of the default ones ! here's how to do it. ! Before doing anything, let's make sure your working copy of run_binary_extras works. -! edit the extras_binary_controls routine +! edit the extras_binary_controls routine ! subroutine extras_binary_controls(binary_id, ierr) ! integer :: binary_id ! integer, intent(out) :: ierr @@ -75,7 +75,7 @@ module mod_other_adjust_mdots ! return ! end if ! end subroutine my_adjust_mdots - + ! NOTE: if you'd like to have some inlist controls for your routine, ! you can use the x_ctrl array of real(dp) variables that is in &controls ! e.g., in the &controls inlist, you can set @@ -93,22 +93,22 @@ module mod_other_adjust_mdots ! end if ! ! To get the binary pointer using the provided binary_id, add these lines. - ! + ! ! type (binary_info), pointer :: b ! call binary_ptr(binary_id, b, ierr) ! if (ierr /= 0) then ! failure in binary_ptr ! return ! end if - ! + ! ! for integer control values, you can use x_integer_ctrl ! for logical control values, you can use x_logical_ctrl implicit none - - + + contains - + subroutine null_other_adjust_mdots(binary_id, ierr) use binary_def, only : binary_info, binary_ptr use const_def, only: dp diff --git a/binary/other/mod_other_binary_ce.f90 b/binary/other/mod_other_binary_ce.f90 index f26a04a35..36b6b5175 100644 --- a/binary/other/mod_other_binary_ce.f90 +++ b/binary/other/mod_other_binary_ce.f90 @@ -22,18 +22,18 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_binary_ce ! NOTE: remember to set true: ! use_other_CE_rlo_mdot = .true. - + ! you can add your own routine for use instead of the default ones ! here's how to do it. ! Before doing anything, let's make sure your working copy of run_binary_extras works. -! edit the extras_binary_controls routine +! edit the extras_binary_controls routine ! subroutine extras_binary_controls(binary_id, ierr) ! integer :: binary_id ! integer, intent(out) :: ierr @@ -75,9 +75,9 @@ module mod_other_binary_ce ! write(*,*) 'failed in binary_ptr' ! return ! end if -! rlo_mdot = 0d0 +! rlo_mdot = 0d0 ! end subroutine my_ce_rlo_mdot - + ! NOTE: if you'd like to have some inlist controls for your routine, ! you can use the x_ctrl array of real(dp) variables that is in &controls ! e.g., in the &controls inlist, you can set @@ -95,22 +95,22 @@ module mod_other_binary_ce ! end if ! ! To get the binary pointer using the provided binary_id, add these lines. - ! + ! ! type (binary_info), pointer :: b ! call binary_ptr(binary_id, b, ierr) ! if (ierr /= 0) then ! failure in binary_ptr ! return ! end if - ! + ! ! for integer control values, you can use x_integer_ctrl ! for logical control values, you can use x_logical_ctrl implicit none - - + + contains - + subroutine null_other_CE_init(binary_id, restart, ierr) use const_def, only: dp use star_def @@ -127,7 +127,7 @@ subroutine null_other_CE_init(binary_id, restart, ierr) return end if end subroutine null_other_CE_init - + subroutine null_other_CE_rlo_mdot(binary_id, mdot, ierr) use const_def, only: dp use star_def @@ -143,9 +143,9 @@ subroutine null_other_CE_rlo_mdot(binary_id, mdot, ierr) write(*,*) 'failed in binary_ptr' return end if - mdot = -1d-99 + mdot = -1d-99 end subroutine null_other_CE_rlo_mdot - + integer function null_other_CE_binary_evolve_step(binary_id) use const_def, only: dp use star_def diff --git a/binary/other/mod_other_binary_edot.f90 b/binary/other/mod_other_binary_edot.f90 index 596b64dbb..db96ca12f 100644 --- a/binary/other/mod_other_binary_edot.f90 +++ b/binary/other/mod_other_binary_edot.f90 @@ -22,14 +22,14 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_binary_edot ! NOTE: remember to set one of: ! use_other_edot_tidal = .true. ! use_other_edot_enhance = .true. ! use_other_extra_edot = .true. - + ! you can add your own routine to add an extra edot. ! to override the entire edot calculation, turn off other contributions ! by setting do_tidal_circ = .false. and use_eccentricity_enhancement = .false. @@ -37,7 +37,7 @@ module mod_other_binary_edot ! here's how to do it. ! Before doing anything, let's make sure your working copy of run_binary_extras works. -! edit the extras_binary_controls routine +! edit the extras_binary_controls routine ! subroutine extras_binary_controls(binary_id, ierr) ! integer :: binary_id ! integer, intent(out) :: ierr @@ -77,9 +77,9 @@ module mod_other_binary_edot ! write(*,*) 'failed in binary_ptr' ! return ! end if -! b% edot_tidal = 0d0 +! b% edot_tidal = 0d0 ! end subroutine my_edot_tidal - + ! NOTE: if you'd like to have some inlist controls for your routine, ! you can use the x_ctrl array of real(dp) variables that is in &controls ! e.g., in the &controls inlist, you can set @@ -97,22 +97,22 @@ module mod_other_binary_edot ! end if ! ! To get the binary pointer using the provided binary_id, add these lines. - ! + ! ! type (binary_info), pointer :: b ! call binary_ptr(binary_id, b, ierr) ! if (ierr /= 0) then ! failure in binary_ptr ! return ! end if - ! + ! ! for integer control values, you can use x_integer_ctrl ! for logical control values, you can use x_logical_ctrl implicit none - - + + contains - + subroutine null_other_edot_tidal(binary_id, ierr) use const_def, only: dp use binary_def, only : binary_info, binary_ptr @@ -125,9 +125,9 @@ subroutine null_other_edot_tidal(binary_id, ierr) write(*,*) 'failed in binary_ptr' return end if - b% edot_tidal = 0d0 + b% edot_tidal = 0d0 end subroutine null_other_edot_tidal - + subroutine null_other_edot_enhance(binary_id, ierr) use binary_def, only : binary_info, binary_ptr integer, intent(in) :: binary_id @@ -139,9 +139,9 @@ subroutine null_other_edot_enhance(binary_id, ierr) write(*,*) 'failed in binary_ptr' return end if - b% edot_enhance = 0d0 + b% edot_enhance = 0d0 end subroutine null_other_edot_enhance - + subroutine null_other_extra_edot(binary_id, ierr) use binary_def, only : binary_info, binary_ptr integer, intent(in) :: binary_id @@ -153,7 +153,7 @@ subroutine null_other_extra_edot(binary_id, ierr) write(*,*) 'failed in binary_ptr' return end if - b% extra_edot = 0d0 + b% extra_edot = 0d0 end subroutine null_other_extra_edot end module mod_other_binary_edot diff --git a/binary/other/mod_other_binary_extras.f90 b/binary/other/mod_other_binary_extras.f90 index 0b794f2c4..72850d648 100644 --- a/binary/other/mod_other_binary_extras.f90 +++ b/binary/other/mod_other_binary_extras.f90 @@ -22,17 +22,17 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_binary_extras - - + + implicit none - + private warn_run_star_extras public - + contains - + integer function null_extras_binary_startup(binary_id,restart,ierr) use binary_def, only : binary_info, binary_ptr use star_def, only : keep_going @@ -47,9 +47,9 @@ integer function null_extras_binary_startup(binary_id,restart,ierr) if (ierr /= 0) then ! failure in binary_ptr return end if - + end function null_extras_binary_startup - + integer function null_extras_binary_start_step(binary_id,ierr) use binary_def, only : binary_info, binary_ptr use star_def, only : keep_going @@ -63,9 +63,9 @@ integer function null_extras_binary_start_step(binary_id,ierr) if (ierr /= 0) then ! failure in binary_ptr return end if - + end function null_extras_binary_start_step - + !Return either keep_going, retry or terminate integer function null_extras_binary_check_model(binary_id) use binary_def, only : binary_info, binary_ptr @@ -77,12 +77,12 @@ integer function null_extras_binary_check_model(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if null_extras_binary_check_model = keep_going - + end function null_extras_binary_check_model - - + + ! returns either keep_going or terminate. ! note: cannot request retry; extras_binary_check_model can do that. integer function null_extras_binary_finish_step(binary_id) @@ -95,13 +95,13 @@ integer function null_extras_binary_finish_step(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if null_extras_binary_finish_step = keep_going end function null_extras_binary_finish_step - - - + + + subroutine null_extras_binary_after_evolve(binary_id, ierr) use binary_def, only : binary_info, binary_ptr use const_def @@ -111,10 +111,10 @@ subroutine null_extras_binary_after_evolve(binary_id, ierr) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if - + end if + end subroutine null_extras_binary_after_evolve - + integer function null_how_many_extra_binary_history_columns(binary_id) use binary_def, only : binary_info, binary_ptr use const_def @@ -124,13 +124,13 @@ integer function null_how_many_extra_binary_history_columns(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if null_how_many_extra_binary_history_columns=0 - - call warn_run_star_extras(b% warn_binary_extra) - + + call warn_run_star_extras(b% warn_binary_extra) + end function null_how_many_extra_binary_history_columns - + subroutine null_data_for_extra_binary_history_columns(binary_id, n, extra_names, vals, ierr) use binary_def, only : binary_info, binary_ptr, maxlen_binary_history_column_name use const_def @@ -143,13 +143,13 @@ subroutine null_data_for_extra_binary_history_columns(binary_id, n, extra_names, call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if - + end if + call warn_run_star_extras(b% warn_binary_extra) - - end subroutine null_data_for_extra_binary_history_columns - - + + end subroutine null_data_for_extra_binary_history_columns + + integer function null_how_many_extra_binary_history_header_items(binary_id) use const_def integer, intent(in) :: binary_id @@ -172,11 +172,11 @@ subroutine null_data_for_extra_binary_history_header_items( & return end if end subroutine null_data_for_extra_binary_history_header_items - - + + subroutine warn_run_star_extras(warn) logical, intent(in) :: warn - + if(warn) then write(*,*) "WARNING: run_binary_extras has changed" write(*,*) "and you are calling a null version of this routine" @@ -187,9 +187,9 @@ subroutine warn_run_star_extras(warn) write(*,*) "MESA exited due to run_binary_extras warning." stop end if - + end subroutine warn_run_star_extras - - + + end module mod_other_binary_extras - + diff --git a/binary/other/mod_other_binary_jdot.f90 b/binary/other/mod_other_binary_jdot.f90 index c3996d1e0..7a42152fc 100644 --- a/binary/other/mod_other_binary_jdot.f90 +++ b/binary/other/mod_other_binary_jdot.f90 @@ -22,7 +22,7 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_binary_jdot ! NOTE: remember to set one of: @@ -30,14 +30,14 @@ module mod_other_binary_jdot ! use_other_jdot_gr = .true. ! use_other_jdot_ml = .true. ! use_other_extra_jdot = .true. - - + + ! you can add your own routine for use instead of the default ones ! here's how to do it. ! Before doing anything, let's make sure your working copy of run_binary_extras works. -! edit the extras_binary_controls routine +! edit the extras_binary_controls routine ! subroutine extras_binary_controls(binary_id, ierr) ! integer :: binary_id ! integer, intent(out) :: ierr @@ -80,7 +80,7 @@ module mod_other_binary_jdot ! ! here is an (unrealistic) example ! b% jdot_mb = 1 ! end subroutine jdot_mb_routine - + ! NOTE: if you'd like to have some inlist controls for your routine, ! you can use the x_ctrl array of real(dp) variables that is in &controls ! e.g., in the &controls inlist, you can set @@ -95,16 +95,16 @@ module mod_other_binary_jdot ! if (ierr /= 0) then ! OOPS ! return ! end if - ! + ! ! for integer control values, you can use x_integer_ctrl ! for logical control values, you can use x_logical_ctrl implicit none - - + + contains - + subroutine null_other_jdot_mb(binary_id, ierr) use binary_def, only : binary_info, binary_ptr integer, intent(in) :: binary_id @@ -116,7 +116,7 @@ subroutine null_other_jdot_mb(binary_id, ierr) write(*,*) 'failed in binary_ptr' return end if - b% jdot_mb = 0 + b% jdot_mb = 0 end subroutine null_other_jdot_mb subroutine null_other_jdot_gr(binary_id, ierr) @@ -130,7 +130,7 @@ subroutine null_other_jdot_gr(binary_id, ierr) write(*,*) 'failed in binary_ptr' return end if - b% jdot_gr = 0 + b% jdot_gr = 0 end subroutine null_other_jdot_gr subroutine null_other_jdot_ml(binary_id, ierr) @@ -144,7 +144,7 @@ subroutine null_other_jdot_ml(binary_id, ierr) write(*,*) 'failed in binary_ptr' return end if - b% jdot_ml = 0 + b% jdot_ml = 0 end subroutine null_other_jdot_ml subroutine null_other_extra_jdot(binary_id, ierr) @@ -158,7 +158,7 @@ subroutine null_other_extra_jdot(binary_id, ierr) write(*,*) 'failed in binary_ptr' return end if - b% extra_jdot = 0 + b% extra_jdot = 0 end subroutine null_other_extra_jdot subroutine null_other_jdot_ls(binary_id, ierr) @@ -172,7 +172,7 @@ subroutine null_other_jdot_ls(binary_id, ierr) write(*,*) 'failed in binary_ptr' return end if - b% jdot_ls = 0 + b% jdot_ls = 0 end subroutine null_other_jdot_ls subroutine null_other_jdot_missing_wind(binary_id, ierr) @@ -186,7 +186,7 @@ subroutine null_other_jdot_missing_wind(binary_id, ierr) write(*,*) 'failed in binary_ptr' return end if - b% jdot_missing_wind = 0 + b% jdot_missing_wind = 0 end subroutine null_other_jdot_missing_wind diff --git a/binary/other/mod_other_binary_wind_transfer.f90 b/binary/other/mod_other_binary_wind_transfer.f90 index 385f4eb6c..cc4c750ee 100644 --- a/binary/other/mod_other_binary_wind_transfer.f90 +++ b/binary/other/mod_other_binary_wind_transfer.f90 @@ -22,18 +22,18 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_binary_wind_transfer ! NOTE: remember to set true: ! use_other_binary_wind_transfer = .true. - + ! you can add your own routine for use instead of the default ones ! here's how to do it. ! Before doing anything, let's make sure your working copy of run_binary_extras works. -! edit the extras_binary_controls routine +! edit the extras_binary_controls routine ! subroutine extras_binary_controls(binary_id, ierr) ! integer :: binary_id ! integer, intent(out) :: ierr @@ -94,24 +94,24 @@ module mod_other_binary_wind_transfer ! write(*,*) 'failed in binary_ptr' ! return ! end if -! +! ! ! Dust radius based on Hofner 2007, ASPC, 378, 145 ! r_dust = 0.5d0 * b% r(s_i) * (b% s_donor % Teff / 1500d0)**2.5d0 ! x = r_dust / b% rl(s_i) -! +! ! ! constants from Abate et al. eq. 5 ! q2 = ( b% m(3-s_i)/b% m(s_i) )**2d0 ! c1 = -0.284d0 ! c2 = 0.918d0 ! c3 = -0.234d0 -! +! ! ! WRLOF transfer fraction from Abate et al. eq. 9 ! b% wind_xfer_fraction(s_i) = 25d0 / 9d0 * q2 * (c1*x**2 + c2*x + c3) -! +! ! b% wind_xfer_fraction(s_i) = min(b% wind_xfer_fraction(s_i), 5d-1) -! +! ! end subroutine WRLOF_wind_transfer - + ! NOTE: if you'd like to have some inlist controls for your routine, ! you can use the x_ctrl array of real(dp) variables that is in &controls ! e.g., in the &controls inlist, you can set @@ -129,22 +129,22 @@ module mod_other_binary_wind_transfer ! end if ! ! To get the binary pointer using the provided binary_id, add these lines. - ! + ! ! type (binary_info), pointer :: b ! call binary_ptr(binary_id, b, ierr) ! if (ierr /= 0) then ! failure in binary_ptr ! return ! end if - ! + ! ! for integer control values, you can use x_integer_ctrl ! for logical control values, you can use x_logical_ctrl implicit none - - + + contains - + subroutine null_other_binary_wind_transfer(binary_id, s_i, ierr) use binary_def, only : binary_info, binary_ptr integer, intent(in) :: binary_id, s_i @@ -156,7 +156,7 @@ subroutine null_other_binary_wind_transfer(binary_id, s_i, ierr) write(*,*) 'failed in binary_ptr' return end if - b% wind_xfer_fraction(s_i) = 0 + b% wind_xfer_fraction(s_i) = 0 end subroutine null_other_binary_wind_transfer end module mod_other_binary_wind_transfer diff --git a/binary/other/mod_other_e2.f90 b/binary/other/mod_other_e2.f90 index 8b7dbc331..beafa9f4f 100644 --- a/binary/other/mod_other_e2.f90 +++ b/binary/other/mod_other_e2.f90 @@ -22,17 +22,17 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_e2 ! NOTE: remember to set true: ! use_other_e2 = .true. - + implicit none - - + + contains - + subroutine null_other_e2(id, e2, ierr) use binary_def, only : binary_info, binary_ptr use star_def, only : star_info, star_ptr @@ -42,7 +42,7 @@ subroutine null_other_e2(id, e2, ierr) integer, intent(out) :: ierr type (binary_info), pointer :: b type (star_info), pointer :: s - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) then diff --git a/binary/other/mod_other_implicit_rlo.f90 b/binary/other/mod_other_implicit_rlo.f90 index 271488849..ecd77193f 100644 --- a/binary/other/mod_other_implicit_rlo.f90 +++ b/binary/other/mod_other_implicit_rlo.f90 @@ -22,19 +22,19 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_implicit_rlo ! NOTE: remember to set one of these to true: ! use_other_check_implicit_rlo_mdot = .true. ! use_other_implicit_function_to_solve = .true. - + ! you can add your own routine for use instead of the default ones ! here's how to do it. ! Before doing anything, let's make sure your working copy of run_binary_extras works. -! edit the extras_binary_controls routine +! edit the extras_binary_controls routine ! subroutine extras_binary_controls(binary_id, ierr) ! integer :: binary_id ! integer, intent(out) :: ierr @@ -80,7 +80,7 @@ module mod_other_implicit_rlo ! function_to_solve = 0d0 ! use_sum = .false. ! end subroutine my_implicit_function_to_solve - + ! NOTE: if you'd like to have some inlist controls for your routine, ! you can use the x_ctrl array of real(dp) variables that is in &controls ! e.g., in the &controls inlist, you can set @@ -98,23 +98,23 @@ module mod_other_implicit_rlo ! end if ! ! To get the binary pointer using the provided binary_id, add these lines. - ! + ! ! type (binary_info), pointer :: b ! call binary_ptr(binary_id, b, ierr) ! if (ierr /= 0) then ! failure in binary_ptr ! return ! end if - ! + ! ! for integer control values, you can use x_integer_ctrl ! for logical control values, you can use x_logical_ctrl use const_def implicit none - - + + contains - + integer function null_other_check_implicit_rlo(binary_id, new_mdot) use binary_def, only : binary_info, binary_ptr use const_def, only: dp @@ -133,7 +133,7 @@ integer function null_other_check_implicit_rlo(binary_id, new_mdot) null_other_check_implicit_rlo = keep_going write(*,*) "WARNING: using null_other_check_implicit_rlo" end function null_other_check_implicit_rlo - + subroutine null_other_implicit_function_to_solve(binary_id, & function_to_solve, use_sum, detached, ierr) use binary_def, only : binary_info, binary_ptr diff --git a/binary/other/mod_other_mdot_edd.f90 b/binary/other/mod_other_mdot_edd.f90 index 66945761e..735def5e6 100644 --- a/binary/other/mod_other_mdot_edd.f90 +++ b/binary/other/mod_other_mdot_edd.f90 @@ -22,18 +22,18 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_mdot_edd ! NOTE: remember to set true: ! use_other_mdot_edd = .true. - + ! you can add your own routine for use instead of the default ones ! here's how to do it. ! Before doing anything, let's make sure your working copy of run_binary_extras works. -! edit the extras_binary_controls routine +! edit the extras_binary_controls routine ! subroutine extras_binary_controls(binary_id, ierr) ! integer :: binary_id ! integer, intent(out) :: ierr @@ -76,10 +76,10 @@ module mod_other_mdot_edd ! write(*,*) 'failed in binary_ptr' ! return ! end if -! mdot_edd = 0d0 -! mdot_edd_eta = 0d0 +! mdot_edd = 0d0 +! mdot_edd_eta = 0d0 ! end subroutine my_mdot_edd - + ! NOTE: if you'd like to have some inlist controls for your routine, ! you can use the x_ctrl array of real(dp) variables that is in &controls ! e.g., in the &controls inlist, you can set @@ -97,22 +97,22 @@ module mod_other_mdot_edd ! end if ! ! To get the binary pointer using the provided binary_id, add these lines. - ! + ! ! type (binary_info), pointer :: b ! call binary_ptr(binary_id, b, ierr) ! if (ierr /= 0) then ! failure in binary_ptr ! return ! end if - ! + ! ! for integer control values, you can use x_integer_ctrl ! for logical control values, you can use x_logical_ctrl implicit none - - + + contains - + subroutine null_other_mdot_edd(binary_id, mdot_edd, mdot_edd_eta, ierr) use binary_def, only : binary_info, binary_ptr use const_def, only: dp @@ -127,8 +127,8 @@ subroutine null_other_mdot_edd(binary_id, mdot_edd, mdot_edd_eta, ierr) write(*,*) 'failed in binary_ptr' return end if - mdot_edd = 0d0 - mdot_edd_eta = 0d0 + mdot_edd = 0d0 + mdot_edd_eta = 0d0 end subroutine null_other_mdot_edd end module mod_other_mdot_edd diff --git a/binary/other/mod_other_pgbinary_plots.f90 b/binary/other/mod_other_pgbinary_plots.f90 index 2f4e577ce..b3fc3da83 100644 --- a/binary/other/mod_other_pgbinary_plots.f90 +++ b/binary/other/mod_other_pgbinary_plots.f90 @@ -48,7 +48,7 @@ end subroutine null_other_pgbinary_plots_info end module mod_other_pgbinary_plots - - - - + + + + diff --git a/binary/other/mod_other_rlo_mdot.f90 b/binary/other/mod_other_rlo_mdot.f90 index 33a6cbb21..df04786c1 100644 --- a/binary/other/mod_other_rlo_mdot.f90 +++ b/binary/other/mod_other_rlo_mdot.f90 @@ -22,18 +22,18 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_rlo_mdot ! NOTE: remember to set true: ! use_other_rlo_mdot = .true. - + ! you can add your own routine for use instead of the default ones ! here's how to do it. ! Before doing anything, let's make sure your working copy of run_binary_extras works. -! edit the extras_binary_controls routine +! edit the extras_binary_controls routine ! subroutine extras_binary_controls(binary_id, ierr) ! integer :: binary_id ! integer, intent(out) :: ierr @@ -75,9 +75,9 @@ module mod_other_rlo_mdot ! write(*,*) 'failed in binary_ptr' ! return ! end if -! rlo_mdot = 0d0 +! rlo_mdot = 0d0 ! end subroutine my_rlo_mdot - + ! NOTE: if you'd like to have some inlist controls for your routine, ! you can use the x_ctrl array of real(dp) variables that is in &controls ! e.g., in the &controls inlist, you can set @@ -95,22 +95,22 @@ module mod_other_rlo_mdot ! end if ! ! To get the binary pointer using the provided binary_id, add these lines. - ! + ! ! type (binary_info), pointer :: b ! call binary_ptr(binary_id, b, ierr) ! if (ierr /= 0) then ! failure in binary_ptr ! return ! end if - ! + ! ! for integer control values, you can use x_integer_ctrl ! for logical control values, you can use x_logical_ctrl implicit none - - + + contains - + subroutine null_other_rlo_mdot(binary_id, mdot, ierr) use binary_def, only : binary_info, binary_ptr use const_def, only: dp diff --git a/binary/other/mod_other_sync_spin_to_orbit.f90 b/binary/other/mod_other_sync_spin_to_orbit.f90 index a22153e44..3ccdbe385 100644 --- a/binary/other/mod_other_sync_spin_to_orbit.f90 +++ b/binary/other/mod_other_sync_spin_to_orbit.f90 @@ -22,18 +22,18 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_sync_spin_to_orbit ! NOTE: remember to set true: ! use_other_sync_spin_to_orbit = .true. - + ! you can add your own routine for use instead of the default ones ! here's how to do it. ! Before doing anything, let's make sure your working copy of run_binary_extras works. -! edit the extras_binary_controls routine +! edit the extras_binary_controls routine ! subroutine extras_binary_controls(binary_id, ierr) ! integer :: binary_id ! integer, intent(out) :: ierr @@ -71,12 +71,12 @@ module mod_other_sync_spin_to_orbit ! real(dp), intent(in) :: qratio ! mass_other_star/mass_this_star ! real(dp), intent(in) :: rl ! roche lobe radius (cm) ! real(dp), intent(in) :: dt_next ! next timestep -! real(dp), intent(in) :: Ftid ! efficiency of tidal synchronization. (time scale / Ftid ). -! +! real(dp), intent(in) :: Ftid ! efficiency of tidal synchronization. (time scale / Ftid ). +! ! character (len=strlen), intent(in) :: sync_type ! synchronization timescale ! character (len=strlen), intent(in) :: sync_mode ! where to put/take angular momentum ! integer, intent(out) :: ierr -! +! ! type (star_info), pointer :: s ! integer :: k ! @@ -90,7 +90,7 @@ module mod_other_sync_spin_to_orbit ! s% extra_jdot(k) = s% extra_jdot(k) - 0d0 ! include the tidal torque here ! end do ! end subroutine null_other_sync_spin_to_orbit - + ! NOTE: if you'd like to have some inlist controls for your routine, ! you can use the x_ctrl array of real(dp) variables that is in &controls ! e.g., in the &controls inlist, you can set @@ -108,20 +108,20 @@ module mod_other_sync_spin_to_orbit ! end if ! ! To get the binary pointer using the provided binary_id, add these lines. - ! + ! ! type (binary_info), pointer :: b ! call binary_ptr(binary_id, b, ierr) ! if (ierr /= 0) then ! failure in binary_ptr ! return ! end if - ! + ! ! for integer control values, you can use x_integer_ctrl ! for logical control values, you can use x_logical_ctrl implicit none - - + + contains subroutine null_other_sync_spin_to_orbit(id, nz, osep, qratio, rl, dt_next, Ftid, sync_type, sync_mode, ierr) @@ -134,12 +134,12 @@ subroutine null_other_sync_spin_to_orbit(id, nz, osep, qratio, rl, dt_next, Ftid real(dp), intent(in) :: qratio ! mass_other_star/mass_this_star real(dp), intent(in) :: rl ! roche lobe radius (cm) real(dp), intent(in) :: dt_next ! next timestep - real(dp), intent(in) :: Ftid ! efficiency of tidal synchronization. (time scale / Ftid ). - + real(dp), intent(in) :: Ftid ! efficiency of tidal synchronization. (time scale / Ftid ). + character (len=strlen), intent(in) :: sync_type ! synchronization timescale character (len=strlen), intent(in) :: sync_mode ! where to put/take angular momentum integer, intent(out) :: ierr - + type (star_info), pointer :: s integer :: k diff --git a/binary/other/mod_other_tsync.f90 b/binary/other/mod_other_tsync.f90 index fea064e03..e147d6574 100644 --- a/binary/other/mod_other_tsync.f90 +++ b/binary/other/mod_other_tsync.f90 @@ -22,18 +22,18 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module mod_other_tsync ! NOTE: remember to set true: ! use_other_tsync = .true. - + ! you can add your own routine for use instead of the default ones ! here's how to do it. ! Before doing anything, let's make sure your working copy of run_binary_extras works. -! edit the extras_binary_controls routine +! edit the extras_binary_controls routine ! subroutine extras_binary_controls(binary_id, ierr) ! integer :: binary_id ! integer, intent(out) :: ierr @@ -66,7 +66,7 @@ module mod_other_tsync ! subroutine my_tsync(id, sync_type, Ftid, qratio, m, r_phot, osep, t_sync, ierr) ! integer, intent(in) :: id ! character (len=strlen), intent(in) :: sync_type ! synchronization timescale -! real(dp), intent(in) :: Ftid ! efficiency of tidal synchronization. (time scale / Ftid ). +! real(dp), intent(in) :: Ftid ! efficiency of tidal synchronization. (time scale / Ftid ). ! real(dp), intent(in) :: qratio ! mass_other_star/mass_this_star ! real(dp), intent(in) :: m ! real(dp), intent(in) :: r_phot @@ -76,7 +76,7 @@ module mod_other_tsync ! real(dp) :: rGyr_squared, moment_of_inertia ! type (binary_info), pointer :: b ! type (star_info), pointer :: s -! +! ! ierr = 0 ! call star_ptr(id, s, ierr) ! if (ierr /= 0) then @@ -91,7 +91,7 @@ module mod_other_tsync ! end if ! t_sync = 1d99 ! end subroutine my_tsync - + ! NOTE: if you'd like to have some inlist controls for your routine, ! you can use the x_ctrl array of real(dp) variables that is in &controls ! e.g., in the &controls inlist, you can set @@ -109,29 +109,29 @@ module mod_other_tsync ! end if ! ! To get the binary pointer using the provided binary_id, add these lines. - ! + ! ! type (binary_info), pointer :: b ! call binary_ptr(binary_id, b, ierr) ! if (ierr /= 0) then ! failure in binary_ptr ! return ! end if - ! + ! ! for integer control values, you can use x_integer_ctrl ! for logical control values, you can use x_logical_ctrl implicit none - - + + contains - + subroutine null_other_tsync(id, sync_type, Ftid, qratio, m, r_phot, osep, t_sync, ierr) use const_def, only: dp, strlen use binary_def, only : binary_info, binary_ptr use star_def, only : star_info, star_ptr integer, intent(in) :: id character (len=strlen), intent(in) :: sync_type ! synchronization timescale - real(dp), intent(in) :: Ftid ! efficiency of tidal synchronization. (time scale / Ftid ). + real(dp), intent(in) :: Ftid ! efficiency of tidal synchronization. (time scale / Ftid ). real(dp), intent(in) :: qratio ! mass_other_star/mass_this_star real(dp), intent(in) :: m real(dp), intent(in) :: r_phot @@ -140,7 +140,7 @@ subroutine null_other_tsync(id, sync_type, Ftid, qratio, m, r_phot, osep, t_sync integer, intent(out) :: ierr type (binary_info), pointer :: b type (star_info), pointer :: s - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) then diff --git a/binary/other/pgbinary_decorator.f90 b/binary/other/pgbinary_decorator.f90 index ec9222fbb..7a8177538 100644 --- a/binary/other/pgbinary_decorator.f90 +++ b/binary/other/pgbinary_decorator.f90 @@ -25,7 +25,7 @@ module pgbinary_decorator - ! NOTE: remember to set X_use_decorator = .true. to enable this, + ! NOTE: remember to set X_use_decorator = .true. to enable this, ! where X is the name of the pgbinary plot ! and set s% X_pgbinary_decorator => your_function in your ! run_binary_extras.f @@ -53,7 +53,7 @@ subroutine null_pgbinary_decorator(id, xmin, xmax, ymin, ymax, plot_num, ierr) end subroutine null_pgbinary_decorator end module pgbinary_decorator - - - - + + + + diff --git a/binary/private/binary_ce.f90 b/binary/private/binary_ce.f90 index 2b792aae0..113cd4271 100644 --- a/binary/private/binary_ce.f90 +++ b/binary/private/binary_ce.f90 @@ -200,7 +200,7 @@ subroutine CE_init(b, restart, ierr) end if deallocate(adjusted_energy,interp_work) end if - + end subroutine subroutine CE_rlo_mdot(binary_id, rlo_mdot, ierr) @@ -293,7 +293,7 @@ integer function CE_binary_evolve_step(b) b% CE_Ebind2 = Ebind b% CE_lambda2 = lambda end if - + initial_Eorb = -standard_cgrav*b% CE_initial_Mdonor*b% CE_initial_Maccretor/(2*b% CE_initial_separation) separation = -b% CE_alpha*standard_cgrav*s% m(1)*b% CE_initial_Maccretor & @@ -304,7 +304,7 @@ integer function CE_binary_evolve_step(b) if (b% point_mass_i == 0) then b% m(b% a_i) = b% s_accretor% mstar end if - + if (b% point_mass_i /= 1) then b% r(1) = Rsun*b% s1% photosphere_r else diff --git a/binary/private/binary_ctrls_io.f90 b/binary/private/binary_ctrls_io.f90 index b8f0f5676..fe067a234 100644 --- a/binary/private/binary_ctrls_io.f90 +++ b/binary/private/binary_ctrls_io.f90 @@ -24,17 +24,17 @@ ! *********************************************************************** module binary_ctrls_io - + use const_def use binary_def implicit none - - include "binary_controls.inc" - + + include "binary_controls.inc" + logical, dimension(max_extra_inlists) :: read_extra_binary_controls_inlist character (len=strlen), dimension(max_extra_inlists) :: extra_binary_controls_inlist_name - + namelist /binary_controls/ & ! specifications for starting model m1, & @@ -82,12 +82,12 @@ module binary_ctrls_io varcontrol_ms, & varcontrol_post_ms, & dt_reduction_factor_for_j, & - + ! when to stop accretor_overflow_terminate, & terminate_if_initial_overflow, & terminate_if_L2_overflow, & - + ! mass transfer controls mass_transfer_alpha, & mass_transfer_beta, & @@ -161,7 +161,7 @@ module binary_ctrls_io do_initial_orbit_sync_1, & do_initial_orbit_sync_2, & tidal_reduction, & - + ! eccentricity controls do_tidal_circ, & circ_type_1, & @@ -198,7 +198,7 @@ module binary_ctrls_io CE_energy_factor_HeIII_toHeII, & CE_energy_factor_H2, & CE_fixed_lambda, & - + ! miscellaneous controls keep_donor_fixed, & mdot_limit_donor_switch, & @@ -233,8 +233,8 @@ module binary_ctrls_io read_extra_binary_controls_inlist, extra_binary_controls_inlist_name contains - - + + subroutine do_one_binary_setup(b, inlist, ierr) use utils_lib type (binary_info), pointer :: b @@ -264,12 +264,12 @@ subroutine read_binary_controls(b, filename, ierr) type (binary_info), pointer :: b character(*), intent(in) :: filename integer, intent(out) :: ierr - + call read_binary_controls_file(b, filename, 1, ierr) - + end subroutine read_binary_controls - - + + recursive subroutine read_binary_controls_file(b, filename, level, ierr) use utils_lib character(*), intent(in) :: filename @@ -279,9 +279,9 @@ recursive subroutine read_binary_controls_file(b, filename, level, ierr) logical, dimension(max_extra_inlists) :: read_extra character (len=strlen), dimension(max_extra_inlists) :: extra integer :: unit, i - - ierr = 0 - + + ierr = 0 + if (level >= 10) then write(*,*) 'ERROR: too many levels of nested extra binary controls inlist files' ierr = -1 @@ -294,40 +294,40 @@ recursive subroutine read_binary_controls_file(b, filename, level, ierr) write(*, *) 'Failed to open binary control namelist file ', trim(filename) return end if - read(unit, nml=binary_controls, iostat=ierr) + read(unit, nml=binary_controls, iostat=ierr) close(unit) if (ierr /= 0) then - write(*, *) - write(*, *) - write(*, *) - write(*, *) + write(*, *) + write(*, *) + write(*, *) + write(*, *) write(*, '(a)') & 'Failed while trying to read binary control namelist file: ' // trim(filename) write(*, '(a)') & 'Perhaps the following runtime error message will help you find the problem.' - write(*, *) + write(*, *) open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) read(unit, nml=binary_controls) close(unit) return end if end if - + call store_binary_controls(b, ierr) - + ! recursive calls to read other inlists do i=1, max_extra_inlists read_extra(i) = read_extra_binary_controls_inlist(i) read_extra_binary_controls_inlist(i) = .false. extra(i) = extra_binary_controls_inlist_name(i) extra_binary_controls_inlist_name(i) = 'undefined' - + if (read_extra(i)) then call read_binary_controls_file(b, extra(i), level+1, ierr) if (ierr /= 0) return end if end do - + end subroutine read_binary_controls_file @@ -340,9 +340,9 @@ subroutine store_binary_controls(b, ierr) use utils_lib, only: mkdir type (binary_info), pointer :: b integer, intent(out) :: ierr - + ierr = 0 - + ! specifications for starting model b% m1 = m1 b% m2 = m2 @@ -470,7 +470,7 @@ subroutine store_binary_controls(b, ierr) b% do_initial_orbit_sync_1 = do_initial_orbit_sync_1 b% do_initial_orbit_sync_2 = do_initial_orbit_sync_2 b% tidal_reduction = tidal_reduction - + ! eccentricity controls b% do_tidal_circ = do_tidal_circ b% circ_type_1 = circ_type_1 @@ -507,7 +507,7 @@ subroutine store_binary_controls(b, ierr) b% CE_energy_factor_HeIII_toHeII = CE_energy_factor_HeIII_toHeII b% CE_energy_factor_H2 = CE_energy_factor_H2 b% CE_fixed_lambda = CE_fixed_lambda - + ! miscellaneous controls b% keep_donor_fixed = keep_donor_fixed b% mdot_limit_donor_switch = mdot_limit_donor_switch @@ -538,14 +538,14 @@ subroutine store_binary_controls(b, ierr) b% x_integer_ctrl = x_integer_ctrl b% x_logical_ctrl = x_logical_ctrl b% x_character_ctrl = x_character_ctrl - + end subroutine store_binary_controls subroutine set_binary_controls_for_writing(b, ierr) type (binary_info), pointer :: b integer, intent(out) :: ierr - + ierr = 0 ! specifications for starting model @@ -668,7 +668,7 @@ subroutine set_binary_controls_for_writing(b, ierr) do_initial_orbit_sync_1 = b% do_initial_orbit_sync_1 do_initial_orbit_sync_2 = b% do_initial_orbit_sync_2 tidal_reduction = b% tidal_reduction - + ! eccentricity controls do_tidal_circ = b% do_tidal_circ circ_type_1 = b% circ_type_1 @@ -701,7 +701,7 @@ subroutine set_binary_controls_for_writing(b, ierr) CE_terminate_when_core_overflows = b% CE_terminate_when_core_overflows CE_min_period_in_minutes = b% CE_min_period_in_minutes CE_fixed_lambda = b% CE_fixed_lambda - + ! miscellaneous controls keep_donor_fixed = b% keep_donor_fixed mdot_limit_donor_switch = b% mdot_limit_donor_switch @@ -727,18 +727,18 @@ subroutine set_binary_controls_for_writing(b, ierr) use_other_CE_rlo_mdot = b% use_other_CE_rlo_mdot use_other_CE_binary_evolve_step = b% use_other_CE_binary_evolve_step use_other_CE_binary_finish_step = b% use_other_CE_binary_finish_step - + x_ctrl = b% x_ctrl x_integer_ctrl = b% x_integer_ctrl x_logical_ctrl = b% x_logical_ctrl x_character_ctrl = b% x_character_ctrl end subroutine set_binary_controls_for_writing - + subroutine write_binary_controls(io,ierr) integer, intent(in) :: io integer, intent(out) :: ierr - write(io, nml=binary_controls, iostat=ierr) + write(io, nml=binary_controls, iostat=ierr) end subroutine write_binary_controls @@ -748,26 +748,26 @@ subroutine get_binary_control(b, name, val, ierr) character(len=*),intent(in) :: name character(len=*), intent(out) :: val integer, intent(out) :: ierr - + character(len(name)) :: upper_name character(len=512) :: str integer :: iounit,iostat,ind,i - - + + ! First save current controls call set_binary_controls_for_writing(b, ierr) if(ierr/=0) return - + ! Write namelist to temporay file open(newunit=iounit,status='scratch') write(iounit,nml=binary_controls) rewind(iounit) - + ! Namelists get written in captials upper_name = StrUpCase(name) val = '' ! Search for name inside namelist - do + do read(iounit,'(A)',iostat=iostat) str ind = index(str,trim(upper_name)) if( ind /= 0 ) then @@ -778,34 +778,34 @@ subroutine get_binary_control(b, name, val, ierr) exit end if if(is_iostat_end(iostat)) exit - end do - + end do + if(len_trim(val) == 0 .and. ind==0 ) ierr = -1 - + close(iounit) - + end subroutine get_binary_control - + subroutine set_binary_control(b, name, val, ierr) type (binary_info), pointer :: b character(len=*), intent(in) :: name, val character(len=len(name)+len(val)+19) :: tmp integer, intent(out) :: ierr - + ! First save current controls call set_binary_controls_for_writing(b, ierr) if(ierr/=0) return - + tmp='' tmp = '&binary_controls '//trim(name)//'='//trim(val)//' /' - + ! Load into namelist read(tmp, nml=binary_controls) - + ! Add to star call store_binary_controls(b, ierr) if(ierr/=0) return - + end subroutine set_binary_control end module binary_ctrls_io diff --git a/binary/private/binary_do_one_utils.f90 b/binary/private/binary_do_one_utils.f90 index fa956047e..64ed1df6d 100644 --- a/binary/private/binary_do_one_utils.f90 +++ b/binary/private/binary_do_one_utils.f90 @@ -24,15 +24,15 @@ ! *********************************************************************** module binary_do_one_utils - + use binary_def use const_def use math_lib implicit none - + contains - + subroutine write_binary_terminal_header(b) type (binary_info), pointer :: b if (b% model_number <= b% recent_binary_log_header) return @@ -41,8 +41,8 @@ subroutine write_binary_terminal_header(b) call do_show_binary_terminal_header(b) b% just_wrote_binary_terminal_header = .true. end subroutine write_binary_terminal_header - - + + subroutine do_show_binary_log_description(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -95,16 +95,16 @@ subroutine do_show_binary_log_description(id, ierr) write(*,'(A)') write(*,'(a)') " All this and more can be saved in binary_history.data during the run." end subroutine do_show_binary_log_description - - + + subroutine do_show_binary_terminal_header(b) type (binary_info), pointer :: b call output_binary_terminal_header(b,terminal_iounit) if (b% extra_binary_terminal_iounit > 0) & call output_binary_terminal_header(b,b% extra_binary_terminal_iounit) end subroutine do_show_binary_terminal_header - - + + subroutine output_binary_terminal_header(b,io) type (binary_info), pointer :: b integer, intent(in) :: io @@ -125,10 +125,10 @@ subroutine output_binary_terminal_header(b,io) '_______________________________________________________________________' // & '___________________________________________________________________________' write(io,'(A)') - + end subroutine output_binary_terminal_header - - + + subroutine do_binary_terminal_summary(b) type (binary_info), pointer :: b call output_binary_terminal_summary(b,terminal_iounit) @@ -137,19 +137,19 @@ subroutine do_binary_terminal_summary(b) flush(b% extra_binary_terminal_iounit) end if end subroutine do_binary_terminal_summary - - + + subroutine output_binary_terminal_summary(b,io) type (binary_info), pointer :: b integer, intent(in) :: io - + real(dp) :: age, time_step, total_mass real(dp) :: Eorb, vorb1, vorb2, dot_M1, dot_M2, eff, dot_Medd, spin1, spin2, P1, P2 integer :: model, ierr, rlo_iters character (len=90) :: fmt, fmt1, fmt2, fmt3, fmt4, fmt5, fmt6 - + include 'formats' - + age = b% binary_age time_step = b% time_step model = b% model_number @@ -200,7 +200,7 @@ subroutine output_binary_terminal_summary(b,io) end if P2 = 0d0 - if (b% point_mass_i /= 2)then + if (b% point_mass_i /= 2)then if (b% s2% rotation_flag) then if (abs(b% s2% omega_avg_surf) > 0) then P2 = 2*pi/(b% s2% omega_avg_surf*24d0*3600d0) @@ -214,7 +214,7 @@ subroutine output_binary_terminal_summary(b,io) end if end if - ierr = 0 + ierr = 0 !make format strings for first line of output !step and m1+m2 @@ -254,7 +254,7 @@ subroutine output_binary_terminal_summary(b,io) fmt6 = '4(1pe11.3))' end if - + fmt = trim(fmt1) // trim(fmt2) // trim(fmt3) // trim(fmt4) // trim(fmt5) // trim(fmt6) write(io,fmt=fmt) & 'bin', & @@ -263,7 +263,7 @@ subroutine output_binary_terminal_summary(b,io) b% separation / Rsun, & b% period / (3600d0*24d0), & b% eccentricity, & - b% m(2)/b% m(1), & + b% m(2)/b% m(1), & b% point_mass_i, & b% d_i, & b% step_mtransfer_rate/Msun*secyer, & @@ -303,7 +303,7 @@ subroutine output_binary_terminal_summary(b,io) else fmt5 = 'f11.6,6(1pe11.3))' end if - + fmt = trim(fmt1) // trim(fmt2) // trim(fmt3) // trim(fmt4) // trim(fmt5) write(io,fmt=fmt) & safe_log10(time_step), & @@ -351,7 +351,7 @@ subroutine output_binary_terminal_summary(b,io) else fmt5 = 'f11.6,5(1pe11.3),0p,i11)' end if - + fmt = trim(fmt1) // trim(fmt2) // trim(fmt3) // trim(fmt4) // trim(fmt5) write(io,fmt=fmt) & age, & @@ -369,11 +369,11 @@ subroutine output_binary_terminal_summary(b,io) rlo_iters write(io,'(A)') - + b% just_wrote_binary_terminal_header = .false. - + end subroutine output_binary_terminal_summary - + end module binary_do_one_utils - + diff --git a/binary/private/binary_edot.f90 b/binary/private/binary_edot.f90 index 5e92f5602..87c2de22b 100644 --- a/binary/private/binary_edot.f90 +++ b/binary/private/binary_edot.f90 @@ -24,7 +24,7 @@ ! *********************************************************************** module binary_edot - + use const_def use star_lib use star_def @@ -61,11 +61,11 @@ real(dp) function get_edot(b) result(edot) else b% edot_tidal = 0d0 end if - + if (b% edot_tidal < -b% max_abs_edot_tidal) then b% edot_tidal = -b% max_abs_edot_tidal end if - + ! eccentricity enhancement if (b% use_eccentricity_enhancement) then if (.not. b% use_other_edot_enhance) then @@ -80,11 +80,11 @@ real(dp) function get_edot(b) result(edot) else b% edot_enhance = 0d0 end if - + if (b% edot_enhance > b% max_abs_edot_enhance) then b% edot_enhance = b% max_abs_edot_enhance end if - + ! user defined eccentricity changes if (b% use_other_extra_edot) then call b% other_extra_edot(b% binary_id, ierr) @@ -95,9 +95,9 @@ real(dp) function get_edot(b) result(edot) else b% extra_edot = 0d0 end if - + b% edot = b% edot_tidal + b% edot_enhance + b% extra_edot - + end if edot = b% edot @@ -118,7 +118,7 @@ subroutine edot_tidal(binary_id, ierr) write(*,*) 'failed in binary_ptr' return end if - + b% edot_tidal = 0d0 if (b% point_mass_i /= 1) then @@ -184,13 +184,13 @@ real(dp) function edot_tidal_Hut(b, s , has_convective_envelope, ierr) result(ed edot_tidal = edot_tidal*(f3(b% eccentricity) - & 11d0/18d0 * omega_s / omega_sync * f4(b% eccentricity) * & pow(1-pow2(b% eccentricity),1.5d0)) - + end function edot_tidal_Hut - + ! ========================================== ! Edot MASS LOSS ! ========================================== - + subroutine edot_enhancement_Isotropic(binary_id, ierr) integer, intent(in) :: binary_id integer, intent(out) :: ierr @@ -210,29 +210,29 @@ subroutine edot_enhancement_Isotropic(binary_id, ierr) ! cos_cr isn't vectorised, so we have to do this in a loop do i = 1, b% anomaly_steps costh = cos(b% theta_co(i)) - + b% e1(i) = b% eccentricity + costh b% e2(i) = 2d0*costh + b% eccentricity*(1d0 + costh*costh) b% e3(i) = b% eccentricity*(1d0-costh*costh) ! = b% eccentricity*sin(b% theta_co)**2 end do - + ! xfer = min(b% wind_xfer_fraction, b% xfer_fraction) Mtot = b% m(1) + b% m(2) ! total mass in gr - + b% edot_theta = - b% mdot_donor_theta / Mtot * b% e1 !-& ! b% mdot_donor_theta * xfer / b% m(b% a_i) * (b% m(b% d_i) / Mtot *& ! ((b% m(b% a_i)**2 / b% m(b% d_i)**2 - 1 ) * e2 - e3 )) - + !integrate to get total eccentricity enhancement de = 0d0 do i = 2,b% anomaly_steps ! trapezoidal integration - de = de + 0.5d0 * (b% edot_theta(i-1) + b% edot_theta(i)) * (b% time_co(i) - b% time_co(i-1)) + de = de + 0.5d0 * (b% edot_theta(i-1) + b% edot_theta(i)) * (b% time_co(i) - b% time_co(i-1)) end do - + b% edot_enhance = de - + end subroutine edot_enhancement_Isotropic - + end module binary_edot diff --git a/binary/private/binary_evolve.f90 b/binary/private/binary_evolve.f90 index 4b8868b9d..5f643ef81 100644 --- a/binary/private/binary_evolve.f90 +++ b/binary/private/binary_evolve.f90 @@ -108,7 +108,7 @@ subroutine binarydata_init(b, doing_restart) b% r(2) = b% r(1) end if end if - + if (b% initial_period_in_days <= 0) then ! calculate from initial_separation_in_Rsuns call set_separation_eccentricity(b% binary_id, & b% initial_separation_in_Rsuns*Rsun, b% initial_eccentricity, ierr) @@ -125,7 +125,7 @@ subroutine binarydata_init(b, doing_restart) ! Set all parameters nessessary for integration over the binary orbit ! 1) true anomaly = polar angle from periastron 0 -> 2pi - do i = 1,b% anomaly_steps + do i = 1,b% anomaly_steps b% theta_co(i) = (i-1) * (2 * pi) / b% anomaly_steps end do ! 2) time between periastron and polar angle theta 0 -> 1 (fraction of the @@ -139,7 +139,7 @@ subroutine binarydata_init(b, doing_restart) b% time_co(i) = b% time_co(i) + b% time_co(b% anomaly_steps/2+1) * 2 end if end do - + if (is_bad(b% rl_relative_gap(1))) call mesa_error(__FILE__,__LINE__,'binarydata_init') if (is_bad(b% rl_relative_gap(2))) call mesa_error(__FILE__,__LINE__,'binarydata_init') b% using_jdot_mb(1) = .false. @@ -164,7 +164,7 @@ subroutine binarydata_init(b, doing_restart) ! zero spin (r_isco = 6). b% eq_initial_bh_mass = b% m(b% point_mass_i) * sqrt(r_isco/6d0) end if - + write(*,'(A)') write(*,1) 'm2', b% m2 write(*,1) 'm1', b% m1 @@ -208,7 +208,7 @@ subroutine binarydata_init(b, doing_restart) b% s_accretor => b% s1 end if end if - + end subroutine subroutine set_donor_star(b) @@ -232,7 +232,7 @@ subroutine set_donor_star(b) b% mdot_hi = - b% mdot_lo b% mdot_lo = - mdot_hi_temp if (.not. b% have_mdot_lo) then - b% have_mdot_hi = .false. + b% have_mdot_hi = .false. end if b% have_mdot_lo = .true. b% fixed_delta_mdot = b% fixed_delta_mdot / 2.0d0 @@ -266,7 +266,7 @@ integer function binary_evolve_step(b) use binary_edot, only: get_edot type(binary_info), pointer :: b integer :: i - + include 'formats' ! store the final mdots used for each star @@ -287,7 +287,7 @@ integer function binary_evolve_step(b) else b% m(b% a_i) = b% m(b% d_i) end if - + if (b% point_mass_i /= 1) then b% r(1) = Rsun*b% s1% photosphere_r else @@ -332,7 +332,7 @@ integer function binary_evolve_step(b) binary_evolve_step = retry return end if - + ! update the eccentricity (ignore in first step) if (.not. b% doing_first_model_of_run) then b% eccentricity = b% eccentricity + get_edot(b) *b% time_step*secyer @@ -344,7 +344,7 @@ integer function binary_evolve_step(b) b% extra_edot = 0d0 b% edot = 0d0 end if - + !use new eccentricity to calculate new time coordinate do i = 1,b% anomaly_steps ! time between periastron and polar angle theta b% time_co(i) = ( 2 * atan( sqrt( (1-b% eccentricity)/(1 + b% eccentricity) ) * & @@ -355,23 +355,23 @@ integer function binary_evolve_step(b) b% time_co(i) = b% time_co(i) + b% time_co(b% anomaly_steps/2+1) * 2 end if end do - + ! use the new j to calculate new separation b% separation = (pow2(b% angular_momentum_j/(b% m(1)*b% m(2)))) *& (b% m(1)+b% m(2)) / standard_cgrav * 1 / (1 - pow2(b% eccentricity)) if (b% separation < b% min_binary_separation) & b% min_binary_separation = b% separation - + b% period = 2*pi*sqrt(pow3(b% separation)/& - (standard_cgrav*(b% m(1)+b% m(2)))) + (standard_cgrav*(b% m(1)+b% m(2)))) if (b% period < min_binary_period) min_binary_period = b% period - + ! use the new separation to calculate the new roche lobe radius - + b% rl(1) = eval_rlobe(b% m(1), b% m(2), b% separation) b% rl(2) = eval_rlobe(b% m(2), b% m(1), b% separation) b% rl_relative_gap(1) = (b% r(1) - b% rl(1) * (1 - b% eccentricity) ) / & - b% rl(1) / (1 - b% eccentricity) ! gap < 0 means out of contact + b% rl(1) / (1 - b% eccentricity) ! gap < 0 means out of contact b% rl_relative_gap(2) = (b% r(2) - b% rl(2) * (1 - b% eccentricity) ) / & b% rl(2) / (1 - b% eccentricity) ! gap < 0 means out of contact @@ -409,11 +409,11 @@ integer function binary_check_model(b) binary_check_model = retry ierr = 0 - + implicit_rlo = (b% max_tries_to_achieve > 0 .and. b% implicit_scheme_tolerance > 0d0) - + binary_check_model = keep_going - + if (.not. b% ignore_rlof_flag) then if (implicit_rlo) then ! check agreement between new r and new rl if (.not. b% use_other_check_implicit_rlo) then @@ -449,7 +449,7 @@ integer function binary_check_model(b) end if ! smooth out the changes in mdot new_mdot = b% cur_mdot_frac*b% mtransfer_rate + (1-b% cur_mdot_frac)*new_mdot - if (-new_mdot/(Msun/secyer) > b% max_explicit_abs_mdot) new_mdot = -b% max_explicit_abs_mdot*Msun/secyer + if (-new_mdot/(Msun/secyer) > b% max_explicit_abs_mdot) new_mdot = -b% max_explicit_abs_mdot*Msun/secyer end if b% mtransfer_rate = new_mdot else @@ -649,7 +649,7 @@ end subroutine binary_set_current_to_old integer function binary_after_evolve(b) type (binary_info), pointer :: b binary_after_evolve = keep_going - + !take care of deallocating binary arrays here if (associated(b% theta_co)) then deallocate(b% theta_co) diff --git a/binary/private/binary_history.f90 b/binary/private/binary_history.f90 index 8d21fec9a..32515098f 100644 --- a/binary/private/binary_history.f90 +++ b/binary/private/binary_history.f90 @@ -753,7 +753,7 @@ subroutine binary_history_getval(b, c, val, int_val, is_int_val, ierr) end subroutine binary_history_getval - subroutine get_binary_history_specs(b, num, names, specs) + subroutine get_binary_history_specs(b, num, names, specs, report) use utils_lib use utils_def @@ -762,6 +762,7 @@ subroutine get_binary_history_specs(b, num, names, specs) integer, intent(in) :: num character (len = *), intent(in) :: names(:) integer, intent(out) :: specs(:) + logical, intent(in) :: report integer :: i, ierr, n, j, iounit, t character (len = strlen) :: buffer, string @@ -778,15 +779,16 @@ subroutine get_binary_history_specs(b, num, names, specs) j = 0 t = token(iounit, n, j, buffer, string) if (t /= name_token) then - if (len_trim(names(i)) > 0) & + if (len_trim(names(i)) > 0 .and. report) & write(*, *) 'bad value for name of history item ' // trim(names(i)) specs(i) = -1 ierr = 0 cycle end if specs(i) = do1_binary_history_spec(& - iounit, t, n, j, string, buffer, ierr) + iounit, t, n, j, string, buffer, report, ierr) if (ierr /= 0) then + if (report) write(*, *) 'get_binary_history_specs failed for ' // trim(names(i)) specs(i) = -1 ierr = 0 end if @@ -833,7 +835,7 @@ subroutine get_binary_history_values(b, num, specs, & end subroutine get_binary_history_values logical function get1_binary_hist_value(b, name, val) - ! includes other_history_columns from run_star_extras + ! includes other_history_columns from run_binary_extras use utils_lib, only : integer_dict_lookup type (binary_info), pointer :: b character (len = *) :: name diff --git a/binary/private/binary_history_specs.f90 b/binary/private/binary_history_specs.f90 index 297540bdf..5f9722d22 100644 --- a/binary/private/binary_history_specs.f90 +++ b/binary/private/binary_history_specs.f90 @@ -41,7 +41,7 @@ module binary_history_specs contains recursive subroutine add_binary_history_columns(& - b, level, capacity, spec, history_columns_file, ierr) + b, level, capacity, spec, history_columns_file, report, ierr) use utils_lib use utils_def use const_def, only : mesa_dir @@ -49,6 +49,7 @@ recursive subroutine add_binary_history_columns(& integer, intent(in) :: level integer, intent(inout) :: capacity integer, pointer :: spec(:) + logical, intent(in) :: report character (len = *), intent(in) :: history_columns_file integer, intent(out) :: ierr @@ -107,7 +108,7 @@ recursive subroutine add_binary_history_columns(& if (t /= string_token) then call error; return end if - call add_binary_history_columns(b, level + 1, capacity, spec, string, ierr) + call add_binary_history_columns(b, level + 1, capacity, spec, string, report, ierr) if (ierr /= 0) then write(*, *) 'failed for included log columns list ' // trim(string) bad_item = .true. @@ -116,7 +117,7 @@ recursive subroutine add_binary_history_columns(& cycle end if - nxt_spec = do1_binary_history_spec(iounit, t, n, i, string, buffer, ierr) + nxt_spec = do1_binary_history_spec(iounit, t, n, i, string, buffer, report, ierr) if (ierr /= 0) bad_item = .true. if (.not. bad_item) then call insert_spec(nxt_spec, string, ierr) @@ -190,13 +191,14 @@ end subroutine add_binary_history_columns integer function do1_binary_history_spec(& - iounit, t, n, i, string, buffer, ierr) result(spec) + iounit, t, n, i, string, buffer, report, ierr) result(spec) use utils_lib use utils_def use chem_lib integer :: iounit, t, n, i, j character (len = *) :: string, buffer + logical, intent(in) :: report integer, intent(out) :: ierr ierr = 0 @@ -209,15 +211,16 @@ integer function do1_binary_history_spec(& end if end do - write(*, *) 'bad history list name: ' // trim(string) + if (report) write(*, *) 'bad history list name: ' // trim(string) ierr = -1 end function do1_binary_history_spec - subroutine set_binary_history_columns(b, binary_history_columns_file, ierr) + subroutine set_binary_history_columns(b, binary_history_columns_file, report, ierr) use utils_lib, only : realloc_integer type(binary_info), pointer :: b character (len = *), intent(in) :: binary_history_columns_file + logical, intent(in) :: report integer, intent(out) :: ierr integer :: capacity, cnt, i logical, parameter :: dbg = .false. @@ -235,7 +238,7 @@ subroutine set_binary_history_columns(b, binary_history_columns_file, ierr) if (ierr /= 0) return b% binary_history_column_spec(:) = 0 call add_binary_history_columns(b, 1, capacity, & - b% binary_history_column_spec, binary_history_columns_file, ierr) + b% binary_history_column_spec, binary_history_columns_file, report, ierr) if (ierr /= 0) then if (associated(old_binary_history_column_spec)) & deallocate(old_binary_history_column_spec) diff --git a/binary/private/binary_jdot.f90 b/binary/private/binary_jdot.f90 index 4aa54e7ee..adf0a520d 100644 --- a/binary/private/binary_jdot.f90 +++ b/binary/private/binary_jdot.f90 @@ -40,7 +40,7 @@ real(dp) function get_jdot(b) type (binary_info), pointer :: b integer :: ierr - + ! calculate jdot from gravitational wave radiation if (.not. b% do_jdot_gr) then b% jdot_gr = 0d0 @@ -49,7 +49,7 @@ real(dp) function get_jdot(b) else call b% other_jdot_gr(b% binary_id, ierr) end if - + ! calculate jdot for mass ejected from system if (.not. b% do_jdot_ml) then b% jdot_ml = 0d0 @@ -85,17 +85,17 @@ real(dp) function get_jdot(b) else call b% other_jdot_mb(b% binary_id, ierr) end if - + ! calculate extra jdot if (.not. b% use_other_extra_jdot) then b% extra_jdot = 0 - else + else call b% other_extra_jdot(b% binary_id, ierr) end if - + get_jdot = (b% jdot_mb + b% jdot_gr + b% jdot_ml + b% jdot_missing_wind + & b% extra_jdot) * b% jdot_multiplier + b% jdot_ls - + end function get_jdot subroutine default_jdot_gr(binary_id, ierr) @@ -209,7 +209,7 @@ subroutine check_jdot_mb_conditions(b, s, apply_jdot_mb, qconv_env) type (star_info), pointer :: s logical, intent(out) :: apply_jdot_mb real(dp), intent(out) :: qconv_env - + real(dp) :: qconv_core integer :: k @@ -218,7 +218,7 @@ subroutine check_jdot_mb_conditions(b, s, apply_jdot_mb, qconv_env) ! calculate how much of inner region is convective qconv_core = 0d0 do k = s% nz, 1, -1 - if (s% q(k) > b% jdot_mb_qlim_for_check_rad_core .and. & + if (s% q(k) > b% jdot_mb_qlim_for_check_rad_core .and. & (qconv_core == 0d0 .or. s% mixing_type(k) /= convective_mixing)) exit if (s% mixing_type(k) == convective_mixing) & qconv_core = qconv_core + s% dq(k) @@ -248,7 +248,7 @@ subroutine check_jdot_mb_conditions(b, s, apply_jdot_mb, qconv_env) apply_jdot_mb = .false. return end if - + end subroutine check_jdot_mb_conditions subroutine default_jdot_mb(binary_id, ierr) @@ -280,7 +280,7 @@ subroutine default_jdot_mb(binary_id, ierr) jdot_scale = exp(-b% jdot_mb_mass_frac_for_scale/max(1d-99,qconv_env)+1) end if end if - b% jdot_mb = -3.8d-30*b% m(b% d_i)*rsun4* & + b% jdot_mb = -3.8d-30*b% m(b% d_i)*rsun4* & pow(min(b% r(b% d_i),b% rl(b% d_i))/rsun,b% magnetic_braking_gamma)* & two_pi_div_p3*jdot_scale write(*,*) "check jdot_scale", 1, jdot_scale, b% jdot_mb @@ -290,7 +290,7 @@ subroutine default_jdot_mb(binary_id, ierr) end if else if (.not. (apply_jdot_mb .or. b% keep_mb_on) .and. b% using_jdot_mb_old(b% d_i)) then ! required mdot for the implicit scheme may drop drastically, - ! so its neccesary to increase change factor to avoid implicit + ! so its neccesary to increase change factor to avoid implicit ! scheme from getting stuck b% change_factor = b% max_change_factor b% using_jdot_mb(b% d_i) = .false. @@ -320,7 +320,7 @@ subroutine default_jdot_mb(binary_id, ierr) end if else if (.not. (apply_jdot_mb .or. b% keep_mb_on) .and. b% using_jdot_mb_old(b% a_i)) then ! required mdot for the implicit scheme may drop drastically, - ! so its neccesary to increase change factor to avoid implicit + ! so its neccesary to increase change factor to avoid implicit ! scheme from getting stuck b% change_factor = b% max_change_factor b% using_jdot_mb(b% a_i) = .false. diff --git a/binary/private/binary_job_ctrls_io.f90 b/binary/private/binary_job_ctrls_io.f90 index e3c709304..6a2d4c3df 100644 --- a/binary/private/binary_job_ctrls_io.f90 +++ b/binary/private/binary_job_ctrls_io.f90 @@ -138,13 +138,13 @@ recursive subroutine read_binary_job_file(b, filename, level, ierr) read_extra_binary_job_inlist(i) = .false. extra(i) = extra_binary_job_inlist_name(i) extra_binary_job_inlist_name(i) = 'undefined' - + if (read_extra(i)) then call read_binary_job_file(b, extra(i), level+1, ierr) if (ierr /= 0) return end if end do - + end subroutine read_binary_job_file @@ -272,26 +272,26 @@ subroutine get_binary_job(b, name, val, ierr) character(len=*),intent(in) :: name character(len=*), intent(out) :: val integer, intent(out) :: ierr - + character(len(name)) :: upper_name character(len=512) :: str integer :: iounit,iostat,ind,i - - + + ! First save current controls call set_binary_job_controls_for_writing(b, ierr) if(ierr/=0) return - + ! Write namelist to temporay file open(newunit=iounit,status='scratch') write(iounit,nml=binary_job) rewind(iounit) - + ! Namelists get written in captials upper_name = StrUpCase(name) val = '' ! Search for name inside namelist - do + do read(iounit,'(A)',iostat=iostat) str ind = index(str,trim(upper_name)) if( ind /= 0 ) then @@ -302,34 +302,34 @@ subroutine get_binary_job(b, name, val, ierr) exit end if if(is_iostat_end(iostat)) exit - end do - + end do + if(len_trim(val) == 0 .and. ind==0 ) ierr = -1 - + close(iounit) - + end subroutine get_binary_job - + subroutine set_binary_job(b, name, val, ierr) type (binary_info), pointer :: b character(len=*), intent(in) :: name, val character(len=len(name)+len(val)+14) :: tmp integer, intent(out) :: ierr - + ! First save current controls call set_binary_job_controls_for_writing(b, ierr) if(ierr/=0) return - + tmp='' tmp = '&binary_job '//trim(name)//'='//trim(val)//' /' - + ! Load into namelist read(tmp, nml=binary_job) - + ! Add to star call store_binary_job_controls(b, ierr) if(ierr/=0) return - + end subroutine set_binary_job diff --git a/binary/private/binary_mdot.f90 b/binary/private/binary_mdot.f90 index 335af30b9..44fe98bf5 100644 --- a/binary/private/binary_mdot.f90 +++ b/binary/private/binary_mdot.f90 @@ -42,14 +42,14 @@ module binary_mdot integer function check_implicit_rlo(binary_id, new_mdot) integer, intent(in) :: binary_id real(dp), intent(out) :: new_mdot - + type (binary_info), pointer :: b type (star_info), pointer :: s real(dp) :: function_to_solve, explicit_mdot, q, slope_contact integer :: ierr logical :: use_sum, detached character (len=90) :: rlo_result - + include 'formats' ierr = 0 call binary_ptr(binary_id, b, ierr) @@ -60,7 +60,7 @@ integer function check_implicit_rlo(binary_id, new_mdot) s => b% s_donor use_sum = .false. detached = .false. - + ! NOTE: keep in mind that for mass loss, mdot is negative. ! b% mtransfer_rate will be considered valid if function_to_solve = 0 ! within the tolerance given by b% implicit_scheme_tolerance, i.e. @@ -76,7 +76,7 @@ integer function check_implicit_rlo(binary_id, new_mdot) ! For other schemes, function_to_solve is chosen as the difference between ! b% mtransfer_rate and the explicit transfer rate, divided by the ! explicit transfer rate. - + check_implicit_rlo = keep_going new_mdot = b% mtransfer_rate b% num_tries = b% num_tries + 1 @@ -128,7 +128,7 @@ integer function check_implicit_rlo(binary_id, new_mdot) ! If accretor is overflowing its Roche lobe, then the contact scheme needs to be used. ! Otherwise, if accretor radius is (within tolerance) below the equipotential ! of the donor, or donor is below tolerance for detachment, then use regular roche_lobe scheme. - if (b% rl_relative_gap(b% a_i) < 0 .and. & + if (b% rl_relative_gap(b% a_i) < 0 .and. & (b% rl_relative_gap(b% d_i)*slope_contact - b% rl_relative_gap(b% a_i) & > b% implicit_scheme_tolerance .or. & b% rl_relative_gap(b% d_i) < - b% implicit_scheme_tolerance)) then @@ -207,7 +207,7 @@ integer function check_implicit_rlo(binary_id, new_mdot) end if return end if - + if (b% num_tries > b% max_tries_to_achieve) then check_implicit_rlo = retry if (b% report_rlo_solver_progress) then @@ -216,7 +216,7 @@ integer function check_implicit_rlo(binary_id, new_mdot) end if return end if - + if (b% num_tries == 1) then b% have_mdot_lo = .false. b% have_mdot_hi = .false. @@ -224,7 +224,7 @@ integer function check_implicit_rlo(binary_id, new_mdot) b% mdot_hi = 0 b% fixed_delta_mdot = b% mtransfer_rate * (1 - b% change_factor) end if - + new_mdot = pick_mdot_for_implicit_rlo(b, function_to_solve, b% mtransfer_rate, use_sum, ierr) !if this iteration is done using the maximum mass transfer rate, @@ -254,7 +254,7 @@ integer function check_implicit_rlo(binary_id, new_mdot) end if return end if - + if (-new_mdot < b% roche_min_mdot*Msun/secyer .and. function_to_solve < 0 .and. & (b% mdot_scheme == "roche_lobe" .or. (b% mdot_scheme == "contact" .and. & .not. use_sum))) then @@ -266,7 +266,7 @@ integer function check_implicit_rlo(binary_id, new_mdot) end if return end if - + if (b% have_mdot_hi .and. b% have_mdot_lo) then if (abs(b% mdot_hi - b% mdot_lo) < & b% implicit_scheme_tiny_factor*min(abs(b% mdot_hi),abs(b% mdot_lo))) then @@ -293,7 +293,7 @@ integer function check_implicit_rlo(binary_id, new_mdot) rlo_result = 'redo' call report_rlo_iter end if - + check_implicit_rlo = redo contains @@ -334,14 +334,14 @@ real(dp) function pick_mdot_for_implicit_rlo( & real(dp), intent(in) :: new_function_to_solve, mdot_current logical, intent(in) :: use_sum integer, intent(out) :: ierr - + real(dp) :: starting_mdot, current_change_factor logical :: do_cubic include 'formats' - + ! NOTE: keep in mind that for mass loss, mdot is negative - - + + starting_mdot = -b% starting_mdot*Msun/secyer current_change_factor = pow(b% change_factor, b% num_tries+1) @@ -427,7 +427,7 @@ real(dp) function pick_mdot_for_implicit_rlo( & end if end if end if - + end function pick_mdot_for_implicit_rlo @@ -506,7 +506,7 @@ subroutine adjust_mdots(b) integer :: ierr actual_mtransfer_rate = 0d0 - + if (b% use_other_adjust_mdots) then call b% other_adjust_mdots(b% binary_id, ierr) if (ierr /= 0) then @@ -514,7 +514,7 @@ subroutine adjust_mdots(b) stop end if return - end if + end if b% fixed_xfer_fraction = 1 - b% mass_transfer_alpha - b% mass_transfer_beta - & b% mass_transfer_delta @@ -612,7 +612,7 @@ subroutine adjust_mdots(b) b% mdot_system_transfer(b% d_i) = 0d0 b% mdot_system_transfer(b% a_i) = 0d0 b% mdot_system_cct = 0d0 - else + else b% mdot_system_transfer(b% d_i) = b% mtransfer_rate * b% mass_transfer_alpha b% mdot_system_cct = b% mtransfer_rate * b% mass_transfer_delta if (b% point_mass_i == 0 .or. b% model_twins_flag) then @@ -661,23 +661,23 @@ subroutine rlo_mdot(binary_id, mdot, ierr) ! Adapted from a routine kindly provi mdot = b% mdot_thin call get_info_for_kolb(b) mdot = mdot + b% mdot_thick - + else if (b% mdot_scheme == "Kolb" .and. b% eccentricity > 0.0d0) then call get_info_for_ritter_eccentric(b) mdot = b% mdot_thin call get_info_for_kolb_eccentric(b) mdot = mdot + b% mdot_thick - + else if (b% mdot_scheme == "Ritter" .and. b% eccentricity <= 0.0d0) then call get_info_for_ritter(b) mdot = b% mdot_thin - + else if (b% mdot_scheme == "Ritter" .and. b% eccentricity > 0.0d0) then call get_info_for_ritter_eccentric(b) mdot = b% mdot_thin end if - + if (b% mdot_scheme == "Arras") then if (b% eccentricity > 0d0) & write(*,*) "mdot_scheme = Arras is not properly implemented for e>0" @@ -731,7 +731,7 @@ subroutine get_info_for_ritter(b) end if end subroutine get_info_for_ritter - + real(dp) function calculate_kolb_mdot_thick(b, indexR, rl_d) result(mdot_thick) real(dp), intent(in) :: rl_d integer, intent(in) :: indexR @@ -742,7 +742,7 @@ real(dp) function calculate_kolb_mdot_thick(b, indexR, rl_d) result(mdot_thick) !--------------------- Optically thin MT rate ----------------------------------------------- ! As described in Kolb and H. Ritter 1990, A&A 236,385-392 - + ! compute integral in Eq. (A17 of Kolb & Ritter 1990) mdot_thick = 0d0 do i=1,indexR-1 @@ -751,7 +751,7 @@ real(dp) function calculate_kolb_mdot_thick(b, indexR, rl_d) result(mdot_thick) mdot_thick = mdot_thick + F3*sqrt(kerg * b% s_donor% T(i) / & (mp * b% s_donor% mu(i)))*(b% s_donor% Peos(i+1)-b% s_donor% Peos(i)) end do - ! only take a fraction of d_P for last cell + ! only take a fraction of d_P for last cell G1 = b% s_donor% gamma1(i) F3 = sqrt(G1) * pow(2d0/(G1+1d0), (G1+1d0)/(2d0*G1-2d0)) d_P = (b% s_donor% r(indexR) - rl_d) / & @@ -764,9 +764,9 @@ real(dp) function calculate_kolb_mdot_thick(b, indexR, rl_d) result(mdot_thick) q_temp = min(max(q,0.5d0),10d0) F1 = (1.23d0 + 0.5D0* log10(q_temp)) mdot_thick = -2.0D0*pi*F1*rl_d*rl_d*rl_d/(standard_cgrav*b% m(b% d_i))*mdot_thick - + end function calculate_kolb_mdot_thick - + subroutine get_info_for_kolb(b) type(binary_info), pointer :: b integer :: i, indexR @@ -783,7 +783,7 @@ subroutine get_info_for_kolb(b) do while (b% s_donor% r(i) > b% rl(b% d_i)) i=i+1 end do - + if (i .eq. 1) then b% mdot_thick = 0d0 else @@ -842,8 +842,8 @@ subroutine get_info_for_ritter_eccentric(b) real(dp) :: F1, q, q_temp, rho, p, grav, hp, v_th, dm real(dp), DIMENSION(b% anomaly_steps):: mdot0, mdot, Erit, rl_d include 'formats' - - ! Optically thin MT rate adapted for eccentric orbits + + ! Optically thin MT rate adapted for eccentric orbits ! As described in H. Ritter 1988, A&A 202,93-100 and U. Kolb and H. Ritter 1990, A&A 236,385-392 rho = b% s_donor% rho(1) ! density at surface in g/cm^3 @@ -851,7 +851,7 @@ subroutine get_info_for_ritter_eccentric(b) grav = standard_cgrav*b% m(b% d_i)/pow2(b% r(b% d_i)) ! local gravitational acceleration hp = p/(grav*rho) ! pressure scale height v_th = sqrt(kerg * b% s_donor% T(1) / (mp * b% s_donor% mu(1))) ! kerg = Boltzmann's constant - + ! phase dependant RL radius do i = 1, b% anomaly_steps rl_d(i) = b% rl(b% d_i) * (1d0 - pow2(b% eccentricity)) / & @@ -864,8 +864,8 @@ subroutine get_info_for_ritter_eccentric(b) F1 = (1.23d0 + 0.5D0* log10(q_temp)) mdot0 = (2.0D0*pi/exp(0.5d0)) * pow3(v_th) * rl_d*rl_d*rl_d / & - (standard_cgrav*b% m(b% d_i)) * rho * F1 - + (standard_cgrav*b% m(b% d_i)) * rho * F1 + q_temp = min(max(q,0.04d0),20d0) if (q_temp < 1.0d0) then b% ritter_h = hp/( 0.954D0 + 0.025D0*log10(q_temp) - 0.038D0*pow2(log10(q_temp)) ) @@ -888,50 +888,50 @@ subroutine get_info_for_ritter_eccentric(b) mdot(i) = -1 * mdot0(i) * exp(Erit(i)) end do end if - + b% mdot_donor_theta = mdot - + !integrate to get total massloss dm = 0d0 do i = 2,b% anomaly_steps ! trapezoidal integration - dm = dm + 0.5d0 * (mdot(i-1) + mdot(i)) * (b% time_co(i) - b% time_co(i-1)) + dm = dm + 0.5d0 * (mdot(i-1) + mdot(i)) * (b% time_co(i) - b% time_co(i-1)) end do - + b% mdot_thin = dm end subroutine get_info_for_ritter_eccentric - + subroutine get_info_for_kolb_eccentric(b) type(binary_info), pointer :: b real(dp) :: e, dm integer :: i, j real(dp), DIMENSION(b% anomaly_steps):: rl_d_i, mdot_thick_i include 'formats' - + ! Optically thick MT rate adapted for eccentric orbits ! As described in H. Ritter 1988, A&A 202,93-100 and U. Kolb and H. Ritter 1990, A&A 236,385-392 b% mdot_thick = 0d0 e = b% eccentricity - + ! If the radius of the donor is smaller as the smallest RL radius, ! there is only atmospheric RLOF, thus return. if ( b% r(b% d_i) < b% rl(b% d_i) * (1-e*e)/(1+e) ) then return end if - - ! For each point in the orbit calculate mdot_thick + + ! For each point in the orbit calculate mdot_thick do i = 1,b% anomaly_steps ! phase dependent RL radius rl_d_i(i) = b% rl(b% d_i) * (1d0 - e*e) / & (1 + e*cos(b% theta_co(i)) ) - + ! find how deep in the star we are j=1 do while (b% s_donor% r(j) > rl_d_i(i)) j=j+1 end do - + ! calculate mdot_thick if (j .eq. 1) then mdot_thick_i(i) = 0d0 @@ -939,18 +939,18 @@ subroutine get_info_for_kolb_eccentric(b) mdot_thick_i(i) = calculate_kolb_mdot_thick(b, j-1, rl_d_i(i)) end if end do - + b% mdot_donor_theta = b% mdot_donor_theta + mdot_thick_i - + ! Integrate mdot_thick over the orbit dm = 0d0 do i = 2,b% anomaly_steps ! trapezoidal integration dm = dm + 0.5d0 * (mdot_thick_i(i-1) + mdot_thick_i(i)) * & - (b% time_co(i) - b% time_co(i-1)) + (b% time_co(i) - b% time_co(i-1)) end do - + b% mdot_thick = dm - + end subroutine get_info_for_kolb_eccentric subroutine eval_accreted_material_j(binary_id, ierr) @@ -977,7 +977,7 @@ subroutine eval_accreted_material_j(binary_id, ierr) if (b% r(b% a_i) < min_r) then b% accretion_mode = 2 b% s_accretor% accreted_material_j = & - sqrt(standard_cgrav * b% m(b% a_i) * b% r(b% a_i)) + sqrt(standard_cgrav * b% m(b% a_i) * b% r(b% a_i)) else b% accretion_mode = 1 b% s_accretor% accreted_material_j = & @@ -1001,7 +1001,7 @@ subroutine set_accretion_composition(b, acc_index) if (acc_index == b% a_i) then !set accreted material composition b% s_accretor% num_accretion_species = b% s_donor% species - + if(b% s_donor% species > size(b% s_accretor% accretion_species_id,dim=1)) then call mesa_error(__FILE__,__LINE__,'Nuclear network is too large for accretor, increase max_num_accretion_species') end if diff --git a/binary/private/binary_private_def.f90 b/binary/private/binary_private_def.f90 index a0daa0b86..2a50893a1 100644 --- a/binary/private/binary_private_def.f90 +++ b/binary/private/binary_private_def.f90 @@ -24,7 +24,7 @@ ! *********************************************************************** module binary_private_def - + use binary_def implicit none @@ -103,17 +103,17 @@ module binary_private_def integer, parameter :: bh_CE_Ebind2 = bh_CE_Ebind1 + 1 integer, parameter :: bh_CE_num1 = bh_CE_Ebind2 + 1 integer, parameter :: bh_CE_num2 = bh_CE_num1 + 1 - + integer, parameter :: bh_col_id_max = bh_CE_num2 - + character (len=maxlen_binary_history_column_name) :: binary_history_column_name(bh_col_id_max) - + contains - - + + subroutine binary_history_column_names_init(ierr) integer, intent(out) :: ierr - + integer :: i, cnt ierr = 0 cnt = 0 @@ -191,13 +191,13 @@ subroutine binary_history_column_names_init(ierr) binary_history_column_name(bh_CE_Ebind2) = 'CE_Ebind2' binary_history_column_name(bh_CE_num1) = 'CE_num1' binary_history_column_name(bh_CE_num2) = 'CE_num2' - + cnt = 0 do i=1,bh_col_id_max if (len_trim(binary_history_column_name(i)) == 0) then write(*,*) 'missing name for log column id', i if (i > 1) write(*,*) 'following ' // trim(binary_history_column_name(i-1)) - write(*,*) + write(*,*) cnt = cnt+1 end if end do @@ -207,23 +207,23 @@ subroutine binary_history_column_names_init(ierr) return end if - end subroutine binary_history_column_names_init + end subroutine binary_history_column_names_init subroutine binary_private_def_init use num_def use utils_lib, only: get_compiler_version, get_mesasdk_version - integer :: i + integer :: i logical :: okay integer :: ierr - + include 'formats' - + okay = .true. ierr = 0 binary_dt_why_str(1:b_numTlim) = '' - + binary_dt_why_str(b_Tlim_comp) = 'b_companion' binary_dt_why_str(b_Tlim_roche) = 'b_RL' binary_dt_why_str(b_Tlim_jorb) = 'b_jorb' @@ -231,7 +231,7 @@ subroutine binary_private_def_init binary_dt_why_str(b_Tlim_sep) = 'b_separation' binary_dt_why_str(b_Tlim_ecc) = 'b_eccentricity' binary_dt_why_str(b_Tlim_dm) = 'b_deltam' - + do i=1,b_numTlim if (len_trim(binary_dt_why_str(i)) == 0) then if (i > 1) then @@ -242,22 +242,22 @@ subroutine binary_private_def_init okay = .false. end if end do - + if (.not. okay) call mesa_error(__FILE__,__LINE__,'binary_private_def_init') - + !here we store useful information about the compiler and SDK call get_compiler_version(compiler_name,compiler_version_name) call get_mesasdk_version(mesasdk_version_name,ierr) call date_and_time(date=date) - - end subroutine binary_private_def_init - + + end subroutine binary_private_def_init + integer function alloc_binary(ierr) integer, intent(out) :: ierr integer :: i type (binary_info), pointer :: b - + ierr = 0 alloc_binary = -1 !$omp critical (binary_handle) @@ -285,15 +285,15 @@ integer function alloc_binary(ierr) return end if b => binary_handles(alloc_binary) - + end function alloc_binary - - + + subroutine free_binary(b) type (binary_info), pointer :: b binary_handles(b% binary_id)% in_use = .false. end subroutine free_binary - + end module binary_private_def diff --git a/binary/private/binary_tides.f90 b/binary/private/binary_tides.f90 index 011582380..4df51ba02 100644 --- a/binary/private/binary_tides.f90 +++ b/binary/private/binary_tides.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module binary_tides use star_lib @@ -28,13 +28,13 @@ module binary_tides use utils_lib use math_lib use binary_def - + implicit none contains - - + + subroutine sync_spin_orbit_torque(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -43,9 +43,9 @@ subroutine sync_spin_orbit_torque(id, ierr) real(dp) :: qratio ! mass_other_star/mass_this_star real(dp) :: rlr ! roche lobe radius (cm) real(dp) :: dt_next ! next timestep - real(dp) :: Ftid ! efficiency of tidal synchronization. (time scale × FSYNC). + real(dp) :: Ftid ! efficiency of tidal synchronization. (time scale × FSYNC). character (len=strlen) :: sync_type - character (len=strlen) :: sync_mode + character (len=strlen) :: sync_mode type (binary_info), pointer :: b ierr = 0 @@ -90,9 +90,9 @@ subroutine sync_spin_orbit_torque(id, ierr) else call sync_spin_to_orbit(s% id, s% nz, osep, qratio, rlr, dt_next, Ftid, sync_type, sync_mode, ierr) end if - + end subroutine sync_spin_orbit_torque - + subroutine sync_spin_to_orbit(id, nz, osep, qratio, rl, dt_next, Ftid, sync_type, sync_mode, ierr) ! initially based on spiba.f kindly provided by Norbert Langer and group. integer, intent(in) :: id @@ -101,26 +101,26 @@ subroutine sync_spin_to_orbit(id, nz, osep, qratio, rl, dt_next, Ftid, sync_type real(dp), intent(in) :: qratio ! mass_other_star/mass_this_star real(dp), intent(in) :: rl ! roche lobe radius (cm) real(dp), intent(in) :: dt_next ! next timestep - real(dp), intent(in) :: Ftid ! efficiency of tidal synchronization. (time scale / Ftid ). - + real(dp), intent(in) :: Ftid ! efficiency of tidal synchronization. (time scale / Ftid ). + character (len=strlen), intent(in) :: sync_type ! synchronization timescale character (len=strlen), intent(in) :: sync_mode ! where to put/take angular momentum integer, intent(out) :: ierr - + type (star_info), pointer :: s real(dp) :: G, m, t_sync, r_phot, delta_total_J, & sum_J_sync, sum_J_non_sync, tdyn, tkh, rho_face, cv_face, & T_face, csound_face, ff, omega_orb - - real(dp), dimension(nz) :: j_sync, delta_j, tdyn_div_tkh + + real(dp), dimension(nz) :: j_sync, delta_j, tdyn_div_tkh integer, dimension(nz) :: layers_in_sync integer :: k, num_sync_layers type (binary_info), pointer :: b real(dp) :: a1,a2 - + include 'formats' - + ierr = 0 call star_ptr(id, s, ierr) @@ -141,9 +141,9 @@ subroutine sync_spin_to_orbit(id, nz, osep, qratio, rl, dt_next, Ftid, sync_type write(*,*) 'failed in binary_ptr' return end if - + t_sync = 0 - + G = standard_cgrav if (is_donor(b, s)) then @@ -153,12 +153,12 @@ subroutine sync_spin_to_orbit(id, nz, osep, qratio, rl, dt_next, Ftid, sync_type m = b% m(b% a_i) r_phot = b% r(b% a_i) end if - + omega_orb = 2d0*pi/b% period do k=1,nz j_sync(k) = omega_orb*s% i_rot(k)% val end do - + if (sync_type == "Instantaneous") then ! instantaneous synchronisation do k=1,nz delta_j(k) = s% j_rot(k) - j_sync(k) @@ -201,7 +201,7 @@ subroutine sync_spin_to_orbit(id, nz, osep, qratio, rl, dt_next, Ftid, sync_type layers_in_sync(k) = 0 end do delta_total_J = delta_total_J*(1d0 - exp(-dt_next/t_sync)) - + ! Iteratively solve the scaling factor ff to add (or remove) delta_total_J. ! At each iteration, ff is solved such that each zone k has a change on ! its angular momentum J_k of the form: @@ -253,7 +253,7 @@ subroutine sync_spin_to_orbit(id, nz, osep, qratio, rl, dt_next, Ftid, sync_type delta_j(k) = 0d0 end do end if - + end if if (b% point_mass_i /= 1 .and. b% s1% id == s% id) then @@ -270,64 +270,64 @@ subroutine sync_spin_to_orbit(id, nz, osep, qratio, rl, dt_next, Ftid, sync_type s% extra_jdot(k) = s% extra_jdot(k) - delta_j(k)/dt_next end do end if - + end subroutine sync_spin_to_orbit real(dp) function f2(e) real(dp), intent(in) :: e - + f2 = 1d0 ! Hut 1981, A&A, 99, 126, definition of f2 after eq. 11 if (e > 0d0) then f2 = 1d0 + 15d0/2d0*pow2(e) + 45d0/8d0*pow4(e) + 5d0/16d0*pow6(e) end if - + end function f2 - + real(dp) function f3(e) real(dp), intent(in) :: e - + f3 = 1d0 ! Hut 1981, A&A, 99, 126, definition of f3 after eq. 11 if (e > 0d0) then f3 = 1d0 + 15d0/4d0*pow2(e) + 15d0/8d0*pow4(e) + 5d0/64d0*pow6(e) end if - + end function f3 - - + + real(dp) function f4(e) real(dp), intent(in) :: e - + f4 = 1d0 ! Hut 1981, A&A, 99, 126, definition of f4 after eq. 11 if (e > 0d0) then f4 = 1d0 + 3d0/2d0*pow2(e) + 1d0/8d0*pow4(e) end if - + end function f4 - + real(dp) function f5(e) real(dp), intent(in) :: e - + f5 = 1d0 ! Hut 1981, A&A, 99, 126, definition of f5 after eq. 11 if (e > 0d0) then f5 = 1d0 + 3d0*pow2(e) + 3d0/8d0*pow4(e) end if - + end function f5 - + subroutine get_tsync(id, sync_type, Ftid, qratio, m, r_phot, osep, t_sync, ierr) integer, intent(in) :: id character (len=strlen), intent(in) :: sync_type ! synchronization timescale - real(dp), intent(in) :: Ftid ! efficiency of tidal synchronization. (time scale / Ftid ). + real(dp), intent(in) :: Ftid ! efficiency of tidal synchronization. (time scale / Ftid ). real(dp), intent(in) :: qratio ! mass_other_star/mass_this_star real(dp), intent(in) :: m real(dp), intent(in) :: r_phot @@ -338,9 +338,9 @@ subroutine get_tsync(id, sync_type, Ftid, qratio, m, r_phot, osep, t_sync, ierr) type (binary_info), pointer :: b type (star_info), pointer :: s integer :: k - + include 'formats' - + ierr = 0 call star_ptr(id, s, ierr) @@ -455,9 +455,9 @@ real(dp) function k_div_T(b, s, has_convective_envelope, ierr) ! E2 from Hurley 2002 eq 43 based on Zahn 1975 e2 = 1.592d-9*pow(m/Msun,2.84d0) end if - k_div_T = k_div_T*e2/secyer + k_div_T = k_div_T*e2/secyer end if - + end function k_div_T end module binary_tides diff --git a/binary/private/binary_timestep.f90 b/binary/private/binary_timestep.f90 index 5f2ab5d31..89f94510d 100644 --- a/binary/private/binary_timestep.f90 +++ b/binary/private/binary_timestep.f90 @@ -99,13 +99,13 @@ subroutine set_star_timesteps(b) ! sets the smallest next timestep for all stars end if b% have_to_reduce_timestep_due_to_j = .false. end if - + end subroutine set_star_timesteps integer function binary_pick_next_timestep(b) type (binary_info), pointer :: b type (star_info), pointer :: s - + real(dp) :: & env_change, dtm, dtj, dta, dtr, dte, dtdm, & j_change, sep_change, rel_gap_change, e_change, set_dt, & @@ -137,19 +137,19 @@ integer function binary_pick_next_timestep(b) else env_change = 0 end if - + if (b% rl_relative_gap_old(b% d_i) /= 0) then rel_gap_change = b% rl_relative_gap_old(b% d_i) - b% rl_relative_gap(b% d_i) else rel_gap_change = 0 end if - + if (b% angular_momentum_j_old /= 0) then j_change = b% angular_momentum_j - b% angular_momentum_j_old else j_change = 0 end if - + if (b% separation_old /= 0) then sep_change = b% separation - b% separation_old else @@ -167,7 +167,7 @@ integer function binary_pick_next_timestep(b) sep_change = 0 e_change = 0 end if - + ! get limits for dt based on relative changes if (b% fj > 0) then rel_change = abs(j_change/b% angular_momentum_j) @@ -193,7 +193,7 @@ integer function binary_pick_next_timestep(b) end if dtm = s% time_step/(rel_change/(b% fm * b% time_delta_coeff)+1d-99) end if - + if (b% fr > 0) then rel_change = abs(rel_gap_change/max(abs(b% rl_relative_gap(b% d_i)), b% fr_limit)) if (.not. b% ignore_hard_limits_this_step .and. & @@ -324,8 +324,8 @@ integer function binary_pick_next_timestep(b) end if b% ignore_hard_limits_this_step = .false. - + end function binary_pick_next_timestep - + end module binary_timestep diff --git a/binary/private/binary_utils.f90 b/binary/private/binary_utils.f90 index c6aaae92c..bd56e44cf 100644 --- a/binary/private/binary_utils.f90 +++ b/binary/private/binary_utils.f90 @@ -148,7 +148,7 @@ subroutine set_m2(binary_id, m2, ierr) b% m(2) = m2*Msun call set_separation_eccentricity(binary_id, b% separation, b% eccentricity, ierr) end subroutine set_m2 - + subroutine set_period_eccentricity(binary_id, period, eccentricity, ierr) integer, intent(in) :: binary_id real(dp) :: period ! in seconds @@ -165,7 +165,7 @@ subroutine set_period_eccentricity(binary_id, period, eccentricity, ierr) call set_angular_momentum_j(binary_id) end subroutine set_period_eccentricity - + subroutine set_separation_eccentricity(binary_id, separation, eccentricity, ierr) integer, intent(in) :: binary_id real(dp) :: separation ! in cm @@ -183,7 +183,7 @@ subroutine set_separation_eccentricity(binary_id, separation, eccentricity, ierr call set_angular_momentum_j(binary_id) end subroutine set_separation_eccentricity - + subroutine set_angular_momentum_j(binary_id) ! Sets b% angular_momentum_j in terms of the masses, separation and eccentricity ! also sets the Roche lobe sizes and relative overflows @@ -199,7 +199,7 @@ subroutine set_angular_momentum_j(binary_id) b% rl(1) = eval_rlobe(b% m(1), b% m(2), b% separation) b% rl(2) = eval_rlobe(b% m(2), b% m(1), b% separation) b% rl_relative_gap(1) = (b% r(1) - b% rl(1) * (1 - b% eccentricity) ) / & - b% rl(1) / (1 - b% eccentricity) ! gap < 0 means out of contact + b% rl(1) / (1 - b% eccentricity) ! gap < 0 means out of contact b% rl_relative_gap(2) = (b% r(2) - b% rl(2) * (1 - b% eccentricity) ) / & b% rl(2) / (1 - b% eccentricity) ! gap < 0 means out of contact diff --git a/binary/private/binary_wind.f90 b/binary/private/binary_wind.f90 index 40e437566..9fd81695e 100644 --- a/binary/private/binary_wind.f90 +++ b/binary/private/binary_wind.f90 @@ -24,16 +24,16 @@ ! *********************************************************************** module binary_wind - + use star_lib use star_def use math_lib use binary_def - + implicit none contains - + subroutine eval_wind_xfer_fractions(binary_id, ierr) integer, intent(in) :: binary_id integer, intent(out) :: ierr @@ -44,7 +44,7 @@ subroutine eval_wind_xfer_fractions(binary_id, ierr) write(*,*) 'failed in binary_ptr' return end if - + ! for the primary if (b% point_mass_i /= 1) then if (.not. b% do_wind_mass_transfer_1 .or. b% model_twins_flag) then @@ -63,7 +63,7 @@ subroutine eval_wind_xfer_fractions(binary_id, ierr) end if end if end if - + ! check if secondary needs wind transfer if (b% point_mass_i /= 2) then if (.not. b% do_wind_mass_transfer_2) then @@ -82,9 +82,9 @@ subroutine eval_wind_xfer_fractions(binary_id, ierr) end if end if end if - + end subroutine eval_wind_xfer_fractions - + subroutine Bondi_Hoyle_wind_transfer(binary_id, s_i, ierr) integer, intent(in) :: binary_id, s_i ! s_i is index of the wind mass losing star integer, intent(out) :: ierr @@ -103,7 +103,7 @@ subroutine Bondi_Hoyle_wind_transfer(binary_id, s_i, ierr) write(*,*) 'failed in binary_ptr' return end if - + if (s_i == 1) then s => b% s1 alpha = b% wind_BH_alpha_1 @@ -115,24 +115,24 @@ subroutine Bondi_Hoyle_wind_transfer(binary_id, s_i, ierr) beta = b% wind_BH_beta_2 max_xfer = b% max_wind_transfer_fraction_2 end if - + ! orbital speed Hurley et al 2002 eq. 8 v_orb = sqrt(standard_cgrav * (b% m(1) + b% m(2)) / b% separation) !cm/s - + ! windspeed from Hurley et al 2002 eq. 9 v_wind = sqrt(2d0 * beta * standard_cgrav * b% m(s_i) / b% r(s_i)) - + ! Bondi-Hoyle transfer fraction Hurley et al. 2002 eq. 6 b% wind_xfer_fraction(s_i) = alpha / pow2(b% separation) /& (2d0 * sqrt(1d0 - pow2(b% eccentricity))) *& pow2(standard_cgrav * b% m(3-s_i) / pow2(v_wind)) *& pow(1d0 + pow2(v_orb/v_wind),-1.5d0) - + ! limit to provided maximum b% wind_xfer_fraction(s_i) = min(max_xfer, b% wind_xfer_fraction(s_i)) - + end subroutine Bondi_Hoyle_wind_transfer - + subroutine Tout_enhance_wind(b, s) type (binary_info), pointer :: b type (star_info), pointer :: s @@ -153,26 +153,26 @@ subroutine Tout_enhance_wind(b, s) B_wind = b% tout_B_wind_2 s_i = 2 end if - + do i = 1,b% anomaly_steps !limit radius / roche lobe ! phase dependent roche lobe radius rl_d(i) = (1d0-pow2(b%eccentricity)) / (1+b%eccentricity*cos(b% theta_co(i))) * b% rl(s_i) r_rl(i) = min(pow6(b% r(s_i) / rl_d(i)), pow6(0.5d0)) end do - + ! actual enhancement mdot = s% mstar_dot * (1 + B_wind * r_rl) - + dm = 0d0 do i = 2,b% anomaly_steps ! trapezoidal integration - dm = dm + 0.5d0 * (mdot(i-1) + mdot(i)) * (b% time_co(i) - b% time_co(i-1)) + dm = dm + 0.5d0 * (mdot(i-1) + mdot(i)) * (b% time_co(i) - b% time_co(i-1)) end do - + ! remember mass-loss is negative! !b% mdot_wind_theta = b% mdot_wind_theta + mdot ! store theta dependance for edot s% mstar_dot = dm ! return enhanced wind mass loss - + end subroutine Tout_enhance_wind - + end module binary_wind - + diff --git a/binary/private/pgbinary_ctrls_io.f90 b/binary/private/pgbinary_ctrls_io.f90 index 3981feee3..2746a9e35 100644 --- a/binary/private/pgbinary_ctrls_io.f90 +++ b/binary/private/pgbinary_ctrls_io.f90 @@ -1434,7 +1434,7 @@ recursive subroutine read_pgbinary_file(b, filename, level, ierr) read_extra_pgbinary_inlist(i) = .false. extra(i) = extra_pgbinary_inlist_name(i) extra_pgbinary_inlist_name(i) = 'undefined' - + if (read_extra(i)) then call read_pgbinary_file(b, extra(i), level+1, ierr) if (ierr /= 0) return diff --git a/binary/private/pgbinary_orbit.f90 b/binary/private/pgbinary_orbit.f90 index f5d5b4754..ac7463a69 100644 --- a/binary/private/pgbinary_orbit.f90 +++ b/binary/private/pgbinary_orbit.f90 @@ -24,16 +24,16 @@ ! *********************************************************************** module pgbinary_orbit - + use binary_private_def use pgbinary_support - + implicit none contains - - + + subroutine Orbit_plot(id, device_id, ierr) integer, intent(in) :: id, device_id integer, intent(out) :: ierr @@ -51,8 +51,8 @@ subroutine Orbit_plot(id, device_id, ierr) if (ierr /= 0) return call pgebuf() end subroutine Orbit_plot - - + + subroutine do_Orbit_plot(b, id, device_id, & winxmin, winxmax, winymin, winymax, subplot, title, txt_scale, ierr) type (binary_info), pointer :: b @@ -64,14 +64,14 @@ subroutine do_Orbit_plot(b, id, device_id, & call orbit_panel(b, device_id, & winxmin, winxmax, winymin, winymax, subplot, title, txt_scale, ierr) end subroutine do_Orbit_plot - - + + subroutine orbit_panel(b, device_id, & winxmin, winxmax, winymin, winymax, subplot, title, txt_scale, ierr) - + use num_lib, only : safe_root_with_guess use math_lib, only : pow - + type (binary_info), pointer :: b integer, intent(in) :: device_id real, intent(in) :: winxmin, winxmax, winymin, winymax, txt_scale @@ -88,9 +88,9 @@ subroutine orbit_panel(b, device_id, & integer, pointer :: ipar(:) ! (lipar) real(dp), pointer :: rpar(:) ! (lrpar) real(dp) :: cosp, q, this_psi, xl1 - + include 'formats' - + ierr = 0 call pgsave call pgsvp(winxmin, winxmax, winymin, winymax) @@ -100,17 +100,17 @@ subroutine orbit_panel(b, device_id, & end if call show_title_pgbinary(b, title) call pgunsa - + a1 = 1 / (1 + b% m(1) / b% m(2)) a2 = 1 / (1 + b% m(2) / b% m(1)) e = b% eccentricity - + !$OMP PARALLEL DO PRIVATE(i) SCHEDULE(dynamic,2) do i = 1, num_points thetas(i) = (i - 0.5) * pi / num_points r1s(i) = a1 * (1 - e**2) / (1 + e * cos(thetas(i))) r2s(i) = a2 / a1 * r1s(i) - + x1s(i) = -r1s(i) * cos(thetas(i)) ! minus to flip orbit x1s(2 * num_points - i + 1) = x1s(i) y1s(i) = -r1s(i) * sin(thetas(i)) @@ -125,11 +125,11 @@ subroutine orbit_panel(b, device_id, & y1s(2 * num_points + 1) = y1s(1) x2s(2 * num_points + 1) = x2s(1) y2s(2 * num_points + 1) = y2s(1) - + x1max = maxval(abs(x1s)) x2max = maxval(abs(x2s)) xmax = max(x1max, x2max) - + q = b% m(2) / b% m(1) if (b% pg% Orbit_show_stars .and. abs(log10(q)) <= 2) then if (b% point_mass_i /= 1) then @@ -144,7 +144,7 @@ subroutine orbit_panel(b, device_id, & 50, 100, 1d-6, 1d-8, & ! i_next, imax, x_tol, y_tol 0, rpar, 0, ipar, & ! func_params ierr) - + x1s_RL(i) = rs(i) * cosp y1s_RL(i) = rs(i) * sin(phis(i)) y1s_RL(2 * num_points - i + 1) = -y1s_RL(i) @@ -169,7 +169,7 @@ subroutine orbit_panel(b, device_id, & x1s_RL = 0d0 y1s_RL = 0d0 end if - + if (b% point_mass_i /= 2) then q = 1d0 / q ! flip q for other star this_psi = Psi_fit(b% r(2) / b% separation, q) @@ -183,7 +183,7 @@ subroutine orbit_panel(b, device_id, & 25, 50, 1d-4, 1d-6, & ! i_next, imax, x_tol, y_tol 0, rpar, 0, ipar, & ! func_params ierr) - + x2s_RL(i) = rs(i) * cosp y2s_RL(i) = rs(i) * sin(phis(i)) y2s_RL(2 * num_points - i + 1) = -y2s_RL(i) @@ -211,7 +211,7 @@ subroutine orbit_panel(b, device_id, & else if (b% pg% Orbit_show_stars .and. abs(log10(q)) > 2) then write(*, 1) "pgbinary: Not plotting RL, q too extreme: abs(log(q)) = ", abs(log10(q)) end if - + call pgsave call pgsci(1) call pgscf(1) @@ -221,7 +221,7 @@ subroutine orbit_panel(b, device_id, & call show_box_pgbinary(b, 'BCSTN', 'BCSTNMV') call show_xaxis_label_pgbinary(b, 'separation') call show_left_yaxis_label_pgbinary(b, 'separation') - + call pgsci(clr_Goldenrod) call pgline(2 * num_points + 1, x1s, y1s) call pgslw(1) @@ -229,7 +229,7 @@ subroutine orbit_panel(b, device_id, & call pgsci(clr_LightSkyBlue) call pgslw(b% pg% pgbinary_lw / 2) call pgline(2 * num_points + 1, x2s, y2s) - + if (b% pg% Orbit_show_stars .and. abs(log10(q)) <= 2) then call pgslw(int(2.0 * b% pg% pgbinary_lw / 3.0)) call pgsfs(3) @@ -241,29 +241,29 @@ subroutine orbit_panel(b, device_id, & call pgline(2 * num_points + 1, x2s_RL, y2s_RL) call pgpoly(2 * num_points + 1, x2s_RL, y2s_RL) end if - + call pgslw(1) call pgmtxt('T', -2.0 - 1.3, 0.05, 0.0, 'Star 2') - + call pgsci(1) call pgpt1(0.0, 0.0, 5) call pgunsa - + contains - + real function xl1_fit(q) real(dp), intent(in) :: q real(dp) :: logq - + logq = log10(q) if (q > 1) logq = -logq xl1_fit = - 1.72452947 / pi * atan(logq * 0.21625699) + 0.5 & + 0.01559149 * logq & - 1.3924d-05 * logq * (logq + 1.5) * (logq + 4.0) if (q > 1) xl1_fit = 1 - xl1_fit - + end function xl1_fit - + real(dp) function Psi_fit(req, q) ! fit of Roche potential versus q = m_other / m_this and r_eq, the & ! dimensionless volume equivalent radius (== r / separation of the model) @@ -273,15 +273,15 @@ real(dp) function Psi_fit(req, q) - 0.3642 * req ** 2 * (req ** 2 - 1) & - 1.8693 * req * (req - 0.1) * (req - 0.3) * (req - 0.7) * (req - 1.0414) end function Psi_fit - + real(dp) function roche(r, cosp) real(dp), intent(in) :: r, cosp - + roche = -1d0 / r & - q * (pow(1 - 2 * r * cosp + r**2, -0.5d0) - r * cosp) & - (1 + q) / 2 * r**2 end function roche - + real(dp) function f(r, dfdx, lrpar, rpar, lipar, ipar, ierr) real(dp), intent(in) :: r integer, intent(in) :: lrpar, lipar @@ -289,14 +289,14 @@ real(dp) function f(r, dfdx, lrpar, rpar, lipar, ipar, ierr) integer, intent(inout), pointer :: ipar(:) ! (lipar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(out) :: ierr - + f = roche(r, cosp) - this_psi dfdx = 1d0 / r**2 & + q * (pow(1 - 2 * r * cosp + r**2, -1.5d0) * (r - cosp) + cosp) & - (1 + q) * r ierr = 0 end function f - + end subroutine orbit_panel diff --git a/binary/private/pgbinary_stub.f90 b/binary/private/pgbinary_stub.f90 index 689216549..36dcb4b6f 100644 --- a/binary/private/pgbinary_stub.f90 +++ b/binary/private/pgbinary_stub.f90 @@ -83,7 +83,7 @@ subroutine do_create_file_name(b, dir, prefix, name) character (len = *), intent(out) :: name name = '' end subroutine do_create_file_name - + subroutine do_write_plot_to_file(b, p, filename, ierr) @@ -121,7 +121,7 @@ subroutine do_restart_run_for_pgbinary(b, ierr) integer, intent(out) :: ierr logical :: fexists ierr = 0 - + end subroutine do_restart_run_for_pgbinary @@ -130,7 +130,7 @@ subroutine do_read_pgbinary_controls(b, inlist_fname, ierr) character(*), intent(in) :: inlist_fname integer, intent(out) :: ierr ierr = 0 - + end subroutine do_read_pgbinary_controls @@ -138,7 +138,7 @@ subroutine set_win_file_data(b, ierr) type (binary_info), pointer :: b integer, intent(out) :: ierr ierr = 0 - + end subroutine set_win_file_data @@ -190,7 +190,7 @@ subroutine update_pgbinary_history_file(b, ierr) include 'formats' ierr = 0 - + end subroutine update_pgbinary_history_file diff --git a/binary/private/pgbinary_summary.f90 b/binary/private/pgbinary_summary.f90 index b040207b1..58d8d14f1 100644 --- a/binary/private/pgbinary_summary.f90 +++ b/binary/private/pgbinary_summary.f90 @@ -403,7 +403,7 @@ subroutine show_column(col, num_rows) real(dp) :: val call get_binary_history_specs(& - b, num_rows, Text_Summary_name(:, col), specs) + b, num_rows, Text_Summary_name(:, col), specs, .false.) call get_binary_history_values(& b, num_rows, specs, & is_int_value, int_values, values, failed_to_find_value) diff --git a/binary/private/run_binary_support.f90 b/binary/private/run_binary_support.f90 index d84f375d0..ef6a91c2f 100644 --- a/binary/private/run_binary_support.f90 +++ b/binary/private/run_binary_support.f90 @@ -290,7 +290,7 @@ end subroutine extras_binary_controls call binarydata_init(b, doing_restart) call binary_private_def_init call binary_history_column_names_init(ierr) - call set_binary_history_columns(b, b% job% binary_history_columns_file, ierr) + call set_binary_history_columns(b, b% job% binary_history_columns_file, .true., ierr) ! setup pgbinary if (.not. doing_restart) then diff --git a/binary/public/binary_def.f90 b/binary/public/binary_def.f90 index 24dae35d1..b5088f2cf 100644 --- a/binary/public/binary_def.f90 +++ b/binary/public/binary_def.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -32,13 +32,13 @@ module binary_def real(dp) :: initial_binary_period ! (seconds) real(dp) :: min_binary_period ! (seconds) - + real(dp) :: initial_mass(2) ! (msun) integer, parameter :: maxlen_binary_history_column_name = 80 integer, parameter :: binary_num_xtra_vals = 30 integer, parameter :: binary_num_x_ctrls = 100 - + ! time_step limit identifiers integer, parameter :: b_Tlim_comp = 1 integer, parameter :: b_Tlim_roche = b_Tlim_comp + 1 @@ -50,7 +50,7 @@ module binary_def integer, parameter :: b_numTlim = b_Tlim_dm character (len=24) :: binary_dt_why_str(b_numTlim) ! indicates the reson for the timestep choice - + !interfaces for procedure pointers abstract interface @@ -60,7 +60,7 @@ subroutine other_rlo_mdot_interface(binary_id, rlo_mdot, ierr) real(dp), intent(out) :: rlo_mdot integer, intent(out) :: ierr end subroutine other_rlo_mdot_interface - + integer function other_check_implicit_rlo_interface(binary_id, new_mdot) use const_def, only: dp integer, intent(in) :: binary_id @@ -151,26 +151,26 @@ end subroutine other_CE_rlo_mdot_interface integer function other_CE_binary_evolve_step_interface(binary_id) integer, intent(in) :: binary_id end function other_CE_binary_evolve_step_interface - + integer function other_CE_binary_finish_step_interface(binary_id) integer, intent(in) :: binary_id end function other_CE_binary_finish_step_interface - + integer function extras_binary_startup_interface(binary_id,restart,ierr) integer, intent(in) :: binary_id integer, intent(out) :: ierr - logical,intent(in) :: restart + logical,intent(in) :: restart end function extras_binary_startup_interface - + integer function extras_binary_start_step_interface(binary_id, ierr) integer, intent(in) :: binary_id integer, intent(out) :: ierr end function extras_binary_start_step_interface - + integer function extras_binary_check_model_interface(binary_id) integer, intent(in) :: binary_id end function extras_binary_check_model_interface - + integer function extras_binary_finish_step_interface(binary_id) integer, intent(in) :: binary_id end function extras_binary_finish_step_interface @@ -195,7 +195,7 @@ subroutine other_e2_interface(id, e2, ierr) real(dp),intent (out) :: e2 integer, intent(out) :: ierr end subroutine other_e2_interface - + subroutine other_pgbinary_plots_info_interface(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -225,8 +225,8 @@ end subroutine other_pgbinary_plots_info_interface integer, parameter :: max_binary_handles = 10 ! this can be increased as necessary type (binary_info), target, save :: binary_handles(max_binary_handles) ! gfortran seems to require "save" here. at least it did once upon a time. - - + + contains subroutine binary_ptr(binary_id, b, ierr) @@ -240,7 +240,7 @@ end subroutine binary_ptr subroutine get_binary_ptr(binary_id, b, ierr) integer, intent(in) :: binary_id type (binary_info), pointer :: b - integer, intent(out) :: ierr + integer, intent(out) :: ierr if (binary_id < 1 .or. binary_id > max_binary_handles) then ierr = -1 return @@ -248,16 +248,16 @@ subroutine get_binary_ptr(binary_id, b, ierr) b => binary_handles(binary_id) ierr = 0 end subroutine get_binary_ptr - + logical function is_donor(b, s) type (binary_info), pointer :: b type (star_info), pointer :: s is_donor = (s% id == b% d_i) end function is_donor - + subroutine init_binary_data - + end subroutine init_binary_data end module binary_def diff --git a/binary/public/binary_lib.f90 b/binary/public/binary_lib.f90 index 688cbb441..c969b4c6a 100644 --- a/binary/public/binary_lib.f90 +++ b/binary/public/binary_lib.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,12 +19,12 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module binary_lib use const_def - + implicit none contains @@ -36,33 +36,33 @@ subroutine run1_binary(tst, & extras_binary_controls, & ierr, & inlist_fname_arg) - + use run_binary_support, only: do_run1_binary use binary_def, only: init_binary_data use star_def, only: star_info - + logical, intent(in) :: tst - + interface subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - end subroutine extras_controls + end subroutine extras_controls subroutine extras_binary_controls(binary_id, ierr) integer :: binary_id integer, intent(out) :: ierr - end subroutine extras_binary_controls + end subroutine extras_binary_controls end interface - + integer, intent(out) :: ierr character (len=*) :: inlist_fname_arg optional inlist_fname_arg call init_binary_data - + call do_run1_binary(tst, & ! star extras extras_controls, & @@ -70,9 +70,9 @@ end subroutine extras_binary_controls extras_binary_controls, & ierr, & inlist_fname_arg) - + end subroutine run1_binary - + subroutine binary_set_ignore_rlof_flag(binary_id, ignore_rlof_flag, ierr) use binary_utils, only:set_ignore_rlof_flag integer, intent(in) :: binary_id @@ -82,7 +82,7 @@ subroutine binary_set_ignore_rlof_flag(binary_id, ignore_rlof_flag, ierr) ierr = 0 call set_ignore_rlof_flag(binary_id, ignore_rlof_flag, ierr) end subroutine binary_set_ignore_rlof_flag - + subroutine binary_set_point_mass_i(binary_id, point_mass_i, ierr) use binary_utils, only:set_point_mass_i integer, intent(in) :: binary_id @@ -92,7 +92,7 @@ subroutine binary_set_point_mass_i(binary_id, point_mass_i, ierr) ierr = 0 call set_point_mass_i(binary_id, point_mass_i, ierr) end subroutine binary_set_point_mass_i - + subroutine binary_set_m1(binary_id, m1, ierr) use binary_utils, only:set_m1 integer, intent(in) :: binary_id @@ -102,7 +102,7 @@ subroutine binary_set_m1(binary_id, m1, ierr) ierr = 0 call set_m1(binary_id, m1, ierr) end subroutine binary_set_m1 - + subroutine binary_set_m2(binary_id, m2, ierr) use binary_utils, only:set_m2 integer, intent(in) :: binary_id @@ -112,7 +112,7 @@ subroutine binary_set_m2(binary_id, m2, ierr) ierr = 0 call set_m2(binary_id, m2, ierr) end subroutine binary_set_m2 - + subroutine binary_set_period_eccentricity(binary_id, period, eccentricity, ierr) use binary_utils, only:set_period_eccentricity integer, intent(in) :: binary_id @@ -121,7 +121,7 @@ subroutine binary_set_period_eccentricity(binary_id, period, eccentricity, ierr) integer, intent(out) :: ierr call set_period_eccentricity(binary_id, period, eccentricity, ierr) end subroutine binary_set_period_eccentricity - + subroutine binary_set_separation_eccentricity(binary_id, separation, eccentricity, ierr) use binary_utils, only:set_separation_eccentricity integer, intent(in) :: binary_id diff --git a/binary/test_suite/double_bh/src/binary_run.f90 b/binary/test_suite/double_bh/src/binary_run.f90 index b542b6138..04599f3ed 100644 --- a/binary/test_suite/double_bh/src/binary_run.f90 +++ b/binary/test_suite/double_bh/src/binary_run.f90 @@ -1,6 +1,6 @@ program binary_run use run_binary, only: do_run_binary - + call do_run_binary(.true.) - + end program diff --git a/binary/test_suite/double_bh/src/run_binary_extras.f90 b/binary/test_suite/double_bh/src/run_binary_extras.f90 index e77648ada..9ca845bb2 100644 --- a/binary/test_suite/double_bh/src/run_binary_extras.f90 +++ b/binary/test_suite/double_bh/src/run_binary_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -18,8 +18,8 @@ ! along with this software; if not, write to the free software ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! -! *********************************************************************** - module run_binary_extras +! *********************************************************************** + module run_binary_extras use star_lib use binary_lib @@ -27,7 +27,7 @@ module run_binary_extras use const_def use math_lib use binary_def - + implicit none include "binary_test_suite_extras_def.inc" @@ -65,7 +65,7 @@ subroutine extras_binary_controls(binary_id, ierr) ! Once you have set the function pointers you want, then uncomment this (or set it in your star_job inlist) ! to disable the printed warning message, b% warn_binary_extra =.false. - + end subroutine extras_binary_controls @@ -96,7 +96,7 @@ integer function how_many_extra_binary_history_columns(binary_id) integer, intent(in) :: binary_id how_many_extra_binary_history_columns = 0 end function how_many_extra_binary_history_columns - + subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr) use const_def, only: dp type (binary_info), pointer :: b @@ -112,10 +112,10 @@ subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr write(*,*) 'failed in binary_ptr' return end if - + end subroutine data_for_extra_binary_history_columns - - + + integer function extras_binary_startup(binary_id,restart,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -141,9 +141,9 @@ integer function extras_binary_start_step(binary_id,ierr) if (ierr /= 0) then ! failure in binary_ptr return end if - + end function extras_binary_start_step - + !Return either keep_going, retry or terminate integer function extras_binary_check_model(binary_id) type (binary_info), pointer :: b @@ -152,12 +152,12 @@ integer function extras_binary_check_model(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_check_model = keep_going - + end function extras_binary_check_model - - + + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. integer function extras_binary_finish_step(binary_id) @@ -257,9 +257,9 @@ integer function extras_binary_finish_step(binary_id) end if extras_binary_finish_step = keep_going - + end function extras_binary_finish_step - + subroutine extras_binary_after_evolve(binary_id, ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -267,10 +267,10 @@ subroutine extras_binary_after_evolve(binary_id, ierr) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if call test_suite_after_evolve(b, ierr) - - end subroutine extras_binary_after_evolve - + + end subroutine extras_binary_after_evolve + end module run_binary_extras diff --git a/binary/test_suite/double_bh/src/run_star_extras.f90 b/binary/test_suite/double_bh/src/run_star_extras.f90 index ef405e770..5b79295bc 100644 --- a/binary/test_suite/double_bh/src/run_star_extras.f90 +++ b/binary/test_suite/double_bh/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,8 +19,8 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - - module run_star_extras + + module run_star_extras use star_lib use star_def @@ -28,9 +28,9 @@ module run_star_extras use chem_def use binary_def use math_lib - + implicit none - + contains subroutine extras_controls(id, ierr) @@ -41,7 +41,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_start_step => extras_start_step s% extras_check_model => extras_check_model @@ -50,11 +50,11 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% other_wind => brott_wind end subroutine extras_controls - + subroutine brott_wind(id, Lsurf, Msurf, Rsurf, Tsurf, X, Y, Z, w, ierr) use star_def integer, intent(in) :: id @@ -145,7 +145,7 @@ subroutine eval_Vink_wind(w) alfa = (T1 - (Teff_jump - dT)) / (2*dT) end if end if - + if (alfa > 0) then ! eval hot side wind (eqn 24) vinf_div_vesc = 2.6d0 ! this is the hot side galactic value vinf_div_vesc = vinf_div_vesc*pow(Z_div_Z_solar,0.13d0) ! corrected for Z @@ -161,7 +161,7 @@ subroutine eval_Vink_wind(w) else w1 = 0 end if - + if (alfa < 1) then ! eval cool side wind (eqn 25) vinf_div_vesc = 1.3d0 ! this is the cool side galactic value vinf_div_vesc = vinf_div_vesc*pow(Z_div_Z_solar,0.13d0) ! corrected for Z @@ -176,9 +176,9 @@ subroutine eval_Vink_wind(w) else w2 = 0 end if - + w = alfa*w1 + (1 - alfa)*w2 - + end subroutine eval_Vink_wind subroutine eval_Nieuwenhuijzen_wind(w) @@ -207,7 +207,7 @@ subroutine eval_Hamann_wind(w) end subroutine eval_Hamann_wind end subroutine brott_wind - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -240,8 +240,8 @@ integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -251,13 +251,13 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) ierr = 0 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer, intent(in) :: id, n, nz character (len=maxlen_profile_column_name) :: names(n) @@ -266,7 +266,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer :: k ierr = 0 end subroutine data_for_extra_profile_columns - + integer function extras_finish_step(id) integer, intent(in) :: id @@ -278,8 +278,8 @@ integer function extras_finish_step(id) extras_finish_step = keep_going end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -289,7 +289,7 @@ subroutine extras_after_evolve(id, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine extras_after_evolve - + end module run_star_extras - + diff --git a/binary/test_suite/evolve_both_stars/src/binary_run.f90 b/binary/test_suite/evolve_both_stars/src/binary_run.f90 index b542b6138..04599f3ed 100644 --- a/binary/test_suite/evolve_both_stars/src/binary_run.f90 +++ b/binary/test_suite/evolve_both_stars/src/binary_run.f90 @@ -1,6 +1,6 @@ program binary_run use run_binary, only: do_run_binary - + call do_run_binary(.true.) - + end program diff --git a/binary/test_suite/evolve_both_stars/src/run_binary_extras.f90 b/binary/test_suite/evolve_both_stars/src/run_binary_extras.f90 index a7c02bfea..ebe427978 100644 --- a/binary/test_suite/evolve_both_stars/src/run_binary_extras.f90 +++ b/binary/test_suite/evolve_both_stars/src/run_binary_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -18,23 +18,23 @@ ! along with this software; if not, write to the free software ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! -! *********************************************************************** - module run_binary_extras +! *********************************************************************** + module run_binary_extras use star_lib use star_def use const_def use math_lib use binary_def - + implicit none - + include "binary_test_suite_extras_def.inc" contains include "binary_test_suite_extras.inc" - + subroutine extras_binary_controls(binary_id, ierr) integer :: binary_id integer, intent(out) :: ierr @@ -64,7 +64,7 @@ subroutine extras_binary_controls(binary_id, ierr) ! Once you have set the function pointers you want, then uncomment this (or set it in your star_job inlist) ! to disable the printed warning message, b% warn_binary_extra =.false. - + end subroutine extras_binary_controls @@ -95,7 +95,7 @@ integer function how_many_extra_binary_history_columns(binary_id) integer, intent(in) :: binary_id how_many_extra_binary_history_columns = 0 end function how_many_extra_binary_history_columns - + subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr) use const_def, only: dp type (binary_info), pointer :: b @@ -111,10 +111,10 @@ subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr write(*,*) 'failed in binary_ptr' return end if - + end subroutine data_for_extra_binary_history_columns - - + + integer function extras_binary_startup(binary_id,restart,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -127,7 +127,7 @@ integer function extras_binary_startup(binary_id,restart,ierr) end if call test_suite_startup(b, restart, ierr) - + extras_binary_startup = keep_going end function extras_binary_startup @@ -141,9 +141,9 @@ integer function extras_binary_start_step(binary_id,ierr) if (ierr /= 0) then ! failure in binary_ptr return end if - + end function extras_binary_start_step - + !Return either keep_going, retry or terminate integer function extras_binary_check_model(binary_id) type (binary_info), pointer :: b @@ -152,12 +152,12 @@ integer function extras_binary_check_model(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_check_model = keep_going - + end function extras_binary_check_model - - + + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. integer function extras_binary_finish_step(binary_id) @@ -167,11 +167,11 @@ integer function extras_binary_finish_step(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_finish_step = keep_going - + end function extras_binary_finish_step - + subroutine extras_binary_after_evolve(binary_id, ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -179,12 +179,12 @@ subroutine extras_binary_after_evolve(binary_id, ierr) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if - - + end if + + call test_suite_after_evolve(b, ierr) - end subroutine extras_binary_after_evolve - + end subroutine extras_binary_after_evolve + end module run_binary_extras diff --git a/binary/test_suite/evolve_both_stars/src/run_star_extras.f90 b/binary/test_suite/evolve_both_stars/src/run_star_extras.f90 index 42925185b..8d91b5cba 100644 --- a/binary/test_suite/evolve_both_stars/src/run_star_extras.f90 +++ b/binary/test_suite/evolve_both_stars/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,8 +19,8 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - - module run_star_extras + + module run_star_extras use star_lib use star_def @@ -28,9 +28,9 @@ module run_star_extras use math_lib use binary_def use utils_lib, only: mesa_error - + implicit none - + contains subroutine extras_controls(id, ierr) @@ -41,7 +41,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_start_step => extras_start_step s% extras_check_model => extras_check_model @@ -50,10 +50,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -86,8 +86,8 @@ integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -97,13 +97,13 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) ierr = 0 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer, intent(in) :: id, n, nz character (len=maxlen_profile_column_name) :: names(n) @@ -112,7 +112,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer :: k ierr = 0 end subroutine data_for_extra_profile_columns - + integer function extras_finish_step(id) integer, intent(in) :: id @@ -124,8 +124,8 @@ integer function extras_finish_step(id) extras_finish_step = keep_going end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -135,7 +135,7 @@ subroutine extras_after_evolve(id, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine extras_after_evolve - + end module run_star_extras - + diff --git a/binary/test_suite/jdot_gr_check/src/binary_run.f90 b/binary/test_suite/jdot_gr_check/src/binary_run.f90 index b542b6138..04599f3ed 100644 --- a/binary/test_suite/jdot_gr_check/src/binary_run.f90 +++ b/binary/test_suite/jdot_gr_check/src/binary_run.f90 @@ -1,6 +1,6 @@ program binary_run use run_binary, only: do_run_binary - + call do_run_binary(.true.) - + end program diff --git a/binary/test_suite/jdot_gr_check/src/run_binary_extras.f90 b/binary/test_suite/jdot_gr_check/src/run_binary_extras.f90 index d1585d3e4..29c728fb3 100644 --- a/binary/test_suite/jdot_gr_check/src/run_binary_extras.f90 +++ b/binary/test_suite/jdot_gr_check/src/run_binary_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -18,25 +18,25 @@ ! along with this software; if not, write to the free software ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! -! *********************************************************************** - module run_binary_extras +! *********************************************************************** + module run_binary_extras use star_lib use star_def use const_def use binary_def use math_lib - + implicit none integer, parameter :: ix_separation_error = 1 - + include "binary_test_suite_extras_def.inc" contains include "binary_test_suite_extras.inc" - + subroutine extras_binary_controls(binary_id, ierr) integer :: binary_id integer, intent(out) :: ierr @@ -66,7 +66,7 @@ subroutine extras_binary_controls(binary_id, ierr) ! Once you have set the function pointers you want, then uncomment this (or set it in your star_job inlist) ! to disable the printed warning message, b% warn_binary_extra =.false. - + end subroutine extras_binary_controls @@ -97,7 +97,7 @@ integer function how_many_extra_binary_history_columns(binary_id) integer, intent(in) :: binary_id how_many_extra_binary_history_columns = 1 end function how_many_extra_binary_history_columns - + subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr) use const_def, only: dp type (binary_info), pointer :: b @@ -120,7 +120,7 @@ subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr b% xtra(ix_separation_error) = (vals(1)-b% separation/Rsun)/vals(1) write(*,*) "error in separation", b% xtra(ix_separation_error) end subroutine data_for_extra_binary_history_columns - + integer function extras_binary_startup(binary_id,restart,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -135,7 +135,7 @@ integer function extras_binary_startup(binary_id,restart,ierr) extras_binary_startup = keep_going end function extras_binary_startup - + integer function extras_binary_start_step(binary_id,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -146,9 +146,9 @@ integer function extras_binary_start_step(binary_id,ierr) if (ierr /= 0) then ! failure in binary_ptr return end if - + end function extras_binary_start_step - + !Return either keep_going, retry or terminate integer function extras_binary_check_model(binary_id) type (binary_info), pointer :: b @@ -157,7 +157,7 @@ integer function extras_binary_check_model(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_check_model = keep_going if (b% s1% mstar_dot /= 0) then @@ -167,10 +167,10 @@ integer function extras_binary_check_model(binary_id) write(*,*) "Terminate because of large error in orbital separation" extras_binary_check_model = terminate end if - + end function extras_binary_check_model - - + + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. integer function extras_binary_finish_step(binary_id) @@ -180,11 +180,11 @@ integer function extras_binary_finish_step(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_finish_step = keep_going - + end function extras_binary_finish_step - + subroutine extras_binary_after_evolve(binary_id, ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -192,12 +192,12 @@ subroutine extras_binary_after_evolve(binary_id, ierr) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if - - + end if + + call test_suite_after_evolve(b, ierr) - end subroutine extras_binary_after_evolve - + end subroutine extras_binary_after_evolve + end module run_binary_extras diff --git a/binary/test_suite/jdot_gr_check/src/run_star_extras.f90 b/binary/test_suite/jdot_gr_check/src/run_star_extras.f90 index 42925185b..8d91b5cba 100644 --- a/binary/test_suite/jdot_gr_check/src/run_star_extras.f90 +++ b/binary/test_suite/jdot_gr_check/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,8 +19,8 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - - module run_star_extras + + module run_star_extras use star_lib use star_def @@ -28,9 +28,9 @@ module run_star_extras use math_lib use binary_def use utils_lib, only: mesa_error - + implicit none - + contains subroutine extras_controls(id, ierr) @@ -41,7 +41,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_start_step => extras_start_step s% extras_check_model => extras_check_model @@ -50,10 +50,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -86,8 +86,8 @@ integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -97,13 +97,13 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) ierr = 0 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer, intent(in) :: id, n, nz character (len=maxlen_profile_column_name) :: names(n) @@ -112,7 +112,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer :: k ierr = 0 end subroutine data_for_extra_profile_columns - + integer function extras_finish_step(id) integer, intent(in) :: id @@ -124,8 +124,8 @@ integer function extras_finish_step(id) extras_finish_step = keep_going end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -135,7 +135,7 @@ subroutine extras_after_evolve(id, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine extras_after_evolve - + end module run_star_extras - + diff --git a/binary/test_suite/jdot_ls_check/src/binary_run.f90 b/binary/test_suite/jdot_ls_check/src/binary_run.f90 index b542b6138..04599f3ed 100644 --- a/binary/test_suite/jdot_ls_check/src/binary_run.f90 +++ b/binary/test_suite/jdot_ls_check/src/binary_run.f90 @@ -1,6 +1,6 @@ program binary_run use run_binary, only: do_run_binary - + call do_run_binary(.true.) - + end program diff --git a/binary/test_suite/jdot_ls_check/src/run_binary_extras.f90 b/binary/test_suite/jdot_ls_check/src/run_binary_extras.f90 index 7c76c9789..ab5fcf205 100644 --- a/binary/test_suite/jdot_ls_check/src/run_binary_extras.f90 +++ b/binary/test_suite/jdot_ls_check/src/run_binary_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -18,23 +18,23 @@ ! along with this software; if not, write to the free software ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! -! *********************************************************************** - module run_binary_extras +! *********************************************************************** + module run_binary_extras use star_lib use star_def use const_def use math_lib use binary_def - + implicit none - + include "binary_test_suite_extras_def.inc" contains include "binary_test_suite_extras.inc" - + subroutine extras_binary_controls(binary_id, ierr) integer :: binary_id integer, intent(out) :: ierr @@ -64,7 +64,7 @@ subroutine extras_binary_controls(binary_id, ierr) ! Once you have set the function pointers you want, then uncomment this (or set it in your star_job inlist) ! to disable the printed warning message, b% warn_binary_extra =.false. - + end subroutine extras_binary_controls @@ -95,7 +95,7 @@ integer function how_many_extra_binary_history_columns(binary_id) integer, intent(in) :: binary_id how_many_extra_binary_history_columns = 0 end function how_many_extra_binary_history_columns - + subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr) use const_def, only: dp type (binary_info), pointer :: b @@ -111,10 +111,10 @@ subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr write(*,*) 'failed in binary_ptr' return end if - + end subroutine data_for_extra_binary_history_columns - - + + integer function extras_binary_startup(binary_id,restart,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -129,7 +129,7 @@ integer function extras_binary_startup(binary_id,restart,ierr) extras_binary_startup = keep_going end function extras_binary_startup - + integer function extras_binary_start_step(binary_id,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -140,9 +140,9 @@ integer function extras_binary_start_step(binary_id,ierr) if (ierr /= 0) then ! failure in binary_ptr return end if - + end function extras_binary_start_step - + !Return either keep_going, retry or terminate integer function extras_binary_check_model(binary_id) type (binary_info), pointer :: b @@ -151,12 +151,12 @@ integer function extras_binary_check_model(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_check_model = keep_going - + end function extras_binary_check_model - - + + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. integer function extras_binary_finish_step(binary_id) @@ -166,11 +166,11 @@ integer function extras_binary_finish_step(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_finish_step = keep_going - + end function extras_binary_finish_step - + subroutine extras_binary_after_evolve(binary_id, ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -178,12 +178,12 @@ subroutine extras_binary_after_evolve(binary_id, ierr) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if - - + end if + + call test_suite_after_evolve(b, ierr) - end subroutine extras_binary_after_evolve - + end subroutine extras_binary_after_evolve + end module run_binary_extras diff --git a/binary/test_suite/jdot_ls_check/src/run_star_extras.f90 b/binary/test_suite/jdot_ls_check/src/run_star_extras.f90 index 2d2218816..a6f9d00d7 100644 --- a/binary/test_suite/jdot_ls_check/src/run_star_extras.f90 +++ b/binary/test_suite/jdot_ls_check/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,8 +19,8 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - - module run_star_extras + + module run_star_extras use star_lib use star_def @@ -28,9 +28,9 @@ module run_star_extras use math_lib use binary_def use utils_lib, only: mesa_error - + implicit none - + contains subroutine extras_controls(id, ierr) @@ -41,7 +41,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_start_step => extras_start_step s% extras_check_model => extras_check_model @@ -50,10 +50,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -86,8 +86,8 @@ integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = 4 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) use binary_def integer, intent(in) :: id, n @@ -119,13 +119,13 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) i=i+1; names(i) = 'spin_orital_period_ratio'; vals(i) = spin_period/b% period end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer, intent(in) :: id, n, nz character (len=maxlen_profile_column_name) :: names(n) @@ -134,7 +134,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer :: k ierr = 0 end subroutine data_for_extra_profile_columns - + integer function extras_finish_step(id) integer, intent(in) :: id @@ -146,8 +146,8 @@ integer function extras_finish_step(id) extras_finish_step = keep_going end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -157,7 +157,7 @@ subroutine extras_after_evolve(id, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine extras_after_evolve - + end module run_star_extras - + diff --git a/binary/test_suite/jdot_ml_check/src/binary_run.f90 b/binary/test_suite/jdot_ml_check/src/binary_run.f90 index b542b6138..04599f3ed 100644 --- a/binary/test_suite/jdot_ml_check/src/binary_run.f90 +++ b/binary/test_suite/jdot_ml_check/src/binary_run.f90 @@ -1,6 +1,6 @@ program binary_run use run_binary, only: do_run_binary - + call do_run_binary(.true.) - + end program diff --git a/binary/test_suite/jdot_ml_check/src/run_binary_extras.f90 b/binary/test_suite/jdot_ml_check/src/run_binary_extras.f90 index ebfb3dcc0..c5225635f 100644 --- a/binary/test_suite/jdot_ml_check/src/run_binary_extras.f90 +++ b/binary/test_suite/jdot_ml_check/src/run_binary_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -18,25 +18,25 @@ ! along with this software; if not, write to the free software ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! -! *********************************************************************** - module run_binary_extras +! *********************************************************************** + module run_binary_extras use star_lib use star_def use const_def use math_lib use binary_def - + implicit none integer, parameter :: ix_separation_error = 1 - + include "binary_test_suite_extras_def.inc" contains include "binary_test_suite_extras.inc" - + subroutine extras_binary_controls(binary_id, ierr) integer :: binary_id integer, intent(out) :: ierr @@ -66,7 +66,7 @@ subroutine extras_binary_controls(binary_id, ierr) ! Once you have set the function pointers you want, then uncomment this (or set it in your star_job inlist) ! to disable the printed warning message, b% warn_binary_extra =.false. - + end subroutine extras_binary_controls @@ -97,7 +97,7 @@ integer function how_many_extra_binary_history_columns(binary_id) integer, intent(in) :: binary_id how_many_extra_binary_history_columns = 1 end function how_many_extra_binary_history_columns - + subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr) use const_def, only: dp type (binary_info), pointer :: b @@ -132,7 +132,7 @@ subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr b% xtra(ix_separation_error) = (vals(1) - b% separation/Rsun)/ vals(1) write(*,1) "error in separation", b% xtra(ix_separation_error) end subroutine data_for_extra_binary_history_columns - + integer function extras_binary_startup(binary_id,restart,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -147,7 +147,7 @@ integer function extras_binary_startup(binary_id,restart,ierr) extras_binary_startup = keep_going end function extras_binary_startup - + integer function extras_binary_start_step(binary_id,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -158,9 +158,9 @@ integer function extras_binary_start_step(binary_id,ierr) if (ierr /= 0) then ! failure in binary_ptr return end if - + end function extras_binary_start_step - + !Return either keep_going, retry or terminate integer function extras_binary_check_model(binary_id) type (binary_info), pointer :: b @@ -169,17 +169,17 @@ integer function extras_binary_check_model(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_check_model = keep_going if(abs(b% xtra(ix_separation_error)) > 1d-4) then write(*,*) "Terminate because of large error in orbital separation" extras_binary_check_model = terminate end if - + end function extras_binary_check_model - - + + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. integer function extras_binary_finish_step(binary_id) @@ -189,11 +189,11 @@ integer function extras_binary_finish_step(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_finish_step = keep_going - + end function extras_binary_finish_step - + subroutine extras_binary_after_evolve(binary_id, ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -201,12 +201,12 @@ subroutine extras_binary_after_evolve(binary_id, ierr) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if - - + end if + + call test_suite_after_evolve(b, ierr) - end subroutine extras_binary_after_evolve - + end subroutine extras_binary_after_evolve + end module run_binary_extras diff --git a/binary/test_suite/jdot_ml_check/src/run_star_extras.f90 b/binary/test_suite/jdot_ml_check/src/run_star_extras.f90 index 42925185b..8d91b5cba 100644 --- a/binary/test_suite/jdot_ml_check/src/run_star_extras.f90 +++ b/binary/test_suite/jdot_ml_check/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,8 +19,8 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - - module run_star_extras + + module run_star_extras use star_lib use star_def @@ -28,9 +28,9 @@ module run_star_extras use math_lib use binary_def use utils_lib, only: mesa_error - + implicit none - + contains subroutine extras_controls(id, ierr) @@ -41,7 +41,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_start_step => extras_start_step s% extras_check_model => extras_check_model @@ -50,10 +50,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -86,8 +86,8 @@ integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -97,13 +97,13 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) ierr = 0 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer, intent(in) :: id, n, nz character (len=maxlen_profile_column_name) :: names(n) @@ -112,7 +112,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer :: k ierr = 0 end subroutine data_for_extra_profile_columns - + integer function extras_finish_step(id) integer, intent(in) :: id @@ -124,8 +124,8 @@ integer function extras_finish_step(id) extras_finish_step = keep_going end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -135,7 +135,7 @@ subroutine extras_after_evolve(id, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine extras_after_evolve - + end module run_star_extras - + diff --git a/binary/test_suite/star_plus_point_mass/src/binary_run.f90 b/binary/test_suite/star_plus_point_mass/src/binary_run.f90 index b542b6138..04599f3ed 100644 --- a/binary/test_suite/star_plus_point_mass/src/binary_run.f90 +++ b/binary/test_suite/star_plus_point_mass/src/binary_run.f90 @@ -1,6 +1,6 @@ program binary_run use run_binary, only: do_run_binary - + call do_run_binary(.true.) - + end program diff --git a/binary/test_suite/star_plus_point_mass/src/run_binary_extras.f90 b/binary/test_suite/star_plus_point_mass/src/run_binary_extras.f90 index 7c76c9789..ab5fcf205 100644 --- a/binary/test_suite/star_plus_point_mass/src/run_binary_extras.f90 +++ b/binary/test_suite/star_plus_point_mass/src/run_binary_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -18,23 +18,23 @@ ! along with this software; if not, write to the free software ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! -! *********************************************************************** - module run_binary_extras +! *********************************************************************** + module run_binary_extras use star_lib use star_def use const_def use math_lib use binary_def - + implicit none - + include "binary_test_suite_extras_def.inc" contains include "binary_test_suite_extras.inc" - + subroutine extras_binary_controls(binary_id, ierr) integer :: binary_id integer, intent(out) :: ierr @@ -64,7 +64,7 @@ subroutine extras_binary_controls(binary_id, ierr) ! Once you have set the function pointers you want, then uncomment this (or set it in your star_job inlist) ! to disable the printed warning message, b% warn_binary_extra =.false. - + end subroutine extras_binary_controls @@ -95,7 +95,7 @@ integer function how_many_extra_binary_history_columns(binary_id) integer, intent(in) :: binary_id how_many_extra_binary_history_columns = 0 end function how_many_extra_binary_history_columns - + subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr) use const_def, only: dp type (binary_info), pointer :: b @@ -111,10 +111,10 @@ subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr write(*,*) 'failed in binary_ptr' return end if - + end subroutine data_for_extra_binary_history_columns - - + + integer function extras_binary_startup(binary_id,restart,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -129,7 +129,7 @@ integer function extras_binary_startup(binary_id,restart,ierr) extras_binary_startup = keep_going end function extras_binary_startup - + integer function extras_binary_start_step(binary_id,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -140,9 +140,9 @@ integer function extras_binary_start_step(binary_id,ierr) if (ierr /= 0) then ! failure in binary_ptr return end if - + end function extras_binary_start_step - + !Return either keep_going, retry or terminate integer function extras_binary_check_model(binary_id) type (binary_info), pointer :: b @@ -151,12 +151,12 @@ integer function extras_binary_check_model(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_check_model = keep_going - + end function extras_binary_check_model - - + + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. integer function extras_binary_finish_step(binary_id) @@ -166,11 +166,11 @@ integer function extras_binary_finish_step(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_finish_step = keep_going - + end function extras_binary_finish_step - + subroutine extras_binary_after_evolve(binary_id, ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -178,12 +178,12 @@ subroutine extras_binary_after_evolve(binary_id, ierr) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if - - + end if + + call test_suite_after_evolve(b, ierr) - end subroutine extras_binary_after_evolve - + end subroutine extras_binary_after_evolve + end module run_binary_extras diff --git a/binary/test_suite/star_plus_point_mass/src/run_star_extras.f90 b/binary/test_suite/star_plus_point_mass/src/run_star_extras.f90 index 42925185b..8d91b5cba 100644 --- a/binary/test_suite/star_plus_point_mass/src/run_star_extras.f90 +++ b/binary/test_suite/star_plus_point_mass/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,8 +19,8 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - - module run_star_extras + + module run_star_extras use star_lib use star_def @@ -28,9 +28,9 @@ module run_star_extras use math_lib use binary_def use utils_lib, only: mesa_error - + implicit none - + contains subroutine extras_controls(id, ierr) @@ -41,7 +41,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_start_step => extras_start_step s% extras_check_model => extras_check_model @@ -50,10 +50,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -86,8 +86,8 @@ integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -97,13 +97,13 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) ierr = 0 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer, intent(in) :: id, n, nz character (len=maxlen_profile_column_name) :: names(n) @@ -112,7 +112,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer :: k ierr = 0 end subroutine data_for_extra_profile_columns - + integer function extras_finish_step(id) integer, intent(in) :: id @@ -124,8 +124,8 @@ integer function extras_finish_step(id) extras_finish_step = keep_going end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -135,7 +135,7 @@ subroutine extras_after_evolve(id, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine extras_after_evolve - + end module run_star_extras - + diff --git a/binary/test_suite/star_plus_point_mass_explicit_mdot/src/binary_run.f90 b/binary/test_suite/star_plus_point_mass_explicit_mdot/src/binary_run.f90 index b542b6138..04599f3ed 100644 --- a/binary/test_suite/star_plus_point_mass_explicit_mdot/src/binary_run.f90 +++ b/binary/test_suite/star_plus_point_mass_explicit_mdot/src/binary_run.f90 @@ -1,6 +1,6 @@ program binary_run use run_binary, only: do_run_binary - + call do_run_binary(.true.) - + end program diff --git a/binary/test_suite/star_plus_point_mass_explicit_mdot/src/run_binary_extras.f90 b/binary/test_suite/star_plus_point_mass_explicit_mdot/src/run_binary_extras.f90 index 7c76c9789..ab5fcf205 100644 --- a/binary/test_suite/star_plus_point_mass_explicit_mdot/src/run_binary_extras.f90 +++ b/binary/test_suite/star_plus_point_mass_explicit_mdot/src/run_binary_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -18,23 +18,23 @@ ! along with this software; if not, write to the free software ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! -! *********************************************************************** - module run_binary_extras +! *********************************************************************** + module run_binary_extras use star_lib use star_def use const_def use math_lib use binary_def - + implicit none - + include "binary_test_suite_extras_def.inc" contains include "binary_test_suite_extras.inc" - + subroutine extras_binary_controls(binary_id, ierr) integer :: binary_id integer, intent(out) :: ierr @@ -64,7 +64,7 @@ subroutine extras_binary_controls(binary_id, ierr) ! Once you have set the function pointers you want, then uncomment this (or set it in your star_job inlist) ! to disable the printed warning message, b% warn_binary_extra =.false. - + end subroutine extras_binary_controls @@ -95,7 +95,7 @@ integer function how_many_extra_binary_history_columns(binary_id) integer, intent(in) :: binary_id how_many_extra_binary_history_columns = 0 end function how_many_extra_binary_history_columns - + subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr) use const_def, only: dp type (binary_info), pointer :: b @@ -111,10 +111,10 @@ subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr write(*,*) 'failed in binary_ptr' return end if - + end subroutine data_for_extra_binary_history_columns - - + + integer function extras_binary_startup(binary_id,restart,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -129,7 +129,7 @@ integer function extras_binary_startup(binary_id,restart,ierr) extras_binary_startup = keep_going end function extras_binary_startup - + integer function extras_binary_start_step(binary_id,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -140,9 +140,9 @@ integer function extras_binary_start_step(binary_id,ierr) if (ierr /= 0) then ! failure in binary_ptr return end if - + end function extras_binary_start_step - + !Return either keep_going, retry or terminate integer function extras_binary_check_model(binary_id) type (binary_info), pointer :: b @@ -151,12 +151,12 @@ integer function extras_binary_check_model(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_check_model = keep_going - + end function extras_binary_check_model - - + + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. integer function extras_binary_finish_step(binary_id) @@ -166,11 +166,11 @@ integer function extras_binary_finish_step(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_finish_step = keep_going - + end function extras_binary_finish_step - + subroutine extras_binary_after_evolve(binary_id, ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -178,12 +178,12 @@ subroutine extras_binary_after_evolve(binary_id, ierr) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if - - + end if + + call test_suite_after_evolve(b, ierr) - end subroutine extras_binary_after_evolve - + end subroutine extras_binary_after_evolve + end module run_binary_extras diff --git a/binary/test_suite/star_plus_point_mass_explicit_mdot/src/run_star_extras.f90 b/binary/test_suite/star_plus_point_mass_explicit_mdot/src/run_star_extras.f90 index 42925185b..8d91b5cba 100644 --- a/binary/test_suite/star_plus_point_mass_explicit_mdot/src/run_star_extras.f90 +++ b/binary/test_suite/star_plus_point_mass_explicit_mdot/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,8 +19,8 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - - module run_star_extras + + module run_star_extras use star_lib use star_def @@ -28,9 +28,9 @@ module run_star_extras use math_lib use binary_def use utils_lib, only: mesa_error - + implicit none - + contains subroutine extras_controls(id, ierr) @@ -41,7 +41,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_start_step => extras_start_step s% extras_check_model => extras_check_model @@ -50,10 +50,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -86,8 +86,8 @@ integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -97,13 +97,13 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) ierr = 0 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer, intent(in) :: id, n, nz character (len=maxlen_profile_column_name) :: names(n) @@ -112,7 +112,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer :: k ierr = 0 end subroutine data_for_extra_profile_columns - + integer function extras_finish_step(id) integer, intent(in) :: id @@ -124,8 +124,8 @@ integer function extras_finish_step(id) extras_finish_step = keep_going end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -135,7 +135,7 @@ subroutine extras_after_evolve(id, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine extras_after_evolve - + end module run_star_extras - + diff --git a/binary/test_suite/wind_fed_bhhmxb/src/binary_run.f90 b/binary/test_suite/wind_fed_bhhmxb/src/binary_run.f90 index b542b6138..04599f3ed 100644 --- a/binary/test_suite/wind_fed_bhhmxb/src/binary_run.f90 +++ b/binary/test_suite/wind_fed_bhhmxb/src/binary_run.f90 @@ -1,6 +1,6 @@ program binary_run use run_binary, only: do_run_binary - + call do_run_binary(.true.) - + end program diff --git a/binary/test_suite/wind_fed_bhhmxb/src/run_binary_extras.f90 b/binary/test_suite/wind_fed_bhhmxb/src/run_binary_extras.f90 index 7ed423505..c765fbd8f 100644 --- a/binary/test_suite/wind_fed_bhhmxb/src/run_binary_extras.f90 +++ b/binary/test_suite/wind_fed_bhhmxb/src/run_binary_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -18,26 +18,26 @@ ! along with this software; if not, write to the free software ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! -! *********************************************************************** - module run_binary_extras +! *********************************************************************** + module run_binary_extras use star_lib use star_def use const_def use math_lib use binary_def - + implicit none integer, parameter :: lx_tested_super_edd = 1 integer, parameter :: lx_tested_sub_edd = 2 - + include "binary_test_suite_extras_def.inc" contains include "binary_test_suite_extras.inc" - + subroutine extras_binary_controls(binary_id, ierr) integer :: binary_id integer, intent(out) :: ierr @@ -67,7 +67,7 @@ subroutine extras_binary_controls(binary_id, ierr) ! Once you have set the function pointers you want, then uncomment this (or set it in your star_job inlist) ! to disable the printed warning message, b% warn_binary_extra =.false. - + end subroutine extras_binary_controls @@ -98,7 +98,7 @@ integer function how_many_extra_binary_history_columns(binary_id) integer, intent(in) :: binary_id how_many_extra_binary_history_columns = 0 end function how_many_extra_binary_history_columns - + subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr) use const_def, only: dp type (binary_info), pointer :: b @@ -114,10 +114,10 @@ subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr write(*,*) 'failed in binary_ptr' return end if - + end subroutine data_for_extra_binary_history_columns - - + + integer function extras_binary_startup(binary_id,restart,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -136,7 +136,7 @@ integer function extras_binary_startup(binary_id,restart,ierr) extras_binary_startup = keep_going end function extras_binary_startup - + integer function extras_binary_start_step(binary_id,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -147,9 +147,9 @@ integer function extras_binary_start_step(binary_id,ierr) if (ierr /= 0) then ! failure in binary_ptr return end if - + end function extras_binary_start_step - + !Return either keep_going, retry or terminate integer function extras_binary_check_model(binary_id) type (binary_info), pointer :: b @@ -158,12 +158,12 @@ integer function extras_binary_check_model(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_check_model = keep_going - + end function extras_binary_check_model - - + + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. integer function extras_binary_finish_step(binary_id) @@ -178,7 +178,7 @@ integer function extras_binary_finish_step(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_finish_step = keep_going ! Test that we are not going above Eddington @@ -225,9 +225,9 @@ integer function extras_binary_finish_step(binary_id) b% mdot_system_wind(1), expected_mdot_wind, frac_error stop end if - + end function extras_binary_finish_step - + subroutine extras_binary_after_evolve(binary_id, ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -235,18 +235,18 @@ subroutine extras_binary_after_evolve(binary_id, ierr) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if if (b% lxtra(lx_tested_super_edd) .and. b% lxtra(lx_tested_sub_edd)) then write(*,*) "Properly tested sub and super Eddington phases" else write(*,*) "System did not had both sub and super Eddington phases", & b% lxtra(lx_tested_super_edd), b% lxtra(lx_tested_sub_edd) - end if - + end if + call test_suite_after_evolve(b, ierr) - end subroutine extras_binary_after_evolve - + end subroutine extras_binary_after_evolve + end module run_binary_extras diff --git a/binary/test_suite/wind_fed_bhhmxb/src/run_star_extras.f90 b/binary/test_suite/wind_fed_bhhmxb/src/run_star_extras.f90 index 42925185b..8d91b5cba 100644 --- a/binary/test_suite/wind_fed_bhhmxb/src/run_star_extras.f90 +++ b/binary/test_suite/wind_fed_bhhmxb/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,8 +19,8 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - - module run_star_extras + + module run_star_extras use star_lib use star_def @@ -28,9 +28,9 @@ module run_star_extras use math_lib use binary_def use utils_lib, only: mesa_error - + implicit none - + contains subroutine extras_controls(id, ierr) @@ -41,7 +41,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_start_step => extras_start_step s% extras_check_model => extras_check_model @@ -50,10 +50,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -86,8 +86,8 @@ integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -97,13 +97,13 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) ierr = 0 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer, intent(in) :: id, n, nz character (len=maxlen_profile_column_name) :: names(n) @@ -112,7 +112,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer :: k ierr = 0 end subroutine data_for_extra_profile_columns - + integer function extras_finish_step(id) integer, intent(in) :: id @@ -124,8 +124,8 @@ integer function extras_finish_step(id) extras_finish_step = keep_going end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -135,7 +135,7 @@ subroutine extras_after_evolve(id, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine extras_after_evolve - + end module run_star_extras - + diff --git a/binary/work/src/binary_run.f90 b/binary/work/src/binary_run.f90 index b542b6138..04599f3ed 100644 --- a/binary/work/src/binary_run.f90 +++ b/binary/work/src/binary_run.f90 @@ -1,6 +1,6 @@ program binary_run use run_binary, only: do_run_binary - + call do_run_binary(.true.) - + end program diff --git a/binary/work/src/run_binary_extras.f90 b/binary/work/src/run_binary_extras.f90 index 2de1a2ed1..94b5c28bf 100644 --- a/binary/work/src/run_binary_extras.f90 +++ b/binary/work/src/run_binary_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -18,8 +18,8 @@ ! along with this software; if not, write to the free software ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! -! *********************************************************************** - module run_binary_extras +! *********************************************************************** + module run_binary_extras use star_lib use star_def @@ -28,11 +28,11 @@ module run_binary_extras use num_lib use binary_def use math_lib - + implicit none - + contains - + subroutine extras_binary_controls(binary_id, ierr) integer :: binary_id integer, intent(out) :: ierr @@ -62,7 +62,7 @@ subroutine extras_binary_controls(binary_id, ierr) ! Once you have set the function pointers you want, then uncomment this (or set it in your star_job inlist) ! to disable the printed warning message, b% warn_binary_extra =.false. - + end subroutine extras_binary_controls @@ -109,10 +109,10 @@ subroutine data_for_extra_binary_history_columns(binary_id, n, names, vals, ierr write(*,*) 'failed in binary_ptr' return end if - + end subroutine data_for_extra_binary_history_columns - - + + integer function extras_binary_startup(binary_id,restart,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -122,11 +122,11 @@ integer function extras_binary_startup(binary_id,restart,ierr) if (ierr /= 0) then ! failure in binary_ptr return end if - + ! b% s1% job% warn_run_star_extras = .false. extras_binary_startup = keep_going end function extras_binary_startup - + integer function extras_binary_start_step(binary_id,ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -137,9 +137,9 @@ integer function extras_binary_start_step(binary_id,ierr) if (ierr /= 0) then ! failure in binary_ptr return end if - + end function extras_binary_start_step - + !Return either keep_going, retry or terminate integer function extras_binary_check_model(binary_id) type (binary_info), pointer :: b @@ -148,12 +148,12 @@ integer function extras_binary_check_model(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_check_model = keep_going - + end function extras_binary_check_model - - + + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. integer function extras_binary_finish_step(binary_id) @@ -163,11 +163,11 @@ integer function extras_binary_finish_step(binary_id) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if + end if extras_binary_finish_step = keep_going - + end function extras_binary_finish_step - + subroutine extras_binary_after_evolve(binary_id, ierr) type (binary_info), pointer :: b integer, intent(in) :: binary_id @@ -175,9 +175,9 @@ subroutine extras_binary_after_evolve(binary_id, ierr) call binary_ptr(binary_id, b, ierr) if (ierr /= 0) then ! failure in binary_ptr return - end if - - - end subroutine extras_binary_after_evolve - + end if + + + end subroutine extras_binary_after_evolve + end module run_binary_extras diff --git a/binary/work/src/run_star_extras.f90 b/binary/work/src/run_star_extras.f90 index b67533d67..9a6dbcd01 100644 --- a/binary/work/src/run_star_extras.f90 +++ b/binary/work/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,8 +19,8 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - - module run_star_extras + + module run_star_extras use star_lib use star_def @@ -29,13 +29,13 @@ module run_star_extras use chem_def use num_lib use binary_def - + implicit none ! these routines are called by the standard run_star check_model contains - + include 'standard_run_star_extras.inc' end module run_star_extras - + diff --git a/chem/preprocessor/src/chem_support.f90 b/chem/preprocessor/src/chem_support.f90 index 71b0d868b..567462ba9 100644 --- a/chem/preprocessor/src/chem_support.f90 +++ b/chem/preprocessor/src/chem_support.f90 @@ -13,33 +13,33 @@ module chem_support ! integer, parameter :: number_winvn_header_lines = 7857 ! character(len=*), parameter :: masstable_filename = 'masslib_library_5.data' real(dp), dimension(:,:), allocatable :: mass_table - - + + ! al26 partition functions from Gupta & Meyer (2001) ! http://ftp.aip.org/epaps//phys_rev_c/E-PRVCAN-64-028108/ ! Note that these values do not match their Table IV. - + real(dp),dimension(24) :: partiton_al26_1 = & (/ 1.00000E+00_dp , 1.00000E+00_dp, 1.00000E+00_dp, 1.00000E+00_dp, 1.00000E+00_dp, 1.00000E+00_dp, 1.00020E+00_dp, 1.00060E+00_dp, & 1.00150E+00_dp, 1.00290E+00_dp, 1.00500E+00_dp, 1.02440E+00_dp, 1.03250E+00_dp, 1.01910E+00_dp, 1.01260E+00_dp, 1.00940E+00_dp, & 1.00780E+00_dp, 1.00760E+00_dp, 1.00870E+00_dp, 1.01620E+00_dp, 1.03310E+00_dp, 1.06000E+00_dp, 1.09270E+00_dp, 1.12850E+00_dp /) - + real(dp),dimension(24) :: partiton_al26_2 = & (/ 1.00000E+00_dp, 1.00000E+00_dp, 1.00000E+00_dp, 1.00010E+00_dp, 1.00030E+00_dp, 1.00090E+00_dp, 1.00180E+00_dp, 1.00310E+00_dp, & 1.00460E+00_dp, 1.00620E+00_dp, 1.00800E+00_dp, 1.06220E+00_dp, 2.02360E+00_dp, 3.38330E+00_dp, 4.19860E+00_dp, 4.81450E+00_dp, & 5.36050E+00_dp, 5.88330E+00_dp, 6.40960E+00_dp, 7.52430E+00_dp, 8.75760E+00_dp, 1.01610E+01_dp, 1.18190E+01_dp, 1.37730E+00_dp /) - - + + namelist /chem/ & & data_dir, output_dir, masstable_filename, winvn_filename, & & masstable_header_length, winvn_header_length, number_nuclides - + contains - + subroutine read_input_parameters(inlist_fname) character(len=*), intent(in) :: inlist_fname integer :: iounit, ios - + ! set default values data_dir = 'chem_input_data' output_dir = 'data/chem_data' @@ -48,7 +48,7 @@ subroutine read_input_parameters(inlist_fname) masstable_header_length = 15 winvn_header_length = 4 number_nuclides = 7853 - + open(newunit=iounit, file=trim(inlist_fname), iostat=ios, status="old", action="read",delim='quote') if ( ios /= 0 ) then write(*,'(A)') @@ -68,30 +68,30 @@ subroutine read_input_parameters(inlist_fname) stop end if end subroutine read_input_parameters - + subroutine init_preprocessor() integer :: ierr ierr=0 call const_init("../../",ierr) if(ierr/=0) stop "Error in const_init" - + call math_init() - + end subroutine init_preprocessor - + subroutine read_mass_table() - integer :: mass_unit + integer :: mass_unit integer :: ios, i, nlines, zmin, zmax, nmin, nmax, Z, A, N, ierr real(dp), parameter :: keV_to_MeV = 1.0d-3 real(dp) :: mass character(len=256) :: filename, buf character(len=24) :: eval, error - + write(filename,'(a)') trim(data_dir)//'/'//trim(masstable_filename) open(newunit=mass_unit, file=trim(filename), iostat=ios, status="old", action="read") - + if (ios /= 0) call mesa_error(__FILE__,__LINE__,'unable to open mass table for reading') - + ! first pass call skip_header nlines = 0 @@ -108,7 +108,7 @@ subroutine read_mass_table() if (N < nmin) nmin = N if (N > nmax) nmax = N end do - + ! now read the table allocate(mass_table(zmin:zmax,nmin:nmax)) mass_table = no_mass_table_entry @@ -123,7 +123,7 @@ subroutine read_mass_table() mass_table(Z,N) = mass*keV_to_MeV end do close(mass_unit) - + contains subroutine skip_header() integer :: i,ios @@ -145,15 +145,15 @@ subroutine process_winvn_table() real(dp) :: W, spin, mass_excess, pfcn(24) character(len=8) :: name, ref logical :: ground_state - + fac = mev_to_ergs/amu/(clight*clight) - + ! the mass table must be allocated first if (.not.allocated(mass_table)) then write (error_unit,*) 'mass_table must be allocated first' return end if - + zmin = lbound(mass_table,dim=1) zmax = ubound(mass_table,dim=1) nmin = lbound(mass_table,dim=2) @@ -161,21 +161,21 @@ subroutine process_winvn_table() write(infile_name,'(a)') trim(data_dir)//'/'//trim(winvn_filename) write(outfile_name,'(a)') trim(output_dir)//'/isotopes.data' - + open(newunit=in_unit, file=trim(infile_name), iostat=ios, status="old", action="read") if ( ios /= 0 ) stop "Error opening raw winvn file" - + open(newunit=out_unit, file=trim(outfile_name), iostat=ios, action="write") if ( ios /= 0 ) stop "Error opening processed winvn file" - + !Add blank line to file at the start write (out_unit,*) - + ! skim off the header do i = 1, winvn_header_length + number_nuclides read(in_unit,*) end do - + do i = 1, number_nuclides ! 4 lines per nuclide read(in_unit,'(A)',iostat=ios) buf if (ios /= 0) exit @@ -189,21 +189,21 @@ subroutine process_winvn_table() read(in_unit,'(A)',iostat=ios) buf call parse_line_pfcn(buf,pfcn(17:24),ierr) if (ios /= 0) exit - + if (name /= 'al-6' .and. name /= 'al*6') then ground_state = .true. else ground_state = .false. end if - + ! lookup the mass information if it is available if (Z >= zmin .and. Z <= zmax .and. N >= nmin .and. N <= nmax .and. ground_state) then if (mass_table(Z,N) /= no_mass_table_entry) mass_excess = mass_table(Z,N) end if - + ! set the atomic weight W = Z + N + mass_excess*fac - + ! convert the name if (name == 'n') name = 'neut' if (name == 'p') name = 'h1' @@ -217,10 +217,10 @@ subroutine process_winvn_table() name = 'al26-2' pfcn = partiton_al26_2 end if - + ! write to the processed datafile call write_entry - + ! duplicate entry for h1 as prot if (name == 'h1') then name = 'prot' @@ -230,13 +230,13 @@ subroutine process_winvn_table() ! write the 'xtra' entries for the rates name = 'xtra1'; W = 100.d0; Z = 0; N = 100; spin = 0.d0; mass_excess = 0.d0; pfcn = 1.d0 call write_entry - + name = 'xtra2'; W = 200.d0; Z = 0; N = 200; spin = 0.d0; mass_excess = 0.d0; pfcn = 1.d0 call write_entry - + close(in_unit) close(out_unit) - + contains subroutine write_entry() write (out_unit,'(a8,f13.7,i5,i5,f6.1,f14.9)') name, W, Z, N, spin, mass_excess @@ -250,27 +250,27 @@ subroutine cleanup() deallocate(mass_table) end subroutine cleanup - + subroutine parse_line_mass_unit(line,z,a,eval,mass,error,ierr) character(len=*),intent(in) :: line integer, intent(out) :: z,a character(len=*), intent(out) :: eval,error real(dp),intent(out) :: mass integer, intent(inout) :: ierr - + integer :: j,k integer, parameter :: num_cols=5 character(len=256),dimension(num_cols) :: tmp - + call parse_line(line,num_cols,tmp) - + read(tmp(1),*) z read(tmp(2),*) a eval=trim(tmp(3)) call str_to_double(tmp(4),mass,ierr) if (ierr /= 0) return error=trim(tmp(5)) - + end subroutine parse_line_mass_unit @@ -282,7 +282,7 @@ subroutine parse_line_nuclides_header(line,name,w,z,n,spin,mass,ref,ierr) integer, intent(inout) :: ierr integer, parameter :: num_cols=7 character(len=256),dimension(num_cols) :: tmp - + call parse_line(line,num_cols,tmp) name=tmp(1) call str_to_double(tmp(2),W,ierr) @@ -296,9 +296,9 @@ subroutine parse_line_nuclides_header(line,name,w,z,n,spin,mass,ref,ierr) call str_to_double(tmp(6),mass,ierr) if (ierr /= 0) return ref=tmp(7) - + end subroutine parse_line_nuclides_header - + subroutine parse_line_pfcn(line,pfcn,ierr) character(len=*),intent(in) :: line integer :: i @@ -306,24 +306,24 @@ subroutine parse_line_pfcn(line,pfcn,ierr) integer, parameter :: num_cols=8 character(len=256),dimension(num_cols) :: tmp real(dp), dimension(:), intent(out) :: pfcn - + call parse_line(line,num_cols,tmp) - + do i=1,num_cols call str_to_double(tmp(i),pfcn(i),ierr) if (ierr /= 0) return end do - + end subroutine parse_line_pfcn - - + + subroutine parse_line(line,num_cols,line_out) character(len=*),intent(in) :: line integer,intent(in) :: num_cols character(len=256),dimension(num_cols),intent(out) :: line_out character(len=256) :: tmp integer :: k,i,j - + k=1 tmp='' line_out='' @@ -338,8 +338,8 @@ subroutine parse_line(line,num_cols,line_out) end if end if if(k==num_cols+1) exit - end do - + end do + end subroutine parse_line diff --git a/chem/preprocessor/src/create_table.f90 b/chem/preprocessor/src/create_table.f90 index c60d475fd..007fc3865 100644 --- a/chem/preprocessor/src/create_table.f90 +++ b/chem/preprocessor/src/create_table.f90 @@ -3,7 +3,7 @@ program create_table use iso_fortran_env, only : error_unit character(len=64) :: inlist_fname integer :: ios - + ios = 0 call get_command_argument(1,inlist_fname,status=ios) if (ios /= 0) then diff --git a/chem/private/chem_isos_io.f90 b/chem/private/chem_isos_io.f90 index 8f4c498f0..c9981b1a5 100644 --- a/chem/private/chem_isos_io.f90 +++ b/chem/private/chem_isos_io.f90 @@ -23,17 +23,17 @@ ! ! ! *********************************************************************** - + module chem_isos_io use chem_def use math_lib use const_def - + implicit none contains - + subroutine do_read_chem_isos(isotopes_filename, ierr) use utils_lib @@ -44,32 +44,32 @@ subroutine do_read_chem_isos(isotopes_filename, ierr) character (len=256) :: filename, buf real(dp), target :: vec_ary(256) real(dp), pointer :: vec(:) - + ierr = 0 vec => vec_ary - + filename = trim(mesa_data_dir) // '/chem_data/' // trim(isotopes_filename) num_chem_isos = 0 - + do pass = 1, 2 - + open(newunit=iounit, file=trim(filename), iostat=ierr, status='old',action='read') if ( ierr /= 0 ) then write(*,*) 'unable to open '// trim(filename) return end if read(iounit,'(A)') buf! skip line 1 - + if (pass == 1) then - + do ! 4 lines per nuclide - read(iounit, *, iostat=ierr) + read(iounit, *, iostat=ierr) if (ierr /= 0) exit - read(iounit, *, iostat=ierr) + read(iounit, *, iostat=ierr) if (ierr /= 0) exit - read(iounit, *, iostat=ierr) + read(iounit, *, iostat=ierr) if (ierr /= 0) exit - read(iounit, *, iostat=ierr) + read(iounit, *, iostat=ierr) if (ierr /= 0) exit num_chem_isos = num_chem_isos+1 end do @@ -78,20 +78,20 @@ subroutine do_read_chem_isos(isotopes_filename, ierr) return end if else - + call allocate_nuclide_data(chem_isos, num_chem_isos, ierr) if (ierr /= 0) then write(*,*) 'unable to allocate nuclide data' return end if - + do i = 1, num_chem_isos - + read(iounit, '(A)',iostat=ierr) buf if (ierr /= 0) exit call parse_line(buf,i,ierr) if (ierr /= 0) exit - + do k=1,3 read(iounit,'(a)',iostat=ierr) buf if (ierr == 0) then @@ -104,11 +104,11 @@ subroutine do_read_chem_isos(isotopes_filename, ierr) end do end do if (ierr /= 0) exit - + chem_isos% chem_id(i) = i chem_isos% nuclide(i) = i chem_isos% isomeric_state(i) = get_isomeric_state(chem_isos% name(i), ierr) - + end do if (ierr /= 0) then write (*,*) 'something went wrong in read of '//trim(filename) @@ -116,16 +116,16 @@ subroutine do_read_chem_isos(isotopes_filename, ierr) end if end if - + close(iounit) - + end do - + if (ierr /= 0) return - + call do_create_nuclides_dict(chem_isos, chem_isos_dict, ierr) if (ierr /= 0) return - + !Set mass excess of proton and neutron do i = 1, num_chem_isos Z = chem_isos% Z(i) @@ -133,14 +133,14 @@ subroutine do_read_chem_isos(isotopes_filename, ierr) if(Z==1 .and. N==0) del_Mp=chem_isos% mass_excess(i) if(N==1 .and. Z==0) del_Mn=chem_isos% mass_excess(i) end do - + chem_isos% Z_plus_N = chem_isos% Z + chem_isos% N ! pre-calculate Z^5/3 do i = 1, num_chem_isos chem_isos% Z53(i) = pow(real(chem_isos% Z(i), dp), five_thirds) end do - + chem_isos% binding_energy = chem_isos% Z*del_Mp + chem_isos% N*del_Mn - chem_isos% mass_excess ! Recompute Atomic masses for double precision consistency. @@ -153,10 +153,10 @@ subroutine do_read_chem_isos(isotopes_filename, ierr) N = chem_isos% N(i) if (N < element_min_N(Z)) element_min_N(Z) = N if (N > element_max_N(Z)) element_max_N(Z) = N - end do - + end do + contains - + integer function get_isomeric_state(name, ierr) character (len=*), intent(in) :: name integer, intent(out) :: ierr @@ -175,8 +175,8 @@ integer function get_isomeric_state(name, ierr) end if end do end function get_isomeric_state - - + + subroutine parse_line(line,i,ierr) character(len=*),intent(in) :: line integer, intent(in) :: i @@ -185,7 +185,7 @@ subroutine parse_line(line,i,ierr) integer, parameter :: num_cols=6 character(len=256),dimension(num_cols) :: tmp character(len=256) :: tmp2 - + k=1 tmp2='' tmp='' @@ -201,7 +201,7 @@ subroutine parse_line(line,i,ierr) end if if(k==num_cols+1) exit end do - + chem_isos% name(i)=tmp(1) call str_to_double(tmp(2),chem_isos% W(i),ierr) if (ierr /= 0) return @@ -213,19 +213,19 @@ subroutine parse_line(line,i,ierr) if (ierr /= 0) return call str_to_double(tmp(6),chem_isos% mass_excess(i),ierr) if (ierr /= 0) return - + end subroutine parse_line end subroutine do_read_chem_isos - - + + subroutine do_create_nuclides_dict(nuclides, nuclides_dict, ierr) use utils_lib, only: integer_dict_define, integer_dict_create_hash, integer_dict_lookup type(nuclide_data), intent(in) :: nuclides type (integer_dict), pointer :: nuclides_dict ! will be allocated integer, intent(out) :: ierr integer :: i - + ierr = 0 nullify(nuclides_dict) do i=1,nuclides% nnuclides @@ -235,8 +235,8 @@ subroutine do_create_nuclides_dict(nuclides, nuclides_dict, ierr) call integer_dict_create_hash(nuclides_dict, ierr) if (ierr /= 0) return - + end subroutine do_create_nuclides_dict - + end module chem_isos_io diff --git a/chem/private/lodders_mod.f90 b/chem/private/lodders_mod.f90 index 558c1fd9a..ba46ab598 100644 --- a/chem/private/lodders_mod.f90 +++ b/chem/private/lodders_mod.f90 @@ -30,7 +30,7 @@ subroutine read_lodders03_data(datafile,ierr) use iso_fortran_env, only : iostat_end use chem_def use utils_lib, only : integer_dict_define - + character(len=*), intent(in) :: datafile integer, intent(out) :: ierr integer, parameter :: lodders_header_length = 5, max_number_isotopes = 500 @@ -42,7 +42,7 @@ subroutine read_lodders03_data(datafile,ierr) character(len=2) :: el character(len=iso_name_length), dimension(max_number_isotopes) :: lodders03_isotopes character(len=256) :: filename - + ierr = 0 filename = trim(mesa_data_dir)//'/chem_data/'//trim(datafile) open(newunit=iounit, file=trim(filename), iostat=ierr, status="old", action="read") @@ -51,12 +51,12 @@ subroutine read_lodders03_data(datafile,ierr) write(*,*) 'filename ' // trim(filename) return end if - + ! skip the header do i = 1, lodders_header_length read(iounit,*) end do - + ! read in the file, setting bookmarks as we go. nentries = 0 ! accumulates number of spaces to hold the percentages do i = 1, max_number_isotopes @@ -79,7 +79,7 @@ subroutine read_lodders03_data(datafile,ierr) close(iounit) end subroutine read_lodders03_data - + function get_lodders03_isotopic_abundance(nuclei,ierr) result(percent) use chem_def use utils_lib, only : integer_dict_lookup @@ -87,13 +87,13 @@ function get_lodders03_isotopic_abundance(nuclei,ierr) result(percent) integer, intent(out) :: ierr real(dp) :: percent integer :: indx - + percent = 0.0d0 if (.not.chem_has_been_initialized) then ierr = -9 return end if - + ierr = 0 call integer_dict_lookup(lodders03_tab6% name_dict, nuclei, indx, ierr) if (ierr /= 0) then @@ -102,5 +102,5 @@ function get_lodders03_isotopic_abundance(nuclei,ierr) result(percent) end if percent = lodders03_tab6% isotopic_percent(indx) end function get_lodders03_isotopic_abundance - + end module lodders_mod diff --git a/chem/private/nuclide_set_mod.f90 b/chem/private/nuclide_set_mod.f90 index c749f15e3..1fe57f3ff 100644 --- a/chem/private/nuclide_set_mod.f90 +++ b/chem/private/nuclide_set_mod.f90 @@ -23,14 +23,14 @@ ! ! ! *********************************************************************** - + module nuclide_set_mod - use chem_def + use chem_def use const_def - + implicit none - contains + contains function rank_in_set(iso, set) character(len=iso_name_length), intent(in) :: iso @@ -43,7 +43,7 @@ function rank_in_set(iso, set) if (adjustl(iso) < adjustl(set(low)% nuclide) .or. adjustl(iso) > adjustl(set(high)% nuclide)) then rank_in_set = nuclide_not_found return - end if + end if do i = 1, max_cycles if (high-low <=1) then if (adjustl(iso) == adjustl(set(high)% nuclide)) then @@ -64,13 +64,13 @@ function rank_in_set(iso, set) end do rank_in_set = nuclide_not_found end function rank_in_set - + subroutine sort_nuclide_set(set) - type(nuclide_set), dimension(:), intent(inout) :: set + type(nuclide_set), dimension(:), intent(inout) :: set integer :: n, i, ir, j, l type(nuclide_set) :: ts - + n = size(set) if (size(set) < 2) return l = n/2+1 @@ -107,13 +107,13 @@ subroutine sort_nuclide_set(set) end do contains - + logical function compare_lt(a, b) type(nuclide_set), intent(in) :: a, b compare_lt = (adjustl(a% nuclide) < adjustl(b% nuclide)) end function compare_lt - + end subroutine sort_nuclide_set - + end module nuclide_set_mod diff --git a/chem/public/chem_def.f90 b/chem/public/chem_def.f90 index 7955006ef..a674b22cb 100644 --- a/chem/public/chem_def.f90 +++ b/chem/public/chem_def.f90 @@ -25,12 +25,12 @@ ! *********************************************************************** module chem_def - + use utils_def, only: integer_dict use const_def, only: dp use math_lib, only: exp10 use utils_lib, only: mesa_error - + implicit none ! Some notes on solar abundance scales: @@ -77,7 +77,7 @@ module chem_def logical, parameter :: convert_mass_excess_to_binding_energy = .true. integer, parameter :: nuclide_not_found = -1 ! warning flag - integer, dimension(0:max_el_z) :: element_min_N, element_max_N + integer, dimension(0:max_el_z) :: element_min_N, element_max_N ! for isos included in chem_isos ! element names @@ -94,7 +94,7 @@ module chem_def 'tl','pb','bi','po','at','rn','fr','ra','ac','th', & 'pa','u','np','pu','am','cm','bk','cf','es','fm','md', & 'no','lr','rf','db','sg','bh','hs','mt','ds','rg','cn'] - + character(len=long_name_length), dimension(0:max_el_z) :: & el_long_name = [character(len=long_name_length) :: & 'neutron','hydrogen','helium','lithium','beryllium', & @@ -127,8 +127,8 @@ module chem_def character(len=long_name_length), dimension(2:3) :: & long_al_isomers = [character(len=long_name_length) :: & 'Aluminum-gs','Aluminum-ex'] - - + + ! chem element id numbers (up to Cn) ! note: for isotope i, the element id number = chem_Z(i) @@ -175,7 +175,7 @@ module chem_def integer, parameter :: e_se = 34 integer, parameter :: e_br = 35 integer, parameter :: e_kr = 36 - + !periodic table, row 5 integer, parameter :: e_rb = 37 integer, parameter :: e_sr = 38 @@ -198,7 +198,7 @@ module chem_def !periodic table, row 6 integer, parameter :: e_cs = 55 - integer, parameter :: e_ba = 56 + integer, parameter :: e_ba = 56 integer, parameter :: e_la = 57 integer, parameter :: e_ce = 58 integer, parameter :: e_pr = 59 @@ -229,7 +229,7 @@ module chem_def integer, parameter :: e_po = 84 integer, parameter :: e_at = 85 integer, parameter :: e_rn = 86 - + !periodic table, row 7 integer, parameter :: e_fr = 87 integer, parameter :: e_ra = 88 @@ -257,10 +257,10 @@ module chem_def integer, parameter :: e_ds = 110 integer, parameter :: e_rg = 111 integer, parameter :: e_cn = 112 - + integer, parameter :: num_chem_elements = max_el_z - + ! anders & grevesse 1989 integer, parameter :: solsiz = 286 integer, parameter :: solnamelen = 5 @@ -268,8 +268,8 @@ module chem_def integer :: izsol(solsiz),iasol(solsiz),jcode(solsiz) real(dp) :: solx(solsiz), zsol, yesol ! according to AG89 type (integer_dict), pointer :: Xsol_names_dict - - + + ! various values for current solar Z and Y (at photosphere) ! note that these have been reduced by diffusion from pre-MS values. ! values updated from Asplund et al. ARAA, 2009, 47, 481 @@ -284,7 +284,7 @@ module chem_def real(dp), parameter :: A09_Prz_zsol = 0.014d0 real(dp), parameter :: MB22_photospheric_zsol = 0.0169d0 real(dp), parameter :: AAG21_photospheric_zsol = 0.0139d0 - + real(dp), parameter :: AG89_ysol = 0.2485d0 real(dp), parameter :: GN93_ysol = 0.2485d0 real(dp), parameter :: GS98_ysol = 0.2485d0 @@ -295,13 +295,13 @@ module chem_def real(dp), parameter :: A09_Prz_ysol = 0.276d0 real(dp), parameter :: MB22_photospheric_ysol = 0.2485 real(dp), parameter :: AAG21_photospheric_ysol = 0.2485 - + character(len=iso_name_length) :: chem_element_main_iso_name(num_chem_elements) integer, parameter :: chem_element_name_len = iso_name_length - character (len=chem_element_name_len) :: chem_element_Name(num_chem_elements) + character (len=chem_element_name_len) :: chem_element_Name(num_chem_elements) ! names for elements - - + + ! identifiers for different Z fractions. integer, parameter :: Custom_zfracs = 0 integer, parameter :: AG89_zfracs = 1 @@ -314,40 +314,40 @@ module chem_def integer, parameter :: A09_Prz_zfracs = 8 integer, parameter :: MB22_photospheric_zfracs = 9 integer, parameter :: AAG21_photospheric_zfracs = 10 - - + + real(dp) :: AG89_element_zfrac(num_chem_elements) ! fraction by mass of total Z ! Anders & Grevesse 1989 - + real(dp) :: GN93_element_zfrac(num_chem_elements) ! fraction by mass of total Z ! Grevesse and Noels 1993 abundances - + real(dp) :: GS98_element_zfrac(num_chem_elements) ! fraction by mass of total Z ! Grevesse and Sauval 1998 abundances - + real(dp) :: L03_element_zfrac(num_chem_elements) ! fraction by mass of total Z ! Lodders 2003 abundances - + real(dp) :: AGS05_element_zfrac(num_chem_elements) ! fraction by mass of total Z ! Asplund, Grevesse, and Sauval 2005 abundances - + real(dp) :: AGSS09_element_zfrac(num_chem_elements) ! fraction by mass of total Z ! Asplund, Grevesse, Sauval, and Scott 2009 abundances ! Annu. Rev. Astron. Astrophys. 2009. 47:481–522 - + real(dp) :: L09_element_zfrac(num_chem_elements) ! fraction by mass of total Z ! Lodders and Palme, 2009. (http://adsabs.harvard.edu/abs/2009M%26PSA..72.5154L) - + real(dp) :: A09_Prz_zfrac(num_chem_elements) ! fraction by mass of the total Z ! Abundances are abased on Asplund, Grevesse, Sauval, and Scott 2009, ARA&A, 47:481–522 ! but that of the some key elements are updated based on: - ! "Present-day cosmic abundances ..." - ! by Nieva, M.-F. & Przybilla, N. 2012, A&A, 539, 143 + ! "Present-day cosmic abundances ..." + ! by Nieva, M.-F. & Przybilla, N. 2012, A&A, 539, 143 ! and the proceeding paper ! "Hot Stars and Cosmic Abundances" by ! Przybilla N. Nieva M. F., Irrgang A. and Butler K. 2013, EAS Publ. Ser. ! in preparation - ! The modified abundances w.r.t. A09 are (eps_El = log(El/H)+12.0) + ! The modified abundances w.r.t. A09 are (eps_El = log(El/H)+12.0) ! eps_He = 10.99 ! eps_C = 8.33 ! eps_N = 7.79 @@ -358,7 +358,7 @@ module chem_def ! eps_Si = 7.50 ! eps_S = 7.14 ! eps_Ar = 6.50 - ! eps_Fe = 7.52 + ! eps_Fe = 7.52 real(dp) :: MB22_photospheric_element_zfrac(num_chem_elements) ! fraction by mass of total Z ! Ekaterina Magg et al. , A&A 661, A140 (2022) photospheric abundance. @@ -368,16 +368,16 @@ module chem_def type (integer_dict), pointer :: chem_element_names_dict - + real(dp) :: element_atomic_weight(num_chem_elements) ! de Laeter et al, Pure and Applied Chemistry 75(6), 683–799, 2003. ! (IUPAC Technical Report) - + ! temperature values at which partition function is defined real(dp), dimension(npart) :: Tpart - + ! mass excess of proton, neutron in MeV (for calculating binding energies) ! should be consistent with the mass excess of the prot and neut from the isotopes.data file @@ -402,7 +402,7 @@ module chem_def real(dp), dimension(:,:), pointer :: pfcn ! table of partition function real(dp), dimension(:), pointer :: mass_excess real(dp), dimension(:), pointer :: Z53 ! cache expensive Z^5/3 result - end type nuclide_data + end type nuclide_data type (nuclide_data) :: chem_isos ! from winvn type (integer_dict), pointer :: chem_isos_dict @@ -415,14 +415,14 @@ module chem_def character(len=iso_name_length) :: nuclide integer :: rank end type nuclide_set - - + + ! reaction categories integer, parameter :: ipp = 1 ! pp chains integer, parameter :: icno = 2 ! cno cycles - integer, parameter :: i3alf = 3 ! triple alpha - + integer, parameter :: i3alf = 3 ! triple alpha + ! "burn" in the following means decays or captures of protons, alphas, or neutrons integer, parameter :: i_burn_c = 4 integer, parameter :: i_burn_n = 5 @@ -437,28 +437,28 @@ module chem_def integer, parameter :: i_burn_ti = 14 integer, parameter :: i_burn_cr = 15 integer, parameter :: i_burn_fe = 16 - + integer, parameter :: icc = 17 ! c12 + c12 integer, parameter :: ico = 18 ! c12 + o16 integer, parameter :: ioo = 19 ! o16 + o16 - + integer, parameter :: ipnhe4 = 20 ! 2prot + 2neut -> he4 - + integer, parameter :: iphoto = 21 ! photodisintegration ! note: for photodisintegrations, eps_nuc will be negative. - + integer, parameter :: i_ni56_co56 = 22 ! ni56 -> co56 integer, parameter :: i_co56_fe56 = 23 ! co56 -> fe56 integer, parameter :: iother = 24 ! misc. - + integer, parameter :: num_categories = iother integer, parameter :: maxlen_category_name = 16 - character (len=maxlen_category_name) :: category_name(num_categories) + character (len=maxlen_category_name) :: category_name(num_categories) type (integer_dict), pointer :: category_names_dict - - ! some commonly used values of get_nuclide_index + + ! some commonly used values of get_nuclide_index integer :: & ih1, ih2, ih3, & ihe3, ihe4, & @@ -527,49 +527,49 @@ module chem_def logical :: chem_has_been_initialized = .false. - + contains - - + + subroutine init_chem_tables use utils_lib, only: integer_dict_define, integer_dict_create_hash - + integer :: i, ierr - + Tpart = (/ & 0.10d0, 0.15d0, 0.20d0, 0.30d0, 0.40d0, 0.50d0, & 0.60d0, 0.70d0, 0.80d0, 0.90d0, 1.00d0, 1.50d0, & 2.00d0, 2.50d0, 3.00d0, 3.50d0, 4.00d0, 4.50d0, & 5.00d0, 6.00d0, 7.00d0, 8.00d0, 9.00d0, 10.0d0 /) - + call init_ag_data - + call init_chem_element_names - + call init_chem_element_main_iso_names - + call init_element_atomic_weights - + call init_AG89_data - + call init_GN93_data - + call init_GS98_data - + call init_L03_data - + call init_AGS05_data - + call init_AGSS09_data - + call init_A09_Przybilla_data call init_MB22_photospheric_data call init_AAG21_photospheric_data - + call init_L09_data - + nullify(chem_element_names_dict) do i=1,num_chem_elements call integer_dict_define(chem_element_names_dict, chem_element_Name(i), i, ierr) @@ -585,7 +585,7 @@ subroutine init_chem_tables flush(6) call mesa_error(__FILE__,__LINE__) end if - + call set_category_names nullify(category_names_dict) do i=1,num_categories @@ -602,13 +602,13 @@ subroutine init_chem_tables flush(6) call mesa_error(__FILE__,__LINE__) end if - + end subroutine init_chem_tables - - + + subroutine init_ag_data use utils_lib - + real(dp) :: sum integer :: i, j, ierr @@ -728,7 +728,7 @@ subroutine init_ag_data 1.2023D-10, 2.7882D-10, 6.7411D-10, 3.1529D-10, 3.1369D-09, & 3.4034D-09, 9.6809D-09, 7.6127D-10, 1.9659D-10, 3.8519D-13, & 5.3760D-11 /) - + !..charge of the stable isotopes @@ -742,7 +742,7 @@ subroutine init_ag_data 31, 32, 32, 32, 32, 32, 33, 34, 34, 34, 34, 34, 34, & 35, 35, 36, 36, 36, 36, 36, 36, 37, 37, 38, 38, 38, & 38, 39, 40, 40, 40, 40, 40, 41, 42, 42, 42, 42, 42 /) - + izsol(118:234) = (/ & 42, 42, 44, 44, 44, 44, 44, 44, 44, 45, 46, 46, 46, & 46, 46, 46, 47, 47, 48, 48, 48, 48, 48, 48, 48, 48, & @@ -822,7 +822,7 @@ subroutine init_ag_data 0, 0, 1, 1, 0, 0, 2, 2, 0, 1, 1, 0, 0, & 0, 0, 2, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0/) - + ! get sum and stuff residual into hydrogen sum = 0.0d0 do j=1,solsiz @@ -830,7 +830,7 @@ subroutine init_ag_data enddo sum = 1.0d0 - sum solx(1) = solx(1) + sum - + sum = 0.0d0 do j=1,solsiz if (izsol(j) .ge. 3) then @@ -838,13 +838,13 @@ subroutine init_ag_data endif enddo zsol = sum - + sum = 0.0d0 do j=1,solsiz sum = sum + dble(izsol(j))/dble(iasol(j))*solx(j) enddo yesol = sum - + nullify(Xsol_names_dict) ierr = 0 do i=1,solsiz @@ -873,10 +873,10 @@ subroutine init_ag_data flush(6) call mesa_error(__FILE__,__LINE__) end if - + end subroutine init_ag_data - - + + subroutine init_chem_element_names integer :: i chem_element_name(:) = '' @@ -887,14 +887,14 @@ subroutine init_chem_element_names if (len_trim(chem_element_name(i)) == 0) then write(*,*)'missing chem_element_name(i)', i flush(6) - call mesa_error(__FILE__,__LINE__) + call mesa_error(__FILE__,__LINE__) end if end do end subroutine init_chem_element_names - - + + subroutine init_chem_element_main_iso_names ! the iso with the largest number abundance according to Lodders03 integer :: i @@ -913,7 +913,7 @@ subroutine init_chem_element_main_iso_names chem_element_main_iso_name(e_o) = 'o16' chem_element_main_iso_name(e_f) = 'f19' chem_element_main_iso_name(e_ne) = 'ne20' - + !periodic table, row 3 chem_element_main_iso_name(e_na) = 'na23' chem_element_main_iso_name(e_mg) = 'mg24' @@ -1030,13 +1030,13 @@ subroutine init_chem_element_main_iso_names if (len_trim(chem_element_main_iso_name(i)) == 0) then write(*,*)'missing chem_element_main_iso_name', i flush(6) - call mesa_error(__FILE__,__LINE__) + call mesa_error(__FILE__,__LINE__) end if end do - + end subroutine init_chem_element_main_iso_names - - + + subroutine init_element_atomic_weights use utils_lib, only: integer_dict_lookup integer :: i, isotope_index, ierr @@ -1052,15 +1052,15 @@ subroutine init_element_atomic_weights element_atomic_weight(i) = chem_isos% W(isotope_index) end do end subroutine init_element_atomic_weights - - + + subroutine init_AG89_data ! fraction by mass of total Z ! anders & grevesse 1989, paper not available on ADS integer :: i - real(dp) :: z_sum + real(dp) :: z_sum AG89_element_zfrac(:) = 0d0 - + AG89_element_zfrac(e_li) = 5.2663415161043120D-07 AG89_element_zfrac(e_be) = 8.7533846996258026D-09 AG89_element_zfrac(e_b) = 3.0535981584981396D-07 @@ -1089,23 +1089,23 @@ subroutine init_AG89_data ! fraction by mass of total Z AG89_element_zfrac(e_ni) = 3.8650578305194534D-03 AG89_element_zfrac(e_cu) = 4.4243068859971588D-05 AG89_element_zfrac(e_zn) = 1.0994428157112287D-04 - + z_sum = sum(AG89_element_zfrac(:)) do i = e_li, e_zn AG89_element_zfrac(i) = AG89_element_zfrac(i) / z_sum end do - + end subroutine init_AG89_data subroutine init_GN93_data ! fraction by mass of total Z ! Grevesse and Noels 1993 integer :: i - real(dp) :: z_sum + real(dp) :: z_sum include 'formats' GN93_element_zfrac(:) = -20.0d0 - + !GN93_element_zfrac(e_H)=12.00d0 !GN93_element_zfrac(e_He)=10.99d0 GN93_element_zfrac(e_Li)=3.31d0 !meteor @@ -1202,12 +1202,12 @@ subroutine init_GN93_data ! fraction by mass of total Z end do end subroutine init_GN93_data - - + + subroutine init_GS98_data ! fraction by mass of total Z ! Grevesse and Sauval 1998, Table 1 integer :: i - real(dp) :: z_sum + real(dp) :: z_sum include 'formats' GS98_element_zfrac(:) = -20.0d0 @@ -1295,7 +1295,7 @@ subroutine init_GS98_data ! fraction by mass of total Z GS98_element_zfrac(e_Bi)=0.71d0 GS98_element_zfrac(e_Th)=0.09d0 GS98_element_zfrac(e_U)=-0.50d0 - + ! convert to fraction of Z by mass z_sum = 0d0 do i = e_li, e_u @@ -1306,17 +1306,17 @@ subroutine init_GS98_data ! fraction by mass of total Z do i = e_li, e_u GS98_element_zfrac(i) = GS98_element_zfrac(i) / z_sum end do - + end subroutine init_GS98_data - + subroutine init_L03_data ! fraction by mass of total Z ! Lodders 2003, ApJ, Table 1 recommended abundance integer :: i - real(dp) :: z_sum + real(dp) :: z_sum include 'formats' L03_element_zfrac(:) = -20.0d0 - + !L03_element_zfrac(e_H)=12d0 !L03_element_zfrac(e_He)=10.89d0 L03_element_zfrac(e_Li)=3.28d0 @@ -1411,18 +1411,18 @@ subroutine init_L03_data ! fraction by mass of total Z do i = e_li, e_u L03_element_zfrac(i) = L03_element_zfrac(i) / z_sum end do - + end subroutine init_L03_data - - + + subroutine init_AGS05_data ! fraction by mass of total Z - ! Asplund, Grevesse and Sauval 2005 + ! Asplund, Grevesse and Sauval 2005 integer :: i - real(dp) :: z_sum + real(dp) :: z_sum include 'formats' AGS05_element_zfrac(:) = -20.0d0 - + ! first store log abundances from the paper (photosphere unless otherwise noted) ! relative to log abundance of H = 12.00d0 AGS05_element_zfrac(e_li) = 3.25d0 !meteor @@ -1517,19 +1517,19 @@ subroutine init_AGS05_data ! fraction by mass of total Z do i = e_li, e_u AGS05_element_zfrac(i) = AGS05_element_zfrac(i) / z_sum end do - + end subroutine init_AGS05_data - - + + subroutine init_AGSS09_data ! fraction by mass of total Z ! Asplund, Grevesse, Sauval, and Scott 2009 abundances ! Annu. Rev. Astron. Astrophys. 2009. 47:481–522 integer :: i - real(dp) :: z_sum + real(dp) :: z_sum include 'formats' - + AGSS09_element_zfrac(:) = -20.0d0 - + ! first store log abundances from the paper AGSS09_element_zfrac(e_li) = 3.26d0 AGSS09_element_zfrac(e_be) = 1.38d0 @@ -1612,7 +1612,7 @@ subroutine init_AGSS09_data ! fraction by mass of total Z AGSS09_element_zfrac(e_Bi) = 0.65d0 AGSS09_element_zfrac(e_Th) = 0.02d0 AGSS09_element_zfrac(e_U) = -0.54d0 - + ! convert to fraction of Z by mass z_sum = 0 do i = e_li, e_u @@ -1623,7 +1623,7 @@ subroutine init_AGSS09_data ! fraction by mass of total Z do i = e_li, e_u AGSS09_element_zfrac(i) = AGSS09_element_zfrac(i) / z_sum end do - + end subroutine init_AGSS09_data @@ -1634,9 +1634,9 @@ subroutine init_A09_Przybilla_data ! fraction by mass of total Z ! Przybilla et al. (2013), EAS proceeding to be published ! The modified elements are: he, c, n, o, ne, mg, al, si, s, ar, fe integer :: i - real(dp) :: z_sum + real(dp) :: z_sum include 'formats' - + A09_Prz_zfrac(:) = -20.0d0 ! A09_Prz_zfrac(e_h ) = 12.00d0 @@ -1722,7 +1722,7 @@ subroutine init_A09_Przybilla_data ! fraction by mass of total Z A09_Prz_zfrac(e_bi) = 0.65d0 A09_Prz_zfrac(e_th) = 0.02d0 A09_Prz_zfrac(e_u ) = -0.54d0 - + ! convert to fraction of Z by mass z_sum = 0d0 do i = e_li, e_u @@ -1733,16 +1733,16 @@ subroutine init_A09_Przybilla_data ! fraction by mass of total Z do i = e_li, e_u A09_Prz_zfrac(i) = A09_Prz_zfrac(i) / z_sum end do - + end subroutine init_A09_Przybilla_data - + subroutine init_MB22_photospheric_data ! fraction by mass of total Z ! Ekaterina Magg et al. , A&A 661, A140 (2022) photospheric abundance. ! supplimented with Asplund, Grevesse, Sauval, and Scott 2009 abundances integer :: i real(dp) :: z_sum include 'formats' - + MB22_photospheric_element_zfrac(:) = -20.0d0 ! first store log abundances from the paper @@ -1838,7 +1838,7 @@ subroutine init_MB22_photospheric_data ! fraction by mass of total Z do i = e_li, e_u MB22_photospheric_element_zfrac(i) = MB22_photospheric_element_zfrac(i) / z_sum end do - + end subroutine init_MB22_photospheric_data @@ -1850,7 +1850,7 @@ subroutine init_AAG21_photospheric_data ! fraction by mass of total Z integer :: i real(dp) :: z_sum include 'formats' - + AAG21_photospheric_element_zfrac(:) = -20.0d0 ! first store log abundances from the paper @@ -1946,17 +1946,17 @@ subroutine init_AAG21_photospheric_data ! fraction by mass of total Z do i = e_li, e_u AAG21_photospheric_element_zfrac(i) = AAG21_photospheric_element_zfrac(i) / z_sum end do - + end subroutine init_AAG21_photospheric_data - + subroutine init_L09_data ! fraction by mass of total Z ! Lodders 09 integer :: i - real(dp) :: z_sum + real(dp) :: z_sum include 'formats' - + L09_element_zfrac(:) = 0 - + ! mass fractions L09_element_zfrac(e_li) = 1.054594933683d-08 L09_element_zfrac(e_be) = 1.5087555571d-10 @@ -2039,20 +2039,20 @@ subroutine init_L09_data ! fraction by mass of total Z L09_element_zfrac(e_Bi) = 7.9004226175D-10 L09_element_zfrac(e_Th) = 2.7961831384D-10 L09_element_zfrac(e_U) = 1.546830543D-10 - + ! convert from mass fraction to fraction of Z by mass z_sum = sum(L09_element_zfrac(e_li:e_u)) do i = e_li, e_u L09_element_zfrac(i) = L09_element_zfrac(i) / z_sum end do - + end subroutine init_L09_data subroutine allocate_nuclide_data(d,n,ierr) type(nuclide_data), intent(out) :: d integer, intent(in) :: n - integer, intent(out) :: ierr + integer, intent(out) :: ierr ierr = 0 allocate(d% name(n), d% W(n), d% Z(n), d% N(n), d% Z_plus_N(n), & d% spin(N), d% binding_energy(n), d% Z53(n), & @@ -2061,7 +2061,7 @@ subroutine allocate_nuclide_data(d,n,ierr) if (ierr /= 0) return d% nnuclides = n end subroutine allocate_nuclide_data - + subroutine free_nuclide_data(n) type(nuclide_data), intent(inout) :: n @@ -2071,8 +2071,8 @@ subroutine free_nuclide_data(n) n% isomeric_state, n% mass_excess, n% pfcn, n% chem_id, n% nuclide) n% nnuclides = 0 end subroutine free_nuclide_data - - + + subroutine free_lodders03_table() use utils_lib, only : integer_dict_free deallocate(lodders03_tab6% isotopic_percent) @@ -2097,7 +2097,7 @@ function get_nuclide_index(nuclei) result(indx) if (ierr /= 0) indx = nuclide_not_found end function get_nuclide_index - + subroutine set_some_isos ih1 = get_nuclide_index('h1') ih2 = get_nuclide_index('h2') @@ -2505,7 +2505,7 @@ subroutine set_some_isos izn72 = get_nuclide_index('zn72') izn73 = get_nuclide_index('zn73') izn74 = get_nuclide_index('zn74') - + iga60 = get_nuclide_index('ga60') iga61 = get_nuclide_index('ga61') iga62 = get_nuclide_index('ga62') @@ -2522,7 +2522,7 @@ subroutine set_some_isos iga73 = get_nuclide_index('ga73') iga74 = get_nuclide_index('ga74') iga75 = get_nuclide_index('ga75') - + ige59 = get_nuclide_index('ge59') ige60 = get_nuclide_index('ge60') ige61 = get_nuclide_index('ge61') @@ -2541,7 +2541,7 @@ subroutine set_some_isos ige74 = get_nuclide_index('ge74') ige75 = get_nuclide_index('ge75') ige76 = get_nuclide_index('ge76') - + ias71 = get_nuclide_index('as71') ias72 = get_nuclide_index('as72') ias73 = get_nuclide_index('as73') @@ -2551,7 +2551,7 @@ subroutine set_some_isos ias77 = get_nuclide_index('as77') ias78 = get_nuclide_index('as78') ias79 = get_nuclide_index('as79') - + ise68 = get_nuclide_index('se68') ise69 = get_nuclide_index('se69') ise70 = get_nuclide_index('se70') @@ -2585,12 +2585,12 @@ subroutine set_some_isos isn104 = get_nuclide_index('sn104') ineut = get_nuclide_index('neut') iprot = get_nuclide_index('prot') - + end subroutine set_some_isos - - + + integer function category_id(cname) - character (len=*), intent(in) :: cname + character (len=*), intent(in) :: cname ! returns id for the category if there is a matching name ! returns 0 otherwise. integer :: i, len @@ -2611,8 +2611,8 @@ integer function category_id(cname) end do category_id = 0 end function category_id - - + + subroutine set_category_names integer :: i category_name(:) = '' @@ -2641,12 +2641,12 @@ subroutine set_category_names category_name(iphoto) = 'photo' category_name(ipnhe4) = 'pnhe4' - + category_name(i_ni56_co56) = 'ni56_co56' category_name(i_co56_fe56) = 'co56_fe56' category_name(iother) = 'other' - + i=1 ! write it this way to avoid stupid compiler warning. if (len_trim(category_name(i)) == 0) then write(*,*) 'missing name for category', i @@ -2661,7 +2661,7 @@ subroutine set_category_names call mesa_error(__FILE__,__LINE__,'set_category_names') end if end do - + end subroutine set_category_names diff --git a/chem/public/chem_lib.f90 b/chem/public/chem_lib.f90 index 0dfcae6ef..fd6869dff 100644 --- a/chem/public/chem_lib.f90 +++ b/chem/public/chem_lib.f90 @@ -28,14 +28,14 @@ module chem_lib use chem_def, only: chem_has_been_initialized use const_def, only: dp use math_lib - + implicit none contains - - - subroutine chem_init(isotopes_filename, ierr) + + + subroutine chem_init(isotopes_filename, ierr) ! uses mesa_data_dir from const_def use chem_def use chem_isos_io, only: do_read_chem_isos @@ -89,18 +89,18 @@ function lodders03_element_atom_percent(nuclei) result(percent) ! "Solar System Abundances and Condensation Temperatures of the Elements", ! ApJ, 591, 1220-1247 (2003). ! Table 6: Abundances of the Isotopes in the Solar System - + ! These are element atom percentages (i.e., by number, not by mass) - + ! NOTE: The data here stops at ge -- the table in the paper goes to 92U - + ! TO DO: add the rest of the info from the paper use chem_def use lodders_mod character(len=*), intent(in) :: nuclei real(dp) :: percent integer :: ierr - + if (.not. chem_has_been_initialized) then write(*,*) 'must call chem_init before calling any other routine in chem_lib' percent = -1.0d0 @@ -109,7 +109,7 @@ function lodders03_element_atom_percent(nuclei) result(percent) percent = get_lodders03_isotopic_abundance(nuclei, ierr) if (ierr /= 0) percent = 0.0d0 end function lodders03_element_atom_percent - + ! returns the index of a particular nuclide in a particular set ! returns nuclide_not_found if name not found @@ -134,8 +134,8 @@ subroutine generate_nuclide_set(names, set) set = [(nuclide_set(names(i), i), i=1, size(names))] call sort_nuclide_set(set) end subroutine generate_nuclide_set - - + + subroutine basic_composition_info( & num_isos, chem_id, x, xh, xhe, z, & abar, zbar, z2bar, z53bar, ye, mass_correction, sumx) @@ -150,8 +150,8 @@ subroutine basic_composition_info( & abar, zbar, z2bar, z53bar, ye, mass_correction, & sumx, .true., dabar_dx, dzbar_dx, dmc_dx) end subroutine basic_composition_info - - + + subroutine composition_info( & num_isos, chem_id, x, xh, xhe, z, & abar, zbar, z2bar, z53bar, ye, mass_correction, & @@ -167,8 +167,8 @@ subroutine composition_info( & abar, zbar, z2bar, z53bar, ye, mass_correction, & sumx, .false., dabar_dx, dzbar_dx, dmc_dx) end subroutine composition_info - - + + subroutine get_composition_info( & num_isos, chem_id, x, xh, xhe, xz, & abar, zbar, z2bar, z53bar, ye, mass_correction, & @@ -179,9 +179,9 @@ subroutine get_composition_info( & ! A(i) ion atomic mass number ! W(i) ion atomic weight (g/mole) ! Z(i) ion charge (number of protons) - ! Y(i) = X(i)/A(i), ion abundance + ! Y(i) = X(i)/A(i), ion abundance ! n(i) = rho*avo*Y(i), ion number density (g/cm^3)*(#/mole)*(mole/g) -> (#/cm^3) - + ! abar = sum(n(i)*A(i))/sum(n(i)) -- average atomic mass number ! zbar = sum(n(i)*Z(i))/sum(n(i)) -- average charge number ! z2bar = sum(n(i)*Z(i)^2)/sum(n(i)) -- average charge^2 @@ -201,7 +201,7 @@ subroutine get_composition_info( & xh, xhe, xz, abar, zbar, z2bar, z53bar, ye, mass_correction, sumx logical, intent(in) :: skip_partials real(dp), dimension(:) :: dabar_dx, dzbar_dx, dmc_dx - + real(dp), dimension(num_isos) :: y, z, w, a integer :: i, cid, iz if (.not. chem_has_been_initialized) then @@ -224,7 +224,7 @@ subroutine get_composition_info( & xhe = xhe + x(i) end select end do - + xz = max(0d0, min(1d0, 1d0 - (xh + xhe))) sumx = sum(x(1:num_isos)) ! this should be one, always, since we define x as a baryon fraction abar = sumx / sum(y(1:num_isos)) @@ -241,39 +241,39 @@ subroutine get_composition_info( & z53bar = z53bar * abar if (skip_partials) return - + do i=1,num_isos dabar_dx(i) = abar*(a(i)-abar)/a(i)/sumx dzbar_dx(i) = abar*(z(i)-zbar)/a(i)/sumx dmc_dx(i) = w(i)/a(i) - mass_correction end do - + end subroutine get_composition_info - - + + ! Q: Is positron annihilation actually included in Qtotal? ! A: (from Frank Timmes) ! - ! the formula used in the code is the atomic mass excess - not the nuclear mass excess - + ! the formula used in the code is the atomic mass excess - not the nuclear mass excess - ! in terms of the binding energy and Deltas. as bill notes, this formulation - ! implicitly takes care of the electron masses. i can see why some confusion may - ! arise at first blush because of the notation used in the code - its says “Mp” but + ! implicitly takes care of the electron masses. i can see why some confusion may + ! arise at first blush because of the notation used in the code - its says “Mp” but ! really means “Mh” where Mh = m_p + m_e. ! ! p + p -> d + e^+ + nu ! - ! let’s do it by hand and then by code, neglecting binding energy terms of + ! let’s do it by hand and then by code, neglecting binding energy terms of ! the atom (13.6 eV and such) as they are a million times smaller than the nuclear terms. ! ! by hand: ! - ! mass excess left-hand-side = twice hydrogen mass excess = + ! mass excess left-hand-side = twice hydrogen mass excess = ! 2 * (m_h - 1 amu) = 2 (m_p + m_e - 1 amu) ! - ! mass excess right-hand-side = + ! mass excess right-hand-side = ! m_h + m_n - B(d) - 2 amu = m_p + m_e + m_n - B(d) - 2 amu ! - ! Q = left - right = m_p + m_e - m_n + B(d) + ! Q = left - right = m_p + m_e - m_n + B(d) ! ! which may be written (adding and subtracting m_p) ! @@ -293,8 +293,8 @@ end subroutine get_composition_info ! ! ! third loop - ! Q = B(d) - del_Mp - del_Mn - ! = B(d) - (m_h - 1 amu) - (m_n - 1 amu) + ! Q = B(d) - del_Mp - del_Mn + ! = B(d) - (m_h - 1 amu) - (m_n - 1 amu) ! = B(d) - (m_p + m_e - 1 amu) - (m_n - 1 amu) ! = B(d) - (mp + m_e + m_n - 2 amu) ! note this is the negative of the right-hand-side term above ! @@ -303,8 +303,8 @@ end subroutine get_composition_info ! ! ! i think the confusion lay between the code nomenclature - ! and nuclear vs atomic mass excesses. - + ! and nuclear vs atomic mass excesses. + real(dp) function reaction_Qtotal(num_in,num_out,reactants,nuclides) use chem_def integer, intent(in) :: num_in,num_out,reactants(:) @@ -320,17 +320,17 @@ real(dp) function reaction_Qtotal(num_in,num_out,reactants,nuclides) else reaction_Qtotal = reaction_Qtotal + Q end if - + end do end function reaction_Qtotal - - - integer function chem_get_element_id(cname) + + + integer function chem_get_element_id(cname) ! NOTE: this is for elements like 'h', not for isotopes like 'h1' ! use chem_get_iso_id for looking up isotope names use chem_def use utils_lib - character (len=*), intent(in) :: cname + character (len=*), intent(in) :: cname ! name of the element (e.g. 'h', 'he', 'ne') ! same names as in chem_element_Name ! returns id for the element if there is a matching name @@ -345,10 +345,10 @@ integer function chem_get_element_id(cname) if (ierr /= 0) value = -1 chem_get_element_id = value end function chem_get_element_id - - + + real(dp) function chem_Xsol(nam) - character (len=*), intent(in) :: nam + character (len=*), intent(in) :: nam ! name of the isotope (e.g. 'h1', 'he4', 'ne20') real(dp) :: z, a, xelem integer :: ierr @@ -364,13 +364,13 @@ real(dp) function chem_Xsol(nam) chem_Xsol = xelem end if end function chem_Xsol - + subroutine chem_get_solar(nam, z, a, xelem, ierr) use chem_def use utils_lib ! returns data from Anders and Grevesse, 1989 - character (len=*), intent(in) :: nam + character (len=*), intent(in) :: nam ! name of the isotope (e.g. 'h1', 'he4', 'ne20') ! note that these names match those in the nuclear net library iso_Names array ! but some net isotopes are not here (ex/ be7, n13, o14, o15, f17, f18, ... fe52, ni56 ) @@ -394,8 +394,8 @@ subroutine chem_get_solar(nam, z, a, xelem, ierr) xelem = solx(i) end subroutine chem_get_solar - - + + ! given an array of Z, A, returns an array of names in chem_isos format subroutine generate_nuclide_names(Z, A, names) use chem_def @@ -431,7 +431,7 @@ subroutine generate_nuclide_names(Z, A, names) names(i) = adjustr(names(i)) end do end subroutine generate_nuclide_names - + subroutine generate_long_nuclide_names(Z, A, long_names) use chem_def @@ -466,29 +466,29 @@ subroutine generate_long_nuclide_names(Z, A, long_names) end select end do end subroutine generate_long_nuclide_names - - + + ! nuclide information comes from the chem_isos tables ! the storage container for the data is called 'chem_isos' ! it has name, A, Z, N, spin, and B for each nuclide - ! use the function chem_get_iso_id to find the index given the name. + ! use the function chem_get_iso_id to find the index given the name. integer function chem_get_iso_id(cname) use chem_def, only: get_nuclide_index character(len=*), intent(in) :: cname chem_get_iso_id = get_nuclide_index(cname) - end function chem_get_iso_id - - + end function chem_get_iso_id + + integer function lookup_ZN(Z,N) integer, intent(in) :: Z, N lookup_ZN = lookup_ZN_isomeric_state(Z,N,0) - end function lookup_ZN - - + end function lookup_ZN + + integer function lookup_ZN_isomeric_state(Z,N,isomeric_state) use chem_def, only: chem_isos, num_chem_isos integer, intent(in) :: Z, N, isomeric_state - integer :: cid, i + integer :: cid, i iso_loop: do cid = 1, num_chem_isos if (chem_isos% Z(cid) == Z .and. chem_isos% N(cid) == N) then if (chem_isos% isomeric_state(cid) == isomeric_state) then @@ -505,13 +505,13 @@ integer function lookup_ZN_isomeric_state(Z,N,isomeric_state) end if end do iso_loop lookup_ZN_isomeric_state = 0 ! indicating failure - end function lookup_ZN_isomeric_state - - + end function lookup_ZN_isomeric_state + + integer function rates_category_id(cname) use chem_def, only: category_names_dict use utils_lib - character (len=*), intent(in) :: cname + character (len=*), intent(in) :: cname ! returns id for the category if there is a matching name ! returns 0 otherwise. integer :: ierr, value @@ -519,7 +519,7 @@ integer function rates_category_id(cname) if (ierr /= 0) value = 0 rates_category_id = value end function rates_category_id - + function binding_energy(nuclides, Y) result (B) use chem_def @@ -528,7 +528,7 @@ function binding_energy(nuclides, Y) result (B) real(dp) :: B B = dot_product(nuclides% binding_energy, Y) end function binding_energy - + ! returns mass excess in MeV function get_mass_excess(nuclides,chem_id) result (mass_excess) use chem_def @@ -536,7 +536,7 @@ function get_mass_excess(nuclides,chem_id) result (mass_excess) integer, intent(in) :: chem_id real(dp) :: mass_excess logical :: use_nuclides_mass_excess=.false. - + ! These should be identical but can have slight ~ulp difference ! due to floating point maths if(use_nuclides_mass_excess)then @@ -544,19 +544,19 @@ function get_mass_excess(nuclides,chem_id) result (mass_excess) else mass_excess = nuclides% Z(chem_id)*del_Mp + nuclides% N(chem_id)*del_Mn -& nuclides% binding_energy(chem_id) - end if - + end if + end function - + function get_Q(nuclides,chem_id) result (q) use chem_def type(nuclide_data), intent(in) :: nuclides integer, intent(in) :: chem_id real(dp) :: q - + !Minus the mass excess q=-get_mass_excess(nuclides,chem_id) - + end function ! returns the indx corresponding to Tpart just less than T9 @@ -595,18 +595,18 @@ function get_partition_fcn_indx(T9) result(indx) end do ! should never get here indx = low-1 - + end function get_partition_fcn_indx ! Given a the chem_id's and abundances for a set of isotopes ! return the abundances of the stable isotopes where the unstable ones ! have decayed to the stable versions. - ! Code from Frank Timmes "decay.zip" + ! Code from Frank Timmes "decay.zip" ! Note this makes some asumptions, firstly that isotopes can only decay to one ! output (thus there are no branches), also we assume an inifinite timescale ! for decay. If you need a high precision output I suggest you use a one zone ! burn model rather than this. - subroutine get_stable_mass_frac(chem_id,num_species,abun_in,abun_out) + subroutine get_stable_mass_frac(chem_id,num_species,abun_in,abun_out) use chem_def integer,intent(in),dimension(:) :: chem_id integer,intent(in) :: num_species @@ -638,7 +638,7 @@ subroutine get_stable_mass_frac(chem_id,num_species,abun_in,abun_out) (z.le.izsol(j) .and. jcode(j).eq.2) .or. & (z.eq.izsol(j) .and. jcode(j).eq.3) .or. & (Z==17 .and. A==36 .and. izsol(j) == 18 .and. iasol(j) == 36) .or. & ! cl36 -> ar36 special case - (Z==21 .and. A==46 .and. izsol(j) == 22 .and. iasol(j) == 46) .or. & ! sc46 -> ti46 special case + (Z==21 .and. A==46 .and. izsol(j) == 22 .and. iasol(j) == 46) .or. & ! sc46 -> ti46 special case (Z==21 .and. A==48 .and. izsol(j) == 22 .and. iasol(j) == 48) .or. & ! sc48 -> ti48 special case (Z==25 .and. A==54 .and. izsol(j) == 24 .and. iasol(j) == 54) .or. & ! mn54 -> cr54 special case (Z==27 .and. A==58 .and. izsol(j) == 26 .and. iasol(j) == 58) .or. & ! co58-> fe58 special case @@ -647,7 +647,7 @@ subroutine get_stable_mass_frac(chem_id,num_species,abun_in,abun_out) (Z==33 .and. A==74 .and. izsol(j) == 32 .and. iasol(j) == 74) .or. & ! as74 -> ge74 special case (Z==33 .and. A==76 .and. izsol(j) == 34 .and. iasol(j) == 76) .or. & ! as76 -> se76 special case (Z==35 .and. A==78 .and. izsol(j) == 34 .and. iasol(j) == 78) .or. & ! br78 -> se78 special case - (Z==35 .and. A==80 .and. izsol(j) == 36 .and. iasol(j) == 80) .or. & ! br80 -> kr80 special case + (Z==35 .and. A==80 .and. izsol(j) == 36 .and. iasol(j) == 80) .or. & ! br80 -> kr80 special case (Z==35 .and. A==82 .and. izsol(j) == 36 .and. iasol(j) == 82) .or. & ! br82 -> kr82 special case (Z==37 .and. A==84 .and. izsol(j) == 36 .and. iasol(j) == 84) & ! rb84 -> kr84 special case ) then @@ -664,19 +664,19 @@ subroutine get_stable_mass_frac(chem_id,num_species,abun_in,abun_out) !Normalise results abun_out(1:solsiz)=abun_out(1:solsiz)/sum(abun_out(1:solsiz)) - + end subroutine get_stable_mass_frac - real(dp) function chem_M_div_h(x,z,zfrac_choice) ! Returns [M/H] + real(dp) function chem_M_div_h(x,z,zfrac_choice) ! Returns [M/H] use chem_def use utils_lib, only: mesa_error real(dp), intent(in) :: x ! Hydrogen fraction real(dp), intent(in) :: z ! metal fraction integer, intent(in) :: zfrac_choice ! See chem_def, *_zfracs options - + real(dp) :: zsolar,ysolar - + zsolar = 0d0 ysolar = 0d0 select case(zfrac_choice) @@ -715,10 +715,10 @@ real(dp) function chem_M_div_h(x,z,zfrac_choice) ! Returns [M/H] case default call mesa_error(__FILE__,__LINE__,"Bad zfrac_choice") end select - + chem_M_div_h = log10(z/x)-log10(zsolar/(1.d0-zsolar-ysolar)) - - + + end function chem_M_div_h diff --git a/colors/private/mod_colors.f90 b/colors/private/mod_colors.f90 index c97d9a954..cde107e59 100644 --- a/colors/private/mod_colors.f90 +++ b/colors/private/mod_colors.f90 @@ -29,58 +29,58 @@ module mod_colors use math_lib use const_def use utils_lib - + implicit none private public :: do_colors_init, free_colors_all, Eval_Colors contains - + subroutine do_colors_init(num_files,fnames,num_colors,ierr) integer,intent(in) :: num_files integer,dimension(:),intent(in) :: num_colors - character(len=*),dimension(:),intent(in) :: fnames + character(len=*),dimension(:),intent(in) :: fnames character(len=strlen) :: fname type (lgt_list), pointer :: thead =>null() - + integer, intent(out) :: ierr integer :: i - + ierr = 0 num_thead=num_files - + if(num_thead<1)THEN color_is_initialized=.false. !Not a failure just dont have any files to read ierr=0 return END IF - + ALLOCATE(thead_all(1:num_thead),STAT=ierr) - if (ierr /= 0) then + if (ierr /= 0) then write(*,*) 'colors can not allocate memory in do_colors_init' ierr=-1 return end if - + bc_total_num_colors=0 do i=1,num_thead allocate(thead_all(i)%thead) - + thead=>thead_all(i)%thead - + fname=fnames(i) thead_all(i)%n_colors=num_colors(i) if(len(fname)==0)THEN exit end if - + if(thead_all(i)%n_colors<1)THEN write(*,*) "num_colors must be > 0" ierr=-1 return end if - + call init_colors(fname,thead,thead_all(i)%color_names,thead_all(i)%n_colors,ierr) thead_all(i)%thead=>thead @@ -89,23 +89,23 @@ subroutine do_colors_init(num_files,fnames,num_colors,ierr) end do color_is_initialized=.true. - + end subroutine do_colors_init subroutine init_colors(fname, thead, col_names, n_colors, ierr) integer, intent(out) :: ierr character(len=*),intent(in) :: fname - type (lgt_list), pointer :: thead + type (lgt_list), pointer :: thead character(len=*),dimension(:) :: col_names integer, intent(in) :: n_colors - call Read_Colors_Data(fname, thead, col_names, n_colors, ierr) + call Read_Colors_Data(fname, thead, col_names, n_colors, ierr) end subroutine init_colors - + subroutine free_colors_all integer :: i type (lgt_list), pointer :: thead => null() - + do i=1,num_thead if(associated(thead_all(i)%thead))then thead=>thead_all(i)%thead @@ -113,7 +113,7 @@ subroutine free_colors_all end if end do deallocate(thead_all) - + end subroutine free_colors_all subroutine free_colors(thead) @@ -128,41 +128,41 @@ subroutine free_colors(thead) tlist => tnxt end do nullify(thead) - + contains - + subroutine free_glist(gptr) - type (lgg_list), pointer :: gptr - type (lgg_list), pointer :: glist => null() - type (lgg_list), pointer :: gnxt => null() - glist => gptr + type (lgg_list), pointer :: gptr + type (lgg_list), pointer :: glist => null() + type (lgg_list), pointer :: gnxt => null() + glist => gptr do while (associated(glist)) gnxt => glist% nxt call free_zlist(glist% zlist) deallocate(glist) glist => gnxt - end do + end do end subroutine free_glist - + subroutine free_zlist(zptr) type (lgz_list), pointer :: zptr type (lgz_list), pointer :: zlist => null() type (lgz_list), pointer :: znxt => null() - zlist => zptr + zlist => zptr do while (associated(zlist)) znxt => zlist% nxt deallocate(zlist) zlist => znxt end do end subroutine free_zlist - + end subroutine free_colors subroutine show_tree(thead) type (lgt_list), pointer :: thead type (lgt_list), pointer :: tlist => null(), tnxt => null() - + tlist => thead do while (associated(tlist)) write(*,*) 'tlist lgt', exp10(tlist% lgt) @@ -170,37 +170,37 @@ subroutine show_tree(thead) call show_glist(tlist% glist) tlist => tnxt end do - + contains - + subroutine show_glist(gptr) type (lgg_list), pointer :: gptr type (lgg_list), pointer :: glist => null(), gnxt => null() - + glist => gptr do while (associated(glist)) write(*,*) 'glist% lgg', glist% lgg gnxt => glist% nxt call show_zlist(glist% zlist) glist => gnxt - end do + end do end subroutine show_glist - + subroutine show_zlist(zptr) - type (lgz_list), pointer :: zptr - type (lgz_list), pointer :: zlist => null() - type (lgz_list), pointer :: znxt => null() - zlist => zptr + type (lgz_list), pointer :: zptr + type (lgz_list), pointer :: zlist => null() + type (lgz_list), pointer :: znxt => null() + zlist => zptr do while (associated(zlist)) write(*,*) 'zlist% lgz', zlist% lgz znxt => zlist% nxt zlist => znxt - end do + end do end subroutine show_zlist - + end subroutine show_tree - - + + subroutine Read_One_Colors_Data(fname, thead, n_colors, col_names, ierr) integer, intent(out) :: ierr ! 0 means ok type (lgt_list), pointer,intent(inout) :: thead @@ -219,9 +219,9 @@ subroutine Read_One_Colors_Data(fname, thead, n_colors, col_names, ierr) character(len=4096) :: tmp integer :: num_entries, num_made, IO_UBV - + include 'formats' - + ! Try local folder first open(NEWUNIT=IO_UBV, FILE=trim(fname), ACTION='READ', STATUS='OLD', IOSTAT=ios) if(ios/=0) THEN @@ -236,7 +236,7 @@ subroutine Read_One_Colors_Data(fname, thead, n_colors, col_names, ierr) ierr = 1; return endif end if - + ierr = 0 num_entries = 0 cnt = 0 @@ -246,26 +246,26 @@ subroutine Read_One_Colors_Data(fname, thead, n_colors, col_names, ierr) read(IO_UBV,'(a)') tmp call split_line(tmp,3+n_colors,tmp_cols) - + col_names(1:n_colors) = tmp_cols(4:n_colors+3) - + do while (.true.) read(IO_UBV,fmt=*,iostat=ios) lgt, lgg, lgz, colors(1:n_colors) if (ios /= 0) exit cnt = cnt + 1 - lgt = log10(lgt) + lgt = log10(lgt) if(cnt==1) thead%lgt = lgt - + call get_tlist(thead, lgt, tlist, ierr) - if (ierr /= 0) exit - + if (ierr /= 0) exit + call get_glist(tlist% glist, lgg, glist, ierr) if (ierr /= 0) exit - + call get_zlist(glist% zlist, lgz, zlist, num_entries, ierr) if (ierr /= 0) exit - + if(zlist% colors(1) > -1d98) then write(*,*) "Warning found duplicated color data for (T, log g, M/H)=", 10**lgT, lgg, lgz end if @@ -273,12 +273,12 @@ subroutine Read_One_Colors_Data(fname, thead, n_colors, col_names, ierr) zlist% colors = colors end do - + close(IO_UBV) if (ierr /= 0) return - + num_made = 0 - + tlist => thead lgt = 1d99 do while (associated(tlist)) @@ -307,23 +307,23 @@ subroutine Read_One_Colors_Data(fname, thead, n_colors, col_names, ierr) end do tlist => tlist% nxt end do - + if(num_entries /= num_made)then - write(0,*) "Error fond less colors than expected ",num_entries,num_made + write(0,*) "Error fond less colors than expected ",num_entries,num_made stop end if - - + + end subroutine Read_One_Colors_Data - - + + subroutine Read_Colors_Data(fname, thead, col_names, n_colors, ierr) integer, intent(out) :: ierr ! 0 means ok type (lgt_list), pointer,intent(inout) :: thead character (len=*),intent(in) :: fname character(len=*),dimension(:),intent(out) :: col_names integer, intent(in) :: n_colors - + Call Read_One_Colors_Data(fname, thead, n_colors, col_names, ierr) if (ierr /= 0) THEN write(*,*) "Read_Colors_One_Data error" @@ -337,29 +337,29 @@ subroutine get_tlist(head, lgt, tlist, ierr) real(dp), intent(in) :: lgt type (lgt_list), pointer :: tlist integer, intent(out) :: ierr ! 0 means ok - + type (lgt_list), pointer :: t1=>null(), t2=>null() - + ierr = 0 - + if (.not. associated(head)) then ! first time if (.not. alloc_tlist()) return head => tlist return end if - + if (head% lgt == lgt) then ! matches head of list tlist => head return end if - + if (head% lgt < lgt) then ! becomes new head of list if (.not. alloc_tlist()) return tlist% nxt => head head => tlist return end if - + ! check list t1 => head do while (associated(t1% nxt)) @@ -367,7 +367,7 @@ subroutine get_tlist(head, lgt, tlist, ierr) if (t2% lgt == lgt) then tlist => t2; return end if - if (t2% lgt < lgt) then ! insert new one before t2 + if (t2% lgt < lgt) then ! insert new one before t2 if (.not. alloc_tlist()) return tlist% nxt => t2 t1% nxt => tlist @@ -378,9 +378,9 @@ subroutine get_tlist(head, lgt, tlist, ierr) ! add to end of list after t1 if (.not. alloc_tlist()) return t1% nxt => tlist - + contains - + logical function alloc_tlist() integer :: istat allocate(tlist,stat=istat) @@ -389,7 +389,7 @@ logical function alloc_tlist() end if nullify(tlist% glist) nullify(tlist% nxt) - tlist% lgt = lgt + tlist% lgt = lgt alloc_tlist = .true. end function alloc_tlist @@ -399,31 +399,31 @@ end subroutine get_tlist subroutine get_glist(head, lgg, glist, ierr) type (lgg_list), pointer :: head real(dp), intent(in) :: lgg - type (lgg_list), pointer :: glist + type (lgg_list), pointer :: glist integer, intent(out) :: ierr - + type (lgg_list), pointer :: g1 => null(), g2 => null() - + ierr = 0 - + if (.not. associated(head)) then ! first time if (.not. alloc_glist()) return head => glist return end if - + if (head% lgg == lgg) then ! matches head of list glist => head return end if - + if (head% lgg < lgg) then ! becomes new head of list if (.not. alloc_glist()) return glist% nxt => head head => glist return end if - + ! check list g1 => head do while (associated(g1% nxt)) @@ -431,7 +431,7 @@ subroutine get_glist(head, lgg, glist, ierr) if (g2% lgg == lgg) then glist => g2; return end if - if (g2% lgg < lgg) then ! insert new one before g2 + if (g2% lgg < lgg) then ! insert new one before g2 if (.not. alloc_glist()) return glist% nxt => g2 g1% nxt => glist @@ -442,9 +442,9 @@ subroutine get_glist(head, lgg, glist, ierr) ! add to end of list after g1 if (.not. alloc_glist()) return g1% nxt => glist - + contains - + logical function alloc_glist() integer :: istat allocate(glist,stat=istat) @@ -453,11 +453,11 @@ logical function alloc_glist() end if nullify(glist% zlist) nullify(glist% nxt) - glist% lgg = lgg - alloc_glist = .true. + glist% lgg = lgg + alloc_glist = .true. end function alloc_glist - - end subroutine get_glist + + end subroutine get_glist subroutine get_zlist(head, lgz, zlist, num_entries, ierr) type (lgz_list), pointer :: head @@ -465,29 +465,29 @@ subroutine get_zlist(head, lgz, zlist, num_entries, ierr) type (lgz_list), pointer :: zlist integer, intent(out) :: ierr ! 0 means ok integer,intent(inout) :: num_entries - + type (lgz_list), pointer :: z1=>null(), z2=>null() - + ierr = 0 - + if (.not. associated(head)) then ! first time if (.not. alloc_zlist()) return head => zlist return end if - + if (head% lgz == lgz) then ! matches head of list zlist => head return end if - + if (head% lgz < lgz) then ! becomes new head of list if (.not. alloc_zlist()) return zlist% nxt => head head => zlist return end if - + ! check list z1 => head do while (associated(z1% nxt)) @@ -495,7 +495,7 @@ subroutine get_zlist(head, lgz, zlist, num_entries, ierr) if (z2% lgz == lgz) then zlist => z2; return end if - if (z2% lgz < lgz) then ! insert new one before z2 + if (z2% lgz < lgz) then ! insert new one before z2 if (.not. alloc_zlist()) return zlist% nxt => z2 z1% nxt => zlist @@ -506,9 +506,9 @@ subroutine get_zlist(head, lgz, zlist, num_entries, ierr) ! add to end of list after z1 if (.not. alloc_zlist()) return z1% nxt => zlist - + contains - + logical function alloc_zlist() integer :: istat allocate(zlist,stat=istat) @@ -517,12 +517,12 @@ logical function alloc_zlist() end if nullify(zlist% nxt) num_entries=num_entries+1 - zlist% lgz = lgz + zlist% lgz = lgz alloc_zlist = .true. end function alloc_zlist - + end subroutine get_zlist - + subroutine Eval_Colors(log_Teff,log_g, M_div_h_in, results, thead, n_colors, ierr) real(dp), intent(in) :: log_Teff ! log10 of surface temp @@ -532,30 +532,30 @@ subroutine Eval_Colors(log_Teff,log_g, M_div_h_in, results, thead, n_colors, ier integer, intent(in) :: n_colors integer, intent(out) :: ierr type (lgt_list), pointer,intent(inout) :: thead - + !real(dp), parameter :: Zsol = 0.02d0, colors_bol_sun = 4.746d0 - + real(dp) :: lgg, lgz, lgt, alfa, beta real(dp),dimension(max_num_bcs_per_file) :: results1, results2 type (lgt_list), pointer :: tlist => null(), tnxt => null() - + lgg=log_g lgz=M_div_h_in lgt=log_Teff - + if (.not. associated(thead)) then ierr = -1; return end if - + ierr = 0 ! write(*,*) log_Teff,log_g, M_div_h_in - + if (lgt >= thead% lgt) then ! Error out results = -1d99 return else - + tlist => thead do while (associated(tlist% nxt)) tnxt => tlist% nxt @@ -583,25 +583,25 @@ subroutine Eval_Colors(log_Teff,log_g, M_div_h_in, results, thead, n_colors, ier tlist => tnxt end do end if - + ! Below all available log t's results = -1d99 - + end subroutine Eval_Colors - - + + subroutine get_glist_results(gptr, lgg, lgz, results, n_colors, ierr) type (lgg_list), pointer :: gptr real(dp), intent(in) :: lgg, lgz real(dp),dimension(:), intent(out) :: results integer,intent(in) :: n_colors integer,intent(out) :: ierr - + type (lgg_list), pointer :: glist => null(), gnxt => null() real(dp),dimension(max_num_bcs_per_file) :: results1, results2 real(dp) :: alfa, beta - + glist => gptr ierr = 0 if (.not. associated(glist)) then @@ -609,7 +609,7 @@ subroutine get_glist_results(gptr, lgg, lgz, results, n_colors, ierr) ierr = -1 return end if - + if (lgg >= glist% lgg) then ! use the largest lgg results = -1d99 return @@ -627,8 +627,8 @@ subroutine get_glist_results(gptr, lgg, lgz, results, n_colors, ierr) call get_zlist_results(glist% zlist, lgz, results1, n_colors, ierr) if (ierr /= 0) return call get_zlist_results(gnxt% zlist, lgz, results2, n_colors, ierr) - if (ierr /= 0) return - + if (ierr /= 0) return + if(any(results1(1:n_colors)<-1d50) .or.any(results2(1:n_colors)<-1d50) ) then results = -1d99 return @@ -640,32 +640,32 @@ subroutine get_glist_results(gptr, lgg, lgz, results, n_colors, ierr) end if glist => gnxt end do - + ! below all available log g's results = -1d99 - + end subroutine get_glist_results - - + + subroutine get_zlist_results(zptr, lgz, results, n_colors, ierr) type (lgz_list), pointer :: zptr real(dp), intent(in) :: lgz real(dp),dimension(:), intent(out) :: results integer, intent(in) :: n_colors integer, intent(out) :: ierr - + type (lgz_list), pointer :: zlist => null(), znxt => null() real(dp) :: alfa, beta - + zlist => zptr - + ierr = 0 if (.not. associated(zlist)) then write(*,*) 'bad zlist for get_zlist_results' ierr = -1 return end if - + if (lgz >= zlist% lgz) then ! use the largest lgz results = -1d99 return @@ -685,10 +685,10 @@ subroutine get_zlist_results(zptr, lgz, results, n_colors, ierr) end if zlist => znxt end do - + ! below all available log z's results = -1d99 - + end subroutine get_zlist_results diff --git a/colors/public/colors_def.f90 b/colors/public/colors_def.f90 index 87e8b6826..70eede673 100644 --- a/colors/public/colors_def.f90 +++ b/colors/public/colors_def.f90 @@ -27,15 +27,15 @@ module colors_def use const_def, only : strlen, dp implicit none - + !Public constants for use by clients !Have we called colors_init yet? logical :: color_is_initialized=.false. - + integer, parameter :: max_num_color_files=10 - integer, parameter :: max_num_bcs_per_file=20 + integer, parameter :: max_num_bcs_per_file=20 integer :: bc_total_num_colors - + ! color indices are differences in magnitudes in different wavelength bands ! as a reminder for non-experts like myself, here's how it goes ! @@ -48,7 +48,7 @@ module colors_def ! i.e., absolute magnitude is what the apparent magnitude would be if star were at 10 parsecs. ! ! thus absolute magnitude of sun is about 4.75 - ! + ! ! "bolometric magnitude" = absolute magnitude using flux integrated over all wavelengths ! can be derived from the current stellar luminosity using the equation ! log(Lstar/Lsun) = (Mbol_sun - Mbol_star)/2.5 using Mbol_sun = 4.75 (LCB) @@ -67,10 +67,10 @@ module colors_def ! "V" is the visual magnitude, center at 550nm. ! "R" is the red magnitude, center at 600nm. ! "I" is the infra-red magnitude, center at 800nm. - + ! in addition, longer wavelength "colors" have been defined as well ! by order of increasing wavelength, these are J, H, K, L, and M. - + ! "color index" is the difference between 2 color magnitudes ! for example, B-V is colors_B - colors_V ! smaller B-V means larger brightness in blue band compared to visual band, means bluer star. @@ -79,15 +79,15 @@ module colors_def ! color magnitude data from Lejeune, Cuisinier, Buser (1998) A&AS 130, 65-75. [LCB] ! the coverage is approximately Teff from 50,000K to 2000K, log g 5.5 to -1.02, [Fe/H} 1.0 to -5.0 ! - ! but not all combination of these are actually represented in the tables. + ! but not all combination of these are actually represented in the tables. ! the current implementation limits the given arguments to the actual range in the tables. ! and it does a simple linear interpolation between tabulated values. ! BTW: they use [Fe/H] as a parameter; ! the evolution code uses log10(Z/Zsun) as an approximation for this. - + ! THE FOLLOWING ARE PRIVATE DEFS -- NOT FOR USE BY CLIENTS - + type :: lgz_list ! sorted in decreasing order of lgz ([M/H]) real(dp) :: lgz ! [Fe_H] type (lgz_list), pointer :: nxt => null() @@ -106,7 +106,7 @@ module colors_def type (lgg_list), pointer :: nxt => null() type (lgz_list), pointer :: zlist => null() end type - + type :: col_list !Main data store type(lgt_list), pointer :: thead => null() @@ -116,7 +116,7 @@ module colors_def integer :: num_thead type (col_list),dimension(:),pointer :: thead_all => null() - - + + end module colors_def diff --git a/colors/public/colors_lib.f90 b/colors/public/colors_lib.f90 index 2e6151be7..aa3e42f4b 100644 --- a/colors/public/colors_lib.f90 +++ b/colors/public/colors_lib.f90 @@ -34,39 +34,39 @@ module colors_lib ! Color-magnitude data shipped with MESA is from: ! Lejeune, Cuisinier, Buser (1998) A&AS 130, 65-75. ! However, you add your own bolometric corrections files for mesa to use - + ! The data interface for the library is defined in colors_def ! Th easiest way to get output is to add the columns to your history_columns.list file - - ! The prefered way for users (in a run_star_extras routine) for accessing the colors data is to + + ! The prefered way for users (in a run_star_extras routine) for accessing the colors data is to ! call either get_by_by_name, get_abs_mag_by_name or get_abs_bolometric_mag. Other routines are there ! to hook into the rest of MESA. - - ! Routines get_bc will return the coefficents from interpolating over log Teff, log g, [M/H] - ! even though the tables are defined as Teff, log g, [M/H]. get_abs_mag routines return + + ! Routines get_bc will return the coefficents from interpolating over log Teff, log g, [M/H] + ! even though the tables are defined as Teff, log g, [M/H]. get_abs_mag routines return ! data thats been turned into an absolute magnitude. A color can be computed by taking the difference between ! two get_bc or two get_abs_mag calls. - + ! Names for the filters should be unique accross all data files (left to the user to enforce this). ! Name matching is perfomed in a case sensitive manner. ! The names themselves are not important as far as MESA is concerned, you can name each filter (including the ! ones MESA ships by defaults) by what ever name you want by editing the data file(s) and changing the names in the header. ! MESA does not rely on any particlaur band exisiting. - + implicit none contains ! the procedure interface for the library ! client programs should only call these routines. - - + + subroutine colors_init(num_files,fnames,num_colors,ierr) use mod_colors, only : do_colors_init integer, intent(in) :: num_files integer, dimension(:), intent(in) :: num_colors - character(len=*), dimension(:), intent(in) :: fnames + character(len=*), dimension(:), intent(in) :: fnames integer, intent(out) :: ierr - + ierr=0 !$OMP critical (color_init) @@ -80,23 +80,23 @@ subroutine colors_init(num_files,fnames,num_colors,ierr) write(*,*) "colors_init failed" return endif - + end subroutine colors_init - - + + subroutine colors_shutdown () use mod_colors, only : free_colors_all if (.not. color_is_initialized) return - + call free_colors_all() color_is_initialized = .FALSE. end subroutine colors_shutdown - - + + subroutine get_bcs_one(log_Teff, log_g, M_div_h, results, thead,n_colors, ierr) use mod_colors, only : Eval_Colors ! input @@ -108,17 +108,17 @@ subroutine get_bcs_one(log_Teff, log_g, M_div_h, results, thead,n_colors, ierr) integer, intent(in) :: n_colors integer, intent(inout) :: ierr type (lgt_list),intent(inout), pointer :: thead - + results(:)=-99.9d0 ierr=0 - + if (.not. color_is_initialized) then ierr=-1 return endif - + call Eval_Colors(log_Teff, log_g, M_div_h, results,thead,n_colors, ierr) - + end subroutine get_bcs_one real(dp) function get_bc_by_name(name,log_Teff,log_g, M_div_h, ierr) @@ -131,40 +131,40 @@ real(dp) function get_bc_by_name(name,log_Teff,log_g, M_div_h, ierr) type (lgt_list), pointer :: thead => null() integer, intent(inout) :: ierr integer :: i,j,n_colors - + get_bc_by_name=-99.9d0 ierr=0 - + if (.not. color_is_initialized) then ierr=-1 return endif - + do i=1,num_thead thead=>thead_all(i)%thead n_colors=thead_all(i)%n_colors do j=1,n_colors if(trim(name)==trim(thead_all(i)%color_names(j)).or. & - trim(name)=='bc_'//trim(thead_all(i)%color_names(j)).or. & - trim(name)=='abs_mag_'//trim(thead_all(i)%color_names(j)).or. & - trim(name)=='lum_band_'//trim(thead_all(i)%color_names(j)).or. & + trim(name)=='bc_'//trim(thead_all(i)%color_names(j)).or. & + trim(name)=='abs_mag_'//trim(thead_all(i)%color_names(j)).or. & + trim(name)=='lum_band_'//trim(thead_all(i)%color_names(j)).or. & trim(name)=='log_lum_band_'//trim(thead_all(i)%color_names(j))& ) then - + call get_bcs_one(log_Teff,log_g, M_div_h, results,thead,n_colors, ierr) if(ierr/=0) return - + get_bc_by_name=results(j) - + return end if end do - + end do - - + + end function get_bc_by_name - + real(dp) function get_bc_by_id(id,log_Teff,log_g, M_div_h, ierr) ! input integer, intent(in) :: id @@ -173,31 +173,31 @@ real(dp) function get_bc_by_id(id,log_Teff,log_g, M_div_h, ierr) real(dp), intent(in) :: M_div_h ! [M/H] integer, intent(inout) :: ierr character(len=strlen) :: name - + get_bc_by_id=-99.9d0 ierr=0 - + if (.not. color_is_initialized) then ierr=-1 return endif - + name=get_bc_name_by_id(id,ierr) if(ierr/=0) return - + get_bc_by_id=get_bc_by_name(name,log_Teff,log_g, M_div_h, ierr) - + end function get_bc_by_id - + integer function get_bc_id_by_name(name,ierr) ! input character(len=*), intent(in) :: name integer, intent(inout) :: ierr integer :: i,j,k - + get_bc_id_by_name=-1 ierr=0 - + if (.not. color_is_initialized) then ierr=-1 return @@ -208,30 +208,30 @@ integer function get_bc_id_by_name(name,ierr) do j=1,thead_all(i)%n_colors k=k+1 if(trim(name)==trim(thead_all(i)%color_names(j)).or. & - trim(name)=='bc_'//trim(thead_all(i)%color_names(j)).or. & + trim(name)=='bc_'//trim(thead_all(i)%color_names(j)).or. & trim(name)=='abs_mag_'//trim(thead_all(i)%color_names(j))) then get_bc_id_by_name=k return end if end do - end do - + end do + end function get_bc_id_by_name - + character(len=strlen) function get_bc_name_by_id(id,ierr) ! input integer, intent(in) :: id integer, intent(inout) :: ierr integer :: i,j,k - + get_bc_name_by_id='' ierr=0 - + if (.not. color_is_initialized) then ierr=-1 return endif - + k=1 do i=1,num_thead do j=1,thead_all(i)%n_colors @@ -242,17 +242,17 @@ character(len=strlen) function get_bc_name_by_id(id,ierr) k=k+1 end do end do - + end function get_bc_name_by_id real(dp) function get_abs_bolometric_mag(lum) use const_def real(dp), intent(in) :: lum ! Luminsoity in lsun units - + get_abs_bolometric_mag = mbolsun - 2.5d0*log10(lum) - + end function get_abs_bolometric_mag - + real(dp) function get_abs_mag_by_name(name,log_Teff,log_g, M_div_h,lum, ierr) ! input character(len=*) :: name @@ -261,20 +261,20 @@ real(dp) function get_abs_mag_by_name(name,log_Teff,log_g, M_div_h,lum, ierr) real(dp), intent(in) :: log_g ! log_10 of surface gravity real(dp), intent(in) :: lum ! Luminsoity in lsun units integer, intent(inout) :: ierr - + ierr=0 get_abs_mag_by_name=-99.9d0 - + if (.not. color_is_initialized) then ierr=-1 return endif - + get_abs_mag_by_name=get_abs_bolometric_mag(lum)-& get_bc_by_name(name,log_Teff,log_g, M_div_h,ierr) end function get_abs_mag_by_name - + real(dp) function get_abs_mag_by_id(id,log_Teff,log_g, M_div_h,lum, ierr) ! input integer, intent(in) :: id @@ -284,34 +284,34 @@ real(dp) function get_abs_mag_by_id(id,log_Teff,log_g, M_div_h,lum, ierr) real(dp), intent(in) :: lum ! Luminsoity in lsun units integer, intent(inout) :: ierr character(len=strlen) :: name - + ierr=0 get_abs_mag_by_id=-99.9d0 - + if (.not. color_is_initialized) then ierr=-1 return endif - + name=get_bc_name_by_id(id,ierr) if(ierr/=0) return - + get_abs_mag_by_id=get_abs_mag_by_name(name,log_Teff,log_g, M_div_h,lum, ierr) - + end function get_abs_mag_by_id - + subroutine get_all_bc_names(names, ierr) character(len=strlen),dimension(:) :: names integer, intent(inout) :: ierr integer :: i,j,cnt - + names(:)='' - + if (.not. color_is_initialized) then ierr=-1 return endif - + cnt=1 do i=1,num_thead do j=1,thead_all(i)%n_colors @@ -319,9 +319,9 @@ subroutine get_all_bc_names(names, ierr) cnt=cnt+1 end do end do - + end subroutine get_all_bc_names - + subroutine get_bcs_all(log_Teff, log_g, M_div_h, results, ierr) ! input real(dp), intent(in) :: log_Teff ! log10 of surface temp @@ -332,15 +332,15 @@ subroutine get_bcs_all(log_Teff, log_g, M_div_h, results, ierr) integer, intent(inout) :: ierr type (lgt_list), pointer :: thead => null() integer :: i,iStart,iEnd - + ierr=0 results(:)=-99.d0 - + if (.not. color_is_initialized) then ierr=-1 return endif - + do i=1,num_thead thead=>thead_all(i)%thead iStart=(i-1)*thead_all(i)%n_colors+1 @@ -348,9 +348,9 @@ subroutine get_bcs_all(log_Teff, log_g, M_div_h, results, ierr) call get_bcs_one(log_Teff, log_g, M_div_h, results(iStart:iEnd),thead,thead_all(i)%n_colors, ierr) if(ierr/=0) return end do - + end subroutine get_bcs_all - + !Returns in lsun units real(dp) function get_lum_band_by_name(name,log_Teff,log_g, M_div_h, lum, ierr) ! input @@ -361,26 +361,26 @@ real(dp) function get_lum_band_by_name(name,log_Teff,log_g, M_div_h, lum, ierr) real(dp), intent(in) :: lum ! Total luminsoity in lsun units real(dp) :: solar_abs_mag, star_abs_mag integer, intent(inout) :: ierr - + ierr=0 get_lum_band_by_name=-99.d0 - + if (.not. color_is_initialized) then ierr=-1 return endif - + ! Filter dependent terms solar_abs_mag=get_abs_mag_by_name(name, safe_log10(Teffsun), loggsun, 0.d0, 1.d0, ierr) if(ierr/=0) return - + star_abs_mag=get_abs_mag_by_name(name, log_Teff, log_g, M_div_h, lum, ierr) if(ierr/=0) return - + get_lum_band_by_name=exp10((star_abs_mag-solar_abs_mag)/(-2.5d0)) end function get_lum_band_by_name - + !Returns in lsun units real(dp) function get_lum_band_by_id(id,log_Teff,log_g, M_div_h, lum, ierr) ! input @@ -394,22 +394,22 @@ real(dp) function get_lum_band_by_id(id,log_Teff,log_g, M_div_h, lum, ierr) ierr=0 get_lum_band_by_id=-99.d0 - + if (.not. color_is_initialized) then ierr=-1 return endif - + ! Filter dependent terms solar_abs_mag=get_abs_mag_by_id(id, safe_log10(Teffsun), loggsun, 0.d0, 1.d0, ierr) if(ierr/=0) return - + star_abs_mag=get_abs_mag_by_id(id, log_Teff, log_g, M_div_h,lum, ierr) if(ierr/=0) return - + get_lum_band_by_id=exp10((star_abs_mag-solar_abs_mag)/(-2.5d0)) - + end function get_lum_band_by_id - + end module colors_lib diff --git a/colors/test/src/test_colors.f90 b/colors/test/src/test_colors.f90 index 2bdbc0ea3..e383b4a88 100644 --- a/colors/test/src/test_colors.f90 +++ b/colors/test/src/test_colors.f90 @@ -4,9 +4,9 @@ program test_colors use colors_lib use math_lib use utils_lib, only: mesa_error, mkdir - + implicit none - + call do_test_colors contains @@ -17,21 +17,21 @@ subroutine do_test_colors character (len=256) :: my_mesa_dir integer :: info - + logical, parameter :: do_one = .true. integer, parameter :: n_colors=11 ! logical, parameter :: do_one = .false. - - my_mesa_dir = '../..' - call const_init(my_mesa_dir,info) + + my_mesa_dir = '../..' + call const_init(my_mesa_dir,info) if (info /= 0) then write(*,*) 'const_init failed' call mesa_error(__FILE__,__LINE__) - end if + end if call math_init() call colors_init(1,(/'../data/lcb98cor.dat'/),(/n_colors/),info) - + if (info /= 0) then write(*,*) 'colors_init failed during initialization' return @@ -43,10 +43,10 @@ subroutine do_test_colors call create_plot_files end if call colors_shutdown() - - end subroutine do_test_colors - - + + end subroutine do_test_colors + + subroutine do_one_colors integer, parameter :: num_results=16 @@ -63,20 +63,20 @@ subroutine do_one_colors logical, parameter :: doing_solar = .true. real(dp), dimension(num_results), parameter :: solar_expected_results = (/ & 4.75d0, -0.11510d0, -0.14211d0, -0.61768d0, -0.36199d0, -0.68894d0, -1.46926d0, -0.32695d0, -0.78032d0, -0.39024d0, & - 0.05223d0, -0.10512d0, -0.33801d0, -0.44312d0, -0.44123d0, -0.43080d0 /) + 0.05223d0, -0.10512d0, -0.33801d0, -0.44312d0, -0.44123d0, -0.43080d0 /) + - ! solar values log_teff = log10(5780d0) log_l = 0d0 mass = 1d0 M_div_h = 0d0 - log_g = log10(mass) + 4.0D0*log_Teff - log_L - 10.6071D0 + log_g = log10(mass) + 4.0D0*log_Teff - log_L - 10.6071D0 + + boloMag=get_abs_bolometric_mag(10**log_l) - boloMag=get_abs_bolometric_mag(10**log_l) - !Store answers in results array - + ! These are bololmetric correction differences NOT magnitude differences ! Thus they are -1*mag diff results(1)=boloMag @@ -95,22 +95,22 @@ subroutine do_one_colors results(14)=get_bc_by_name('J',log_Teff,log_g, M_div_h, info)-get_bc_by_name('L',log_Teff,log_g, M_div_h, info) results(15)=get_bc_by_name('J',log_Teff,log_g, M_div_h, info)-get_bc_by_name('Lprime',log_Teff,log_g, M_div_h, info) results(16)=get_bc_by_name('K',log_Teff,log_g, M_div_h, info)-get_bc_by_name('M',log_Teff,log_g, M_div_h, info) - + if (info /= 0) then call mesa_error(__FILE__,__LINE__,'bad return from colors_get') end if - + write(*,'(A)') write(*,*) 'color magnitude results' write(*,'(A)') write(*,'(6a12)') 'teff', 'log_teff', 'log_l', 'mass', '[M_div_h]', 'log_g' write(*,'(i12,5f12.2)') floor(exp10(log_teff) + 0.5d0), log_teff, log_l, mass, M_div_h, log_g write(*,'(A)') - + !call get_all_bc_names(colors_name,total_num_colors,info) colors_name=(/'bol ','bcv ','U-B ','B-V ','V-R ','V-I ','V-K ','R-I ',& 'I-K ','J-H ','H-K ','K-L ','J-K ','J-L ','J-Lp','K-M '/) - + do i=1,num_results write(*,'(9x,a8,f10.5)') colors_name(i), results(i) end do @@ -118,9 +118,9 @@ subroutine do_one_colors vname = 'vcolors' write(*,'(9x,a8,f10.5)') vname, results(1)-results(2) write(*,'(A)') - + if (doing_solar) then - + do i=1,num_results if (abs(results(i) - solar_expected_results(i)) > 0.02d0) then write(*,'(A)') @@ -131,11 +131,11 @@ subroutine do_one_colors stop end if end do - + write(*,*) 'matches expected solar results' write(*,'(A)') - - end if + + end if !Check some extreme values @@ -151,7 +151,7 @@ subroutine do_one_colors write(*,'(A,1pes40.16e3)') 'high m/h',x - + end subroutine do_one_colors @@ -162,9 +162,9 @@ subroutine create_plot_files integer, parameter :: num_results=16 real(dp), dimension(max_num_masses) :: mass, logl, logteff real(dp) :: read_junk, log_g, M_div_h, boloMag - real(dp),dimension(num_results) :: results + real(dp),dimension(num_results) :: results integer :: info, i, num_masses, io_unit, ios, iread_junk - + M_div_h = 0d0 fname = 'zams_data/z02.log' io_unit = 40 @@ -173,7 +173,7 @@ subroutine create_plot_files write(*,*) 'failed to open the zams data' return end if - + num_masses = 0 do i = 1, max_num_masses read(io_unit,fmt=*,iostat=ios) iread_junk, mass(i), logl(i), read_junk, logteff(i) @@ -183,21 +183,21 @@ subroutine create_plot_files end if end do read_junk = read_junk; iread_junk = iread_junk ! to keep g95 quiet - + close(io_unit) dir = 'plot_data' call mkdir(dir) fname = trim(dir) // '/' // 'colors.data' open(unit=io_unit,file=trim(fname)) - + do i = 1, num_masses !call colors_get(logteff(i), logl(i), mass(i), M_div_h, results, log_g, info) - - boloMag=get_abs_bolometric_mag(10**logl(i)) - - log_g=log10(mass(i)) + 4.0D0*logteff(i) - logl(i) - 10.6071D0 + + boloMag=get_abs_bolometric_mag(10**logl(i)) + + log_g=log10(mass(i)) + 4.0D0*logteff(i) - logl(i) - 10.6071D0 !Store answers in results array results(1)=boloMag results(2)=get_bc_by_name('V',logteff(i),log_g, M_div_h, info) @@ -215,13 +215,13 @@ subroutine create_plot_files results(14)=get_bc_by_name('J',logteff(i),log_g, M_div_h, info)-get_bc_by_name('L',logteff(i),log_g, M_div_h, info) results(15)=get_bc_by_name('J',logteff(i),log_g, M_div_h, info)-get_bc_by_name('Lprime',logteff(i),log_g, M_div_h, info) results(16)=get_bc_by_name('K',logteff(i),log_g, M_div_h, info)-get_bc_by_name('M',logteff(i),log_g, M_div_h, info) - + if (info == 0) write(io_unit,'(99f15.8)') mass(i), logl(i), logteff(i), log_g, results end do - + close(io_unit) - + write(*,*) 'finished creating plot files' end subroutine create_plot_files diff --git a/data/star_data/zams_models/create_z2m2_y28/src/run.f90 b/data/star_data/zams_models/create_z2m2_y28/src/run.f90 index f16133c3d..782510fa8 100644 --- a/data/star_data/zams_models/create_z2m2_y28/src/run.f90 +++ b/data/star_data/zams_models/create_z2m2_y28/src/run.f90 @@ -1,8 +1,8 @@ program run use run_star_extras, only: do_run - + implicit none - + call do_run ! create zams - + end program diff --git a/data/star_data/zams_models/create_z2m2_y28/src/run_star_extras.f90 b/data/star_data/zams_models/create_z2m2_y28/src/run_star_extras.f90 index bcc031c00..a853f4d7a 100644 --- a/data/star_data/zams_models/create_z2m2_y28/src/run_star_extras.f90 +++ b/data/star_data/zams_models/create_z2m2_y28/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -32,7 +32,7 @@ ! create a single model using create_pre_main_sequence_model. - + module run_star_extras use star_lib @@ -41,54 +41,54 @@ module run_star_extras use math_lib use run_star_support - + implicit none - + include "test_suite_extras_def.inc" - + ! controls for create zams character (len=256) :: zams_name real(dp) :: create_z, create_y, mlo, mhi, dmass namelist /create_zams_job/ & zams_name, create_z, create_y, mlo, mhi, dmass - - + + contains include "test_suite_extras.inc" subroutine do_run - + integer :: id, ierr type (star_info), pointer :: s character (len=128) :: zams_inlist real(dp) :: dt - + write(*,*) 'do create zams' ierr = 0 call test_suite_startup(s, .false., ierr) - + call do_read_star_job('inlist', ierr) if (failed('do_read_star_job')) return id = id_from_read_star_job id_from_read_star_job = 0 - + call star_ptr(id, s, ierr) if (failed('star_ptr')) return - + call starlib_init(s, ierr) if (failed('star_init')) return s% inlist_fname = 'inlist' - + call star_set_kap_and_eos_handles(id, ierr) if (failed('set_star_kap_and_eos_handles')) return - + call star_setup(id, 'inlist', ierr) if (failed('star_setup')) return @@ -97,17 +97,17 @@ subroutine do_run call do_star_job_controls_before(id, s, .false., ierr) if (failed('do_star_job_controls_before')) return - + zams_inlist = 'inlist_zams_specification' call do_create_zams( & s, zams_inlist, s% job% history_columns_file, & s% job% profile_columns_file, ierr) - + call test_suite_after_evolve(s, ierr) - + contains - + logical function failed(str) character (len=*), intent(in) :: str @@ -118,10 +118,10 @@ logical function failed(str) end function failed - end subroutine do_run + end subroutine do_run + - subroutine do_create_zams( & s, zams_inlist, history_columns_file_in, profile_columns_file_in, ierr) use mtx_lib, only: lapack_decsol @@ -129,8 +129,8 @@ subroutine do_create_zams( & type (star_info), pointer :: s character (len=*) :: zams_inlist, history_columns_file_in, profile_columns_file_in integer, intent(out) :: ierr - - integer :: io_ms_mod, io_ms_index + + integer :: io_ms_mod, io_ms_index real(dp) :: init_m integer :: i, j, k, n, id, result, result_reason, pre_ms_relax_num_steps character (len=256) :: ms_file @@ -141,10 +141,10 @@ subroutine do_create_zams( & 2 format(a40, i6, 1pe26.16) 3 format(a15, 2x, f15.6) 14 format(a40, e24.14) - + ierr = 0 id = s% id - + pre_ms_relax_num_steps = 1 call read_zams_controls(s, zams_inlist, ierr) @@ -165,30 +165,30 @@ subroutine do_create_zams( & ms_file = trim(zams_name) // '_mod.data' open(newunit=io_ms_mod, file=trim(ms_file), action='write', status='replace') n = (mhi-mlo)/dmass + 1 - + write(*,1) 'mlo', mlo write(*,1) 'mhi', mhi - + mass_loop: do i=1, n - + init_m = exp10(mlo+(i-1)*dmass) - + s% mesh_delta_coeff = 0.5d0 if (init_m > 1) s% mesh_delta_coeff = 0.8d0 if (init_m > 80) s% mesh_delta_coeff = 1 - - if (init_m > exp10(mhi)) exit + + if (init_m > exp10(mhi)) exit mass_loop do j=1, 10 write(*, *) end do - + s% initial_z = create_z s% initial_y = create_y s% initial_mass = init_m write(*, 14) 'do ' // trim(zams_name), s% initial_mass if (i==1) call write_index_head - + call star_create_pre_ms_model( & id, s% job% pre_ms_T_c, s% job% pre_ms_guess_rho_c, & s% job% pre_ms_d_log10_P, & @@ -196,40 +196,40 @@ subroutine do_create_zams( & s% job% initial_zfracs, & s% job% dump_missing_metals_into_heaviest, & .false., '', s% job% pre_ms_relax_num_steps, ierr) - if (failed('star_create_pre_ms_model')) exit - + if (failed('star_create_pre_ms_model')) exit mass_loop + call evolve_to_zams(s, id, ierr) - if (failed('evolve_to_zams')) exit + if (failed('evolve_to_zams')) exit mass_loop - call write_model(id, io_ms_mod, io_ms_index, ierr) - if (failed('write_model')) exit + call write_model(id, io_ms_mod, io_ms_index, ierr) + if (failed('write_model')) exit mass_loop end do mass_loop - + 11 format(3x, f15.8, i15) write(io_ms_index, 11) -1d0, -1 ! marks end of index write(io_ms_index, *) ! blank line at end of index - + close ( io_ms_mod ) open(newunit=io_ms_mod, file=trim(ms_file), action='read', status='old', iostat=ierr) if (failed('open mods to read')) return - - do + + do read(io_ms_mod, fmt='(a)', iostat=ierr) line if (ierr /= 0) then ierr = 0; exit end if write(io_ms_index, fmt='(a)') trim(line) end do - + close ( io_ms_mod ) close ( io_ms_index ) - + call free_star(id, ierr) - if (failed('free_star')) return - + if (failed('free_star')) return + call starlib_shutdown - + write(*, *) if (okay) then write(*, '(a)') 'finished create main sequence' @@ -237,9 +237,9 @@ subroutine do_create_zams( & write(*, '(a)') 'failed during attempt to create main sequence' end if write(*, *) - + contains - + subroutine write_index_head use chem_def use net_def @@ -271,7 +271,7 @@ subroutine write_index_head write(io_ms_index, *) ! blank line for end of property list write(io_ms_index, '(a)') ' M/Msun n_shells' end subroutine write_index_head - + logical function failed(str) character (len=*), intent(in) :: str failed = (ierr /= 0) @@ -282,30 +282,30 @@ logical function failed(str) !call mesa_error(__FILE__,__LINE__) end if end function failed - + end subroutine do_create_zams - + subroutine write_model(id, io_ms_mod, io_ms_index, ierr) use chem_def integer, intent(in) :: id, io_ms_mod, io_ms_index integer, intent(out) :: ierr - + integer :: k, j, species, nz type (star_info), pointer :: s 1 format(a32, 2x, 1pe26.16) 2 format(a32, 2x, i9) 11 format(3x, f15.8, i15) - + call star_ptr(id, s, ierr) if (ierr /= 0) then write(*, *) 'write_model: star_ptr failed' return end if - + species = s% species nz = s% nz - + write(io_ms_index, 11) s% star_mass, nz ! write property list @@ -327,12 +327,12 @@ subroutine write_model(id, io_ms_mod, io_ms_index, ierr) write(io_ms_mod, fmt='(1pe24.16, 1x)', advance='no') s% xa(j, k) end do write(io_ms_mod, *) - end do - write(io_ms_mod, *) - + end do + write(io_ms_mod, *) + end subroutine write_model - - + + subroutine evolve_to_zams(s, id, ierr) type (star_info), pointer :: s integer, intent(in) :: id @@ -361,7 +361,7 @@ subroutine before_evolve_to_zams(s, id, lipar, ipar, lrpar, rpar, ierr) integer, intent(out) :: ierr ierr = 0 end subroutine before_evolve_to_zams - + integer function evolve_to_zams_adjust_model(s, id, lipar, ipar, lrpar, rpar) use star_def, only:star_info type (star_info), pointer :: s @@ -370,14 +370,14 @@ integer function evolve_to_zams_adjust_model(s, id, lipar, ipar, lrpar, rpar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) evolve_to_zams_adjust_model = keep_going end function evolve_to_zams_adjust_model - + integer function evolve_to_zams_check_model(s, id, lipar, ipar, lrpar, rpar) use star_def, only:star_info type (star_info), pointer :: s integer, intent(in) :: id, lipar, lrpar integer, intent(inout), pointer :: ipar(:) ! (lipar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) - evolve_to_zams_check_model = bare_bones_check_model(id) + evolve_to_zams_check_model = bare_bones_check_model(id) if (evolve_to_zams_check_model /= keep_going) return if (s% X(s% nz) < s% x_ctrl(1)) then ! stop when star has depleted a small amount of hydrogen @@ -395,8 +395,8 @@ integer function evolve_to_zams_check_model(s, id, lipar, ipar, lrpar, rpar) ! s% termination_code = t_extras_check_model ! end if end function evolve_to_zams_check_model - - + + integer function evolve_to_zams_finish_step(s) type (star_info), pointer :: s evolve_to_zams_finish_step = keep_going @@ -411,11 +411,11 @@ subroutine read_zams_controls(s, zams_inlist, ierr) character (len=256) :: filename, message integer :: unit - + 11 format(a30, f16.6) - + ierr = 0 - + ! set defaults create_z = 2d-2 zams_name = 'z2m2' @@ -428,24 +428,24 @@ subroutine read_zams_controls(s, zams_inlist, ierr) if (ierr /= 0) then write(*, *) 'Failed to open control namelist file ', trim(filename) else - read(unit, nml=create_zams_job, iostat=ierr) + read(unit, nml=create_zams_job, iostat=ierr) close(unit) if (ierr /= 0) then write(*, *) 'Failed while trying to read control namelist file ', trim(filename) write(*, '(a)') & 'The following runtime error message might help you find the problem' - write(*, *) + write(*, *) open(newunit=unit, file=trim(filename), action='read', & delim='quote', status='old', iostat=ierr) read(unit, nml=create_zams_job) close(unit) - end if + end if end if end subroutine read_zams_controls - + include 'standard_run_star_extras.inc' end module run_star_extras - + diff --git a/docs/source/about.rst b/docs/source/about.rst index b9139707f..23317a309 100644 --- a/docs/source/about.rst +++ b/docs/source/about.rst @@ -58,11 +58,11 @@ Use of MESA requires: 1. That all publications and presentations (research, educational, or outreach) deriving from the use of MESA acknowledge the MESA - instrument papers (Paxton et al. - `2011 `_, - `2013 `_, - `2015 `_, - `2018 `_, + instrument papers (Paxton et al. + `2011 `_, + `2013 `_, + `2015 `_, + `2018 `_, `2019 `_, Jermyn et al. `2023 `_) @@ -112,10 +112,12 @@ Developers * Matthias Fabry * Ebraheem Farag * Eoin Farrell +* `Jared Goldberg `__ * `Meridith Joyce `__ -* Pablo Marchant +* `Pablo Marchant `__ * `Philip Mocz `__ * `Joey Mombarg `__ +* `Mathieu Renzo `__ * `Radek Smolec `__ * Anne Thoul * `Frank Timmes `__ diff --git a/docs/source/developing/new_developers.rst b/docs/source/developing/new_developers.rst index d303cf514..0d1a2d560 100644 --- a/docs/source/developing/new_developers.rst +++ b/docs/source/developing/new_developers.rst @@ -90,3 +90,4 @@ Changelog --------- * Initial document approved December 5, 2022 +* "Infrastucture Access for Collaborators" section adopted March 1, 2024 diff --git a/eos/eosCMS_builder/src/cms_mixing.f90 b/eos/eosCMS_builder/src/cms_mixing.f90 index da70830fb..70cd72afd 100644 --- a/eos/eosCMS_builder/src/cms_mixing.f90 +++ b/eos/eosCMS_builder/src/cms_mixing.f90 @@ -34,7 +34,7 @@ module cms use const_def, only: dp, ln10 - + implicit none logical, parameter :: DBG = .false. @@ -126,7 +126,7 @@ function exp10(x) result(y) real(dp) :: y y=exp(ln10*x) end function exp10 - + subroutine blend_tables(X,Y,Z,ierr) type(table), intent(inout) :: X, Y, Z @@ -158,7 +158,7 @@ subroutine additive_volume(eosX,eosY,eosXY,mass_frac_X,mass_frac_Y,ierr) real(dp), parameter :: tol = 1.0E-5_dp real(dp), parameter :: kerg = 1.380649D-16 real(dp), parameter :: avo = 6.02214076d23 - real(dp), parameter :: amu = 1.0_dp/avo + real(dp), parameter :: amu = 1.0_dp/avo real(dp) :: Nx, Ny, Ntot, Abar real(dp) :: rhoXY, rhoX, rhoY @@ -292,7 +292,7 @@ program cms_mixing call get_command_argument(2, H% filename) call get_command_argument(3, J% filename) - + call get_command_argument(4, K% filename) write(*,*) 'H input: ', trim(H% filename) @@ -307,7 +307,7 @@ program cms_mixing call read_one(H) J% H_mass_frac = 0.0_dp - J% He_mass_frac = Y + J% He_mass_frac = Y call read_one(J) call blend_tables(H,J,K,ierr) diff --git a/eos/eosCMS_builder/src/cms_resample.f90 b/eos/eosCMS_builder/src/cms_resample.f90 index 999c008f3..45ba51610 100644 --- a/eos/eosCMS_builder/src/cms_resample.f90 +++ b/eos/eosCMS_builder/src/cms_resample.f90 @@ -27,25 +27,25 @@ !also calculates extra quantities wanted by MESA EOS program cms_resample - + use const_def use const_lib use interp_1d_def use interp_1d_lib use math_lib - + implicit none - + integer, parameter :: version = 1 integer, parameter :: NT = 121 integer, parameter :: NP = 441 integer, parameter :: NRho = 281 ! -8 <= logRho <= +6 by 0.05 integer :: ierr, i, j, io - + character(len=256) :: input, output real(dp) :: H_mass_fraction, He_mass_fraction - + !old EOS table real(dp), dimension(NP,NT) :: logT(NP,NT) real(dp), dimension(NP,NT) :: logRho, logP, logU, logS, dlnRho_dlnT_P, & @@ -63,12 +63,12 @@ program cms_resample real(dp) :: dS_dP_T, dS_dT_P, dse, dsp, dpe !for consistency check ierr=0 - + if(command_argument_count()<2)then write(*,*) './cms_resample [input] [output]' stop endif - + call get_command_argument(1,input) call get_command_argument(2,output) @@ -106,9 +106,9 @@ program cms_resample new_logT = logT(1,i) do j=1,NRho new_logRho = logRho_min + real(j-1,kind=dp)*delta_logRho - + call do_stuff(i, new_logRho, new_logP, new_logU, new_logS, & - new_dlnRho_dlnT, new_dlnRho_dlnP, new_dlnS_dlnT, new_dlnS_dlnP, new_grad_ad) + new_dlnRho_dlnT, new_dlnRho_dlnP, new_dlnS_dlnT, new_dlnS_dlnP, new_grad_ad) P = exp10(new_logP) U = exp10(new_logU) @@ -127,9 +127,9 @@ program cms_resample dS_dP_T = (S/P) * new_dlnS_dlnP dS_dT_P = (S/T) * new_dlnS_dlnT - + dU_dRho = dU_dP_T /( (rho/P) * new_dlnRho_dlnP) - + mu = 4.0_dp / (6.0_dp*H_mass_fraction + He_mass_fraction + 2.0_dp) lnfree_e = log(0.5_dp*(1.0_dp + H_mass_fraction)) @@ -156,18 +156,18 @@ program cms_resample enddo enddo close(io) - + contains subroutine mesa_init - call const_init(' ',ierr) + call const_init(' ',ierr) if (ierr /= 0) then write(0,*) 'const_init failed' stop 1 end if - + call math_init() - + end subroutine mesa_init subroutine do_stuff(iT, new_logRho, new_logP, new_logU, new_logS, new_dlnRho_dlnT, & @@ -188,7 +188,7 @@ subroutine do_stuff(iT, new_logRho, new_logP, new_logU, new_logS, new_dlnRho_dln real(dp), pointer :: work(:) work => work_ary - + count = 0 do j=1,NP if(logRho(j,iT) >= logRho_min_for_interp)then @@ -206,10 +206,10 @@ subroutine do_stuff(iT, new_logRho, new_logP, new_logU, new_logS, new_dlnRho_dln endif endif enddo - + num_pts = count allocate(x_old(num_pts), y_old(num_pts)) - + !get logP for logRho input x_old(1:num_pts) = tmp_logRho(1:num_pts) y_old(1:num_pts) = tmp_logP(1:num_pts) @@ -233,7 +233,7 @@ subroutine do_stuff(iT, new_logRho, new_logP, new_logU, new_logS, new_dlnRho_dln x_new(1) = new_logP call interpolate_vector(num_pts, x_old, 1, x_new, y_old, y_new, & interp_m3a, nwork, work, 'sigh', ierr) - new_logS = y_new(1) + new_logS = y_new(1) !dlnRho_dlnT_constP x_old(1:num_pts) = tmp_logP(1:num_pts) @@ -241,7 +241,7 @@ subroutine do_stuff(iT, new_logRho, new_logP, new_logU, new_logS, new_dlnRho_dln x_new(1) = new_logP call interpolate_vector(num_pts, x_old, 1, x_new, y_old, y_new, & interp_m3a, nwork, work, 'sigh', ierr) - new_dlnRho_dlnT = y_new(1) + new_dlnRho_dlnT = y_new(1) !dlnRho_dlnP_constT x_old(1:num_pts) = tmp_logP(1:num_pts) @@ -249,15 +249,15 @@ subroutine do_stuff(iT, new_logRho, new_logP, new_logU, new_logS, new_dlnRho_dln x_new(1) = new_logP call interpolate_vector(num_pts, x_old, 1, x_new, y_old, y_new, & interp_m3a, nwork, work, 'sigh', ierr) - new_dlnRho_dlnP = y_new(1) - + new_dlnRho_dlnP = y_new(1) + !dlnS_dlnT_constP x_old(1:num_pts) = tmp_logP(1:num_pts) y_old(1:num_pts) = tmp_dlnS_dlnT(1:num_pts) x_new(1) = new_logP call interpolate_vector(num_pts, x_old, 1, x_new, y_old, y_new, & interp_m3a, nwork, work, 'sigh', ierr) - new_dlnS_dlnT = y_new(1) + new_dlnS_dlnT = y_new(1) !dlnS_dlnP_constT x_old(1:num_pts) = tmp_logP(1:num_pts) @@ -265,7 +265,7 @@ subroutine do_stuff(iT, new_logRho, new_logP, new_logU, new_logS, new_dlnRho_dln x_new(1) = new_logP call interpolate_vector(num_pts, x_old, 1, x_new, y_old, y_new, & interp_m3a, nwork, work, 'sigh', ierr) - new_dlnS_dlnP = y_new(1) + new_dlnS_dlnP = y_new(1) !grad_ad x_old(1:num_pts) = tmp_logP(1:num_pts) @@ -274,7 +274,7 @@ subroutine do_stuff(iT, new_logRho, new_logP, new_logU, new_logS, new_dlnRho_dln call interpolate_vector(num_pts, x_old, 1, x_new, y_old, y_new, & interp_m3a, nwork, work, 'sigh', ierr) new_grad_ad = min(0.5_dp, max(0.1_dp, y_new(1))) - + end subroutine do_stuff - + end program cms_resample diff --git a/eos/eosFreeEOS_builder/src/free_eos_table.f90 b/eos/eosFreeEOS_builder/src/free_eos_table.f90 index 81ed3b1cf..8c6d35869 100644 --- a/eos/eosFreeEOS_builder/src/free_eos_table.f90 +++ b/eos/eosFreeEOS_builder/src/free_eos_table.f90 @@ -45,7 +45,7 @@ module free_eos_table integer, parameter :: kif = 2 !for P(Rho,T) - !for MESA + !for MESA integer, parameter :: h1 = 1 integer, parameter :: he4 = 2 integer, parameter :: c12 = 3 @@ -69,7 +69,7 @@ module free_eos_table !!!!! -contains +contains !for the 4 basic EOS options subroutine free_eos_set_version(eos_version) @@ -117,9 +117,9 @@ subroutine free_eos_eval(logRho,logT,mass_frac,result) ! FreeEOS uses an abundance array called eps: ! EPS(:) = ( H,He,C,N,O,Ne,Na,Mg,Al,Si,P,S,Cl,Ar,Ca,Ti,Cr,Mn,Fe,Ni) - ! consisting of 20 elements, each entry of eps is the mass fraction + ! consisting of 20 elements, each entry of eps is the mass fraction ! of that element divided by its atomic weight - + !these are FreeEOS masses, not MESA values atom_wgt = [ 1.007825_dp, 4.0026_dp, 12.0111_dp, 14.0067_dp, 15.9994_dp, & 20.179_dp, 22.98977_dp, 24.305_dp, 26.9815_dp, 28.086_dp, & @@ -146,11 +146,11 @@ subroutine free_eos_eval(logRho,logT,mass_frac,result) dP_dT_constRho = (p/T)*pressure(3) dS_dRho_constT = entropy(2)/Rho - + dpe = (rho/p)*energy(2) + chiT - 1._dp !good dse = T*(entropy(3)/energy(3)) - 1._dp !good dsp = -rho*rho*(dS_dRho_constT/dP_dT_constRho) - 1._dp !good - + result(i_lnPgas) = log10(P - Prad) result(i_lnE) = log10(energy(1)) result(i_lnS) = log10(entropy(1)) @@ -247,7 +247,7 @@ program make_free_eos_table write(*,*) ' final counts: ' write(*,*) ' num DT tables loaded = ', num_DT write(*,*) ' num FreeEOS tables loaded = ', num_FreeEOS - + contains subroutine read_namelist @@ -276,7 +276,7 @@ subroutine read_namelist close(io_unit) num_logTs = 1 + int( (log10Tmax - log10Tmin) / dlog10T ) - num_logQs = 1 + int( (log10Qmax - log10Qmin) / dlog10Q ) + num_logQs = 1 + int( (log10Qmax - log10Qmin) / dlog10Q ) if(debug)then write(*,*) 'dlog10T = ', dlog10T @@ -292,7 +292,7 @@ subroutine set_mass_fractions mass_frac(1) = 1d0 !H mass_frac(2) = 1d0 !He open(newunit=io_unit,file=trim(mass_list),action='read',status='old',iostat=ierr) - if(ierr/=0) then + if(ierr/=0) then write(*,*) 'free_eos_table: problem opening mass fractions list: ', trim(mass_list) stop endif @@ -339,8 +339,8 @@ subroutine write_table(io_unit) logTs=0._dp logRhos=0._dp mesa_fracs=0._dp - - !write header + + !write header write(io_unit,'(99(a14))') 'version', 'X', 'Z', 'num logTs', 'logT min', & 'logT max', 'del logT', 'num logQs', 'logQ min', 'logQ max', 'del logQ' @@ -352,9 +352,9 @@ subroutine write_table(io_unit) do while (log10Q <= log10Qmax) log10T = log10Tmax iT = num_logTs - + !write sub-header - write(io_unit,'(/,7x,a)') 'logQ = logRho - 2*logT + 12' + write(io_unit,'(/,7x,a)') 'logQ = logRho - 2*logT + 12' write(io_unit,'(2x,f14.6/)') log10Q !original '(99(a40,1x))' @@ -362,9 +362,9 @@ subroutine write_table(io_unit) 'logPgas', 'logE', 'logS', 'chiRho', 'chiT', 'Cp', 'Cv', 'dE_dRho', & 'dS_dT', 'dS_dRho', 'mu', 'log10_free_e', 'gamma1', 'gamma3', 'grad_ad', & 'eta', 'MESA', 'logRho', 'dpe', 'dsp', 'dse' - + do while (log10T >= log10Tmin) - + if(debug) write(*,*) 'log10Q, log10T=', log10Q, log10T log10Rho = log10Q + 2d0*log10T - 12.0d0 @@ -397,7 +397,7 @@ subroutine write_table(io_unit) mesa_fracs(iT) = mesa_frac logTs(iT) = log10T logRhos(iT) = log10Rho - + log10T = log10T - dlog10T iT = iT - 1 @@ -421,8 +421,8 @@ subroutine write_table(io_unit) results(i_mu,iT), & results(i_lnfree_e,iT)/ln10, & !MESA tables are based on OPAL tables, which results(i_gamma1,iT), & !list log10(free_e) rather than ln(free_e) - results(i_gamma3,iT), & - results(i_grad_ad,iT), & + results(i_gamma3,iT), & + results(i_grad_ad,iT), & results(i_eta,iT), & mesa_fracs(iT), & logRhos(iT), & @@ -532,7 +532,7 @@ subroutine mesa_eos_eval( logRho0, logT, mass_Frac, eos_result) real(dp) :: d_dxa_const_TRho(num_eos_d_dxa_results,neps) logical :: off_table real(dp), parameter :: logRho_min = -32.23619130191664_dp !-14 * ln10 - integer :: ierr + integer :: ierr T = exp(logT) log10T = logT/ln10 @@ -540,7 +540,7 @@ subroutine mesa_eos_eval( logRho0, logT, mass_Frac, eos_result) logRho = max(logRho_min, logRho0) Rho = exp(logRho) log10Rho = logRho/ln10 - + call eosDT_get(eos_handle, & Neps, chem_id, net_iso, mass_frac, & Rho, log10Rho, T, log10T, & @@ -552,7 +552,7 @@ subroutine mesa_eos_eval( logRho0, logT, mass_Frac, eos_result) logRho = max(logRho_min, logRho0) Rho = exp(logRho) log10Rho = logRho/ln10 - + call eosDT_get_component(eos_handle, i_eos_HELM, & Neps, chem_id, net_iso, mass_frac, & Rho, log10Rho, T, log10T, & @@ -569,7 +569,7 @@ subroutine mesa_eos_eval( logRho0, logT, mass_Frac, eos_result) write(*,*) 'ierr= ', ierr stop endif - + eos_result(1:num_eos_basic_results) = res eos_result(i_lnRho) = logRho eos_result(i_dpe) = 0._dp diff --git a/eos/plotter/src/eos_plotter.f90 b/eos/plotter/src/eos_plotter.f90 index 64d3feff3..34fd0cf1f 100644 --- a/eos/plotter/src/eos_plotter.f90 +++ b/eos/plotter/src/eos_plotter.f90 @@ -542,14 +542,14 @@ subroutine eos_call(handle, i_eos, species, chem_id, net_iso, xa, & use eos_def use eos_lib use chem_lib, only: basic_composition_info - integer, intent(in) :: handle, i_eos, species + integer, intent(in) :: handle, i_eos, species integer, pointer :: chem_id(:) ! maps species to chem id integer, pointer :: net_iso(:) ! maps chem id to species number - real(dp), intent(in) :: xa(:) ! mass fractions + real(dp), intent(in) :: xa(:) ! mass fractions real(dp), intent(in) :: Rho, logRho ! the density - real(dp), intent(in) :: T, logT ! the temperature - real(dp), intent(inout) :: res(:) ! (num_eos_basic_results) - real(dp), intent(inout) :: d_dlnd(:) ! (num_eos_basic_results) + real(dp), intent(in) :: T, logT ! the temperature + real(dp), intent(inout) :: res(:) ! (num_eos_basic_results) + real(dp), intent(inout) :: d_dlnd(:) ! (num_eos_basic_results) real(dp), intent(inout) :: d_dlnT(:) ! (num_eos_basic_results) real(dp), intent(inout) :: d_dxa(:,:) ! (num_eos_d_dxa_results,species) integer, intent(out) :: ierr ! 0 means AOK. diff --git a/eos/private/create_EXCOR7_table.f90 b/eos/private/create_EXCOR7_table.f90 index bed070e47..9e553a300 100644 --- a/eos/private/create_EXCOR7_table.f90 +++ b/eos/private/create_EXCOR7_table.f90 @@ -21,20 +21,20 @@ ! *********************************************************************** module create_EXCOR7_table - + use const_def use chem_def use utils_lib, only: is_bad use math_lib - + implicit none public :: do_create_EXCOR7_table private - + contains - + subroutine do_create_EXCOR7_table(fname) character (len=*), intent(in) :: fname real(dp) :: logRS, logRS_min, logRS_max, dlogRS @@ -47,19 +47,19 @@ subroutine do_create_EXCOR7_table(fname) logRS_max = 0.0d0 dlogRS = 1d-2 nlogRS = (logRS_max - logRS_min)/dlogRS + 1 - + logGAME_min = -2d0 logGAME_max = 4d0 dlogGAME = 1d-2 nlogGAME = (logGAME_max - logGAME_min)/dlogGAME + 1 - + !write(*,'(a)') 'create ' // trim(fname) open(newunit=io_unit,file=trim(fname)) - + write(io_unit,'(99(a14))') 'num logRS', 'logRS min', 'logRS max', 'del logRS', & 'num logGAME', 'logGAME min', 'logGAME max', 'del logGAME' - + write(io_unit,'(2(i10,4x,3(f14.4)),i10)') & nlogRS, logRS_min, logRS_max, dlogRS, & nlogGAME, logGAME_min, logGAME_max, dlogGAME, 0 @@ -67,7 +67,7 @@ subroutine do_create_EXCOR7_table(fname) do i = 1, nlogRS logRS = logRS_min + (i-1) * dlogRS RS = exp10(logRS) - write(io_unit,'(/,7x,a)') 'logRS' + write(io_unit,'(/,7x,a)') 'logRS' write(io_unit,'(2x,f14.6/)') logRS write(io_unit,'(99(a26))') & 'logGAME', 'FXC', 'UXC', 'PXC', 'CVXC', 'SXC', 'PDTXC', 'PDRXC', 'RS', 'GAME' @@ -87,7 +87,7 @@ subroutine do_create_EXCOR7_table(fname) write(io_unit,*) write(io_unit,*) close(io_unit) - + end subroutine do_create_EXCOR7_table @@ -300,6 +300,6 @@ subroutine EXCOR7(RS,GAME,FXC,UXC,PXC,CVXC,SXC,PDTXC,PDRXC) PDTXC=GAME*(THETA*FXCDHG-GAME*FXCDGG/3.d0)-THETA*(FXCDH/0.75d0+THETA*FXCDHH/1.5d0) return end subroutine EXCOR7 - - + + end module create_EXCOR7_table diff --git a/eos/private/create_FSCRliq8_table.f90 b/eos/private/create_FSCRliq8_table.f90 index b17bb1a09..a490211ef 100644 --- a/eos/private/create_FSCRliq8_table.f90 +++ b/eos/private/create_FSCRliq8_table.f90 @@ -21,21 +21,21 @@ ! *********************************************************************** module create_FSCRliq8_table - + use const_def use chem_def use utils_lib, only: is_bad use math_lib - + implicit none public :: do_create_FSCRliq8_table private - + contains - - + + subroutine do_create_FSCRliq8_table(fname,iZion) character (len=*), intent(in) :: fname integer, intent(in) :: iZion @@ -44,28 +44,28 @@ subroutine do_create_FSCRliq8_table(fname,iZion) integer :: nlogRS, nlogGAME, io_unit, i, j, ierr real(dp) :: Zion, RS, GAME, FSCR, USCR, PSCR, CVSCR, PDTSCR, PDRSCR include 'formats' - + Zion = iZion - + logRS_min = -3.5d0 logRS_max = 0.0d0 dlogRS = 1d-2 nlogRS = (logRS_max - logRS_min)/dlogRS + 1 - + logGAME_min = -2d0 logGAME_max = 4d0 dlogGAME = 1d-2 nlogGAME = (logGAME_max - logGAME_min)/dlogGAME + 1 io_unit = 40 - + !write(*,'(a)') 'create ' // trim(fname) open(unit=io_unit,file=trim(fname)) - + write(io_unit,'(99(a14))') 'num logRS', 'logRS min', 'logRS max', 'del logRS', & 'num logGAME', 'logGAME min', 'logGAME max', 'del logGAME', 'Zion' - + write(io_unit,'(2(i10,4x,3(f14.4)),i14)') & nlogRS, logRS_min, logRS_max, dlogRS, & nlogGAME, logGAME_min, logGAME_max, dlogGAME, iZion @@ -73,7 +73,7 @@ subroutine do_create_FSCRliq8_table(fname,iZion) do i = 1, nlogRS logRS = logRS_min + (i-1) * dlogRS RS = exp10(logRS) - write(io_unit,'(/,7x,a)') 'logRS' + write(io_unit,'(/,7x,a)') 'logRS' write(io_unit,'(2x,f14.6/)') logRS write(io_unit,'(99(a26))') & 'logGAME', 'FSCR', 'USCR', 'PSCR', 'CVSCR', 'PDTSCR', 'PDRSCR', 'RS', 'GAME' @@ -101,7 +101,7 @@ subroutine do_create_FSCRliq8_table(fname,iZion) write(io_unit,*) write(io_unit,*) close(io_unit) - + end subroutine do_create_FSCRliq8_table @@ -135,7 +135,7 @@ subroutine FSCRliq8(RS,GAME,Zion, & real(dp) :: DN1, DN1DX, DN1DG, DN1DXX, DN1DGG, DN1DXG real(dp) :: DN, DNDX, DNDG, DNDXX, DNDGG, DNDXG real(dp) :: FX, FXDG, FDX, FG, FDG, FDGDH, FDXX, FDGG, FDXG - + real(dp), parameter :: XRS=.0140047d0 real(dp), parameter :: TINY=1.d-19 diff --git a/eos/private/eos_blend.f90 b/eos/private/eos_blend.f90 index 0d33e34aa..931a61148 100644 --- a/eos/private/eos_blend.f90 +++ b/eos/private/eos_blend.f90 @@ -30,7 +30,7 @@ integer function quadrant(p) result(q) end function quadrant !! Determines the winding number of a polygon around the origin. - !! + !! !! Implements the winding number algorithm of !! Moscato, Titolo, Feliu, and Munoz (https://shemesh.larc.nasa.gov/people/cam/publications/FM2019-draft.pdf) !! @@ -107,7 +107,7 @@ logical function is_contained(num_points, coords, p) result(contained) end function is_contained !! Computes the minimum distance from a given point to a given line segment. - !! + !! !! @param line_start The coordinates of the start of the line segment (x,y). !! @param line_end The coordinates of the end of the line segment (x,y). !! @param p The point whose distance to compute. @@ -152,9 +152,9 @@ type(auto_diff_real_2var_order1) function min_distance_from_point_to_line_segmen end function min_distance_from_point_to_line_segment !! Computes the distance to the nearest line segment. - !! This is done by looping over segments, computing the minimum distance to each, and + !! This is done by looping over segments, computing the minimum distance to each, and !! returning the smallest of those differences. - !! + !! !! @param num_points The number of points specifying the polygon. !! @param coords The coordinates of the polygon. An array of shape (num_points, 2) storing (x,y) pairs. !! @param p The point whose distance to compute. diff --git a/eos/private/eos_ctrls_io.f90 b/eos/private/eos_ctrls_io.f90 index 6d3f76339..f0ffd5bcc 100644 --- a/eos/private/eos_ctrls_io.f90 +++ b/eos/private/eos_ctrls_io.f90 @@ -76,7 +76,7 @@ module eos_ctrls_io real(dp) :: logT_cut_FreeEOS_hi real(dp) :: logT_cut_FreeEOS_lo character (len=30) :: suffix_for_FreeEOS_Z(num_FreeEOS_Zs) - + ! controls for CMS logical :: use_CMS, CMS_use_fixed_composition integer :: CMS_fixed_composition_index @@ -86,7 +86,7 @@ module eos_ctrls_io real(dp) :: logRho_max_for_all_CMS, logRho_max_for_any_CMS ! for upper blend zone in logRho real(dp) :: logRho_min_for_all_CMS, logRho_min_for_any_CMS ! for lower blend zone in logRho real(dp) :: logT_max_for_all_CMS, logT_max_for_any_CMS ! for upper blend zone in logT - real(dp) :: logT_min_for_all_CMS, logT_min_for_any_CMS ! for lower blend zone in logT + real(dp) :: logT_min_for_all_CMS, logT_min_for_any_CMS ! for lower blend zone in logT real(dp) :: logT_max_for_all_CMS_pure_He, logT_max_for_any_CMS_pure_He ! upper logT blend zone is different for pure He ! controls for PC @@ -126,7 +126,7 @@ module eos_ctrls_io ! other eos logical :: use_other_eos_component, use_other_eos_results - + ! debugging logical :: dbg real(dp) :: logT_lo, logT_hi @@ -146,14 +146,14 @@ module eos_ctrls_io namelist /eos/ & use_FreeEOS, & - + ! controls for HELM Z_all_HELM, & ! all HELM for Z >= this unless use_FreeEOS logT_all_HELM, & ! all HELM for lgT >= this logT_low_all_HELM, & ! all HELM for lgT <= this coulomb_temp_cut_HELM, & coulomb_den_cut_HELM, & - + ! controls for OPAL_SCVH use_OPAL_SCVH, & logT_low_all_SCVH, & ! SCVH for lgT >= this @@ -164,7 +164,7 @@ module eos_ctrls_io logQ_max_OPAL_SCVH, & ! no OPAL/SCVH for logQ > this logQ_min_OPAL_SCVH, & ! no OPAL/SCVH for logQ <= this. Z_all_OPAL, & ! all OPAL for Z <= this - + ! controls for FreeEOS use_FreeEOS, & logQ_max_FreeEOS_hi, & @@ -189,7 +189,7 @@ module eos_ctrls_io logT_cut_FreeEOS_hi, & logT_cut_FreeEOS_lo, & suffix_for_FreeEOS_Z, & - + ! controls for CMS use_CMS, CMS_use_fixed_composition, & CMS_fixed_composition_index, & @@ -206,10 +206,10 @@ module eos_ctrls_io logT_max_for_all_CMS, & logT_max_for_any_CMS, & ! for upper blend zone in logT logT_min_for_all_CMS, & - logT_min_for_any_CMS, & ! for lower blend zone in logT + logT_min_for_any_CMS, & ! for lower blend zone in logT logT_max_for_all_CMS_pure_He, & logT_max_for_any_CMS_pure_He, & ! upper logT blend zone is different for pure He - + ! controls for PC use_PC, & mass_fraction_limit_for_PC, & ! skip any species with abundance < this @@ -244,7 +244,7 @@ module eos_ctrls_io eosDT_use_linear_interp_for_X, & eosDT_use_linear_interp_to_HELM, & eosDT_file_prefix, & - + okay_to_convert_ierr_to_skip, & tiny_fuzz, & @@ -257,7 +257,7 @@ module eos_ctrls_io logRho_lo, logRho_hi, & X_lo, X_hi, & Z_lo, Z_hi, & - + read_extra_eos_inlist, extra_eos_inlist_name,& ! User supplied inputs @@ -306,7 +306,7 @@ recursive subroutine read_controls_file(rq, filename, level, ierr) ierr = -1 return end if - + if (len_trim(filename) > 0) then open(newunit=unit, file=trim(filename), & action='read', delim='quote', status='old', iostat=ierr) @@ -343,7 +343,7 @@ recursive subroutine read_controls_file(rq, filename, level, ierr) end if call store_controls(rq) - + if (len_trim(filename) == 0) return ! recursive calls to read other inlists @@ -352,7 +352,7 @@ recursive subroutine read_controls_file(rq, filename, level, ierr) read_extra_eos_inlist(i) = .false. extra(i) = extra_eos_inlist_name(i) extra_eos_inlist_name(i) = 'undefined' - + if (read_extra(i)) then call read_controls_file(rq, extra(i), level+1, ierr) if (ierr /= 0) return @@ -375,7 +375,7 @@ subroutine store_controls(rq) rq% logT_all_HELM = logT_all_HELM rq% logT_low_all_HELM = logT_low_all_HELM rq% coulomb_temp_cut_HELM = coulomb_temp_cut_HELM - rq% coulomb_den_cut_HELM = coulomb_den_cut_HELM + rq% coulomb_den_cut_HELM = coulomb_den_cut_HELM ! controls for OPAL_SCVH rq% use_OPAL_SCVH = use_OPAL_SCVH rq% logT_low_all_SCVH = logT_low_all_SCVH @@ -385,7 +385,7 @@ subroutine store_controls(rq) rq% logRho_min_OPAL_SCVH_limit = logRho_min_OPAL_SCVH_limit rq% logQ_max_OPAL_SCVH = logQ_max_OPAL_SCVH rq% logQ_min_OPAL_SCVH = logQ_min_OPAL_SCVH - rq% Z_all_OPAL = Z_all_OPAL + rq% Z_all_OPAL = Z_all_OPAL ! controls for FreeEOS rq% use_FreeEOS = use_FreeEOS rq% logQ_max_FreeEOS_hi = logQ_max_FreeEOS_hi @@ -410,7 +410,7 @@ subroutine store_controls(rq) rq% logT_cut_FreeEOS_hi = logT_cut_FreeEOS_hi rq% logT_cut_FreeEOS_lo = logT_cut_FreeEOS_lo rq% suffix_for_FreeEOS_Z(1:num_FreeEOS_Zs) = & - suffix_for_FreeEOS_Z(1:num_FreeEOS_Zs) + suffix_for_FreeEOS_Z(1:num_FreeEOS_Zs) ! controls for CMS rq% use_CMS = use_CMS rq% CMS_use_fixed_composition = CMS_use_fixed_composition @@ -430,7 +430,7 @@ subroutine store_controls(rq) rq% logT_min_for_all_CMS = logT_min_for_all_CMS rq% logT_min_for_any_CMS = logT_min_for_any_CMS rq% logT_max_for_all_CMS_pure_He = logT_max_for_all_CMS_pure_He - rq% logT_max_for_any_CMS_pure_He = logT_max_for_any_CMS_pure_He + rq% logT_max_for_any_CMS_pure_He = logT_max_for_any_CMS_pure_He ! controls for PC rq% use_PC = use_PC rq% mass_fraction_limit_for_PC = mass_fraction_limit_for_PC @@ -460,8 +460,8 @@ subroutine store_controls(rq) rq% include_radiation = include_radiation rq% include_elec_pos = include_elec_pos rq% eosDT_use_linear_interp_for_X = eosDT_use_linear_interp_for_X - rq% eosDT_use_linear_interp_to_HELM = eosDT_use_linear_interp_to_HELM - rq% eosDT_file_prefix = eosDT_file_prefix + rq% eosDT_use_linear_interp_to_HELM = eosDT_use_linear_interp_to_HELM + rq% eosDT_file_prefix = eosDT_file_prefix rq% okay_to_convert_ierr_to_skip = okay_to_convert_ierr_to_skip rq% tiny_fuzz = tiny_fuzz @@ -491,7 +491,7 @@ end subroutine store_controls subroutine write_namelist(handle, filename, ierr) integer, intent(in) :: handle character(*), intent(in) :: filename - integer, intent(out) :: ierr + integer, intent(out) :: ierr type (EoS_General_Info), pointer :: rq integer :: iounit open(newunit=iounit, file=trim(filename), & @@ -504,8 +504,8 @@ subroutine write_namelist(handle, filename, ierr) if (ierr /= 0) then close(iounit) return - end if - call set_controls_for_writing(rq) + end if + call set_controls_for_writing(rq) write(iounit, nml=eos, iostat=ierr) close(iounit) end subroutine write_namelist @@ -518,7 +518,7 @@ subroutine set_controls_for_writing(rq) logT_all_HELM = rq% logT_all_HELM logT_low_all_HELM = rq% logT_low_all_HELM coulomb_temp_cut_HELM = rq% coulomb_temp_cut_HELM - coulomb_den_cut_HELM = rq% coulomb_den_cut_HELM + coulomb_den_cut_HELM = rq% coulomb_den_cut_HELM ! controls for OPAL_SCVH use_OPAL_SCVH = rq% use_OPAL_SCVH logT_low_all_SCVH = rq% logT_low_all_SCVH @@ -528,7 +528,7 @@ subroutine set_controls_for_writing(rq) logRho_min_OPAL_SCVH_limit = rq% logRho_min_OPAL_SCVH_limit logQ_max_OPAL_SCVH = rq% logQ_max_OPAL_SCVH logQ_min_OPAL_SCVH = rq% logQ_min_OPAL_SCVH - Z_all_OPAL = rq% Z_all_OPAL + Z_all_OPAL = rq% Z_all_OPAL ! controls for FreeEOS use_FreeEOS = rq% use_FreeEOS logQ_max_FreeEOS_hi = rq% logQ_max_FreeEOS_hi @@ -553,7 +553,7 @@ subroutine set_controls_for_writing(rq) logT_cut_FreeEOS_hi = rq% logT_cut_FreeEOS_hi logT_cut_FreeEOS_lo = rq% logT_cut_FreeEOS_lo suffix_for_FreeEOS_Z(1:num_FreeEOS_Zs) = & - rq% suffix_for_FreeEOS_Z(1:num_FreeEOS_Zs) + rq% suffix_for_FreeEOS_Z(1:num_FreeEOS_Zs) ! controls for CMS use_CMS = rq% use_CMS CMS_use_fixed_composition = rq% CMS_use_fixed_composition @@ -573,7 +573,7 @@ subroutine set_controls_for_writing(rq) logT_min_for_all_CMS = rq% logT_min_for_all_CMS logT_min_for_any_CMS = rq% logT_min_for_any_CMS logT_max_for_all_CMS_pure_He = rq% logT_max_for_all_CMS_pure_He - logT_max_for_any_CMS_pure_He = rq% logT_max_for_any_CMS_pure_He + logT_max_for_any_CMS_pure_He = rq% logT_max_for_any_CMS_pure_He ! controls for PC use_PC = rq% use_PC mass_fraction_limit_for_PC = rq% mass_fraction_limit_for_PC @@ -589,9 +589,9 @@ subroutine set_controls_for_writing(rq) ! controls for Skye use_Skye = rq% use_Skye Skye_use_ion_offsets = rq% Skye_use_ion_offsets - mass_fraction_limit_for_Skye = rq% mass_fraction_limit_for_Skye + mass_fraction_limit_for_Skye = rq% mass_fraction_limit_for_Skye Skye_min_gamma_for_solid = rq% Skye_min_gamma_for_solid - Skye_max_gamma_for_liquid = rq% Skye_max_gamma_for_liquid + Skye_max_gamma_for_liquid = rq% Skye_max_gamma_for_liquid Skye_solid_mixing_rule = rq% Skye_solid_mixing_rule use_simple_Skye_blends = rq% use_simple_Skye_blends logRho_min_for_any_Skye = rq% logRho_min_for_any_Skye @@ -603,8 +603,8 @@ subroutine set_controls_for_writing(rq) include_radiation = rq% include_radiation include_elec_pos = rq% include_elec_pos eosDT_use_linear_interp_for_X = rq% eosDT_use_linear_interp_for_X - eosDT_use_linear_interp_to_HELM = rq% eosDT_use_linear_interp_to_HELM - eosDT_file_prefix = rq% eosDT_file_prefix + eosDT_use_linear_interp_to_HELM = rq% eosDT_use_linear_interp_to_HELM + eosDT_file_prefix = rq% eosDT_file_prefix okay_to_convert_ierr_to_skip = rq% okay_to_convert_ierr_to_skip tiny_fuzz = rq% tiny_fuzz @@ -629,7 +629,7 @@ subroutine set_controls_for_writing(rq) Z_lo = rq% Z_lo Z_hi = rq% Z_hi end subroutine set_controls_for_writing - + subroutine get_eos_controls(rq, name, val, ierr) use utils_lib, only: StrUpCase @@ -657,7 +657,7 @@ subroutine get_eos_controls(rq, name, val, ierr) upper_name = trim(StrUpCase(name))//'=' val = '' ! Search for name inside namelist - do + do read(iounit,'(A)',iostat=iostat) str ind = index(trim(str),trim(upper_name)) if( ind /= 0 ) then @@ -668,7 +668,7 @@ subroutine get_eos_controls(rq, name, val, ierr) exit end if if(is_iostat_end(iostat)) exit - end do + end do if(len_trim(val) == 0 .and. ind==0 ) ierr = -1 diff --git a/eos/private/eos_helm_eval.f90 b/eos/private/eos_helm_eval.f90 index 2e6a1e947..1b4467967 100644 --- a/eos/private/eos_helm_eval.f90 +++ b/eos/private/eos_helm_eval.f90 @@ -33,7 +33,7 @@ module eos_HELM_eval use helm implicit none - + logical, parameter :: stop_for_is_bad = .false. logical, parameter :: dbg = .false. @@ -107,11 +107,11 @@ subroutine get_helm_for_eosdt( & end subroutine get_helm_for_eosdt - + subroutine Get_HELMEOS_Results( & rq, Z, abar, zbar, Rho, logRho, T, logT, & res, d_dlnd, d_dlnT, d_dabar, d_dzbar, & - helm_res, off_table, ierr) + helm_res, off_table, ierr) type (EoS_General_Info), pointer :: rq real(dp), intent(in) :: Z, abar, zbar real(dp), intent(in) :: Rho, logRho, T, logT @@ -122,17 +122,17 @@ subroutine Get_HELMEOS_Results( & integer, intent(out) :: ierr logical, parameter :: clip_to_table_boundaries = .true. - + logical :: include_elec_pos, include_radiation - + include 'formats' ierr = 0 off_table = .false. - + include_elec_pos = rq% include_elec_pos include_radiation = rq% include_radiation - + call helmeos2( & T, logT, Rho, logRho, abar, zbar, & rq% coulomb_temp_cut_HELM, rq% coulomb_den_cut_HELM, & @@ -163,7 +163,7 @@ subroutine Get_HELMEOS_Results( & if (ierr /= 0) then if (dbg) write(*,*) 'failed in do_convert_helm_results' return - end if + end if end subroutine Get_HELMEOS_Results @@ -184,12 +184,12 @@ subroutine do_convert_helm_results( & real(dp) :: mu, P, Pgas, energy, entropy, free_e, dse, dpe, dsp integer :: j, k, ci - + include 'formats' - + ierr = 0 - - if (.false. .and. eos_test_partials) then + + if (.false. .and. eos_test_partials) then eos_test_partials_val = helm_res(h_etot) eos_test_partials_dval_dx = helm_res(h_dea) write(*,1) 'logRho', log10(Rho) @@ -206,12 +206,12 @@ subroutine do_convert_helm_results( & write(*,1) 'detot_dzbar', helm_res(h_dez) call mesa_error(__FILE__,__LINE__,'do_convert_helm_results') end if - + energy = helm_res(h_etot) entropy = helm_res(h_stot) P = helm_res(h_ptot) Pgas = helm_res(h_pgas) - + res(i_lnE) = log(energy) res(i_lnS) = log(entropy) res(i_lnPgas) = log(Pgas) @@ -231,11 +231,11 @@ subroutine do_convert_helm_results( & res(i_gamma1) = helm_res(h_gam1) res(i_gamma3) = helm_res(h_gam3) res(i_eta) = helm_res(h_etaele) - + d_dlnRho_c_T(i_lnS) = helm_res(h_dsd)*Rho/entropy d_dlnRho_c_T(i_lnPgas) = helm_res(h_dpgasd)*Rho/Pgas d_dlnRho_c_T(i_lnE) = helm_res(h_ded)*Rho/energy - + d_dlnRho_c_T(i_grad_ad) = helm_res(h_dnabdd)*Rho d_dlnRho_c_T(i_chiRho) = helm_res(h_dchiddd)*Rho d_dlnRho_c_T(i_chiT) = helm_res(h_dchitdd)*Rho @@ -249,11 +249,11 @@ subroutine do_convert_helm_results( & d_dlnRho_c_T(i_gamma1) = helm_res(h_dgam1dd)*Rho d_dlnRho_c_T(i_gamma3) = helm_res(h_dgam3dd)*Rho d_dlnRho_c_T(i_eta) = helm_res(h_detad)*Rho - + d_dlnT_c_Rho(i_lnS) = helm_res(h_dst)*T/entropy d_dlnT_c_Rho(i_lnPgas) = helm_res(h_dpgast)*T/Pgas d_dlnT_c_Rho(i_lnE) = helm_res(h_det)*T/energy - + d_dlnT_c_Rho(i_grad_ad) = helm_res(h_dnabdt)*T d_dlnT_c_Rho(i_chiRho) = helm_res(h_dchiddt)*T d_dlnT_c_Rho(i_chiT) = helm_res(h_dchitdt)*T @@ -269,8 +269,8 @@ subroutine do_convert_helm_results( & d_dlnT_c_Rho(i_eta) = helm_res(h_detat)*T d_dlnRho_c_T(i_lnE) = helm_res(h_ded)*Rho/energy - d_dlnT_c_Rho(i_lnE) = helm_res(h_det)*T/energy - + d_dlnT_c_Rho(i_lnE) = helm_res(h_det)*T/energy + d_dlnRho_c_T(i_lnS) = helm_res(h_dsd)*Rho/entropy d_dlnT_c_Rho(i_lnS) = helm_res(h_dst)*T/entropy @@ -281,7 +281,7 @@ subroutine do_convert_helm_results( & d_dabar_c_TRho(i_lnS) = helm_res(h_dsa)/entropy d_dabar_c_TRho(i_lnPgas) = helm_res(h_dpgasa)/Pgas d_dabar_c_TRho(i_lnE) = helm_res(h_dea)/energy - + d_dabar_c_TRho(i_grad_ad) = helm_res(h_dnabda) d_dabar_c_TRho(i_chiRho) = helm_res(h_dchidda) d_dabar_c_TRho(i_chiT) = helm_res(h_dchitda) @@ -299,7 +299,7 @@ subroutine do_convert_helm_results( & d_dzbar_c_TRho(i_lnS) = helm_res(h_dsz)/entropy d_dzbar_c_TRho(i_lnPgas) = helm_res(h_dpgasz)/Pgas d_dzbar_c_TRho(i_lnE) = helm_res(h_dez)/energy - + d_dzbar_c_TRho(i_grad_ad) = helm_res(h_dnabdz) d_dzbar_c_TRho(i_chiRho) = helm_res(h_dchiddz) d_dzbar_c_TRho(i_chiT) = helm_res(h_dchitdz) @@ -314,10 +314,10 @@ subroutine do_convert_helm_results( & d_dzbar_c_TRho(i_gamma3) = helm_res(h_dgam3dz) d_dzbar_c_TRho(i_eta) = helm_res(h_detaz) - + end subroutine do_convert_helm_results - + subroutine Get_HELM_Results( & abar, zbar, arho, alogrho, atemp, alogtemp, & coulomb_temp_cut, coulomb_den_cut, & @@ -329,7 +329,7 @@ subroutine Get_HELM_Results( & type (EoS_General_Info), pointer :: rq real(dp), intent(in) :: abar, zbar real(dp), intent(in) :: arho, alogrho - real(dp), intent(in) :: atemp, alogtemp + real(dp), intent(in) :: atemp, alogtemp real(dp), intent(in) :: coulomb_temp_cut, coulomb_den_cut logical, intent(in) :: include_radiation, include_elec_pos real(dp), intent(inout) :: res(:) ! (num_helm_results) @@ -337,11 +337,11 @@ subroutine Get_HELM_Results( & integer, intent(out) :: ierr ! 0 means AOK. real(dp) :: Rho, logRho, T, logT, dse, dpe, dsp - + logical, parameter :: clip_to_table_boundaries = .true. - + include 'formats' - + ierr = 0 off_table = .false. @@ -351,21 +351,21 @@ subroutine Get_HELM_Results( & ierr = -2; return end if if (atemp == arg_not_provided) T = exp10(logT) - + Rho = arho; logrho = alogrho if (arho == arg_not_provided .and. alogrho == arg_not_provided) then ierr = -3; return end if if (arho == arg_not_provided) Rho = exp10(logRho) - + call helmeos2(T, logT, Rho, logRho, abar, zbar, & coulomb_temp_cut, coulomb_den_cut, & res, clip_to_table_boundaries, include_radiation, & include_elec_pos, off_table, ierr) res(h_valid) = 1 - + end subroutine Get_HELM_Results end module eos_HELM_eval - + diff --git a/eos/private/eos_initialize.f90 b/eos/private/eos_initialize.f90 index 5a89e12e0..09e01d0c9 100644 --- a/eos/private/eos_initialize.f90 +++ b/eos/private/eos_initialize.f90 @@ -29,8 +29,8 @@ module eos_initialize implicit none contains - - + + subroutine Init_eos( & eosDT_cache_dir_in, & use_cache, ierr) @@ -41,7 +41,7 @@ subroutine Init_eos( & character(*), intent(IN) :: eosDT_cache_dir_in logical, intent(in) :: use_cache integer, intent(OUT) :: ierr ! 0 means AOK. - !integer, parameter :: imax = 261, jmax = 101 + !integer, parameter :: imax = 261, jmax = 101 ! dimensions of small version of helm table !integer, parameter :: imax = 1081, jmax = 401 ! dimensions of medium version of helm table; 40 points per decade @@ -65,20 +65,20 @@ subroutine Init_eos( & eosDT_temp_cache_dir = trim(mesa_temp_caches_dir) // '/eosDT_cache' if(use_mesa_temp_cache) call mkdir(eosDT_temp_cache_dir) end if - + call alloc_helm_table(eos_ht, imax, jmax, ierr) if (ierr /= 0) return - + call read_helm_table(eos_ht, & eosDT_data_dir, eosDT_cache_dir, eosDT_temp_cache_dir, use_cache_for_eos, ierr) if (ierr /= 0) return call eos_def_init ! replace defaults from eos_def_init by argument - + eos_root_is_initialized = .true. - + end subroutine Init_eos - - + + end module eos_initialize diff --git a/eos/private/eoscms_eval.f90 b/eos/private/eoscms_eval.f90 index c3d793112..5f3134e15 100644 --- a/eos/private/eoscms_eval.f90 +++ b/eos/private/eoscms_eval.f90 @@ -32,14 +32,14 @@ module eoscms_eval use math_lib use interp_2d_lib_db - implicit none + implicit none logical, parameter :: CMS_cubic_in_X = .false. - + integer, parameter :: CMS_num_Xs = 11 integer, parameter :: min_for_cubic = 2 integer, parameter :: max_for_cubic = CMS_num_Xs - 2 - + character(len=3) :: CMS_Xstr(CMS_num_Xs) = ['000','010','020','030','040','050','060','070','080','090','100'] real(dp) :: CMS_Xvals(CMS_num_Xs) = [ 0.0_dp, 0.1_dp, 0.2_dp, 0.3_dp, 0.4_dp, 0.5_dp, 0.6_dp, 0.7_dp, 0.8_dp, 0.9_dp, 1.0_dp] @@ -61,7 +61,7 @@ module eoscms_eval type(eosCMS_X_Info), target :: eosCMS_X_data(CMS_num_Xs) logical :: eosCMS_X_loaded(CMS_num_Xs) = .false. - + contains subroutine eosCMS_init(ierr) @@ -70,7 +70,7 @@ subroutine eosCMS_init(ierr) ierr=0 end subroutine eosCMS_init - + subroutine Get_CMS_alfa( & rq, logRho, logT, Z, abar, zbar, & alfa, d_alfa_dlogT, d_alfa_dlogRho, & @@ -191,7 +191,7 @@ subroutine get_CMS_for_eosdt( & ierr=-1 return endif - + iX = rq% CMS_fixed_composition_index + 1 call eval_eosCMS_fixed_X(iX,logRho,logT,res,d_dlnT,d_dlnd,ierr) @@ -204,7 +204,7 @@ subroutine get_CMS_for_eosdt( & ! composition derivatives; here composition is constant so no change d_dxa = 0 - + else !do full composition !locate X values in the tables such that Xvals(iX) <= X < Xvals(iX+1) if (X <= CMS_Xvals(1)) then @@ -302,7 +302,7 @@ subroutine get_CMS_for_eosdt( & ! mark this one res(i_frac_CMS) = 1.0 - + end subroutine get_CMS_for_eosdt @@ -461,7 +461,7 @@ subroutine include_radiation(Z, X, abar, zbar, & end subroutine include_radiation - + subroutine eval_eosCMS_fixed_X(iX,logRho,logT,res,dres_dlnT,dres_dlnRho,ierr) use eosdt_support, only: Do_EoS_Interpolations integer, intent(in) :: iX @@ -472,14 +472,14 @@ subroutine eval_eosCMS_fixed_X(iX,logRho,logT,res,dres_dlnT,dres_dlnRho,ierr) integer :: iRho, iT real(dp) :: fval(nv), df_dx(nv), df_dy(nv) real(dp) :: logT0, logRho0, logT1, logRho1, my_logT, my_logRho - ierr = 0 + ierr = 0 !$OMP CRITICAL(OMP_CRITICAL_IX) if(.not.eosCMS_X_loaded(iX)) call load_eosCMS_table(iX,ierr) !$OMP END CRITICAL(OMP_CRITICAL_IX) my_logT = logT my_logRho = logRho - + c => eosCMS_X_data(iX) call locate_logRho(c, my_logRho, iRho, logRho0, logRho1) @@ -534,7 +534,7 @@ subroutine locate_logT(c,logT, iT, logT0, logT1) endif end subroutine locate_logT - + subroutine locate_logRho(c,logRho, iRho, logRho0, logRho1) type(eosCMS_X_info), pointer :: c real(dp), intent(inout) :: logRho @@ -558,7 +558,7 @@ subroutine locate_logRho(c,logRho, iRho, logRho0, logRho1) logRho1 = logRho0 + c% delta_logRho endif end subroutine locate_logRho - + subroutine load_eosCMS_table(iX, ierr) integer, intent(in) :: iX integer, intent(out) :: ierr @@ -573,7 +573,7 @@ subroutine load_eosCMS_table(iX, ierr) real(dp) :: X_in, Z_in ierr=0 - c => eosCMS_X_data(iX) + c => eosCMS_X_data(iX) vec => vec_ary data_sub_dir = '/eosCMS_data/' @@ -607,7 +607,7 @@ subroutine load_eosCMS_table(iX, ierr) allocate(c% logTs(c% num_logTs)) allocate(c% logRhos(c% num_logRhos)) - + c% logTs(1) = c% logT_min do i = 2, c% num_logTs c% logTs(i) = c% logTs(i-1) + c% delta_logT @@ -627,7 +627,7 @@ subroutine load_eosCMS_table(iX, ierr) ierr=-1 return endif - + read(io,*) !header read(io,*) !header @@ -639,7 +639,7 @@ subroutine load_eosCMS_table(iX, ierr) f1 => f1_ary f(1:sz_per_eos_point,1:c% num_logTs,1:c% num_logRhos) => & f1(1:sz_per_eos_point*c% num_logTs*c% num_logRhos) - + do i=1,c% num_logTs do j=1,c% num_logRhos read(io,'(a)') message @@ -666,7 +666,7 @@ subroutine load_eosCMS_table(iX, ierr) tbl(1,i_eta,i,j) = vec(18) enddo enddo - + close(io) ! logT is "x" @@ -679,7 +679,7 @@ subroutine load_eosCMS_table(iX, ierr) ibcxmax = 0; bcxmax(:) = 0 ibcymin = 0; bcymin(:) = 0 ibcymax = 0; bcymax(:) = 0 - + !create table for bicubic spline do v = 1, nv do j = 1, c% num_logRhos @@ -687,7 +687,7 @@ subroutine load_eosCMS_table(iX, ierr) f(1,i,j) = tbl(1,v,i,j) enddo enddo - + call interp_mkbicub_db( & c% logTs, c% num_logTs, c% logRhos, c% num_logRhos, f1, c% num_logTs, & ibcxmin, bcxmin, ibcxmax, bcxmax, ibcymin, bcymin, ibcymax, bcymax, & @@ -703,7 +703,7 @@ subroutine load_eosCMS_table(iX, ierr) enddo if(ierr==0) eosCMS_X_loaded(iX) = .true. - + end subroutine load_eosCMS_table end module eoscms_eval diff --git a/eos/private/eosde_eval.f90 b/eos/private/eosde_eval.f90 index ccdadefa9..e1e0eb1a3 100644 --- a/eos/private/eosde_eval.f90 +++ b/eos/private/eosde_eval.f90 @@ -46,30 +46,30 @@ subroutine Get_eos_gamma_DE_Results( & real(dp), intent(out) :: T, log10T real(dp), intent(inout), dimension(:) :: & res, d_dlnRho_const_T, d_dlnT_const_Rho - real(dp), intent(out) :: & + real(dp), intent(out) :: & dlnT_dlnE_c_Rho, dlnT_dlnd_c_E, & dlnPgas_dlnE_c_Rho, dlnPgas_dlnd_c_E integer, intent(out) :: ierr - + real(dp) :: avo_k_div_abar, P, entropy include 'formats' - + ierr = 0 - + res(1:nv) = 0d0 d_dlnRho_const_T(1:nv) = 0d0 d_dlnT_const_Rho(1:nv) = 0d0 avo_k_div_abar = avo*kerg/abar - + P = (gamma - 1d0)*energy*rho T = (gamma - 1d0)*energy/avo_k_div_abar log10T = log10(T) res(i_Cv) = avo_k_div_abar/(gamma - 1) ! energy/T - + entropy = res(i_Cv)*log(P/pow(rho,gamma)) + 1d9 ! offset to keep it > 0 - + if (is_bad(entropy) .or. entropy <= 0d0) then if (.false.) then !$OMP critical (eosde_eval_crit1) @@ -88,7 +88,7 @@ subroutine Get_eos_gamma_DE_Results( & end if entropy = 1d-99 end if - + res(i_lnPgas) = log(P) ! treat P as Pgas res(i_lnE) = log10E*ln10 res(i_lnS) = log(entropy) @@ -104,20 +104,20 @@ subroutine Get_eos_gamma_DE_Results( & res(i_gamma3) = gamma res(i_lnfree_e) = -1d99 res(i_eta) = 0d0 - + d_dlnRho_const_T(i_lnPgas) = 1 - + d_dlnT_const_Rho(i_lnPgas) = 1 d_dlnT_const_Rho(i_lnE) = 1 - + dlnT_dlnd_c_E = 0 dlnPgas_dlnd_c_E = 1 dlnT_dlnE_c_Rho = 1 dlnPgas_dlnE_c_Rho = 1 - + end subroutine Get_eos_gamma_DE_Results end module eosDE_eval - + diff --git a/eos/private/eosdt_eval.f90 b/eos/private/eosdt_eval.f90 index 334605582..df4da3f4f 100644 --- a/eos/private/eosdt_eval.f90 +++ b/eos/private/eosdt_eval.f90 @@ -48,7 +48,7 @@ module eosDT_eval integer, parameter :: blend_corner_in = 6 integer, parameter :: blend_diagonal = 7 integer, parameter :: blend_in_Z = 8 - + abstract interface subroutine get_values_for_eosdt_interface( & handle, dbg, Z, X, abar, zbar, & @@ -57,7 +57,7 @@ subroutine get_values_for_eosdt_interface( & res, d_dlnd, d_dlnT, d_dxa, & skip, ierr) use const_def, only: dp - use eos_def, only: nv + use eos_def, only: nv integer, intent(in) :: handle logical, intent(in) :: dbg real(dp), intent(in) :: & @@ -73,8 +73,8 @@ subroutine get_values_for_eosdt_interface( & integer, intent(out) :: ierr end subroutine get_values_for_eosdt_interface end interface - - + + contains @@ -92,31 +92,31 @@ subroutine Test_one_eosDT_component(rq, which_eos, & real(dp), intent(inout), dimension(nv) :: res, d_dlnd, d_dlnT real(dp), intent(inout), dimension(nv, species) :: d_dxa integer, intent(out) :: ierr - + real(dp) :: rho, logRho, T, logT logical :: skip include 'formats' - + T = atemp; logT = alogtemp if (atemp == arg_not_provided .and. alogtemp == arg_not_provided) then ierr = -1; return end if if (alogtemp == arg_not_provided) logT = log10(T) if (atemp == arg_not_provided) T = exp10(logT) - + if (T <= 0) then ierr = -1 return end if - + Rho = arho; logrho = alogrho if (arho == arg_not_provided .and. alogrho == arg_not_provided) then ierr = -1; return end if if (alogrho == arg_not_provided) logRho = log10(Rho) if (arho == arg_not_provided) Rho = exp10(logRho) - + if (Rho <= 0) then ierr = -1 return @@ -179,17 +179,17 @@ subroutine Test_one_eosDT_component(rq, which_eos, & case default ierr = -1 end select - + if (ierr /= 0) then write(*,*) 'failed in Test_one_eosDT_component', which_eos return end if - + if (skip) then write(*,*) 'skipped - no results Test_one_eosDT_component', which_eos return end if - + end subroutine Test_one_eosDT_component @@ -199,7 +199,7 @@ subroutine Get_eosDT_Results(rq, & arho, alogrho, atemp, alogtemp, & res, d_dlnd, d_dlnT, d_dxa, ierr) type (EoS_General_Info), pointer :: rq - real(dp), intent(in) :: Z, X, abar, zbar + real(dp), intent(in) :: Z, X, abar, zbar integer, intent(in) :: species integer, pointer :: chem_id(:), net_iso(:) real(dp), intent(in) :: xa(:) @@ -207,12 +207,12 @@ subroutine Get_eosDT_Results(rq, & real(dp), intent(inout), dimension(nv) :: res, d_dlnd, d_dlnT real(dp), intent(inout), dimension(nv, species) :: d_dxa integer, intent(out) :: ierr - + real(dp) :: rho, logRho, T, logT logical :: skip, dbg include 'formats' - + T = atemp; logT = alogtemp if (atemp == arg_not_provided .and. alogtemp == arg_not_provided) then @@ -220,19 +220,19 @@ subroutine Get_eosDT_Results(rq, & end if if (alogtemp == arg_not_provided) logT = log10(T) if (atemp == arg_not_provided) T = exp10(logT) - + if (T <= 0) then ierr = -1 return end if - + Rho = arho; logrho = alogrho if (arho == arg_not_provided .and. alogrho == arg_not_provided) then ierr = -1; return end if if (alogrho == arg_not_provided) logRho = log10(Rho) if (arho == arg_not_provided) Rho = exp10(logRho) - + if (Rho <= 0) then ierr = -1 return @@ -248,7 +248,7 @@ subroutine Get_eosDT_Results(rq, & logRho >= rq% logRho_lo .and. logRho <= rq% logRho_hi .and. & X >= rq% X_lo .and. X <= rq% X_hi .and. & Z >= rq% Z_lo .and. Z <= rq% Z_hi - + call get_level0_for_eosdt( & rq% handle, dbg, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & @@ -263,19 +263,19 @@ subroutine Get_eosDT_Results(rq, & call rq% other_eos_results( & rq% handle, & species, chem_id, net_iso, xa, & - Rho, logRho, T, logT, & + Rho, logRho, T, logT, & res, d_dlnd, d_dlnT, d_dxa, ierr) end if - - if (eos_test_partials) then + + if (eos_test_partials) then eos_test_partials_val = abar eos_test_partials_dval_dx = 0 write(*,*) 'eos_test_partials' end if - + end subroutine Get_eosDT_Results - - + + subroutine get_other_for_eosdt( & handle, dbg, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & @@ -301,7 +301,7 @@ subroutine get_other_for_eosdt( & rq => eos_handles(handle) ierr = 0 - + call rq% other_eos_component( & handle, & species, chem_id, net_iso, xa, & @@ -338,13 +338,13 @@ subroutine get_level0_for_eosdt( & ! other logical, intent(out) :: skip integer, intent(out) :: ierr - real(dp) :: frac, d_frac_dlogT, d_frac_dlogRho + real(dp) :: frac, d_frac_dlogT, d_frac_dlogRho real(dp) :: alfa, d_alfa_dlogT, d_alfa_dlogRho type (EoS_General_Info), pointer :: rq procedure (get_values_for_eosdt_interface), pointer :: get_1st, get_2nd include 'formats' - + ierr = 0 rq => eos_handles(handle) @@ -364,9 +364,9 @@ subroutine get_level0_for_eosdt( & ! other d_alfa_dlogT = 0d0 d_alfa_dlogRho = 0d0 end if - + if (dbg) write(*,1) 'other', (1d0 - alfa)*remaining_fraction - + get_1st => get_other_for_eosdt get_2nd => get_level1_for_eosdt call combine_for_eosdt( & @@ -381,7 +381,7 @@ subroutine get_level0_for_eosdt( & ! other skip = .true. ierr = 0 end if - + end subroutine get_level0_for_eosdt @@ -404,13 +404,13 @@ subroutine get_level1_for_eosdt( & ! CMS real(dp), intent(inout), dimension(nv, species) :: d_dxa logical, intent(out) :: skip integer, intent(out) :: ierr - + real(dp) :: alfa, d_alfa_dlogT, d_alfa_dlogRho type (EoS_General_Info), pointer :: rq procedure (get_values_for_eosdt_interface), pointer :: get_1st, get_2nd include 'formats' - + ierr = 0 rq => eos_handles(handle) @@ -425,9 +425,9 @@ subroutine get_level1_for_eosdt( & ! CMS d_alfa_dlogT = 0d0 d_alfa_dlogRho = 0d0 end if - + if (dbg) write(*,1) 'CMS', (1d0 - alfa)*remaining_fraction - + get_1st => get_CMS_for_eosdt get_2nd => get_level2_for_eosdt call combine_for_eosdt( & @@ -442,10 +442,10 @@ subroutine get_level1_for_eosdt( & ! CMS skip = .true. ierr = 0 end if - + end subroutine get_level1_for_eosdt - - + + subroutine get_level2_for_eosdt( & ! Skye handle, dbg, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & @@ -464,13 +464,13 @@ subroutine get_level2_for_eosdt( & ! Skye real(dp), intent(inout), dimension(nv, species) :: d_dxa logical, intent(out) :: skip integer, intent(out) :: ierr - + real(dp) :: alfa, d_alfa_dlogT, d_alfa_dlogRho type (EoS_General_Info), pointer :: rq procedure (get_values_for_eosdt_interface), pointer :: get_1st, get_2nd include 'formats' - + ierr = 0 rq => eos_handles(handle) @@ -486,13 +486,13 @@ subroutine get_level2_for_eosdt( & ! Skye alfa, d_alfa_dlogT, d_alfa_dlogRho, & ierr) end if - if (ierr /= 0) return + if (ierr /= 0) return else alfa = 1d0 ! no Skye d_alfa_dlogT = 0d0 d_alfa_dlogRho = 0d0 - end if - + end if + if (dbg) write(*,1) 'Skye', (1d0 - alfa)*remaining_fraction get_1st => get_Skye_for_eosdt @@ -509,10 +509,10 @@ subroutine get_level2_for_eosdt( & ! Skye skip = .true. ierr = 0 end if - + end subroutine get_level2_for_eosdt - - + + subroutine get_level3_for_eosdt( & ! PC handle, dbg, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & @@ -532,18 +532,18 @@ subroutine get_level3_for_eosdt( & ! PC real(dp), intent(inout), dimension(nv, species) :: d_dxa logical, intent(out) :: skip integer, intent(out) :: ierr - + real(dp) :: alfa, d_alfa_dlogT, d_alfa_dlogRho type (EoS_General_Info), pointer :: rq procedure (get_values_for_eosdt_interface), pointer :: get_1st, get_2nd include 'formats' - + ierr = 0 rq => eos_handles(handle) if (rq% use_PC) then - call Get_PC_alfa( & + call Get_PC_alfa( & rq, logRho, logT, Z, abar, zbar, & alfa, d_alfa_dlogT, d_alfa_dlogRho, & ierr) @@ -552,8 +552,8 @@ subroutine get_level3_for_eosdt( & ! PC alfa = 1d0 ! no PC d_alfa_dlogT = 0d0 d_alfa_dlogRho = 0d0 - end if - + end if + if (dbg) write(*,1) 'PC', (1d0 - alfa)*remaining_fraction get_1st => get_PC_for_eosdt @@ -570,10 +570,10 @@ subroutine get_level3_for_eosdt( & ! PC skip = .true. ierr = 0 end if - + end subroutine get_level3_for_eosdt - - + + subroutine get_level4_for_eosdt( & ! FreeEOS handle, dbg, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & @@ -593,18 +593,18 @@ subroutine get_level4_for_eosdt( & ! FreeEOS real(dp), intent(inout), dimension(nv, species) :: d_dxa logical, intent(out) :: skip integer, intent(out) :: ierr - + real(dp) :: alfa, d_alfa_dlogT, d_alfa_dlogRho type (EoS_General_Info), pointer :: rq procedure (get_values_for_eosdt_interface), pointer :: get_1st, get_2nd include 'formats' - + ierr = 0 rq => eos_handles(handle) if (rq% use_FreeEOS) then - call Get_FreeEOS_alfa( & + call Get_FreeEOS_alfa( & rq, dbg, logRho, logT, Z, abar, zbar, & alfa, d_alfa_dlogT, d_alfa_dlogRho, & ierr) @@ -617,7 +617,7 @@ subroutine get_level4_for_eosdt( & ! FreeEOS if (dbg) write(*,1) 'FreeEOS', (1d0 - alfa)*remaining_fraction get_1st => get_FreeEOS_for_eosdt - + get_2nd => get_level5_for_eosdt call combine_for_eosdt( & get_1st, get_2nd, alfa*remaining_fraction, & @@ -631,10 +631,10 @@ subroutine get_level4_for_eosdt( & ! FreeEOS skip = .true. ierr = 0 end if - + end subroutine get_level4_for_eosdt - - + + subroutine get_level5_for_eosdt( & ! OPAL/SCVH handle, dbg, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & @@ -654,21 +654,21 @@ subroutine get_level5_for_eosdt( & ! OPAL/SCVH real(dp), intent(inout), dimension(nv, species) :: d_dxa logical, intent(out) :: skip integer, intent(out) :: ierr - + real(dp) :: alfa, d_alfa_dlogT, d_alfa_dlogRho, & logT_HELM, T_HELM, logQ, logQ2, T, logT type (EoS_General_Info), pointer :: rq procedure (get_values_for_eosdt_interface), pointer :: get_1st, get_2nd include 'formats' - + ierr = 0 rq => eos_handles(handle) - + T = T_in logT = logT_in - if (rq% use_OPAL_SCVH) then + if (rq% use_OPAL_SCVH) then call get_opal_scvh_alfa_and_partials( & rq, logT, logRho, Z, & alfa, d_alfa_dlogRho, d_alfa_dlogT, ierr) @@ -678,7 +678,7 @@ subroutine get_level5_for_eosdt( & ! OPAL/SCVH d_alfa_dlogT = 0d0 d_alfa_dlogRho = 0d0 end if - + if (dbg) write(*,1) 'OPAL/SCVH', (1d0 - alfa)*remaining_fraction get_1st => get_opal_scvh_for_eosdt @@ -695,9 +695,9 @@ subroutine get_level5_for_eosdt( & ! OPAL/SCVH skip = .true. ierr = 0 end if - + end subroutine get_level5_for_eosdt - + subroutine get_level6_for_eosdt( & ! HELM/ideal handle, dbg, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & @@ -717,22 +717,22 @@ subroutine get_level6_for_eosdt( & ! HELM/ideal real(dp), intent(inout), dimension(nv, species) :: d_dxa logical, intent(out) :: skip integer, intent(out) :: ierr - + real(dp) :: alfa, d_alfa_dlogT, d_alfa_dlogRho, & logT_HELM, T_HELM, logQ, logQ2, T, logT type (EoS_General_Info), pointer :: rq procedure (get_values_for_eosdt_interface), pointer :: get_1st, get_2nd include 'formats' - + ierr = 0 rq => eos_handles(handle) - + T = T_in logT = logT_in call get_HELM_alfa(rq, logRho, logT, alfa, d_alfa_dlogRho, d_alfa_dlogT, ierr) - + if (dbg) write(*,1) 'HELM', (1d0 - alfa)*remaining_fraction get_1st => get_helm_for_eosdt @@ -749,10 +749,10 @@ subroutine get_level6_for_eosdt( & ! HELM/ideal skip = .true. ierr = 0 end if - + end subroutine get_level6_for_eosdt - subroutine get_HELM_alfa( & + subroutine get_HELM_alfa( & rq, logRho, logT, alfa, d_alfa_dlogT, d_alfa_dlogRho, ierr) use const_def use eos_blend @@ -772,7 +772,7 @@ subroutine get_HELM_alfa( & type (Helm_Table), pointer :: ht ierr = 0 - ht => eos_ht + ht => eos_ht helm_blend_width = 0.1d0 bounds(1,1) = ht% logdlo @@ -977,7 +977,7 @@ subroutine Get_FreeEOS_alfa( & d_alfa_dlogT = -blend% d1val2 end subroutine Get_FreeEOS_alfa - + subroutine get_opal_scvh_for_eosdt( & handle, dbg, Z, X, abar, zbar, & @@ -1019,7 +1019,7 @@ subroutine get_opal_scvh_for_eosdt( & ! mark this one res(i_frac_OPAL_SCVH) = 1.0 - end subroutine get_opal_scvh_for_eosdt + end subroutine get_opal_scvh_for_eosdt subroutine get_FreeEOS_for_eosdt( & @@ -1061,7 +1061,7 @@ subroutine get_FreeEOS_for_eosdt( & ! mark this one res(i_frac_FreeEOS) = 1.0 - end subroutine get_FreeEOS_for_eosdt + end subroutine get_FreeEOS_for_eosdt subroutine get_opal_scvh_alfa_and_partials( & @@ -1070,7 +1070,7 @@ subroutine get_opal_scvh_alfa_and_partials( & real(dp), intent(in) :: logT, logRho, Z real(dp), intent(out) :: alfa, d_alfa_dlogRho, d_alfa_dlogT integer, intent(out) :: ierr - + integer :: iregion real(dp) :: logRho1_max, logRho1, logRho2, logRho5, logRho6, logRho7, & logRho8, logT5, logT6, logT3, logT4 @@ -1080,7 +1080,7 @@ subroutine get_opal_scvh_alfa_and_partials( & real(dp) :: logQ, A, B, dA_dlnT, dA_dlnRho, dB_dlnT, dB_dlnRho real(dp) :: c_dx, c_dy, d_dx_dlogT, d_dx_dlogRho, d_dy_dlogT, d_dy_dlogRho real(dp), parameter :: tiny = 1d-20 - + include 'formats' logRho1_max = 3.71d0 @@ -1090,7 +1090,7 @@ subroutine get_opal_scvh_alfa_and_partials( & logQmax = rq% logQ_max_OPAL_SCVH ! 5.3 logQ3 = rq% logQ_min_OPAL_SCVH ! -8.0 logQ4 = rq% logQ_min_OPAL_SCVH ! -8.0 - + logRho5 = rq% logRho_min_OPAL_SCVH_limit ! -14.299 logRho6 = logRho5 - 1d-3 ! -14.3 logRho7 = -14.90d0 @@ -1107,27 +1107,27 @@ subroutine get_opal_scvh_alfa_and_partials( & logT8 = rq% logT_low_all_HELM ! 2.2 logT7 = rq% logT_low_all_SCVH ! 2.3 - logT6 = 4.890d0 + logT6 = 4.890d0 logT5 = 4.899d0 ! problems with blend here so just jump logT2 = rq% logT_all_OPAL ! 7.6 logT1 = rq% logT_all_HELM ! 7.7 - + Z_all_HELM = rq% Z_all_HELM Z_no_HELM = rq% Z_all_OPAL - + if (logT >= logT1) then ! just use other alfa = 1d0 beta = 0d0 - + else - + logT3 = (logRho1 - logQ1 + 12d0)/2d0 logT4 = (logRho2 - logQ2 + 12d0)/2d0 logRho3 = logQ1 + 2*logT7 - 12d0 logRho4 = logQ2 + 2*logT7 - 12d0 - + if (.false.) then write(*,'(A)') write(*,1) 'logRho1', logRho1 @@ -1200,23 +1200,23 @@ subroutine get_opal_scvh_alfa_and_partials( & ierr = -1 return end if - + call determine_region_opal_scvh - + call set_alfa_and_partials if (ierr /= 0) return - + end if - + contains - - + + subroutine determine_region_opal_scvh logical, parameter :: dbg = .false. real(dp) :: logRho_hi, logRho_lo, d_logRho_dlogT, & d_alfa_dlogQ, dlogQ_dlogRho, dlogQ_dlogT, Z_all_HELM - + include 'formats' logQ = logRho - 2d0*logT + 12d0 @@ -1233,7 +1233,7 @@ subroutine determine_region_opal_scvh end if return end if - + ! blends in T/Rho if (logT >= logT1 .or. logT <= logT8 .or. logRho >= logRho1 .or. & @@ -1249,7 +1249,7 @@ subroutine determine_region_opal_scvh write(*,1) 'iregion = use_none 1 logT logT5 logT6', logT, logT5, logT6 end if iregion = use_none - + else if (logQ <= logQ3 .and. logT >= logT5) then ! blend in Q d_alfa_dlogQ = 1d0/(logQ4 - logQ3) alfa = (logQ - logQ3)*d_alfa_dlogQ @@ -1269,29 +1269,29 @@ subroutine determine_region_opal_scvh write(*,1) 'd_dy_dlogT', d_dy_dlogT end if iregion = blend_diagonal - - else if (logT >= logT2) then + + else if (logT >= logT2) then if (dbg) write(*,*) 'logT >= logT2', logT, logT2 if (logT1 - logT2 < 0.01d0) then d_dy_dlogT = 0d0 ! bad blend partials cause problems for 150M_z1m4_pre_ms_to_collapse ! have tried to fix, but failed. hence this awful workaround. else - d_dy_dlogT = 1/(logT1 - logT2) + d_dy_dlogT = 1/(logT1 - logT2) end if c_dy = (logT - logT2)*d_dy_dlogT if (logRho > logRho2) then if (dbg) write(*,*) 'logRho > logRho2', logRho, logRho2 d_dx_dlogRho = 1/(logRho1 - logRho2) - c_dx = (logRho - logRho2)*d_dx_dlogRho + c_dx = (logRho - logRho2)*d_dx_dlogRho if (dbg) write(*,*) 'iregion = blend_corner_out' iregion = blend_corner_out else ! logRho <= logRho2 if (dbg) write(*,*) 'logRho <= logRho2', logRho, logRho2 if (dbg) write(*,*) 'iregion = blend_in_y' iregion = blend_in_y - end if - + end if + else if (logT >= logT3) then ! NOTE: this assumes logT3 > logT4 if (dbg) write(*,*) 'logT >= logT3', logT, logT3 if (logRho > logRho2) then @@ -1304,9 +1304,9 @@ subroutine determine_region_opal_scvh if (dbg) write(*,*) 'logRho <= logRho2', logRho, logRho2 if (dbg) write(*,*) 'iregion = use_all' iregion = use_all - end if - - else if (logT >= logT4) then + end if + + else if (logT >= logT4) then if (dbg) write(*,*) 'logT >= logT4', logT, logT4 logRho_hi = logQ1 + 2*logT - 12 if (logRho >= logRho_hi) then @@ -1323,9 +1323,9 @@ subroutine determine_region_opal_scvh if (dbg) write(*,*) 'logRho <= logRho2', logRho, logRho2 if (dbg) write(*,*) 'iregion = use_all' iregion = use_all - end if - - else if (logRho > logRho4) then + end if + + else if (logRho > logRho4) then if (dbg) write(*,*) 'logRho > logRho4', logRho, logRho4 if (logT > logT7) then A = ((logQ1+2*logT4-12) - logRho3)/(logT4-logT7) @@ -1341,13 +1341,13 @@ subroutine determine_region_opal_scvh c_dx = (logRho - logRho_lo)/(logRho_hi - logRho_lo) d_dx_dlogRho = 1/(logRho3 - logRho4 + (A - B)*(logT - logT7)) if (dbg) write(*,*) 'iregion = blend_in_x' - iregion = blend_in_x + iregion = blend_in_x else ! logRho < logRho_lo if (dbg) write(*,*) 'logRho < logRho_lo', logRho, logRho_lo if (dbg) write(*,*) 'iregion = use_all' - iregion = use_all - end if - else ! logT is > logT8 + iregion = use_all + end if + else ! logT is > logT8 if (dbg) write(*,*) 'logT > logT8', logT, logT8 if (logRho > logRho3) then if (dbg) write(*,*) 'logRho > logRho3', logRho, logRho3 @@ -1361,13 +1361,13 @@ subroutine determine_region_opal_scvh c_dy = (logT - logT7)*d_dy_dlogT if (dbg) write(*,*) 'iregion = blend_corner_out' iregion = blend_corner_out - end if + end if end if - + else if (logRho >= logRho5 .or. logT > logT5) then if (dbg) write(*,*) 'iregion = use_all' iregion = use_all - + else if (logT >= logT6) then if (logRho <= logRho6) then d_dy_dlogT = 1/(logT6 - logT5) @@ -1382,8 +1382,8 @@ subroutine determine_region_opal_scvh if (dbg) write(*,*) 'iregion = blend_corner_in' iregion = blend_corner_in end if - - else + + else if (dbg) write(*,*) 'logRho > logRho6', logRho, logRho6 d_dx_dlogRho = 1/(logRho6 - logRho5) c_dx = (logRho - logRho5)*d_dx_dlogRho @@ -1392,20 +1392,20 @@ subroutine determine_region_opal_scvh end if if (dbg) call mesa_error(__FILE__,__LINE__,'determine_region') - + end subroutine determine_region_opal_scvh subroutine set_alfa_and_partials ! alfa = fraction other logical, parameter :: dbg = .false. - + real(dp) :: zfactor - + include 'formats' - + d_alfa_dlogT = 0d0 d_alfa_dlogRho = 0 - + if (iregion == use_none .or. Z >= Z_all_HELM) then if (dbg) write(*,*) 'iregion == use_none' alfa = 1 @@ -1433,8 +1433,8 @@ subroutine set_alfa_and_partials ! alfa = fraction other else if (alfa < 1d-10) then alfa = 0 else - d_alfa_dlogT = c_dy*d_dy_dlogT/alfa - d_alfa_dlogRho = c_dx*d_dx_dlogRho/alfa + d_alfa_dlogT = c_dy*d_dy_dlogT/alfa + d_alfa_dlogRho = c_dx*d_dx_dlogRho/alfa end if else if (iregion == blend_corner_in) then if (dbg) write(*,*) 'iregion == blend_corner_in' @@ -1445,8 +1445,8 @@ subroutine set_alfa_and_partials ! alfa = fraction other else if (alfa < 1d-10) then alfa = 0 else - d_alfa_dlogT = -c_dy*d_dy_dlogT/beta - d_alfa_dlogRho = -c_dx*d_dx_dlogRho/beta + d_alfa_dlogT = -c_dy*d_dy_dlogT/beta + d_alfa_dlogRho = -c_dx*d_dx_dlogRho/beta end if else ierr = -1 @@ -1460,13 +1460,13 @@ subroutine set_alfa_and_partials ! alfa = fraction other d_alfa_dlogRho = d_alfa_dlogRho*zfactor d_alfa_dlogT = d_alfa_dlogT*zfactor end if - + end subroutine set_alfa_and_partials end subroutine get_opal_scvh_alfa_and_partials - - + + subroutine combine_for_eosdt( & get_1st, get_2nd, remaining_fraction, & alfa_in, d_alfa_dlogT_in, d_alfa_dlogRho_in, & @@ -1489,19 +1489,19 @@ subroutine combine_for_eosdt( & real(dp), intent(inout), dimension(nv, species) :: d_dxa logical, intent(out) :: skip integer, intent(out) :: ierr - + real(dp), dimension(nv) :: & res_1, d_dlnd_1, d_dlnT_1, res_2, d_dlnd_2, d_dlnT_2 real(dp), dimension(:,:), allocatable :: d_dxa_1, d_dxa_2 real(dp) :: alfa, d_alfa_dlogT, d_alfa_dlogRho logical :: skip_1st, skip_2nd logical, parameter :: linear_blend = .false. - + include 'formats' - + ierr = 0 skip = .false. - + allocate(d_dxa_1(nv, species), d_dxa_2(nv, species)) alfa = alfa_in @@ -1526,7 +1526,7 @@ subroutine combine_for_eosdt( & return end if end if - + if (alfa < 1d0) then ! some of 1st call get_1st(rq% handle, dbg, & Z, X, abar, zbar, & @@ -1541,9 +1541,9 @@ subroutine combine_for_eosdt( & end if if (skip_1st) then ! switch to pure 2nd alfa = 1d0; d_alfa_dlogT = 0d0; d_alfa_dlogRho = 0d0 - end if + end if end if - + if (alfa == 1d0) then ! no 1st call get_2nd(rq% handle, dbg, & Z, X, abar, zbar, & @@ -1559,9 +1559,9 @@ subroutine combine_for_eosdt( & if (skip_2nd) skip = .true. return end if - + ! blend 1st and 2nd - + call get_2nd( & rq% handle, dbg, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & @@ -1583,7 +1583,7 @@ subroutine combine_for_eosdt( & res_1, d_dlnd_1, d_dlnT_1, d_dxa_1, & res_2, d_dlnd_2, d_dlnT_2, d_dxa_2, & res, d_dlnd, d_dlnT, d_dxa) - + end subroutine combine_for_eosdt @@ -1650,27 +1650,27 @@ subroutine Get1_eosdt_Results( & ! blend in Z real(dp) :: denom, c(2), dcdZ(2), tiny integer :: iz, j, ci - + include 'formats' ierr = 0 tiny = rq% tiny_fuzz - + if (xz% nZs < 3) then write(*, *) 'error: Get1_eosdt_Results assumes nZs >= 3' call mesa_error(__FILE__,__LINE__) end if - + if (xz% Zs(1) /= 0) then write(*, *) 'error: Get1_eosdt_Results assumes eos_Zs(1) == 0' call mesa_error(__FILE__,__LINE__) end if - + if (abs(xz% Zs(1) - 2*xz% Zs(2) + xz% Zs(3)) > tiny) then write(*, *) 'error: Get1_eosdt_Results assumes equal spaced Zs(1:3)' call mesa_error(__FILE__,__LINE__) end if - + if (Z <= max(1d-20,xz% Zs(1))) then call Get1_eosdt_for_X( & rq, which_eosdt, xz, 1, X, & @@ -1688,8 +1688,8 @@ subroutine Get1_eosdt_Results( & ! blend in Z dlnd_zx(i_frac:i_frac+num_eos_frac_results-1,:) = 0d0 dlnT_zx(i_phase:i_latent_ddlnRho,:) = 0d0 - dlnT_zx(i_frac:i_frac+num_eos_frac_results-1,:) = 0d0 - + dlnT_zx(i_frac:i_frac+num_eos_frac_results-1,:) = 0d0 + if (Z >= xz% Zs(xz% nZs)) then call Get1_eosdt_for_X( & rq, which_eosdt, xz, xz% nZs, X, & @@ -1706,14 +1706,14 @@ subroutine Get1_eosdt_Results( & ! blend in Z exit end if end do - + do j=1,nv - + res(j) = c(1)*res_zx(j,1) + c(2)*res_zx(j,2) - + dlnd(j) = & c(1)*dlnd_zx(j,1) + c(2)*dlnd_zx(j,2) - + dlnT(j) = & c(1)*dlnT_zx(j,1) + c(2)*dlnT_zx(j,2) @@ -1724,9 +1724,9 @@ subroutine Get1_eosdt_Results( & ! blend in Z dcdZ(1)*res_zx(j,1) + dcdZ(2)*res_zx(j,2) end do - + contains - + subroutine do_interp2(iz1, iz2, ierr) integer, intent(in) :: iz1, iz2 integer, intent(out) :: ierr @@ -1750,10 +1750,10 @@ subroutine do_interp2(iz1, iz2, ierr) ierr) if (ierr /= 0) return end subroutine do_interp2 - + end subroutine Get1_eosdt_Results - + subroutine Get1_eosdt_for_X( & rq, which_eosdt, xz, iz, X, Rho, logRho, T, logT, & res, dlnd, dlnT, d_dX, ierr) @@ -1773,19 +1773,19 @@ subroutine Get1_eosdt_for_X( & integer :: ix, ix_lo, ix_hi, j, num_Xs logical, parameter :: dbg_for_X = dbg ! .or. .true. logical :: what_we_use_is_equal_spaced - + include 'formats' - + ierr = 0 tiny = rq% tiny_fuzz - + num_Xs = xz% nXs_for_Z(iz) - + if (xz% Xs_for_Z(1,iz) /= 0d0) then write(*, *) 'error: Get1_eosdt_for_X assumes xz% nXs_for_Z(1) == 0' call mesa_error(__FILE__,__LINE__) end if - + if (X < tiny .or. num_Xs == 1) then call Get1_eosdt_XTable_Results( & rq, which_eosdt, 1, iz, Rho, logRho, T, logT, & @@ -1793,7 +1793,7 @@ subroutine Get1_eosdt_for_X( & d_dX = 0 return end if - + if (X >= xz% Xs_for_Z(num_Xs,iz)) then call Get1_eosdt_XTable_Results( & @@ -1807,7 +1807,7 @@ subroutine Get1_eosdt_for_X( & write(*,1) 'res(i_lnS), logRho, logT', res(i_lnS), logRho, logT call mesa_error(__FILE__,__LINE__,'Get1_eosdt_for_X num_Xs') end if - + return end if @@ -1815,7 +1815,7 @@ subroutine Get1_eosdt_for_X( & call do_linear return end if - + ix_hi = -1 if (X <= xz% Xs_for_Z(2,iz)) then ix_lo = 1; ix_hi = 3 @@ -1828,7 +1828,7 @@ subroutine Get1_eosdt_for_X( & end if end do end if - + if (ix_hi < 0) then write(*, *) 'X', X write(*, *) 'ix_lo', ix_lo @@ -1836,7 +1836,7 @@ subroutine Get1_eosdt_for_X( & write(*, *) 'error: Get1_eosdt_for_X logic bug' call mesa_error(__FILE__,__LINE__) end if - + if (dbg_for_X) then write(*, *) 'X', X write(*, *) 'ix_lo', ix_lo @@ -1848,12 +1848,12 @@ subroutine Get1_eosdt_for_X( & dX2 = xz% Xs_for_Z(ix_lo+2,iz)-xz% Xs_for_Z(ix_lo+1,iz) if (ix_hi-ix_lo==2) then ! check that the 3 table X's are equal spaced if (abs(dX1 - dX2) > tiny) what_we_use_is_equal_spaced = .false. - else ! check that the 4 table X's are equal spaced + else ! check that the 4 table X's are equal spaced dX3 = xz% Xs_for_Z(ix_hi,iz)-xz% Xs_for_Z(ix_lo+2,iz) if (abs(dX1 - dX2) > tiny .or. abs(dX2 - dX3) > tiny) & what_we_use_is_equal_spaced = .false. end if - + if (.not. what_we_use_is_equal_spaced) then call do_linear if (is_bad(d_dX(1))) then @@ -1861,7 +1861,7 @@ subroutine Get1_eosdt_for_X( & end if return end if - + do ix=ix_lo, ix_hi j = ix-ix_lo+1 call Get1_eosdt_XTable_Results( & @@ -1881,18 +1881,18 @@ subroutine Get1_eosdt_for_X( & dlnT_zx(i_phase:i_latent_ddlnRho,:) = 0d0 dlnT_zx(i_frac:i_frac+num_eos_frac_results-1,:) = 0d0 - + delX = X - xz% Xs_for_Z(ix_lo,iz) dX = dX1 - + if (ix_hi-ix_lo==2) then - + denom = 2*dX*dX c(1) = (2*dX*dX - 3*dX*delX + delX*delX)/denom c(2) = 2*(2*dX-delX)*delX/denom c(3) = delX*(delX-dX)/denom res(:) = c(1)*res_zx(:, 1) + c(2)*res_zx(:, 2) + c(3)*res_zx(:, 3) - + dlnd(:) = & c(1)*dlnd_zx(:,1) + & c(2)*dlnd_zx(:,2) + & @@ -1914,10 +1914,10 @@ subroutine Get1_eosdt_for_X( & if (is_bad(d_dX(1))) then call mesa_error(__FILE__,__LINE__,'Get1_eosdt_for_X bad d_dX; 3') end if - + else - - coef = (X-xz% Xs_for_Z(ix_lo+1,iz))/dX + + coef = (X-xz% Xs_for_Z(ix_lo+1,iz))/dX ! coef = fractional location of X between 2nd and 3rd X's for fit. ! coef is weight for the quadratic based on points 2, 3, 4 of fit. ! (1-coef) is weight for quadratic based on points 1, 2, 3 of fit. @@ -1930,7 +1930,7 @@ subroutine Get1_eosdt_for_X( & (c(2)*res_zx(:, 2) + & (c(3)*res_zx(:, 3) + & c(4)*res_zx(:, 4))) - + dlnd(:) = & c(1)*dlnd_zx(:, 1) + & (c(2)*dlnd_zx(:, 2) + & @@ -1960,15 +1960,15 @@ subroutine Get1_eosdt_for_X( & end if end if - + contains - + subroutine do_linear - + do ix = 2, num_Xs if (xz% Xs_for_Z(ix,iz) >= X) exit end do - + j = 1 call Get1_eosdt_XTable_Results( & rq, which_eosdt, ix-1, iz, Rho, logRho, T, logT, & @@ -1978,7 +1978,7 @@ subroutine do_linear if (.not. stop_for_is_bad) return call mesa_error(__FILE__,__LINE__,'Get1_eosdt_for_X') end if - + j = 2 call Get1_eosdt_XTable_Results( & rq, which_eosdt, ix, iz, Rho, logRho, T, logT, & @@ -1999,20 +1999,20 @@ subroutine do_linear dlnT_zx(i_phase:i_latent_ddlnRho,:) = 0d0 dlnT_zx(i_frac:i_frac+num_eos_frac_results-1,:) = 0d0 - + alfa = (X - xz% Xs_for_Z(ix,iz))/(xz% Xs_for_Z(ix-1,iz) - xz% Xs_for_Z(ix,iz)) beta = 1d0 - alfa dalfa_dX = 1d0 / (xz% Xs_for_Z(ix-1,iz) - xz% Xs_for_Z(ix,iz)) dbeta_dX = -dalfa_dX - + do j=1,nv - + res(j) = alfa*res_zx(j,1) + beta*res_zx(j,2) - + dlnd(j) = & alfa*dlnd_zx(j,1) + beta*dlnd_zx(j,2) - + dlnT(j) = & alfa*dlnT_zx(j,1) + beta*dlnT_zx(j,2) @@ -2020,22 +2020,22 @@ subroutine do_linear dalfa_dX*res_zx(j,1) + dbeta_dX*res_zx(j,2) end do - + end subroutine do_linear - + end subroutine Get1_eosdt_for_X - + subroutine Locate_logQ(rq, ep, logQ, iQ, logQ0, logQ1, ierr) type (EoS_General_Info), pointer :: rq type (EosDT_xz_Info), pointer :: ep real(dp), intent(inout) :: logQ integer, intent(out) :: iQ real(dp), intent(out) :: logQ0, logQ1 - integer, intent(out) :: ierr + integer, intent(out) :: ierr ierr = 0 - iQ = int((logQ - ep% logQ_min)/ep% del_logQ + 1d-4) + 1 - if (iQ < 1 .or. iQ >= ep% num_logQs) then + iQ = int((logQ - ep% logQ_min)/ep% del_logQ + 1d-4) + 1 + if (iQ < 1 .or. iQ >= ep% num_logQs) then if (iQ < 1) then iQ = 1 logQ0 = ep% logQ_min @@ -2048,24 +2048,24 @@ subroutine Locate_logQ(rq, ep, logQ, iQ, logQ0, logQ1, ierr) logQ1 = logQ0 + ep% del_logQ logQ = logQ1 if (return_ierr_beyond_table_bounds) ierr = -1 - end if - else + end if + else logQ0 = ep% logQ_min + (iQ-1)*ep% del_logQ logQ1 = logQ0 + ep% del_logQ end if end subroutine Locate_logQ - - + + subroutine Locate_logT(rq, ep, logT, iT, logT0, logT1, ierr) type (EoS_General_Info), pointer :: rq type (EosDT_xz_Info), pointer :: ep real(dp), intent(inout) :: logT integer, intent(out) :: iT real(dp), intent(out) :: logT0, logT1 - integer, intent(out) :: ierr + integer, intent(out) :: ierr ierr = 0 - iT = int((logT - ep% logT_min)/ep% del_logT + 1d-4) + 1 - if (iT < 1 .or. iT >= ep% num_logTs) then + iT = int((logT - ep% logT_min)/ep% del_logT + 1d-4) + 1 + if (iT < 1 .or. iT >= ep% num_logTs) then if (iT < 1) then iT = 1 logT0 = ep% logT_min @@ -2078,14 +2078,14 @@ subroutine Locate_logT(rq, ep, logT, iT, logT0, logT1, ierr) logT1 = logT0 + ep% del_logT logT = logT1 if (return_ierr_beyond_table_bounds) ierr = -1 - end if - else + end if + else logT0 = ep% logT_min + (iT-1)*ep% del_logT logT1 = logT0 + ep% del_logT end if end subroutine Locate_logT - - + + subroutine Get1_eosdt_XTable_Results( & rq, which_eosdt, ix, iz, Rho, logRho_in, T, logT_in, & res, d_dlnd, d_dlnT, ierr) @@ -2096,7 +2096,7 @@ subroutine Get1_eosdt_XTable_Results( & real(dp), intent(in) :: Rho, logRho_in, T, logT_in real(dp), intent(inout), dimension(nv) :: res, d_dlnd, d_dlnT integer, intent(out) :: ierr - + real(dp), parameter :: ln10sq = ln10*ln10 real(dp) :: & fval(nv), df_dx(nv), df_dy(nv), & @@ -2111,14 +2111,14 @@ subroutine Get1_eosdt_XTable_Results( & type (EosDT_xz_Info), pointer :: ep logical, parameter :: show = .false. real(dp) :: logRho, logT, logQ - + include 'formats' logRho = logRho_in logT = logT_in logQ = logRho - 2*logT + 12 - ierr = 0 + ierr = 0 call load_single_eosDT_table_by_id(rq, which_eosdt, ep, ix, iz, ierr) if (ierr /= 0) return @@ -2127,58 +2127,58 @@ subroutine Get1_eosdt_XTable_Results( & write(*,1) 'eosDT failed in Locate_logQ', logQ return end if - + call Locate_logT(rq, ep, logT, jtemp, logT0, logT1, ierr) if (ierr /= 0) then write(*,1) 'eosDT failed in Locate_logT', logT return end if - + call Do_EoS_Interpolations( & 1, nv, nv, ep% num_logQs, ep% logQs, ep% num_logTs, ep% logTs, & ep% tbl1, iQ, jtemp, logQ0, logQ, logQ1, logT0, logT, logT1, & - fval, df_dx, df_dy, ierr) + fval, df_dx, df_dy, ierr) if (ierr /= 0) then write(*,1) 'failed in Do_EoS_Interpolations' return end if - + if (is_bad(fval(i_lnS))) then ierr = -1 if (.not. stop_for_is_bad) return write(*,1) 'fval(i_lnS), logRho, logT', fval(i_lnS), logRho, logT call mesa_error(__FILE__,__LINE__,'after Do_Interp_with_2nd_derivs') end if - + res(i_lnPgas) = fval(i_lnPgas) res(i_lnE) = fval(i_lnE) res(i_lnS) = fval(i_lnS) - + if (is_bad(res(i_lnS))) then ierr = -1 if (.not. stop_for_is_bad) return write(*,1) 'res(i_lnS), logRho, logT', res(i_lnS), logRho, logT call mesa_error(__FILE__,__LINE__,'after interpolation') end if - + if (is_bad(res(i_lnS)) .or. res(i_lnS) > ln10*100) then ierr = -1 if (.not. stop_for_is_bad) return write(*,1) 'res(i_lnS), logRho, logT', res(i_lnS), logRho, logT call mesa_error(__FILE__,__LINE__,'after interpolation') end if - + res(i_grad_ad) = fval(i_grad_ad) res(i_chiRho) = fval(i_chiRho) res(i_chiT) = fval(i_chiT) - + res(i_Cp) = fval(i_Cp) res(i_Cv) = fval(i_Cv) - + res(i_dE_dRho) = fval(i_dE_dRho) res(i_dS_dT) = fval(i_dS_dT) res(i_dS_dRho) = fval(i_dS_dRho) - + res(i_mu) = fval(i_mu) res(i_lnfree_e) = fval(i_lnfree_e) res(i_gamma1) = fval(i_gamma1) @@ -2186,15 +2186,15 @@ subroutine Get1_eosdt_XTable_Results( & res(i_eta) = fval(i_eta) ! convert df_dx and df_dy to df_dlogRho_c_T and df_dlogT_c_Rho - + ! df_dx is df_dlogQ at const T ! df_dy is df_dlogT_c_Rho at const Q ! logQ = logRho - 2*logT + 12 - + ! f = f(logQ(logRho,logT),logT) ! df/dlogRho|T = df/dlogQ|T * dlogQ/dlogRho|T = df_dx ! df/dlogT|Rho = df/dlogT|Q + df/dlogQ|T * dlogQ/dlogT|Rho = df_dy - 2*df_dx - + do k=1,nv df_dlnd(k) = df_dx(k)/ln10 df_dlnT(k) = df_dy(k)/ln10 - 2d0*df_dlnd(k) @@ -2206,7 +2206,7 @@ subroutine Get1_eosdt_XTable_Results( & d_dlnd(i_grad_ad) = df_dlnd(i_grad_ad) d_dlnd(i_chiRho) = df_dlnd(i_chiRho) d_dlnd(i_chiT) = df_dlnd(i_chiT) - + d_dlnd(i_Cp) = df_dlnd(i_Cp) d_dlnd(i_Cv) = df_dlnd(i_Cv) d_dlnd(i_dE_dRho) = df_dlnd(i_dE_dRho) @@ -2217,7 +2217,7 @@ subroutine Get1_eosdt_XTable_Results( & d_dlnd(i_gamma1) = df_dlnd(i_gamma1) d_dlnd(i_gamma3) = df_dlnd(i_gamma3) d_dlnd(i_eta) = df_dlnd(i_eta) - + d_dlnT(i_lnPgas) = df_dlnT(i_lnPgas) d_dlnT(i_lnE) = df_dlnT(i_lnE) d_dlnT(i_lnS) = df_dlnT(i_lnS) @@ -2234,7 +2234,7 @@ subroutine Get1_eosdt_XTable_Results( & d_dlnT(i_gamma1) = df_dlnT(i_gamma1) d_dlnT(i_gamma3) = df_dlnT(i_gamma3) d_dlnT(i_eta) = df_dlnT(i_eta) - + if (is_bad(d_dlnd(i_lnS)) .or. is_bad(d_dlnT(i_lnS))) then ierr = -1 if (.not. stop_for_is_bad) return @@ -2255,33 +2255,33 @@ subroutine get_T( & logT_bnd1, logT_bnd2, other_at_bnd1, other_at_bnd2, & logT_result, res, d_dlnRho_c_T, d_dlnT_c_Rho, d_dxa_c_TRho, & eos_calls, ierr) - + integer, intent(in) :: handle real(dp), intent(in) :: Z ! the metals mass fraction real(dp), intent(in) :: X ! the hydrogen mass fraction - + real(dp), intent(in) :: abar, zbar - + integer, intent(in) :: species - integer, pointer :: chem_id(:) + integer, pointer :: chem_id(:) integer, pointer :: net_iso(:) real(dp), intent(in) :: xa(:) - + real(dp), intent(in) :: logRho ! log10 of density integer, intent(in) :: which_other ! from eos_def. e.g., i_P for pressure real(dp), intent(in) :: other_value ! desired value for the other variable real(dp), intent(in) :: other_tol - + real(dp), intent(in) :: logT_tol - integer, intent(in) :: max_iter ! max number of iterations + integer, intent(in) :: max_iter ! max number of iterations real(dp), intent(in) :: logT_guess real(dp), intent(in) :: logT_bnd1, logT_bnd2 ! bounds for logT ! set to arg_not_provided if do not know bounds real(dp), intent(in) :: other_at_bnd1, other_at_bnd2 ! values at bounds ! if don't know these values, just set to arg_not_provided (defined in c_def) - + real(dp), intent(out) :: logT_result real(dp), intent(inout), dimension(nv) :: res, d_dlnRho_c_T, d_dlnT_c_Rho real(dp), intent(inout), dimension(:,:) :: d_dxa_c_TRho @@ -2290,7 +2290,7 @@ subroutine get_T( & integer, intent(out) :: ierr ! 0 means AOK. logical, parameter :: doing_Rho = .false. - + call do_safe_get_Rho_T( & handle, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & @@ -2298,9 +2298,9 @@ subroutine get_T( & logT_guess, logT_result, logT_bnd1, logT_bnd2, other_at_bnd1, other_at_bnd2, & logT_tol, other_tol, max_iter, res, d_dlnRho_c_T, d_dlnT_c_Rho, d_dxa_c_TRho, & eos_calls, ierr) - + end subroutine get_T - + subroutine get_Rho( & handle, Z, X, abar, zbar, & @@ -2310,37 +2310,37 @@ subroutine get_Rho( & logRho_bnd1, logRho_bnd2, other_at_bnd1, other_at_bnd2, & logRho_result, res, d_dlnRho_c_T, d_dlnT_c_Rho, d_dxa_c_TRho, & eos_calls, ierr) - + use const_def - + integer, intent(in) :: handle real(dp), intent(in) :: Z ! the metals mass fraction real(dp), intent(in) :: X ! the hydrogen mass fraction - + real(dp), intent(in) :: abar, zbar - + integer, intent(in) :: species - integer, pointer :: chem_id(:) + integer, pointer :: chem_id(:) integer, pointer :: net_iso(:) real(dp), intent(in) :: xa(:) - + real(dp), intent(in) :: logT ! log10 of temperature integer, intent(in) :: which_other ! from eos_def. real(dp), intent(in) :: other_value ! desired value for the other variable real(dp), intent(in) :: other_tol - + real(dp), intent(in) :: logRho_tol - integer, intent(in) :: max_iter ! max number of Newton iterations + integer, intent(in) :: max_iter ! max number of Newton iterations real(dp), intent(in) :: logRho_guess real(dp), intent(in) :: logRho_bnd1, logRho_bnd2 ! bounds for logrho ! set to arg_not_provided if do not know bounds real(dp), intent(in) :: other_at_bnd1, other_at_bnd2 ! values at bounds ! if don't know these values, just set to arg_not_provided (defined in c_def) - + real(dp), intent(out) :: logRho_result real(dp), intent(inout), dimension(nv) :: res, d_dlnRho_c_T, d_dlnT_c_Rho real(dp), intent(inout), dimension(:,:) :: d_dxa_c_TRho @@ -2350,7 +2350,7 @@ subroutine get_Rho( & logical, parameter :: doing_Rho = .true. real(dp) :: Prad - + call do_safe_get_Rho_T( & handle, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & @@ -2360,7 +2360,7 @@ subroutine get_Rho( & eos_calls, ierr) end subroutine get_Rho - + subroutine do_safe_get_Rho_T( & handle, Z, XH1, abar, zbar, & @@ -2376,7 +2376,7 @@ subroutine do_safe_get_Rho_T( & integer, intent(in) :: handle real(dp), intent(in) :: Z, XH1, abar, zbar integer, intent(in) :: species - integer, pointer :: chem_id(:) + integer, pointer :: chem_id(:) integer, pointer :: net_iso(:) real(dp), intent(in) :: xa(:) integer, intent(in) :: which_other ! 0 means total P @@ -2387,11 +2387,11 @@ subroutine do_safe_get_Rho_T( & real(dp), intent(in) :: the_other_log real(dp), intent(in) :: xbnd1, xbnd2, other_at_bnd1, other_at_bnd2 real(dp), intent(in) :: xacc, yacc ! tolerances - integer, intent(in) :: ntry ! max number of iterations + integer, intent(in) :: ntry ! max number of iterations real(dp), intent(inout), dimension(nv) :: res, d_dlnRho_c_T, d_dlnT_c_Rho real(dp), dimension(:,:) :: d_dxa_c_TRho integer, intent(out) :: eos_calls, ierr - + integer :: i, j, ix, iz integer, parameter :: lrpar = 0, lipar = 0, newt_imax = 6 real(dp), parameter :: dx = 0.1d0 @@ -2401,9 +2401,9 @@ subroutine do_safe_get_Rho_T( & type (EoS_General_Info), pointer :: rq include 'formats' - + ierr = 0 - + call get_eos_ptr(handle, rq, ierr) if (ierr /= 0) then write(*, *) 'get_eos_ptr returned ierr', ierr @@ -2414,7 +2414,7 @@ subroutine do_safe_get_Rho_T( & x3 = arg_not_provided y1 = arg_not_provided y3 = arg_not_provided - + eos_calls = 0 the_other_val = exp10(the_other_log) nullify(ipar, rpar) @@ -2423,9 +2423,9 @@ subroutine do_safe_get_Rho_T( & f, initial_guess, dx, x1, x3, y1, y3, & min(ntry,newt_imax), ntry, xacc, yacc, & lrpar, rpar, lipar, ipar, ierr) - + contains - + real(dp) function f(x, dfdx, lrpar, rpar, lipar, ipar, ierr) ! returns with ierr = 0 if was able to evaluate f and df/dx at x ! if df/dx not available, it is okay to set it to 0 @@ -2436,20 +2436,20 @@ real(dp) function f(x, dfdx, lrpar, rpar, lipar, ipar, ierr) integer, intent(inout), pointer :: ipar(:) ! (lipar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(out) :: ierr - + real(dp) :: Pgas, Prad, energy, entropy, dPgas_dlnT, dPrad_dlnT, & dPgas_dlnRho, erad, egas, derad_dlnT, degas_dlnT, derad_dlnRho - + include 'formats' ierr = 0 eos_calls = eos_calls + 1 f = 0; dfdx = 0 - + if (x > 50d0) then ierr = -1 return end if - + if (doing_Rho) then logRho = x rho = exp10(logRho) @@ -2461,7 +2461,7 @@ real(dp) function f(x, dfdx, lrpar, rpar, lipar, ipar, ierr) logRho = the_other_log rho = the_other_val end if - + call Get_eosDT_Results(rq, Z, XH1, abar, zbar, & species, chem_id, net_iso, xa, & rho, logRho, T, logT, & @@ -2488,7 +2488,7 @@ real(dp) function f(x, dfdx, lrpar, rpar, lipar, ipar, ierr) end if return end if - + if (is_bad(res(i_Cv))) then ierr = -1 if (.not. stop_for_is_bad) return @@ -2504,12 +2504,12 @@ real(dp) function f(x, dfdx, lrpar, rpar, lipar, ipar, ierr) write(*,'(A)') call mesa_error(__FILE__,__LINE__,'do_safe_get_Rho_T') end if - + if (which_other == -1) then ! other_value is egas erad = crad*pow4(T)/rho egas = energy - erad f = egas - other_value - if (doing_Rho) then + if (doing_Rho) then derad_dlnRho = -erad dfdx = energy*d_dlnRho_c_T(i_lnE)*ln10 - derad_dlnRho else @@ -2519,7 +2519,7 @@ real(dp) function f(x, dfdx, lrpar, rpar, lipar, ipar, ierr) end if else if (which_other == 0) then ! other_value is log10P f = log10(Pgas + Prad) - other_value - if (doing_Rho) then + if (doing_Rho) then dPgas_dlnRho = Pgas*d_dlnRho_c_T(i_lnPgas) dfdx = dPgas_dlnRho/(Pgas + Prad)*ln10 else @@ -2535,9 +2535,9 @@ real(dp) function f(x, dfdx, lrpar, rpar, lipar, ipar, ierr) dfdx = d_dlnT_c_Rho(which_other)*ln10 end if end if - + end function f - + end subroutine do_safe_get_Rho_T diff --git a/eos/private/eosdt_load_tables.f90 b/eos/private/eosdt_load_tables.f90 index 170344cf8..7f1e73d13 100644 --- a/eos/private/eosdt_load_tables.f90 +++ b/eos/private/eosdt_load_tables.f90 @@ -31,7 +31,7 @@ module eosDT_load_tables use math_lib implicit none - + ! the file EOS data integer, parameter :: jlogPgas = 1 integer, parameter :: jlogE = 2 @@ -53,11 +53,11 @@ module eosDT_load_tables integer, parameter :: file_max_num_logQs = 1000 - + contains - - + + subroutine request_user_to_reinstall write(*,'(A)') write(*,'(A)') @@ -72,8 +72,8 @@ subroutine request_user_to_reinstall write(*,'(A)') call mesa_error(__FILE__,__LINE__) end subroutine request_user_to_reinstall - - + + subroutine check_for_error_in_eosDT_data(ierr, fname) integer, intent(in) :: ierr character (len=*) :: fname @@ -92,7 +92,7 @@ subroutine check_for_error_in_eosDT_data(ierr, fname) call mesa_error(__FILE__,__LINE__) end subroutine check_for_error_in_eosDT_data - + subroutine load_single_eosDT_table_by_id( & rq, which_eosdt, ep, ix, iz, ierr) use utils_lib @@ -101,7 +101,7 @@ subroutine load_single_eosDT_table_by_id( & type (EosDT_XZ_Info), pointer :: ep integer,intent(in) :: iz, ix integer, intent(out) :: ierr - + if (which_eosdt == eosdt_max_FreeEOS) then ep => FreeEOS_XZ_data(ix,iz) if (FreeEOS_XZ_loaded(ix,iz)) return @@ -112,7 +112,7 @@ subroutine load_single_eosDT_table_by_id( & ierr = -1 return end if - + !$OMP CRITICAL(eosDT_load) if (which_eosdt == eosdt_max_FreeEOS) then if (.not. FreeEOS_XZ_loaded(ix,iz)) call do_read @@ -120,9 +120,9 @@ subroutine load_single_eosDT_table_by_id( & if (.not. eosDT_XZ_loaded(ix,iz)) call do_read end if !$OMP END CRITICAL(eosDT_load) - + contains - + subroutine do_read call read_one(ix,iz,ierr) if (ierr /= 0) return @@ -132,18 +132,18 @@ subroutine do_read eosDT_XZ_loaded(ix,iz) = .true. end if end subroutine do_read - + subroutine read_one(ix,iz,ierr) use const_def, only: mesa_data_dir integer, intent(in) :: ix, iz integer, intent(out) :: ierr character (len=256) :: fname, cache_filename, temp_cache_filename - integer :: iounit1, iounit2 - real(dp) :: X, Z + integer :: iounit1, iounit2 + real(dp) :: X, Z type (DT_xz_Info), pointer :: xz include 'formats' iounit1 = alloc_iounit(ierr); if (ierr /= 0) return - iounit2 = alloc_iounit(ierr); if (ierr /= 0) return + iounit2 = alloc_iounit(ierr); if (ierr /= 0) return if (which_eosdt == eosdt_max_FreeEOS) then xz => FreeEOS_xz_struct else @@ -159,10 +159,10 @@ subroutine read_one(ix,iz,ierr) call free_iounit(iounit2) call free_iounit(iounit1) end subroutine read_one - + end subroutine load_single_eosDT_table_by_id - - + + subroutine Get_eosDT_Table_Filenames(rq, which_eosdt, xz, & ix, iz, data_dir, fname, cache_filename, temp_cache_filename) type (EoS_General_Info), pointer :: rq @@ -173,13 +173,13 @@ subroutine Get_eosDT_Table_Filenames(rq, which_eosdt, xz, & character (len=*), intent(out) :: fname, cache_filename, temp_cache_filename character (len=256) :: Zstr, Xstr, suffix, data_dir_name, data_prefix real(dp) :: X, Z - + Z = xz% Zs(iz) X = xz% Xs_for_Z(ix,iz) - + call setstr(Z,Zstr) call setstr(X,Xstr) - suffix = '' + suffix = '' if (which_eosdt == eosdt_max_FreeEOS) then data_dir_name = '/eosFreeEOS_data/' data_prefix = '-FreeEOS_' @@ -188,19 +188,19 @@ subroutine Get_eosDT_Table_Filenames(rq, which_eosdt, xz, & data_dir_name = '/eosDT_data/' data_prefix = '-eosDT_' end if - + fname = trim(data_dir) // & trim(data_dir_name) // trim(rq% eosDT_file_prefix) // trim(data_prefix) // & trim(Zstr) // 'z' // trim(Xstr) // 'x' // trim(suffix) // '.data' cache_filename = trim(eosDT_cache_dir) // & '/' // trim(rq% eosDT_file_prefix) // trim(data_prefix) // & - trim(Zstr) // 'z' // trim(Xstr) // 'x' // trim(suffix) // '.bin' + trim(Zstr) // 'z' // trim(Xstr) // 'x' // trim(suffix) // '.bin' temp_cache_filename = trim(eosDT_temp_cache_dir) // & '/' // trim(rq% eosDT_file_prefix) // trim(data_prefix) // & trim(Zstr) // 'z' // trim(Xstr) // 'x' // trim(suffix) // '.bin' - + contains - + subroutine setstr(v,str) real(dp), intent(in) :: v character (len=*) :: str @@ -212,10 +212,10 @@ subroutine setstr(v,str) write(str, '(a,i1)') '0', floor(100d0 * v + 0.5d0) end if end subroutine setstr - + end subroutine Get_eosDT_Table_Filenames - - + + subroutine Load1_eosDT_Table(rq, which_eosdt, ep, xz, & ix, iz, filename, cache_filename, temp_cache_filename, & io_unit, cache_io_unit, use_cache, info) @@ -228,7 +228,7 @@ subroutine Load1_eosDT_Table(rq, which_eosdt, ep, xz, & integer, intent(in) :: io_unit, cache_io_unit logical, intent(in) :: use_cache integer, intent(out) :: info - + real(dp) :: X, Z, logQ, logT, X_in, Z_in integer :: j, i, k, iQ, ios, status character (len=1000) :: message @@ -238,22 +238,22 @@ subroutine Load1_eosDT_Table(rq, which_eosdt, ep, xz, & real(dp), target :: vec_ary(50) real(dp), pointer :: vec(:) integer :: n - + include 'formats' - info = 0 + info = 0 vec => vec_ary Z = xz% Zs(iz) X = xz% Xs_for_Z(ix,iz) write(message,*) 'open ', trim(filename) - + open(UNIT=io_unit, FILE=trim(filename), ACTION='READ', STATUS='OLD', IOSTAT=ios) call check_for_error_in_eosDT_data(ios, filename) read(io_unit,*,iostat=info) if (info /= 0) return - + read(io_unit,'(a)',iostat=info) message if (info == 0) call str_to_vector(message, vec, n, info) if (info /= 0 .or. n < 11) then @@ -291,7 +291,7 @@ subroutine Load1_eosDT_Table(rq, which_eosdt, ep, xz, & call request_user_to_reinstall return end if - + if (show_allocations) write(*,2) 'Load1_eosDT_Table ep% tbl1', & sz_per_eos_point*nv*ep% num_logQs*ep% num_logTs + ep% num_logQs + ep% num_logTs allocate(ep% tbl1(sz_per_eos_point*nv*ep% num_logQs*ep% num_logTs), & @@ -301,16 +301,16 @@ subroutine Load1_eosDT_Table(rq, which_eosdt, ep, xz, & write(*,*) "Info: ",info call mesa_error(__FILE__,__LINE__, "Allocation in Load1_eosDT_Table failed, you're likely out of memory") end if - + tbl(1:sz_per_eos_point,1:nv,1:ep% num_logQs,1:ep% num_logTs) => & ep% tbl1(1:sz_per_eos_point*nv*ep% num_logQs*ep% num_logTs) - + ep% logQs(1) = ep% logQ_min do i = 2, ep% num_logQs-1 ep% logQs(i) = ep% logQs(i-1) + ep% del_logQ end do ep% logQs(ep% num_logQs) = ep% logQ_max - + ep% logTs(1) = ep% logT_min do i = 2, ep% num_logTs-1 ep% logTs(i) = ep% logTs(i-1) + ep% del_logT @@ -324,22 +324,22 @@ subroutine Load1_eosDT_Table(rq, which_eosdt, ep, xz, & return end if end if - + status = 0 allocate(tbl2_1(num_eos_file_vals*ep% num_logQs*ep% num_logTs), STAT=status) if (status .ne. 0) then info = -1 return end if - + tbl2(1:num_eos_file_vals,1:ep% num_logQs,1:ep% num_logTs) => & tbl2_1(1:num_eos_file_vals*ep% num_logQs*ep% num_logTs) do iQ=1,ep% num_logQs - + read(io_unit,*,iostat=info) if (failed('skip line')) return - + read(io_unit,'(a)',iostat=info) message if (info == 0) call str_to_double(message, vec(1), info) if (failed('read logQ')) return @@ -347,12 +347,12 @@ subroutine Load1_eosDT_Table(rq, which_eosdt, ep, xz, & read(io_unit,*,iostat=info) if (failed('skip line')) return - + read(io_unit,*,iostat=info) if (failed('skip line')) return - + do i=1,ep% num_logTs - + read(io_unit,'(a)',iostat=info) message if (failed('read line')) then write(*,'(a)') trim(message) @@ -362,7 +362,7 @@ subroutine Load1_eosDT_Table(rq, which_eosdt, ep, xz, & write(*,*) 'bad input line?' call mesa_error(__FILE__,__LINE__) end if - + call str_to_vector(message, vec, n, info) if (info /= 0 .or. n < 1+num_eos_file_vals) then write(*,'(a)') trim(message) @@ -376,25 +376,25 @@ subroutine Load1_eosDT_Table(rq, which_eosdt, ep, xz, & do j=1,num_eos_file_vals tbl2(j,iQ,i) = vec(1+j) end do - + enddo - + if(iQ == ep% num_logQs) exit read(io_unit,*,iostat=info) if (failed('skip line')) return read(io_unit,*,iostat=info) if (failed('skip line')) return - + end do - + close(io_unit) - + call Make_XEoS_Interpolation_Data(ep, tbl2_1, info) deallocate(tbl2_1) if (failed('Make_XEoS_Interpolation_Data')) return - + call Check_XEoS_Interpolation_Data(ep) - + if (.not. use_cache) return open(unit=cache_io_unit, & @@ -412,10 +412,10 @@ subroutine Load1_eosDT_Table(rq, which_eosdt, ep, xz, & close(cache_io_unit) if(use_mesa_temp_cache) call mv(temp_cache_filename, cache_filename,.true.) end if - - + + contains - + subroutine Check_XEoS_Interpolation_Data(ep) use utils_lib,only:is_bad type (EosDT_XZ_Info), pointer :: ep @@ -434,17 +434,17 @@ subroutine Check_XEoS_Interpolation_Data(ep) end do end do end subroutine Check_XEoS_Interpolation_Data - + logical function failed(str) character (len=*), intent(in) :: str failed = (info /= 0) if (failed) write(*,*) 'Load1_eosDT_Table failed: ' // trim(str) end function failed - + end subroutine Load1_eosDT_Table - - + + subroutine Make_XEoS_Interpolation_Data(ep, tbl2_1, info) use interp_2d_lib_db use const_def, only: crad, ln10 @@ -473,13 +473,13 @@ subroutine Make_XEoS_Interpolation_Data(ep, tbl2_1, info) real(dp) :: gamma3, gamma1, grad_ad, Prad, E, S integer :: iQ, jtemp, ilogT, ilogQ real(dp) :: fval(num_eos_file_vals), df_dx(num_eos_file_vals), df_dy(num_eos_file_vals) - + real(dp) :: x, y, dlnT, energy, lnE, entropy, lnS, Pgas, lnPgas, dlogT, & dlnPgas_dlnd, dlnE_dlnd, dlnS_dlnd, dlnPgas_dlnT, dlnE_dlnT, dlnS_dlnT - + integer :: v, vlist(3), var, i, j, num_logQs, num_logTs, ii, jj character (len=256) :: message - + include 'formats' info = 0 @@ -489,22 +489,22 @@ subroutine Make_XEoS_Interpolation_Data(ep, tbl2_1, info) ibcxmax = 0; bcxmax(:) = 0 ibcymin = 0; bcymin(:) = 0 ibcymax = 0; bcymax(:) = 0 - + num_logQs = ep% num_logQs num_logTs = ep% num_logTs - + ep_tbl(1:sz_per_eos_point,1:nv,1:num_logQs,1:num_logTs) => & ep% tbl1(1:sz_per_eos_point*nv*num_logQs*num_logTs) tbl2(1:num_eos_file_vals,1:num_logQs,1:num_logTs) => & tbl2_1(1:num_eos_file_vals*num_logQs*num_logTs) - + allocate(f1_ary(sz_per_eos_point * ep% num_logQs * ep% num_logTs)) - + f1 => f1_ary f(1:sz_per_eos_point,1:num_logQs,1:num_logTs) => & f1_ary(1:sz_per_eos_point*num_logQs*num_logTs) - + do iQ = 1, ep% num_logQs logQs(iQ) = ep% logQ_min + (iQ-1) * ep% del_logQ end do @@ -512,7 +512,7 @@ subroutine Make_XEoS_Interpolation_Data(ep, tbl2_1, info) do jtemp = 1, ep% num_logTs logTs(jtemp) = ep% logT_min + (jtemp-1) * ep% del_logT end do - + ! copy file eos variables to internal eos interpolation tables do j=1,num_logTs do i=1,num_logQs @@ -532,11 +532,11 @@ subroutine Make_XEoS_Interpolation_Data(ep, tbl2_1, info) ! to protect against non-monotonic interpolation caused by extreme values ep_tbl(1,i_gamma1,i,j) = tbl2(jgamma1,i,j) ep_tbl(1,i_gamma3,i,j) = tbl2(jgamma3,i,j) - ep_tbl(1,i_eta,i,j) = tbl2(jeta,i,j) - end do + ep_tbl(1,i_eta,i,j) = tbl2(jeta,i,j) + end do end do - ! create tables for bicubic spline interpolation + ! create tables for bicubic spline interpolation do v = 1, nv do i=1,ep% num_logQs do j=1,ep% num_logTs @@ -561,11 +561,11 @@ subroutine Make_XEoS_Interpolation_Data(ep, tbl2_1, info) end do end do end do - - + + end subroutine Make_XEoS_Interpolation_Data - - + + subroutine Read_EoS_Cache(X, Z, ep, cache_filename, io_unit, ios) real(dp), intent(in) :: X, Z type (EosDT_XZ_Info), pointer :: ep @@ -577,19 +577,19 @@ subroutine Read_EoS_Cache(X, Z, ep, cache_filename, io_unit, ios) logQ_min_in, logQ_max_in, del_logQ_in integer :: num_logQs_in, num_logTs_in, version_in real(dp), parameter :: tiny = 1d-10 - + include 'formats' - + ios = 0 open(unit=io_unit,file=trim(cache_filename),action='read', & status='old',iostat=ios,form='unformatted') if (ios /= 0) return - + read(io_unit, iostat=ios) & X_in, Z_in, num_logTs_in, logT_min_in, logT_max_in, del_logT_in, & num_logQs_in, logQ_min_in, logQ_max_in, del_logQ_in, version_in if (ios /= 0) return - + if (ep% version /= version_in) then ios = 1 write(*,*) 'read cache failed for version_in' @@ -597,7 +597,7 @@ subroutine Read_EoS_Cache(X, Z, ep, cache_filename, io_unit, ios) if (ep% num_logQs /= num_logQs_in) then ios = 1 write(*,*) 'read cache failed for ep% num_logQs' - end if + end if if (ep% num_logTs /= num_logTs_in) then ios = 1 write(*,*) 'read cache failed for ep% num_logTs' @@ -613,19 +613,19 @@ subroutine Read_EoS_Cache(X, Z, ep, cache_filename, io_unit, ios) if (abs(ep% logT_min-logT_min_in) > tiny) then ios = 1 write(*,*) 'read cache failed for eos_logT_min' - end if + end if if (abs(ep% logT_max-logT_max_in) > tiny) then ios = 1 write(*,*) 'read cache failed for eos_logT_max' - end if + end if if (abs(ep% del_logT-del_logT_in) > tiny) then ios = 1 write(*,*) 'read cache failed for eos_del_logT' - end if + end if if (abs(ep% logQ_min-logQ_min_in) > tiny) then ios = 1 write(*,*) 'read cache failed for eos_logQ_min' - end if + end if if (abs(ep% logQ_max-logQ_max_in) > tiny) then ios = 1 write(*,*) 'read cache failed for eos_logQ_max' @@ -634,7 +634,7 @@ subroutine Read_EoS_Cache(X, Z, ep, cache_filename, io_unit, ios) ios = 1 write(*,*) 'read cache failed for eos_del_logQ' end if - + if (ios /= 0) then close(io_unit); return end if @@ -645,10 +645,10 @@ subroutine Read_EoS_Cache(X, Z, ep, cache_filename, io_unit, ios) if (ios /= 0) then close(io_unit); return end if - + close(io_unit) end subroutine Read_EoS_Cache - - + + end module eosDT_load_tables diff --git a/eos/private/eosdt_support.f90 b/eos/private/eosdt_support.f90 index 3871b8544..1588548e0 100644 --- a/eos/private/eosdt_support.f90 +++ b/eos/private/eosdt_support.f90 @@ -29,14 +29,14 @@ module eosdt_support use const_def, only: avo, crad, ln10, arg_not_provided, mp, kerg, dp, qp, one_sixth use utils_lib, only: is_bad, mesa_error use math_lib - + implicit none - + integer, parameter :: sz = sz_per_eos_point - + contains - + subroutine Do_EoS_Interpolations( & nvlo, nvhi, n, nx, x, ny, y, fin1, i, j, & x0, xget, x1, y0, yget, y1, & @@ -50,7 +50,7 @@ subroutine Do_EoS_Interpolations( & real(dp), intent(in) :: y0, yget, y1 ! y0 <= yget <= y1; y0 = ys(j), y1 = ys(j+1) real(dp), intent(inout), dimension(nv) :: fval, df_dx, df_dy integer, intent(out) :: ierr - + real(dp) :: xp, xpi, xp2, xpi2, ax, axbar, bx, bxbar, cx, cxi, hx2, cxd, cxdi, hx, hxi real(dp) :: yp, ypi, yp2, ypi2, ay, aybar, by, bybar, cy, cyi, hy2, cyd, cydi, hy, hyi real(dp) :: sixth_hx2, sixth_hy2, z36th_hx2_hy2 @@ -58,18 +58,18 @@ subroutine Do_EoS_Interpolations( & real(dp) :: sixth_hx2_hyi, sixth_hy, z36th_hx2_hy integer :: k, ip1, jp1 real(dp), pointer :: fin(:,:,:,:) - + include 'formats' - + ierr = 0 - + fin(1:sz_per_eos_point,1:n,1:nx,1:ny) => & fin1(1:sz_per_eos_point*n*nx*ny) - + hx=x1-x0 hxi=1d0/hx hx2=hx*hx - + xp=(xget-x0)*hxi xpi=1d0-xp @@ -78,55 +78,55 @@ subroutine Do_EoS_Interpolations( & ax=xp2*(3d0-2d0*xp) axbar=1d0-ax - + bx=-xp2*xpi bxbar=xpi2*xp - + cx=xp*(xp2-1d0) cxi=xpi*(xpi2-1d0) cxd=3d0*xp2-1d0 cxdi=-3d0*xpi2+1d0 - + hy=y1-y0 hyi=1d0/hy hy2=hy*hy - + yp=(yget-y0)*hyi - + ypi=1d0-yp yp2=yp*yp ypi2=ypi*ypi ay=yp2*(3d0-2d0*yp) aybar=1d0-ay - + by=-yp2*ypi bybar=ypi2*yp - + cy=yp*(yp2-1d0) cyi=ypi*(ypi2-1d0) cyd=3d0*yp2-1d0 cydi=-3d0*ypi2+1d0 - + sixth_hx2 = one_sixth*hx2 sixth_hy2 = one_sixth*hy2 z36th_hx2_hy2 = sixth_hx2*sixth_hy2 - + sixth_hx = one_sixth*hx sixth_hxi_hy2 = sixth_hy2*hxi z36th_hx_hy2 = sixth_hx*sixth_hy2 - + sixth_hx2_hyi = sixth_hx2*hyi sixth_hy = one_sixth*hy z36th_hx2_hy = sixth_hx2*sixth_hy - + ip1 = i+1 jp1 = j+1 - + !$omp simd do k = nvlo, nvhi ! bicubic spline interpolation - + ! f(1,i,j) = f(x(i),y(j)) ! f(2,i,j) = d2f/dx2(x(i),y(j)) ! f(3,i,j) = d2f/dy2(x(i),y(j)) @@ -145,7 +145,7 @@ subroutine Do_EoS_Interpolations( & +z36th_hx2_hy2*( & cxi*(cyi*fin(4,k,i,j) +cy*fin(4,k,i,jp1))+ & cx*(cyi*fin(4,k,ip1,j)+cy*fin(4,k,ip1,jp1))) - + ! derivatives of bicubic splines df_dx(k) = & hxi*( & @@ -174,9 +174,9 @@ subroutine Do_EoS_Interpolations( & +z36th_hx2_hy*( & cxi*(cydi*fin(4,k,i,j) +cyd*fin(4,k,i,jp1))+ & cx*(cydi*fin(4,k,ip1,j)+cyd*fin(4,k,ip1,jp1))) - + end do - + end subroutine Do_EoS_Interpolations @@ -201,9 +201,9 @@ subroutine Do_Blend( & d_alfa_dlnd, d_alfa_dlnT, & d_beta_dlnd, d_beta_dlnT integer :: j, k - - if (.not. linear_blend) then - + + if (.not. linear_blend) then + ! smooth the transitions near alfa = 0.0 and 1.0 ! quintic smoothing function with 1st and 2nd derivs = 0 at ends @@ -211,24 +211,24 @@ subroutine Do_Blend( & d_alfa0_dlnT = d_alfa_dlogT_in/ln10 d_alfa0_dlnd = d_alfa_dlogRho_in/ln10 alfa = -alfa0*alfa0*alfa0*(-10d0 + alfa0*(15d0 - 6d0*alfa0)) - A = 30d0*(alfa0 - 1d0)*(alfa0 - 1d0)*alfa0*alfa0 + A = 30d0*(alfa0 - 1d0)*(alfa0 - 1d0)*alfa0*alfa0 d_alfa_dlnd = A*d_alfa0_dlnd d_alfa_dlnT = A*d_alfa0_dlnT - + else - + alfa = alfa_in d_alfa_dlnT = d_alfa_dlogT_in/ln10 d_alfa_dlnd = d_alfa_dlogRho_in/ln10 - - end if - + + end if + beta = 1d0 - alfa d_beta_dlnT = -d_alfa_dlnT d_beta_dlnd = -d_alfa_dlnd do j=1,nv - res(j) = alfa*res_1(j) + beta*res_2(j) + res(j) = alfa*res_1(j) + beta*res_2(j) dlnd(j) = & alfa*d_dlnd_1(j) + beta*d_dlnd_2(j) + & d_alfa_dlnd*res_1(j) + d_beta_dlnd*res_2(j) @@ -248,4 +248,4 @@ end subroutine Do_Blend end module eosdt_support - + diff --git a/eos/private/eospc_eval.f90 b/eos/private/eospc_eval.f90 index ebc41b36f..63aa48e30 100644 --- a/eos/private/eospc_eval.f90 +++ b/eos/private/eospc_eval.f90 @@ -32,12 +32,12 @@ module eospc_eval use math_lib implicit none - - + + contains - - subroutine Get_PC_alfa( & + + subroutine Get_PC_alfa( & rq, logRho, logT, Z, abar, zbar, & alfa, d_alfa_dlogT, d_alfa_dlogRho, & ierr) @@ -49,22 +49,22 @@ subroutine Get_PC_alfa( & real(dp) :: logGe0, logGe, logGe_lo, logGe_hi, & A, B, dA_dlnT, dA_dlnRho, dB_dlnT, dB_dlnRho, dlogGe_dlogT, dlogGe_dlogRho, & logT_lo, logT_hi, logRho_lo, logRho_hi - + include 'formats' ierr = 0 - + d_alfa_dlogT = 0d0 d_alfa_dlogRho = 0d0 logRho_lo = rq% logRho2_PC_limit ! don't use PC for logRho < this logRho_hi = rq% logRho1_PC_limit ! okay for pure PC for logRho > this - + if (rq% PC_use_Gamma_limit_instead_of_T) then !gamma_e = (qe**2)*(four_thirds_pi*avo*Rho*zbar/abar)**one_third/(kerg*T) !logGe = logGe0 + logRho/3 - logT ! where Ge0 = (qe**2)*(four_thirds_pi*avo*zbar/abar)**one_third/kerg - logGe0 = log10( & + logGe0 = log10( & qe*qe*pow(four_thirds_pi*avo*zbar/abar, one_third)/kerg) logGe = logGe0 + logRho/3 - logT logGe_lo = rq% log_Gamma_e_all_HELM ! HELM for logGe <= this @@ -167,13 +167,13 @@ subroutine Get_PC_Results( & real(dp), intent(inout) :: d_dlnT_c_Rho(:) ! (nv) real(dp), intent(inout) :: d_dxa(:,:) ! (nv, species) integer, intent(out) :: ierr - + real(dp) :: start_crystal, full_crystal real(dp), dimension(species) :: AY, AZion, ACMI integer :: i, j - + include 'formats' - + ierr = 0 AZion(1:species) = chem_isos% Z(chem_id(1:species)) ACMI(1:species) = chem_isos% W(chem_id(1:species)) ! this really is atomic weight. @@ -194,7 +194,7 @@ subroutine Get_PC_Results( & ! composition derivatives not provided d_dxa = 0 - + if (is_bad(res(i_lnS))) then ierr = -1 write(*,1) 'res(i_lnS), logRho, logT', res(i_lnS), logRho, logT @@ -202,7 +202,7 @@ subroutine Get_PC_Results( & end if contains - + subroutine do1(show,RHO_real,T_real,start_crystal,full_crystal,res,d_dlnT_c_Rho,d_dlnRho_c_T,ierr) logical, intent(in) :: show real(dp), intent(in) :: start_crystal, full_crystal @@ -220,15 +220,15 @@ subroutine do1(show,RHO_real,T_real,start_crystal,full_crystal,res,d_dlnT_c_Rho, real(dp), parameter :: UN_T6=0.3157746d0 include 'formats' - + ierr = 0 - + T = T_real T%d1val1 = 1d0 RHO = RHO_real RHO%d1val2 = 1d0 - + TEMP=T*1d-6/UN_T6 ! T [au] if (show) then @@ -256,7 +256,7 @@ subroutine do1(show,RHO_real,T_real,start_crystal,full_crystal,res,d_dlnT_c_Rho, else ! blend of liquid and solid phase = (GAMImean - start_crystal)/(full_crystal - start_crystal) ! 1 for solid, 0 for liquid end if - + if (ierr /= 0) then return write(*,1) 'RHO', RHO @@ -266,7 +266,7 @@ subroutine do1(show,RHO_real,T_real,start_crystal,full_crystal,res,d_dlnT_c_Rho, write(*,*) 'ierr from MELANGE9' call mesa_error(__FILE__,__LINE__,'debug eos') end if - + if (show) then write(*,1) 'PRADnkT', PRADnkT write(*,1) 'DENS', DENS @@ -284,7 +284,7 @@ subroutine do1(show,RHO_real,T_real,start_crystal,full_crystal,res,d_dlnT_c_Rho, write(*,1) 'CHIT', CHIT write(*,'(A)') end if - + Tnk=8.31447d7/CMImean*RHO*T ! n_i kT [erg/cc] Pgas = PnkT*Tnk if (rq% include_radiation) then @@ -368,9 +368,9 @@ subroutine do1(show,RHO_real,T_real,start_crystal,full_crystal,res,d_dlnT_c_Rho, d_dlnRho_c_T(i_phase) = phase % d1val2 * RHO % val end subroutine do1 - + end subroutine Get_PC_Results - + end module eospc_eval - + diff --git a/eos/private/eospt_eval.f90 b/eos/private/eospt_eval.f90 index a0a15fc4a..f571293e9 100644 --- a/eos/private/eospt_eval.f90 +++ b/eos/private/eospt_eval.f90 @@ -32,10 +32,10 @@ module eosPT_eval implicit none - + integer, parameter :: doing_get_T = 1 integer, parameter :: doing_get_Pgas = 2 - + contains @@ -57,27 +57,27 @@ subroutine Get_eosPT_Results(rq, & real(dp), intent(inout) :: res(:), d_dlnRho_c_T(:), d_dlnT_c_Rho(:) ! (nv) real(dp), intent(inout) :: d_dxa_c_TRho(:,:) ! (nv, species) integer, intent(out) :: ierr - + real(dp) :: X, Z, T, logT real(dp) :: Pgas, logPgas, Prad, tiny logical, parameter :: dbg = .false. - + logical :: skip include 'formats' - + ierr = 0 tiny = rq% tiny_fuzz - + if (is_bad(X_in) .or. is_bad(Z_in)) then ierr = -1 return end if - + X = X_in; Z = Z_in if (X < tiny) X = 0d0 if (Z < tiny) Z = 0d0 - + if (X > 1d0) then if (X > 1.0001D0) then write(*,1) 'Get_eosPT_Results: X bad', X @@ -87,24 +87,24 @@ subroutine Get_eosPT_Results(rq, & end if X = 1d0 end if - + call get_PT_args( & aPgas, alogPgas, atemp, alogtemp, Pgas, logPgas, T, logT, ierr) if (ierr /= 0) then if (dbg) write(*,*) 'error from get_PT_args' return end if - + if (Pgas <= 0) then ierr = -1 return end if - + if (is_bad(Pgas) .or. is_bad(T)) then ierr = -1 return end if - + call Get_PT_Results_using_DT( & rq, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & @@ -121,7 +121,7 @@ end subroutine Get_eosPT_Results subroutine get_PT_args( & - aPg, alogPg, atemp, alogtemp, Pgas, logPgas, T, logT, ierr) + aPg, alogPg, atemp, alogtemp, Pgas, logPgas, T, logT, ierr) real(dp), intent(in) :: aPg, alogPg real(dp), intent(in) :: atemp, alogtemp real(dp), intent(out) :: Pgas, logPgas, T, logT @@ -149,7 +149,7 @@ subroutine get_PT_args( & return end if end subroutine get_PT_args - + subroutine Get_PT_Results_using_DT( & rq, Z, X, abar, zbar, & @@ -159,11 +159,11 @@ subroutine Get_PT_Results_using_DT( & res, d_dlnRho_c_T, d_dlnT_c_Rho, d_dxa_c_TRho, ierr) use eosDT_eval, only: get_Rho use utils_lib, only: is_bad - + type (EoS_General_Info), pointer :: rq ! general information about the request real(dp), intent(in) :: Z, X, abar, zbar integer, intent(in) :: species - integer, pointer :: chem_id(:) + integer, pointer :: chem_id(:) integer, pointer :: net_iso(:) real(dp), intent(in) :: xa(:) real(dp), intent(inout) :: Pgas, logPgas, T, logT @@ -173,27 +173,27 @@ subroutine Get_PT_Results_using_DT( & real(dp), intent(inout) :: d_dlnT_c_Rho(:) ! (nv) real(dp), intent(inout) :: d_dxa_c_TRho(:,:) ! (nv, species) integer, intent(out) :: ierr - + integer:: i, eos_calls, max_iter, which_other real(dp) :: & logRho_guess, rho_guess, other, other_tol, logRho_tol, Prad, f, dfdx, & logRho_bnd1, logRho_bnd2, other_at_bnd1, other_at_bnd2, logRho_result logical, parameter :: dbg = .false. - + include 'formats' - + ierr = 0 which_other = i_lnPgas other = logPgas*ln10 other_tol = 1d-8 logRho_tol = 1d-8 - + ! guess based on fully ionized, ideal gas of ions and electrons rho_guess = Pgas*abar*mp/(kerg*T*(1+zbar)) logRho_guess = log10(rho_guess) - + logRho_bnd1 = arg_not_provided logRho_bnd2 = arg_not_provided other_at_bnd1 = arg_not_provided @@ -201,7 +201,7 @@ subroutine Get_PT_Results_using_DT( & max_iter = 20 eos_calls = 0 - + if (dbg) write(*,1) 'rho_guess', rho_guess if (dbg) write(*,1) 'logRho_guess', logRho_guess @@ -230,10 +230,10 @@ subroutine Get_PT_Results_using_DT( & end if return end if - + logRho = logRho_result Rho = exp10(logRho) - + if (dbg) write(*,1) 'Rho', Rho if (dbg) write(*,1) 'logRho', logRho if (dbg) write(*,*) @@ -244,29 +244,29 @@ subroutine Get_PT_Results_using_DT( & if (dbg) write(*,*) if (dbg) write(*,1) 'get_Rho: grad_ad', res(i_grad_ad) if (dbg) write(*,*) - + call do_partials - + contains - + subroutine do_partials ! dlnRho_dlnPgas_c_T and dlnRho_dlnT_c_Pgas real(dp) :: Prad, P, dP_dRho, dPgas_dRho, & dP_dT, dPrad_dT, dPgas_dT, dRho_dPgas, dRho_dT include 'formats' - + Prad = crad*T*T*T*T/3 P = Pgas + Prad dP_dRho = res(i_chiRho)*P/Rho dPgas_dRho = dP_dRho ! const T, so dP_dRho = dPgas_dRho dRho_dPgas = 1/dPgas_dRho ! const T dlnRho_dlnPgas_c_T = dRho_dPgas*Pgas/Rho ! const T - + dPrad_dT = 4*crad*T*T*T/3 dP_dT = res(i_chiT)*P/T dPgas_dT = dP_dT - dPrad_dT ! const Rho dRho_dT = -dPgas_dT/dPgas_dRho ! const Pgas dlnRho_dlnT_c_Pgas = dRho_dT*T/Rho - + end subroutine do_partials end subroutine Get_PT_Results_using_DT @@ -281,33 +281,33 @@ subroutine get_T( & logT_result, Rho, logRho, dlnRho_dlnPgas_c_T, dlnRho_dlnT_c_Pgas, & res, d_dlnRho_c_T, d_dlnT_c_Rho, d_dxa_c_TRho, & eos_calls, ierr) - + integer, intent(in) :: handle real(dp), intent(in) :: Z ! the metals mass fraction real(dp), intent(in) :: X ! the hydrogen mass fraction - + real(dp), intent(in) :: abar, zbar - + integer, intent(in) :: species - integer, pointer :: chem_id(:) + integer, pointer :: chem_id(:) integer, pointer :: net_iso(:) real(dp), intent(in) :: xa(:) - + real(dp), intent(in) :: logPgas ! log10 of density integer, intent(in) :: which_other real(dp), intent(in) :: other_value ! desired value for the other variable real(dp), intent(in) :: other_tol - + real(dp), intent(in) :: logT_tol - integer, intent(in) :: max_iter ! max number of iterations + integer, intent(in) :: max_iter ! max number of iterations real(dp), intent(in) :: logT_guess real(dp), intent(in) :: logT_bnd1, logT_bnd2 ! bounds for logT ! set to arg_not_provided if do not know bounds real(dp), intent(in) :: other_at_bnd1, other_at_bnd2 ! values at bounds ! if don't know these values, just set to arg_not_provided (defined in c_def) - + real(dp), intent(out) :: logT_result real(dp), intent(out) :: Rho, logRho ! density real(dp), intent(out) :: dlnRho_dlnPgas_c_T @@ -317,10 +317,10 @@ subroutine get_T( & real(dp), intent(inout) :: d_dlnRho_c_T(:) ! (nv) real(dp), intent(inout) :: d_dlnT_c_Rho(:) ! (nv) real(dp), intent(inout) :: d_dxa_c_TRho(:,:) ! (nv, species) - + integer, intent(out) :: eos_calls integer, intent(out) :: ierr ! 0 means AOK. - + call do_safe_get_Pgas_T( & handle, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & @@ -330,9 +330,9 @@ subroutine get_T( & Rho, logRho, dlnRho_dlnPgas_c_T, dlnRho_dlnT_c_Pgas, & res, d_dlnRho_c_T, d_dlnT_c_Rho, d_dxa_c_TRho, & eos_calls, ierr) - + end subroutine get_T - + subroutine get_Pgas( & handle, Z, X, abar, zbar, & @@ -343,37 +343,37 @@ subroutine get_Pgas( & logPgas_result, Rho, logRho, dlnRho_dlnPgas_c_T, dlnRho_dlnT_c_Pgas, & res, d_dlnRho_c_T, d_dlnT_c_Rho, d_dxa_c_TRho, & eos_calls, ierr) - + use const_def - + integer, intent(in) :: handle real(dp), intent(in) :: Z ! the metals mass fraction real(dp), intent(in) :: X ! the hydrogen mass fraction - + real(dp), intent(in) :: abar, zbar - + integer, intent(in) :: species - integer, pointer :: chem_id(:) + integer, pointer :: chem_id(:) integer, pointer :: net_iso(:) real(dp), intent(in) :: xa(:) - + real(dp), intent(in) :: logT ! log10 of temperature integer, intent(in) :: which_other real(dp), intent(in) :: other_value ! desired value for the other variable real(dp), intent(in) :: other_tol - + real(dp), intent(in) :: logPgas_tol - integer, intent(in) :: max_iter ! max number of Newton iterations + integer, intent(in) :: max_iter ! max number of Newton iterations real(dp), intent(in) :: logPgas_guess real(dp), intent(in) :: logPgas_bnd1, logPgas_bnd2 ! bounds for logPgas ! set to arg_not_provided if do not know bounds real(dp), intent(in) :: other_at_bnd1, other_at_bnd2 ! values at bounds ! if don't know these values, just set to arg_not_provided (defined in c_def) - + real(dp), intent(out) :: logPgas_result real(dp), intent(out) :: Rho, logRho ! density real(dp), intent(out) :: dlnRho_dlnPgas_c_T @@ -386,7 +386,7 @@ subroutine get_Pgas( & integer, intent(out) :: eos_calls integer, intent(out) :: ierr ! 0 means AOK. - + call do_safe_get_Pgas_T( & handle, Z, X, abar, zbar, & species, chem_id, net_iso, xa, & diff --git a/eos/private/gauss_fermi.f90 b/eos/private/gauss_fermi.f90 index 0f0208de1..a34d6eb5d 100644 --- a/eos/private/gauss_fermi.f90 +++ b/eos/private/gauss_fermi.f90 @@ -16,7 +16,7 @@ module gauss_fermi use const_def, only: dp use math_lib - + implicit none private @@ -26,12 +26,12 @@ module gauss_fermi contains subroutine dfermi(dk,eta,theta,fd,fdeta,fdtheta) -!..this routine computes the fermi-dirac integrals of +!..this routine computes the fermi-dirac integrals of !..index dk, with degeneracy parameter eta and relativity parameter theta. !..input is dk the real(dp) index of the fermi-dirac function, !..eta the degeneracy parameter, and theta the relativity parameter. !.. theta = (k * T)/(mass_electron * c^2), k = Boltzmann const. -!..the output is fd is computed by applying three 10-point +!..the output is fd is computed by applying three 10-point !..gauss-legendre and one 10-point gauss-laguerre rules over !..four appropriate subintervals. the derivative with respect to eta is !..output in fdeta, and the derivative with respct to theta is in fdtheta. @@ -95,7 +95,7 @@ subroutine dfermi(dk,eta,theta,fd,fdeta,fdtheta) s3=x1+x3 s12=sqrt(s1) -! quadrature integrations: +! quadrature integrations: ! 9 significant figure accuracy ! call dqleg010(fdfunc2, 0.d0, s12, res1, dres1, ddres1, par,3) @@ -130,11 +130,11 @@ subroutine dfermi(dk,eta,theta,fd,fdeta,fdtheta) fdtheta = ddres1 + ddres2 + ddres3 + ddres4 return end subroutine dfermi - + subroutine fdfunc1(x,par,n,fd,fdeta,fdtheta) !.. !..forms the fermi-dirac integrand and its derivatives with eta and theta. -!..on input x is the integration variable, par(1) is the real(dp) +!..on input x is the integration variable, par(1) is the real(dp) !..index, par(2) is the degeneravy parameter, and par(3) is the relativity !..parameter. on output fd is the integrand, fdeta is the derivative !..with respect to eta, and fdtheta is the derivative with respect to theta. @@ -157,7 +157,7 @@ subroutine fdfunc1(x,par,n,fd,fdeta,fdtheta) factor = exp(x-eta) denom = factor + 1.0d0 fd = xdk * dxst / denom - fdeta = fd * factor / denom + fdeta = fd * factor / denom denom2 = 4.0d0 * dxst * denom fdtheta = xdkp1 / denom2 @@ -176,7 +176,7 @@ subroutine fdfunc2(x,par,n,fd,fdeta,fdtheta) !.. !..forms the fermi-dirac integrand and its derivatives with eta and theta, !..when the z**2=x variable change has been made. -!..on input x is the integration variable, par(1) is the real(dp) +!..on input x is the integration variable, par(1) is the real(dp) !..index, par(2) is the degeneravy parameter, and par(3) is the relativity !..parameter. on output fd is the integrand, fdeta is the derivative !..with respect to eta, and fdtheta is the derivative with respect to theta. @@ -198,7 +198,7 @@ subroutine fdfunc2(x,par,n,fd,fdeta,fdtheta) if ((xsq-eta) .lt. 1.d2) then factor = exp(xsq - eta) denom = factor + 1.0d0 - fd = 2.0d0 * xdk * dxst/denom + fd = 2.0d0 * xdk * dxst/denom fdeta = fd * factor/denom denom2 = 4.0d0 * dxst * denom fdtheta = 2.0d0 * xdkp1/denom2 @@ -206,7 +206,7 @@ subroutine fdfunc2(x,par,n,fd,fdeta,fdtheta) else factor = exp(eta - xsq) fd = 2.0d0 * xdk * dxst * factor - fdeta = fd + fdeta = fd denom2 = 4.0d0 * dxst fdtheta = 2.0d0 * xdkp1/denom2 * factor endif @@ -221,7 +221,7 @@ subroutine dqleg010(f,a,b,res,dres,ddres,par,n) !..on input f is the name of the subroutine containing the integrand, !..a is the lower end point of the interval, b is the higher end point, !..par is an array of constant parameters to be passed to subroutine f, -!..and n is the length of the par array. on output res is the +!..and n is the length of the par array. on output res is the !..approximation from applying the 10-point gauss-legendre rule, !..dres is the derivative with respect to eta, and ddres is the !..derivative with respect to theta. @@ -290,7 +290,7 @@ subroutine dqleg020(f,a,b,res,dres,ddres,par,n) !..on input f is the name of the subroutine containing the integrand, !..a is the lower end point of the interval, b is the higher end point, !..par is an array of constant parameters to be passed to subroutine f, -!..and n is the length of the par array. on output res is the +!..and n is the length of the par array. on output res is the !..approximation from applying the 20-point gauss-legendre rule, !..dres is the derivative with respect to eta, and ddres is the !..derivative with respect to theta. @@ -372,7 +372,7 @@ subroutine dqleg040(f,a,b,res,dres,ddres,par,n) !..on input f is the name of the subroutine containing the integrand, !..a is the lower end point of the interval, b is the higher end point, !..par is an array of constant parameters to be passed to subroutine f, -!..and n is the length of the par array. on output res is the +!..and n is the length of the par array. on output res is the !..approximation from applying the 40-point gauss-legendre rule, !..dres is the derivative with respect to eta, and ddres is the !..derivative with respect to theta. @@ -473,7 +473,7 @@ subroutine dqleg080(f,a,b,res,dres,ddres,par,n) !..on input f is the name of the subroutine containing the integrand, !..a is the lower end point of the interval, b is the higher end point, !..par is an array of constant parameters to be passed to subroutine f, -!..and n is the length of the par array. on output res is the +!..and n is the length of the par array. on output res is the !..approximation from applying the 80-point gauss-legendre rule, !..dres is the derivative with respect to eta, and ddres is the !..derivative with respect to theta. @@ -612,12 +612,12 @@ subroutine dqlag010(f,a,b,res,dres,ddres,par,n) !.. !..10 point gauss-laguerre rule for the fermi-dirac function. !..on input f is the external function defining the integrand -!..f(x)=g(x)*w(x), where w(x) is the gaussian weight -!..w(x)=exp(-(x-a)/b) and g(x) a smooth function, +!..f(x)=g(x)*w(x), where w(x) is the gaussian weight +!..w(x)=exp(-(x-a)/b) and g(x) a smooth function, !..a is the lower end point of the interval, b is the higher end point, !..par is an array of constant parameters to be passed to the function f, -!..and n is the length of the par array. on output res is the -!..approximation from applying the 10-point gauss-laguerre rule. +!..and n is the length of the par array. on output res is the +!..approximation from applying the 10-point gauss-laguerre rule. !..since the number of nodes is even, zero is not an abscissa. !.. !..declare @@ -630,7 +630,7 @@ subroutine dqlag010(f,a,b,res,dres,ddres,par,n) ! the abscissae and weights are given for the interval (0,+inf). ! xg - abscissae of the 10-point gauss-laguerre rule ! wg - weights of the 10-point gauss rule. since f yet -! includes the weight function, the values in wg +! includes the weight function, the values in wg ! are actually exp(xg) times the standard ! gauss-laguerre weights ! @@ -685,12 +685,12 @@ subroutine dqlag020(f,a,b,res,dres,ddres,par,n) !.. !..20 point gauss-laguerre rule for the fermi-dirac function. !..on input f is the external function defining the integrand -!..f(x)=g(x)*w(x), where w(x) is the gaussian weight -!..w(x)=dexp(-(x-a)/b) and g(x) a smooth function, +!..f(x)=g(x)*w(x), where w(x) is the gaussian weight +!..w(x)=dexp(-(x-a)/b) and g(x) a smooth function, !..a is the lower end point of the interval, b is the higher end point, !..par is an array of constant parameters to be passed to the function f, -!..and n is the length of the par array. on output res is the -!..approximation from applying the 20-point gauss-laguerre rule. +!..and n is the length of the par array. on output res is the +!..approximation from applying the 20-point gauss-laguerre rule. !..since the number of nodes is even, zero is not an abscissa. !.. !..declare @@ -703,7 +703,7 @@ subroutine dqlag020(f,a,b,res,dres,ddres,par,n) ! the abscissae and weights are given for the interval (0,+inf). ! xg - abscissae of the 20-point gauss-laguerre rule ! wg - weights of the 20-point gauss rule. since f yet -! includes the weight function, the values in wg +! includes the weight function, the values in wg ! are actually exp(xg) times the standard ! gauss-laguerre weights ! @@ -778,12 +778,12 @@ subroutine dqlag040(f,a,b,res,dres,ddres,par,n) !.. !..20 point gauss-laguerre rule for the fermi-dirac function. !..on input f is the external function defining the integrand -!..f(x)=g(x)*w(x), where w(x) is the gaussian weight -!..w(x)=dexp(-(x-a)/b) and g(x) a smooth function, +!..f(x)=g(x)*w(x), where w(x) is the gaussian weight +!..w(x)=dexp(-(x-a)/b) and g(x) a smooth function, !..a is the lower end point of the interval, b is the higher end point, !..par is an array of constant parameters to be passed to the function f, -!..and n is the length of the par array. on output res is the -!..approximation from applying the 20-point gauss-laguerre rule. +!..and n is the length of the par array. on output res is the +!..approximation from applying the 20-point gauss-laguerre rule. !..since the number of nodes is even, zero is not an abscissa. !.. !..declare @@ -796,7 +796,7 @@ subroutine dqlag040(f,a,b,res,dres,ddres,par,n) ! the abscissae and weights are given for the interval (0,+inf). ! xg - abscissae of the 20-point gauss-laguerre rule ! wg - weights of the 20-point gauss rule. since f yet -! includes the weight function, the values in wg +! includes the weight function, the values in wg ! are actually exp(xg) times the standard ! gauss-laguerre weights ! @@ -912,12 +912,12 @@ subroutine dqlag080(f,a,b,res,dres,ddres,par,n) !.. !..20 point gauss-laguerre rule for the fermi-dirac function. !..on input f is the external function defining the integrand -!..f(x)=g(x)*w(x), where w(x) is the gaussian weight -!..w(x)=dexp(-(x-a)/b) and g(x) a smooth function, +!..f(x)=g(x)*w(x), where w(x) is the gaussian weight +!..w(x)=dexp(-(x-a)/b) and g(x) a smooth function, !..a is the lower end point of the interval, b is the higher end point, !..par is an array of constant parameters to be passed to the function f, -!..and n is the length of the par array. on output res is the -!..approximation from applying the 20-point gauss-laguerre rule. +!..and n is the length of the par array. on output res is the +!..approximation from applying the 20-point gauss-laguerre rule. !..since the number of nodes is even, zero is not an abscissa. !.. !..declare @@ -930,7 +930,7 @@ subroutine dqlag080(f,a,b,res,dres,ddres,par,n) ! the abscissae and weights are given for the interval (0,+inf). ! xg - abscissae of the 20-point gauss-laguerre rule ! wg - weights of the 20-point gauss rule. since f yet -! includes the weight function, the values in wg +! includes the weight function, the values in wg ! are actually exp(xg) times the standard ! gauss-laguerre weights ! diff --git a/eos/private/helm.f90 b/eos/private/helm.f90 index 80c3d4d2c..fe4c4f27a 100644 --- a/eos/private/helm.f90 +++ b/eos/private/helm.f90 @@ -7,12 +7,12 @@ module helm use math_lib implicit none - - + + logical, parameter :: dbg = .false. !logical, parameter :: dbg = .true. - - + + private :: dbg contains @@ -36,21 +36,21 @@ subroutine helmeos2( & include_elec_pos logical, intent(out) :: off_table integer, intent(out) :: ierr - + logical :: skip_elec_pos include 'formats' - + ierr = 0 off_table = .false. - + skip_elec_pos = .not. include_elec_pos call helmeos2aux( & T, logT, Rho, logRho, abar_in, zbar_in, & coulomb_temp_cut, coulomb_den_cut, helm_res, & clip_to_table_boundaries, include_radiation, (.not. include_elec_pos), off_table, ierr) if (off_table) return - + end subroutine helmeos2 @@ -63,7 +63,7 @@ subroutine helmeos2aux( & use helm_polynomials use const_def, asol => crad use utils_lib, only: is_bad - + implicit none real(dp), intent(in) :: temp_in, logtemp_in, den_in, logden_in @@ -75,23 +75,23 @@ subroutine helmeos2aux( & real(dp) :: h ! = planck_h type (Helm_Table), pointer :: ht - + !..declare local variables include 'helm_declare_local_variables.dek' - -!..given a temperature temp [K], density den [g/cm**3], and a composition -!..characterized by abar and zbar, this routine returns most of the other -!..thermodynamic quantities. of prime interest is the pressure [erg/cm**3], -!..specific thermal energy [erg/gr], the entropy [erg/g/K], along with + +!..given a temperature temp [K], density den [g/cm**3], and a composition +!..characterized by abar and zbar, this routine returns most of the other +!..thermodynamic quantities. of prime interest is the pressure [erg/cm**3], +!..specific thermal energy [erg/gr], the entropy [erg/g/K], along with !..their derivatives with respect to temperature, density, abar, and zbar. !..other quantites such the normalized chemical potential eta (plus its -!..derivatives), number density of electrons and positron pair (along -!..with their derivatives), adiabatic indices, specific heats, and +!..derivatives), number density of electrons and positron pair (along +!..with their derivatives), adiabatic indices, specific heats, and !..relativistically correct sound speed are also returned. !.. -!..this routine assumes planckian photons, an ideal gas of ions, +!..this routine assumes planckian photons, an ideal gas of ions, !..and an electron-positron gas with an arbitrary degree of relativity !..and degeneracy. interpolation in a table of the helmholtz free energy !..is used to return the electron-positron thermodynamic quantities. @@ -107,7 +107,7 @@ subroutine helmeos2aux( & real(dp) abar, zbar, temp, logtemp, den, logden logical skip_elec_pos - + !..for the interpolations integer iat, jat real(dp) xt, xd, mxt, mxd, fi(36), & @@ -143,7 +143,7 @@ subroutine helmeos2aux( & ierr = 0 off_table = .false. - + h = planck_h third = 1.0d0/3.0d0 sioncon = (2.0d0 * pi * amu * kerg)/(h*h) @@ -159,7 +159,7 @@ subroutine helmeos2aux( & teninth = 10.0d0/9.0d0 esqu = qe*qe forthpi = forth * pi - + abar = abar_in zbar = zbar_in temp = temp_in @@ -168,29 +168,29 @@ subroutine helmeos2aux( & logden = logden_in !..for very low T, convert all H to H2. adjust abar and zbar accordingly. - + ! NOTE: table lookup uses din rather than den ytot1 = 1.0d0/abar ye = ytot1 * zbar din = ye*den - + skip_elec_pos = must_skip_elec_pos if (.not. skip_elec_pos) then ! see if need to set it true if (temp < ht% templo) then ierr = 1 return end if - + if (din < ht% denlo) then ierr = 1 return end if - if (temp > ht% temphi) then + if (temp > ht% temphi) then ierr = 1 return end if - + if (din > ht% denhi) then ierr = 1 return @@ -203,7 +203,7 @@ subroutine helmeos2aux( & return end if -!..very neutron rich compositions may need to be bounded, +!..very neutron rich compositions may need to be bounded, !..avoid that extrema for now in order to increase efficiency ! ye = max(1.0d-16, ye) @@ -281,7 +281,7 @@ subroutine helmeos2aux( & include 'helm_store_results.dek' helm_res(h_crp:h_valid) = 0 -!..debugging printout +!..debugging printout if (.false.) then include 'helm_print_results.dek' end if @@ -295,46 +295,46 @@ subroutine show_h5(fi, ia, ja, w0t, w1t, w2t, w0mt, w1mt, w2mt, w0d, w1d, w2d, w write(*,'(99e15.6)') w0t, w1t, w2t, w0mt, w1mt, w2mt, w0d, w1d, w2d, w0md, w1md, w2md write(*,'(a30,99e26.16)') 'fi(1)*w0d*w0t', fi(1)*w0d*w0t, fi(1),w0d,w0t write(*,'(a30,99e26.16)') 'fi(2)*w0md*w0t', fi(2)*w0md*w0t, fi(2),w0md,w0t - write(*,'(a30,99e26.16)') 'fi(3)*w0d*w0mt', fi(3)*w0d*w0mt, fi(3),w0d,w0mt + write(*,'(a30,99e26.16)') 'fi(3)*w0d*w0mt', fi(3)*w0d*w0mt, fi(3),w0d,w0mt write(*,'(a30,99e26.16)') 'fi(4)*w0md*w0mt', fi(4)*w0md*w0mt, fi(4),w0md,w0mt write(*,'(a30,99e26.16)') '1 + 2 + 3 + 4', fi(1)*w0d*w0t + fi(2)*w0md*w0t + fi(3)*w0d*w0mt + fi(4)*w0md*w0mt write(*,'(A)') - write(*,'(a30,99e26.16)') 'fi(5)*w0d*w1t', fi(5)*w0d*w1t, fi(5),w0d,w1t + write(*,'(a30,99e26.16)') 'fi(5)*w0d*w1t', fi(5)*w0d*w1t, fi(5),w0d,w1t write(*,'(a30,99e26.16)') 'fi(6)*w0md*w1t', fi(6)*w0md*w1t, fi(6),w0md,w1t - write(*,'(a30,99e26.16)') 'fi(7)*w0d*w1mt', fi(7)*w0d*w1mt, fi(7),w0d,w1mt + write(*,'(a30,99e26.16)') 'fi(7)*w0d*w1mt', fi(7)*w0d*w1mt, fi(7),w0d,w1mt write(*,'(a30,99e26.16)') 'fi(8)*w0md*w1mt', fi(8)*w0md*w1mt, fi(8),w0md,w1mt write(*,'(a30,99e26.16)') 'fi(9)*w0d*w2t', fi(9)*w0d*w2t, fi(9),w0d,w2t write(*,'(a30,99e26.16)') 'fi(10)*w0md*w2t', fi(10)*w0md*w2t, fi(10),w0md,w2t - write(*,'(a30,99e26.16)') 'fi(11)*w0d*w2mt', fi(11)*w0d*w2mt, fi(11),w0d,w2mt - write(*,'(a30,99e26.16)') 'fi(12)*w0md*w2mt', fi(12)*w0md*w2mt, fi(12),w0md,w2mt - write(*,'(a30,99e26.16)') 'fi(13)*w1d*w0t', fi(13)*w1d*w0t, fi(13),w1d,w0t + write(*,'(a30,99e26.16)') 'fi(11)*w0d*w2mt', fi(11)*w0d*w2mt, fi(11),w0d,w2mt + write(*,'(a30,99e26.16)') 'fi(12)*w0md*w2mt', fi(12)*w0md*w2mt, fi(12),w0md,w2mt + write(*,'(a30,99e26.16)') 'fi(13)*w1d*w0t', fi(13)*w1d*w0t, fi(13),w1d,w0t write(*,'(a30,99e26.16)') 'fi(14)*w1md*w0t', fi(14)*w1md*w0t, fi(14),w1md,w0t - write(*,'(a30,99e26.16)') 'fi(15)*w1d*w0mt', fi(15)*w1d*w0mt, fi(15),w1d,w0mt + write(*,'(a30,99e26.16)') 'fi(15)*w1d*w0mt', fi(15)*w1d*w0mt, fi(15),w1d,w0mt write(*,'(a30,99e26.16)') 'fi(16)*w1md*w0mt', fi(16)*w1md*w0mt, fi(16),w1md,w0mt - write(*,'(a30,99e26.16)') 'fi(17)*w2d*w0t', fi(17)*w2d*w0t, fi(17),w2d,w0t + write(*,'(a30,99e26.16)') 'fi(17)*w2d*w0t', fi(17)*w2d*w0t, fi(17),w2d,w0t write(*,'(a30,99e26.16)') 'fi(18)*w2md*w0t', fi(18)*w2md*w0t, fi(18),w2md,w0t - write(*,'(a30,99e26.16)') 'fi(19)*w2d*w0mt', fi(19)*w2d*w0mt, fi(19),w2d,w0mt - write(*,'(a30,99e26.16)') 'fi(20)*w2md*w0mt', fi(20)*w2md*w0mt, fi(20),w2md,w0mt - write(*,'(a30,99e26.16)') 'fi(21)*w1d*w1t', fi(21)*w1d*w1t, fi(21),w1d,w1t + write(*,'(a30,99e26.16)') 'fi(19)*w2d*w0mt', fi(19)*w2d*w0mt, fi(19),w2d,w0mt + write(*,'(a30,99e26.16)') 'fi(20)*w2md*w0mt', fi(20)*w2md*w0mt, fi(20),w2md,w0mt + write(*,'(a30,99e26.16)') 'fi(21)*w1d*w1t', fi(21)*w1d*w1t, fi(21),w1d,w1t write(*,'(a30,99e26.16)') 'fi(22)*w1md*w1t', fi(22)*w1md*w1t, fi(22),w1md,w1t - write(*,'(a30,99e26.16)') 'fi(23)*w1d*w1mt', fi(23)*w1d*w1mt, fi(23),w1d,w1mt + write(*,'(a30,99e26.16)') 'fi(23)*w1d*w1mt', fi(23)*w1d*w1mt, fi(23),w1d,w1mt write(*,'(a30,99e26.16)') 'fi(24)*w1md*w1mt', fi(24)*w1md*w1mt, fi(24),w1md,w1mt - write(*,'(a30,99e26.16)') 'fi(25)*w2d*w1t', fi(25)*w2d*w1t, fi(25),w2d,w1t + write(*,'(a30,99e26.16)') 'fi(25)*w2d*w1t', fi(25)*w2d*w1t, fi(25),w2d,w1t write(*,'(a30,99e26.16)') 'fi(26)*w2md*w1t', fi(26)*w2md*w1t, fi(26),w2md,w1t - write(*,'(a30,99e26.16)') 'fi(27)*w2d*w1mt', fi(27)*w2d*w1mt, fi(27),w2d,w1mt + write(*,'(a30,99e26.16)') 'fi(27)*w2d*w1mt', fi(27)*w2d*w1mt, fi(27),w2d,w1mt write(*,'(a30,99e26.16)') 'fi(28)*w2md*w1mt', fi(28)*w2md*w1mt, fi(28),w2md,w1mt - write(*,'(a30,99e26.16)') 'fi(29)*w1d*w2t', fi(29)*w1d*w2t, fi(29),w1d,w2t + write(*,'(a30,99e26.16)') 'fi(29)*w1d*w2t', fi(29)*w1d*w2t, fi(29),w1d,w2t write(*,'(a30,99e26.16)') 'fi(30)*w1md*w2t', fi(30)*w1md*w2t, fi(30),w1md,w2t - write(*,'(a30,99e26.16)') 'fi(31)*w1d*w2mt', fi(31)*w1d*w2mt, fi(31),w1d,w2mt + write(*,'(a30,99e26.16)') 'fi(31)*w1d*w2mt', fi(31)*w1d*w2mt, fi(31),w1d,w2mt write(*,'(a30,99e26.16)') 'fi(32)*w1md*w2mt', fi(32)*w1md*w2mt, fi(32),w1md,w2mt - write(*,'(a30,99e26.16)') 'fi(33)*w2d*w2t', fi(33)*w2d*w2t, fi(33),w2d,w2t + write(*,'(a30,99e26.16)') 'fi(33)*w2d*w2t', fi(33)*w2d*w2t, fi(33),w2d,w2t write(*,'(a30,99e26.16)') 'fi(34)*w2md*w2t', fi(34)*w2md*w2t, fi(34),w2md,w2t - write(*,'(a30,99e26.16)') 'fi(35)*w2d*w2mt', fi(35)*w2d*w2mt, fi(35),w2d,w2mt + write(*,'(a30,99e26.16)') 'fi(35)*w2d*w2mt', fi(35)*w2d*w2mt, fi(35),w2d,w2mt write(*,'(a30,99e26.16)') 'fi(36)*w2md*w2mt', fi(36)*w2md*w2mt, fi(36),w2md,w2mt end subroutine show_h5 - + end module - + diff --git a/eos/private/helm_alloc.f90 b/eos/private/helm_alloc.f90 index 46f1c252e..28441846f 100644 --- a/eos/private/helm_alloc.f90 +++ b/eos/private/helm_alloc.f90 @@ -23,35 +23,35 @@ module helm_alloc use const_def, only: dp, use_mesa_temp_cache use math_lib - + implicit none contains - - + + subroutine alloc_helm_table(h, imax, jmax, ierr) ! This routine allocates a Helm_Table and places pointer to it in h. ! It also allocates the arrays in the Helm_Table record. - + use eos_def - + type (Helm_Table), pointer :: h integer, intent(in) :: imax, jmax integer, intent(out) :: ierr ! 0 means AOK. - + ierr = 0 - + allocate(h,stat=ierr) if (ierr /= 0) return - + h% imax = imax - h% jmax = jmax + h% jmax = jmax h% with_coulomb_corrections = .true. - + call alloc_1d_array(h% d, imax) call alloc_1d_array(h% t, jmax) - + !..for the helmholtz free energy tables call alloc_2d_array(h% f, imax, jmax) call alloc_2d_array(h% fd, imax, jmax) @@ -62,7 +62,7 @@ subroutine alloc_helm_table(h, imax, jmax, ierr) call alloc_2d_array(h% fddt, imax, jmax) call alloc_2d_array(h% fdtt, imax, jmax) call alloc_2d_array(h% fddtt, imax, jmax) - + !..for the pressure derivative with density tables call alloc_2d_array(h% dpdf, imax, jmax) call alloc_2d_array(h% dpdfd, imax, jmax) @@ -80,14 +80,14 @@ subroutine alloc_helm_table(h, imax, jmax, ierr) call alloc_2d_array(h% xfd, imax, jmax) call alloc_2d_array(h% xft, imax, jmax) call alloc_2d_array(h% xfdt, imax, jmax) - + !..for storing the differences call alloc_1d_array(h% dt_sav, jmax) call alloc_1d_array(h% dt2_sav, jmax) call alloc_1d_array(h% dti_sav, jmax) call alloc_1d_array(h% dt2i_sav, jmax) call alloc_1d_array(h% dt3i_sav, jmax) - + call alloc_1d_array(h% dd_sav, imax) call alloc_1d_array(h% dd2_sav, imax) call alloc_1d_array(h% ddi_sav, imax) @@ -95,30 +95,30 @@ subroutine alloc_helm_table(h, imax, jmax, ierr) call alloc_1d_array(h% dd3i_sav, imax) contains - + subroutine alloc_1d_array(ptr,sz) real(dp), dimension(:), pointer :: ptr - integer, intent(in) :: sz + integer, intent(in) :: sz allocate(ptr(sz),stat=ierr) end subroutine alloc_1d_array - + subroutine alloc_2d_array(ptr,sz1,sz2) real(dp), dimension(:,:), pointer :: ptr - integer, intent(in) :: sz1,sz2 + integer, intent(in) :: sz1,sz2 allocate(ptr(sz1,sz2),stat=ierr) end subroutine alloc_2d_array - - + + end subroutine alloc_helm_table - - + + subroutine setup_td_deltas(h, imax, jmax) use eos_def type (Helm_Table), pointer :: h integer, intent(in) :: imax, jmax integer :: i, j real(dp) dth,dt2,dti,dt2i,dt3i,dd,dd2,ddi,dd2i,dd3i - !..construct the temperature and density deltas and their inverses + !..construct the temperature and density deltas and their inverses do j=1,jmax-1 dth = h% t(j+1) - h% t(j) dt2 = dth * dth @@ -149,7 +149,7 @@ end subroutine setup_td_deltas subroutine read_helm_table(h, data_dir, cache_dir, temp_cache_dir, use_cache, ierr) use eos_def use utils_lib, only: mv, switch_str - + implicit none type (Helm_Table), pointer :: h @@ -157,7 +157,7 @@ subroutine read_helm_table(h, data_dir, cache_dir, temp_cache_dir, use_cache, ie logical, intent(IN) :: use_cache integer, intent(out) :: ierr -!..this routine reads the helmholtz eos file, and +!..this routine reads the helmholtz eos file, and !..must be called once before the helmeos routine is invoked. !..declare local variables @@ -169,16 +169,16 @@ subroutine read_helm_table(h, data_dir, cache_dir, temp_cache_dir, use_cache, ie integer i,j,k,ios,imax,jmax,n real(dp) tsav,dsav logical, parameter :: dmp = .false. - + ierr = 0 vec => vec_ary - + !..read the normal helmholtz free energy table h% logtlo = 3.0d0 h% logthi = 13.0d0 h% logdlo = -12.0d0 h% logdhi = 15.0d0 - + h% templo = exp10(h% logtlo) h% temphi = exp10(h% logthi) h% denlo = exp10(h% logdlo) @@ -190,19 +190,19 @@ subroutine read_helm_table(h, data_dir, cache_dir, temp_cache_dir, use_cache, ie h% logtstpi = 1.0d0/h% logtstp h% logdstp = (h% logdhi - h% logdlo)/real(imax-1,kind=dp) h% logdstpi = 1.0d0/h% logdstp - + ios = -1 if (use_cache) then write(filename,'(2a)') trim(cache_dir), '/helm_table.bin' open(unit=19,file=trim(filename), & action='read',status='old',iostat=ios,form='unformatted') end if - + if (ios .eq. 0) then - + read(19) imax read(19) jmax - + if (imax /= h% imax .or. jmax /= h% jmax) then ios = 1 ! wrong cached info else @@ -227,7 +227,7 @@ subroutine read_helm_table(h, data_dir, cache_dir, temp_cache_dir, use_cache, ie read(19) h% xfd(1:imax,1:jmax) read(19) h% xft(1:imax,1:jmax) read(19) h% xfdt(1:imax,1:jmax) - + do j=1,jmax tsav = h% logtlo + (j-1)*h% logtstp h% t(j) = exp10(tsav) @@ -237,23 +237,23 @@ subroutine read_helm_table(h, data_dir, cache_dir, temp_cache_dir, use_cache, ie h% d(i) = exp10(dsav) enddo end if - + close(unit=19) end if if (ios .ne. 0) then - + write(filename,'(2a)') trim(data_dir), '/helm_table.dat' - write(*,*) 'read ', trim(filename) - + write(*,*) 'read ', trim(filename) + ios = 0 open(unit=19,file=trim(filename),action='read',status='old',iostat=ios) - if (ios .ne. 0) then + if (ios .ne. 0) then write(*,'(3a,i6)') 'failed to open ', trim(filename), ' : ios ', ios ierr = -1 return end if - + do j=1,jmax tsav = h% logtlo + (j-1)*h% logtstp h% t(j) = exp10(tsav) @@ -356,19 +356,19 @@ subroutine read_helm_table(h, data_dir, cache_dir, temp_cache_dir, use_cache, ie close(unit=19) !..write cachefile - + if (dmp) call mesa_error(__FILE__,__LINE__,'helm_alloc') - + ios = -1 if (use_cache) then write(filename,'(2a)') trim(cache_dir), '/helm_table.bin' write(temp_filename,'(2a)') trim(temp_cache_dir), '/helm_table.bin' - write(*,*) 'write ', trim(filename) + write(*,*) 'write ', trim(filename) open(unit=19,file=trim(switch_str(temp_filename, filename, use_mesa_temp_cache)), & status='replace', iostat=ios,action='write',form='unformatted') end if - - if (ios == 0) then + + if (ios == 0) then write(19) imax write(19) jmax write(19) h% f(1:imax,1:jmax) @@ -393,12 +393,12 @@ subroutine read_helm_table(h, data_dir, cache_dir, temp_cache_dir, use_cache, ie write(19) h% xft(1:imax,1:jmax) write(19) h% xfdt(1:imax,1:jmax) close(unit=19) - + if (use_mesa_temp_cache) call mv(temp_filename,filename,.true.) - - end if - - end if + + end if + + end if call setup_td_deltas(h, imax, jmax) @@ -409,12 +409,12 @@ end subroutine read_helm_table subroutine free_helm_table(h) use eos_def - + type (Helm_Table), pointer :: h - + call do_free(h% d) call do_free(h% t) - + call do_free2(h% f) call do_free2(h% fd) call do_free2(h% ft) @@ -454,17 +454,17 @@ subroutine free_helm_table(h) call do_free(h% ddi_sav) call do_free(h% dd2i_sav) call do_free(h% dd3i_sav) - + deallocate(h) nullify(h) - + contains - + subroutine do_free(array_ptr) real(dp), pointer :: array_ptr(:) if (associated(array_ptr)) deallocate(array_ptr) end subroutine do_free - + subroutine do_free2(array_ptr) real(dp), pointer :: array_ptr(:,:) if (associated(array_ptr)) deallocate(array_ptr) @@ -472,7 +472,7 @@ end subroutine do_free2 end subroutine free_helm_table - - + + end module helm_alloc diff --git a/eos/private/helm_polynomials.f90 b/eos/private/helm_polynomials.f90 index 3ad66aaf1..6258932f6 100644 --- a/eos/private/helm_polynomials.f90 +++ b/eos/private/helm_polynomials.f90 @@ -30,17 +30,17 @@ end function dddpsi0 !..psi1 and its derivatives - pure real(dp) function psi1(z) + pure real(dp) function psi1(z) real(dp), intent(in) :: z psi1 = z* (z*z * ( z * (-3.0d0*z + 8.0d0) - 6.0d0) + 1.0d0) end function psi1 - pure real(dp) function dpsi1(z) + pure real(dp) function dpsi1(z) real(dp), intent(in) :: z dpsi1 = z*z * ( z * (-15.0d0*z + 32.0d0) - 18.0d0) +1.0d0 end function dpsi1 - pure real(dp) function ddpsi1(z) + pure real(dp) function ddpsi1(z) real(dp), intent(in) :: z ddpsi1 = z * (z * (-60.0d0*z + 96.0d0) -36.0d0) end function ddpsi1 @@ -52,17 +52,17 @@ end function dddpsi1 !..psi2 and its derivatives - pure real(dp) function psi2(z) + pure real(dp) function psi2(z) real(dp), intent(in) :: z psi2 = 0.5d0*z*z*( z* ( z * (-z + 3.0d0) - 3.0d0) + 1.0d0) end function psi2 - pure real(dp) function dpsi2(z) + pure real(dp) function dpsi2(z) real(dp), intent(in) :: z dpsi2 = 0.5d0*z*( z*(z*(-5.0d0*z + 12.0d0) - 9.0d0) + 2.0d0) end function dpsi2 - pure real(dp) function ddpsi2(z) + pure real(dp) function ddpsi2(z) real(dp), intent(in) :: z ddpsi2 = 0.5d0*(z*( z * (-20.0d0*z + 36.0d0) - 18.0d0) +2.0d0) end function ddpsi2 @@ -105,12 +105,12 @@ end function h5 !..cubic hermite polynomial statement functions !..psi0 & derivatives - pure real(dp) function xpsi0(z) + pure real(dp) function xpsi0(z) real(dp), intent(in) :: z xpsi0 = z * z * (2.0d0*z - 3.0d0) + 1.0d0 end function xpsi0 - pure real(dp) function xdpsi0(z) + pure real(dp) function xdpsi0(z) real(dp), intent(in) :: z xdpsi0 = z * (6.0d0*z - 6.0d0) end function xdpsi0 @@ -127,12 +127,12 @@ end function xdddpsi0 !..psi1 & derivatives - pure real(dp) function xpsi1(z) + pure real(dp) function xpsi1(z) real(dp), intent(in) :: z xpsi1 = z * ( z * (z - 2.0d0) + 1.0d0) end function xpsi1 - pure real(dp) function xdpsi1(z) + pure real(dp) function xdpsi1(z) real(dp), intent(in) :: z xdpsi1 = z * (3.0d0*z - 4.0d0) + 1.0d0 end function xdpsi1 diff --git a/eos/private/ideal.f90 b/eos/private/ideal.f90 index 44bc682fd..add5f9a51 100644 --- a/eos/private/ideal.f90 +++ b/eos/private/ideal.f90 @@ -12,7 +12,7 @@ module ideal contains - subroutine get_ideal_alfa( & + subroutine get_ideal_alfa( & rq, logRho, logT, Z, abar, zbar, & alfa, d_alfa_dlogT, d_alfa_dlogRho, & ierr) @@ -62,7 +62,7 @@ end subroutine get_ideal_for_eosdt subroutine get_ideal_eos_results( & rq, Z, X, abar, zbar, Rho, logRho, T, logT, & - species, chem_id, xa, res, d_dlnd, d_dlnT, d_dxa, ierr) + species, chem_id, xa, res, d_dlnd, d_dlnT, d_dxa, ierr) type (EoS_General_Info), pointer :: rq real(dp), intent(in) :: Z, X, abar, zbar real(dp), intent(in) :: Rho, logRho, T, logT @@ -110,7 +110,7 @@ subroutine ideal_eos( & real(dp), intent(out), dimension(nv) :: res, d_dlnd, d_dlnT real(dp), intent(out), dimension(nv, species) :: d_dxa real(dp), parameter :: mass_fraction_limit = 1d-10 - + integer :: relevant_species type(auto_diff_real_2var_order3) :: temp, den real(dp) :: ACMI(species), A(species), ya(species), select_xa(species), norm @@ -121,7 +121,7 @@ subroutine ideal_eos( & ierr = 0 F_ele = 0d0 F_coul = 0d0 - + ! No electrons, so extreme negative chemical potential etaele = -1d99 xnefer = 1d-20 @@ -135,7 +135,7 @@ subroutine ideal_eos( & temp = temp_in temp%d1val1 = 1d0 den = den_in - den%d1val2 = 1d0 + den%d1val2 = 1d0 ! Count and pack relevant species for Coulomb corrections. Relevant means mass fraction above limit. relevant_species = 0 @@ -180,7 +180,7 @@ subroutine ideal_eos( & call pack_for_export(F_ideal_ion, F_coul, F_rad, F_ele, temp, den, xnefer, etaele, abar, zbar, & phase, latent_ddlnT, latent_ddlnRho, res, d_dlnd, d_dlnT, ierr) if(ierr/=0) return - + res(i_mu) = abar ! ideal assumes neutral matter, whereas pack_for_export assumes ionized matter. So we patch it up here. end subroutine ideal_eos diff --git a/eos/private/ion_offset.f90 b/eos/private/ion_offset.f90 index 8485578d3..c0f5d4836 100644 --- a/eos/private/ion_offset.f90 +++ b/eos/private/ion_offset.f90 @@ -6,8 +6,8 @@ module ion_offset logical, parameter :: dbg = .false. !logical, parameter :: dbg = .true. - - + + private public :: compute_ion_offset diff --git a/eos/private/pc_eos.f90 b/eos/private/pc_eos.f90 index 51c020d0a..157f72fc3 100644 --- a/eos/private/pc_eos.f90 +++ b/eos/private/pc_eos.f90 @@ -5,11 +5,11 @@ module pc_eos use const_def, only: dp, PI implicit none - + contains - + !* Equation of state for fully ionized electron-ion plasmas (EOS EIP) -! A.Y.Potekhin & G.Chabrier, Contrib. Plasma Phys., 50 (2010) 82, +! A.Y.Potekhin & G.Chabrier, Contrib. Plasma Phys., 50 (2010) 82, ! and references therein ! Please communicate comments/suggestions to Alexander Potekhin: ! palex@astro.ioffe.ru @@ -54,7 +54,7 @@ module pc_eos ! ELECT11 - for an ideal electron gas of arbitrary degeneracy and ! relativity at given temperature and electron chemical ! potential, renders number density (in atomic units), free -! energy, pressure, internal energy, entropy, heat capacity +! energy, pressure, internal energy, entropy, heat capacity ! (normalized to the electron ideal-gas values), logarithmic ! derivatives of pressure over temperature and density. ! EXCOR7 - electron-electron (exchange-correlation) contributions to @@ -187,7 +187,7 @@ module pc_eos ! C%C 113 format(I3,2F8.3,1PE12.4) ! C%C 114 format(' Z CMI x_j') ! C%C end - + subroutine MELANGE9(NMIX,AY,AZion,ACMI,RHO,TEMP, & GAMIlo,GAMIhi,PRADnkT, & DENS,Zmean,CMImean,Z2mean,GAMImean,CHI,TPT,LIQSOL, & @@ -197,7 +197,7 @@ subroutine MELANGE9(NMIX,AY,AZion,ACMI,RHO,TEMP, & ! Wigner-Kirkwood correction for the entropy corrected 28.05.15 ! Stems from MELANGE8 v.26.12.09. ! Difference: output PRADnkT instead of input KRAD -! + EOS of fully ionized electron-ion plasma mixture. +! + EOS of fully ionized electron-ion plasma mixture. ! Limitations: ! (a) inapplicable in the regimes of ! (1) bound-state formation, @@ -242,7 +242,7 @@ subroutine MELANGE9(NMIX,AY,AZion,ACMI,RHO,TEMP, & type(auto_diff_real_2var_order1), intent(out) :: PRADnkT, DENS, GAMImean real(dp), intent(out) :: Zmean, CMImean, Z2mean type(auto_diff_real_2var_order1), intent(out) :: CHI, TPT, PnkT, UNkT, SNk, CV, CHIR, CHIT - + integer :: IX, I, J real(dp) :: Y, Z13, Z52, Z53, Z73, Z321, Zion, CMI type(auto_diff_real_2var_order1) :: UINTRAD, PRESSRAD @@ -352,7 +352,7 @@ subroutine MELANGE9(NMIX,AY,AZion,ACMI,RHO,TEMP, & CMI=ACMI(IX) GAMI=pow(Zion,5d0/3d0)*GAME ! Gamma_i for given ion species DNI=DENSI*AY(IX) ! number density of ions of given type - PRI=DNI*TEMP ! = ideal-ions partial pressure (normalization) + PRI=DNI*TEMP ! = ideal-ions partial pressure (normalization) if (LIQSOL == 0 .or. LIQSOL == 1) then call EOSFI8(LIQSOL,CMI,Zion,RS,GAMI, & FC1,UC1,PC1,SC1,CV1,PDT1,PDR1, & @@ -381,7 +381,7 @@ subroutine MELANGE9(NMIX,AY,AZion,ACMI,RHO,TEMP, & CV2 = alfa*CV2_1 + beta*CV2_0 PDT2 = alfa*PDT2_1 + beta*PDT2_0 PDR2 = alfa*PDR2_1 + beta*PDR2_0 - end if + end if ! First-order TD functions: UINT=UINT+UC2*PRI ! internal energy density (e+i+Coul.) Stot=Stot+DNI*(SC2-log(AY(IX))) !entropy per unit volume[a.u.] @@ -457,11 +457,11 @@ subroutine MELANGE9(NMIX,AY,AZion,ACMI,RHO,TEMP, & ! Second-order: CV=CVtot/DENSI ! C_V per ion CHIR=PDLR/PRESS ! d ln P / d ln\rho - CHIT=PDLT/PRESS ! d ln P / d ln T + CHIT=PDLT/PRESS ! d ln P / d ln T ! CHIT=CHIT+4.*PRESSRAD/PRESS ! d ln P / d ln T return end subroutine MELANGE9 - + subroutine EOSFI8(LIQSOL,CMI,Zion,RS,GAMI, & FC1,UC1,PC1,SC1,CV1,PDT1,PDR1, & FC2,UC2,PC2,SC2,CV2,PDT2,PDR2,ierr) @@ -471,18 +471,18 @@ subroutine EOSFI8(LIQSOL,CMI,Zion,RS,GAMI, & ! slight cleaning 10.12.14 ! Non-ideal parts of thermodynamic functions in the fully ionized plasma ! Stems from EOSFI5 and EOSFI05 v.04.10.05 -! Input: LIQSOL=0/1(liquid/solid), +! Input: LIQSOL=0/1(liquid/solid), ! Zion,CMI - ion charge and mass numbers, ! RS=r_s (electronic density parameter), ! GAMI=Gamma_i (ion coupling), -! Output: FC1 and UC1 - non-ideal "ii+ie+ee" contribution to the +! Output: FC1 and UC1 - non-ideal "ii+ie+ee" contribution to the ! free and internal energies (per ion per kT), ! PC1 - analogous contribution to pressure divided by (n_i kT), ! CV1 - "ii+ie+ee" heat capacity per ion [units of k] ! PDT1=(1/n_i kT)*(d P_C/d ln T)_V ! PDR1=(1/n_i kT)*(d P_C/d ln\rho)_T ! FC2,UC2,PC2,SC2,CV2 - analogous to FC1,UC1,PC1,SC1,CV1, but including -! the part corresponding to the ideal ion gas. This is useful for +! the part corresponding to the ideal ion gas. This is useful for ! preventing accuracy loss in some cases (e.g., when SC2 << SC1). ! FC2 does not take into account the entropy of mixing S_{mix}: in a ! mixture, S_{mix}/(N_i k) has to be added externally (see MELANGE9). @@ -504,8 +504,8 @@ subroutine EOSFI8(LIQSOL,CMI,Zion,RS,GAMI, & type(auto_diff_real_2var_order1) :: Fah,Uah,Pah,CVah,PDTah,PDRah type(auto_diff_real_2var_order1) :: FSCR,USCR,PSCR,S_SCR,CVSCR,PDTSCR,PDRSCR type(auto_diff_real_2var_order1) :: FC0, UC0, PC0, SC0, CV0, PDT0, PDR0 - - real(dp), parameter :: TINY=1.d-20 + + real(dp), parameter :: TINY=1.d-20 real(dp), parameter :: AUM=1822.888d0 ! a.m.u/m_e ierr = 0 @@ -602,7 +602,7 @@ subroutine EOSFI8(LIQSOL,CMI,Zion,RS,GAMI, & PC2=PItot+PC0 SC2=SCItot+SC0 CV2=CVItot+CV0 - PDT2=PDTi+PDT0 + PDT2=PDTi+PDT0 PDR2=PDRi+PDR0 return end subroutine EOSFI8 @@ -635,7 +635,7 @@ subroutine FITION9(GAMI, & real(dp), parameter :: C2=-8.4d-5 real(dp), parameter :: G2=.0037d0 real(dp), parameter :: SQ32=.8660254038d0 ! SQ32=sqrt(3)/2 - + real(dp) :: & xFION, dFION_dlnGAMI, & xUION, dUION_dlnGAMI, & @@ -669,7 +669,7 @@ subroutine FITION9(GAMI, & PDTii=CVii/3.0d0 ! p_{ii} + d p_{ii} / d ln T endif - + if (use_FITION9_table .or. debug_FITION9_table) then ierr = 0 call get_FITION9(GAMI%val, & @@ -733,7 +733,7 @@ subroutine FITION9(GAMI, & contains - + logical function check1(v, xv, str) type(auto_diff_real_2var_order1), intent(in) :: v real(dp), intent(in) :: xv @@ -790,10 +790,10 @@ subroutine FSCRliq8(RS,GAME,Zion, & type(auto_diff_real_2var_order1) :: DN1, DN1DX, DN1DG, DN1DXX, DN1DGG, DN1DXG type(auto_diff_real_2var_order1) :: DN, DNDX, DNDG, DNDXX, DNDGG, DNDXG type(auto_diff_real_2var_order1) :: FX, FXDG, FDX, FG, FDG, FDGDH, FDXX, FDGG, FDXG - + real(dp), parameter :: XRS=.0140047d0 real(dp), parameter :: TINY=1.d-19 - + real(dp) :: & xFSCR, dFSCR_dlnRS, dFSCR_dlnGAME, & xUSCR, dUSCR_dlnRS, dUSCR_dlnGAME, & @@ -821,7 +821,7 @@ subroutine FSCRliq8(RS,GAME,Zion, & PDRSCR=0.d0 return endif - + if (use_FSCRliq8_table .or. debug_FSCRliq8_table) then ierr = 0 call get_FSCRliq8(int(Zion), RS%val, GAME%val, & @@ -831,7 +831,7 @@ subroutine FSCRliq8(RS,GAME,Zion, & xCVSCR, dCVSCR_dlnRS, dCVSCR_dlnGAME, & xPDTSCR, dPDTSCR_dlnRS, dPDTSCR_dlnGAME, & xPDRSCR, dPDRSCR_dlnRS, dPDRSCR_dlnGAME, skip, ierr) - if (ierr /= 0) return + if (ierr /= 0) return else skip = .true. endif @@ -981,7 +981,7 @@ subroutine FSCRliq8(RS,GAME,Zion, & CVSCR% d1val2 = dCVSCR_dlnRS * dlnRS_dRho + dCVSCR_dlnGAME * dlnGAME_dRho PDTSCR% d1val2 = dPDTSCR_dlnRS * dlnRS_dRho + dPDTSCR_dlnGAME * dlnGAME_dRho PDRSCR% d1val2 = dPDRSCR_dlnRS * dlnRS_dRho + dPDRSCR_dlnGAME * dlnGAME_dRho - + end if contains @@ -1045,7 +1045,7 @@ subroutine FSCRsol8(RS,GAMI,Zion,TPT, & type(auto_diff_real_2var_order1) :: GR3, GR3X, GR3DX, GR3G, GR3DG, GR3DXX, GR3DGG, GR3DXG type(auto_diff_real_2var_order1) :: W, WDX, WDG, WDXX, WDGG, WDXG type(auto_diff_real_2var_order1) :: FDX, FDG, FDXX, FDGG, FDXG - + real(dp) :: AP(4) real(dp) :: ENAT real(dp) :: TINY @@ -1191,7 +1191,7 @@ subroutine ANHARM8(GAMI,TPT,Fah,Uah,Pah,CVah,PDTah,PDRah) type(auto_diff_real_2var_order1), intent(in) :: GAMI,TPT type(auto_diff_real_2var_order1), intent(out) :: Fah,Uah,Pah,CVah,PDTah,PDRah integer, parameter :: NM=3 - + integer :: N real(dp) :: AA(3) type(auto_diff_real_2var_order1) :: CK, TPT2, TPT4, TQ, TK2, SUP @@ -1205,7 +1205,7 @@ subroutine ANHARM8(GAMI,TPT,Fah,Uah,Pah,CVah,PDTah,PDRah) AA(2) = 247.0d0 AA(3) = 1.765d5 - + CK=B1/AA(1) ! fit coefficient TPT2=TPT*TPT TPT4=TPT2*TPT2 @@ -1242,7 +1242,7 @@ end subroutine ANHARM8 subroutine FHARM12(GAMI,TPT, & Fharm,Uharm,Pharm,CVth,Sharm,PDTharm,PDRharm) ! Thermodynamic functions of a harmonic crystal, incl.stat.Coul.lattice -! +! ! Version 27.04.12 ! Stems from FHARM8 v.15.02.08 ! Replaced HLfit8 with HLfit12: rearranged output. @@ -1255,9 +1255,9 @@ subroutine FHARM12(GAMI,TPT, & type(auto_diff_real_2var_order1) :: Fth,Uth,Sth,U0,E0 type(auto_diff_real_2var_order1) :: F,U,U1 - + real(dp), parameter :: CM = .895929256d0 ! Madelung - + call HLfit12(TPT,F,U,CVth,Sth,U1,1) U0=-CM*GAMI ! perfect lattice E0=1.5d0*U1*TPT ! zero-point energy @@ -1294,10 +1294,10 @@ subroutine HLfit12(eta,F,U,CV,S,U1,LATTICE) real(dp) :: B0, B2, B4, B5, B6, B7, B9, B11 real(dp) :: C9, C11 type(auto_diff_real_2var_order1) :: UP, DN, EA, EB, EG, UP1, UP2, DN1, DN2, E0 - + real(dp) :: EPS real(dp) :: TINY - + EPS=1.d-5 TINY=1.d-99 @@ -1414,11 +1414,11 @@ subroutine CORMIX(RS,GAME,Zmean,Z2mean,Z52,Z53,Z321, & type(auto_diff_real_2var_order1) :: GAMImean, Dif0, DifR, DifFDH, D type(auto_diff_real_2var_order1) :: P3, D0, GP, FMIX0, Q, R, GQ, G, GDG, UDG - + real(dp) :: TINY TINY=1.d-9 - + GAMImean=GAME*Z53 if (RS.lt.TINY) then ! OCP Dif0=Z52-sqrt(Z2mean*Z2mean*Z2mean/Zmean) @@ -1462,7 +1462,7 @@ subroutine ELECT11(TEMP,CHI, & DlnDH,DlnDT,DlnDHH,DlnDTT,DlnDHT) ! Version 17.11.11 ! ELECT9 v.04.03.09 + smooth match of two fits at chi >> 1 + add.outputs -! Compared to ELECTRON v.06.07.00, this S/R is completely rewritten: +! Compared to ELECTRON v.06.07.00, this S/R is completely rewritten: ! numerical differentiation is avoided now. ! Compared to ELECT7 v.06.06.07, ! - call BLIN7 is changed to call BLIN9, @@ -1486,7 +1486,7 @@ subroutine ELECT11(TEMP,CHI, & type(auto_diff_real_2var_order1) :: X2, FP, FM type(auto_diff_real_2var_order1) :: DENSa,FEida,PEida,UEida,SEida,CVEa,CHITEa,CHIREa,DlnDHa,DlnDTa,DlnDHHa,DlnDTTa,DlnDHTa type(auto_diff_real_2var_order1) :: DENSb,FEidb,PEidb,UEidb,SEidb,CVEb,CHITEb,CHIREb,DlnDHb,DlnDTb,DlnDHHb,DlnDTTb,DlnDHTb - + type(auto_diff_real_2var_order1) :: CHI1 type(auto_diff_real_2var_order1) :: CHI2 type(auto_diff_real_2var_order1) :: XMAX @@ -1500,7 +1500,7 @@ subroutine ELECT11(TEMP,CHI, & DCHI1=0.1d0 DCHI2=CHI2-CHI1-DCHI1 XSCAL2=XMAX/DCHI2 - + X2=(CHI-CHI2)*XSCAL2 if (X2.lt.-XMAX) then call ELECT11a(TEMP,CHI, & @@ -1549,14 +1549,14 @@ subroutine ELECT11a(TEMP,CHI, & type(auto_diff_real_2var_order1) :: W2,W2DX,W2DT,W2DXX,W2DTT,W2DXT type(auto_diff_real_2var_order1) :: W0XXX,W0XTT,W0XXT type(auto_diff_real_2var_order1) :: TPI, DENR, PR, U - type(auto_diff_real_2var_order1) :: dndT, dPdT, dUdT, dndH, dPdH, dUdH + type(auto_diff_real_2var_order1) :: dndT, dPdT, dUdT, dndH, dPdH, dUdH type(auto_diff_real_2var_order1) :: dndHH, dndHT, dndTT type(auto_diff_real_2var_order1) :: BOHR type(auto_diff_real_2var_order1) :: PI2 type(auto_diff_real_2var_order1) :: BOHR2 type(auto_diff_real_2var_order1) :: BOHR3 - + BOHR=137.036d0 PI2=PI*PI BOHR2=BOHR*BOHR @@ -1612,7 +1612,7 @@ subroutine ELECT11b(TEMP,CHI, & type(auto_diff_real_2var_order1) :: TEMR, EF, DeltaEF, G, PF, F, DF, P, DelP, S, U type(auto_diff_real_2var_order1) :: DENR, DT, D1, D2 type(auto_diff_real_2var_order1) :: TPI, dndH, dndT, dndHH, dndHT, dndTT - type(auto_diff_real_2var_order1) :: W0,W0DX,W0DT,W0DXX,W0DTT,W0DXT,W1,W1DX,W1DT,W1DXX,W1DTT,W1DXT,W2,W2DX,W2DT,W2DXX,W2DTT,W2DXT,W0XXX,W0XTT,W0XXT + type(auto_diff_real_2var_order1) :: W0,W0DX,W0DT,W0DXX,W0DTT,W0DXT,W1,W1DX,W1DT,W1DXX,W1DTT,W1DXT,W2,W2DX,W2DT,W2DXX,W2DTT,W2DXT,W0XXX,W0XTT,W0XXT type(auto_diff_real_2var_order1) :: BOHR type(auto_diff_real_2var_order1) :: PI2 @@ -1803,7 +1803,7 @@ subroutine FERMI10(X,XMAX,FP,FM) type(auto_diff_real_2var_order1), intent(in) :: X type(auto_diff_real_2var_order1) :: XMAX ! not sure if this side-effect is desired type(auto_diff_real_2var_order1), intent(out) :: FP, FM - + if (XMAX.lt.3.d0) XMAX = 3d0 !call mesa_error(__FILE__,__LINE__,'FERMI: XMAX') if (X.gt.XMAX) then FP=0.d0 @@ -1889,7 +1889,7 @@ subroutine EXCOR7(RS,GAME,FXC,UXC,PXC,CVXC,SXC,PDTXC,PDRXC) endif if (.not. use_EXCOR7_table .or. debug_EXCOR7_table .or. skip) then - + THETA=0.543d0*RS/GAME ! non-relativistic degeneracy parameter SQTH=sqrt(THETA) THETA2=THETA*THETA @@ -2110,9 +2110,9 @@ subroutine EXCOR7(RS,GAME,FXC,UXC,PXC,CVXC,SXC,PDTXC,PDRXC) PDRXC% d1val2 = dPDRXC_dlnRS * dlnRS_dRho + dPDRXC_dlnGAME * dlnGAME_dRho end if - + contains - + logical function check1(v, xv, str) type(auto_diff_real_2var_order1), intent(in) :: v real(dp), intent(in) :: xv @@ -2157,7 +2157,7 @@ subroutine FERINV7(F,N,X,XDF,XDFF) ! Inverse Fermi intergals integer :: I type(auto_diff_real_2var_order1) :: P, T, T1, T2, UP, UP1, UP2, DOWN, DOWN1, DOWN2 type(auto_diff_real_2var_order1) :: R, R1, R2, RT - + ! The next four are really parameters but there isn't a clean way to initialize them ! at declaration time. - Adam Jermyn 4/2/2020 real(dp) :: A(0:5,0:3) ! read only after initialization @@ -2225,7 +2225,7 @@ subroutine FERINV7(F,N,X,XDF,XDFF) ! Inverse Fermi intergals -2.315515517515d-2,9.198776585252d-2,-3.835879295548d-1, & 5.415026856351d-1,-3.847241692193d-1,3.739781456585d-2, & -3.008504449098d-2/) ! X_{5/2} - + if (N.lt.0d0 .or.N.gt.3d0) call mesa_error(__FILE__,__LINE__,'FERINV7: Invalid subscript') if (F.le.0.d0) F = 1d-99 !call mesa_error(__FILE__,__LINE__,'FERINV7: Non-positive argument') if (F.lt.4.d0) then @@ -2310,7 +2310,7 @@ subroutine BLIN9(TEMP,CHI, & type(auto_diff_real_2var_order1) :: W1b,W1DXb,W1DTb,W1DXXb,W1DTTb,W1DXTb type(auto_diff_real_2var_order1) :: W2b,W2DXb,W2DTb,W2DXXb,W2DTTb,W2DXTb type(auto_diff_real_2var_order1) :: W0XXXb,W0XTTb,W0XXTb - + type(auto_diff_real_2var_order1) :: CHI1 type(auto_diff_real_2var_order1) :: CHI2 type(auto_diff_real_2var_order1) :: XMAX @@ -2326,7 +2326,7 @@ subroutine BLIN9(TEMP,CHI, & DCHI2=CHI2-CHI1-DCHI1 XSCAL1=XMAX/DCHI1 XSCAL2=XMAX/DCHI2 - + X1=(CHI-CHI1)*XSCAL1 X2=(CHI-CHI2)*XSCAL2 if (X1.lt.-XMAX) then @@ -2381,7 +2381,7 @@ subroutine BLIN9(TEMP,CHI, & W2DT=W2DTa*FP+W2DTb*FM W2DXX=W2DXXa*FP+W2DXXb*FM !! +2.d0*(W2DXa-W2DXb)*F1+(W2a-W2b)*F2 W2DTT=W2DTTa*FP+W2DTTb*FM - W2DXT=W2DXTa*FP+W2DXTb*FM !! + W2DXT=W2DXTa*FP+W2DXTb*FM !! else call BLIN9c(TEMP,CHI, & W0,W0DX,W0DT,W0DXX,W0DTT,W0DXT, & @@ -2538,7 +2538,7 @@ subroutine BLIN9b(TEMP,CHI, & (/.29505869d0, .32064856d0, 7.3915570d-2, & 3.6087389d-3, 2.3369894d-5/) ! \bar{V}_i real(dp), parameter :: EPS=1.d-3 - + if (CHI.lt.EPS) CHI = EPS !call mesa_error(__FILE__,__LINE__,'BLIN9b: CHI is too small') do K=0,2 W=0.d0 @@ -2660,7 +2660,7 @@ subroutine BLIN9c(TEMP,CHI, & type(auto_diff_real_2var_order1) :: FJ0XXX, FJ0XXT, FJ0XTT type(auto_diff_real_2var_order1) :: FJ1, FJ1DX, FJ1DT, FJ1DXX, FJ1DXT, FJ1DTT type(auto_diff_real_2var_order1) :: FJ2, FJ2DX, FJ2DT, FJ2DXX, FJ2DXT, FJ2DTT - + integer :: J, K real(dp), parameter :: PI26=PI*PI/6. @@ -2874,7 +2874,7 @@ subroutine CHEMFIT(DENS,TEMP,CHI) type(auto_diff_real_2var_order1), intent(out) :: CHI type(auto_diff_real_2var_order1) :: DENR,TEMR,CMU1,CMUDENR,CMUDT,CMUDTT - + DENR=DENS/2.5733806d6 ! n_e in rel.un.=\lambda_{Compton}^{-3} TEMR=TEMP/1.8778865d4 ! T in rel.un.=(mc^2/k)=5.93e9 K call CHEMFIT7(DENR,TEMR,CHI,CMU1,0,CMUDENR,CMUDT,CMUDTT) @@ -2909,13 +2909,13 @@ subroutine CHEMFIT7(DENR,TEMR,CHI,CMU1,KDERIV, & type(auto_diff_real_2var_order1) :: HDY, HDT, HDYY, HDTT, HDYT type(auto_diff_real_2var_order1) :: CTY, CTT, CTDY, CTDT, CTDYY, CTDTT, CTDYT type(auto_diff_real_2var_order1) :: CHIDT, CHIDTT, CHIDYT - + real(dp), parameter :: PARA=1.612d0 real(dp), parameter :: PARB=6.192d0 real(dp), parameter :: PARC=0.0944d0 real(dp), parameter :: PARF=5.535d0 real(dp), parameter :: PARG=0.698d0 - + PF0=pow(29.6088132d0*DENR,1d0/3d0) ! Classical Fermi momentum if (PF0.gt.1.d-4) then TF=sqrt(1.d0+PF0*PF0)-1.d0 ! Fermi temperature @@ -2931,7 +2931,7 @@ subroutine CHEMFIT7(DENR,TEMR,CHI,CMU1,KDERIV, & THETAG=pow(THETA,PARG) D3=PARB*THETAC*T1*T1+PARF*THETAG Q3=1.365568127d0-U3/D3 ! 1.365...=2/\pi^{1/3} - if (THETA.gt.1.d-5) then + if (THETA.gt.1.d-5) then Q1=1.5d0*T1/(1.d0-T1) else Q1=1.5d0/THETA @@ -2958,7 +2958,7 @@ subroutine CHEMFIT7(DENR,TEMR,CHI,CMU1,KDERIV, & CHIDY=-XDF/THETA52 ! d\chi/d\theta CHIDYY=(XDFF/pow4(THETA)-2.5d0*CHIDY)/THETA ! d^2\chi/d\theta^2 ! (b): Relativistic corrections: - if (THETA.gt.1.d-5) then + if (THETA.gt.1.d-5) then Q1D=-Q1/(1.d0-T1) Q1DD=-Q1D*(1.d0+T1)/(1.d0-T1) else @@ -3002,5 +3002,5 @@ subroutine CHEMFIT7(DENR,TEMR,CHI,CMU1,KDERIV, & CMUDTT=2.d0*(CHIDY/TF+CHIDT+THETA*CHIDYT)+THETA/TF*CHIDYY+TEMR*CHIDTT return end subroutine CHEMFIT7 - + end module pc_eos diff --git a/eos/private/pc_support.f90 b/eos/private/pc_support.f90 index b7e7a0b12..9a2c07fd6 100644 --- a/eos/private/pc_support.f90 +++ b/eos/private/pc_support.f90 @@ -5,7 +5,7 @@ module pc_support use math_lib implicit none - + public :: get_FITION9, get_EXCOR7, get_FSCRliq8 private @@ -28,10 +28,10 @@ module pc_support integer, parameter :: iPDRSCR = 6 integer, parameter :: nvals_FSCRliq8 = 6 - + contains - - + + subroutine get_FITION9(GAMI, & FION, dFION_dlnGAMI, & UION, dUION_dlnGAMI, & @@ -56,22 +56,22 @@ subroutine get_FITION9(GAMI, & integer, parameter :: iPION = 3 integer, parameter :: iCVii = 4 integer, parameter :: iPDTii = 5 - integer, parameter :: iPDRii = 6 + integer, parameter :: iPDRii = 6 real(dp) :: lnGAMI_min, lnGAMI_max, dlnGAMI, lnGAMI integer :: nlnGAMI, k_old real(dp) :: xk_old, xkp1_old, xk_new, delta real(dp), pointer, dimension(:,:) :: f_1, f_2, f_3, f_4, f_5, f_6 - + include 'formats' ierr = 0 skip = .false. - + lnGAMI_min = -2.0d0*ln10 lnGAMI_max = 6.5d0*ln10 dlnGAMI = 1d-2*ln10 nlnGAMI = (lnGAMI_max - lnGAMI_min)/dlnGAMI + 1 - + if (.not. FITION9_loaded) then !$OMP CRITICAL(eosPC_support_FITION9_load) if (.not. FITION9_loaded) then @@ -81,13 +81,13 @@ subroutine get_FITION9(GAMI, & !$OMP END CRITICAL(eosPC_support_FITION9_load) if (ierr /= 0) return end if - + lnGAMI = log(GAMI) if (lnGAMI < lnGAMI_min .or. lnGAMI > lnGAMI_max) then skip = .true. return end if - + f_1(1:4,1:nlnGAMI) => FITION_data(iFION)% f1 f_2(1:4,1:nlnGAMI) => FITION_data(iUION)% f1 f_3(1:4,1:nlnGAMI) => FITION_data(iPION)% f1 @@ -96,8 +96,8 @@ subroutine get_FITION9(GAMI, & f_6(1:4,1:nlnGAMI) => FITION_data(iPDRii)% f1 xk_new = lnGAMI - k_old = int((lnGAMI - lnGAMI_min)/dlnGAMI + 1d-4) + 1 - if (k_old < 1 .or. k_old >= nlnGAMI) then + k_old = int((lnGAMI - lnGAMI_min)/dlnGAMI + 1d-4) + 1 + if (k_old < 1 .or. k_old >= nlnGAMI) then if (k_old < 1) then k_old = 1 xk_old = lnGAMI_min @@ -106,53 +106,53 @@ subroutine get_FITION9(GAMI, & k_old = nlnGAMI-1 xk_old = lnGAMI_min + (k_old-1)*dlnGAMI xkp1_old = xk_old + dlnGAMI - end if - else + end if + else xk_old = lnGAMI_min + (k_old-1)*dlnGAMI xkp1_old = xk_old + dlnGAMI end if - + delta = xk_new - xk_old - + FION = & f_1(1, k_old) + delta*(f_1(2, k_old) & + delta*(f_1(3, k_old) + delta*f_1(4, k_old))) dFION_dlnGAMI = & f_1(2, k_old) + 2*delta*(f_1(3, k_old) + 1.5d0*delta*f_1(4, k_old)) - + UION = & f_2(1, k_old) + delta*(f_2(2, k_old) & + delta*(f_2(3, k_old) + delta*f_2(4, k_old))) dUION_dlnGAMI = & f_2(2, k_old) + 2*delta*(f_2(3, k_old) + 1.5d0*delta*f_2(4, k_old)) - + PION = & f_3(1, k_old) + delta*(f_3(2, k_old) & + delta*(f_3(3, k_old) + delta*f_3(4, k_old))) dPION_dlnGAMI = & f_3(2, k_old) + 2*delta*(f_3(3, k_old) + 1.5d0*delta*f_3(4, k_old)) - + CVii = & f_4(1, k_old) + delta*(f_4(2, k_old) & + delta*(f_4(3, k_old) + delta*f_4(4, k_old))) dCVii_dlnGAMI = & f_4(2, k_old) + 2*delta*(f_4(3, k_old) + 1.5d0*delta*f_4(4, k_old)) - + PDTii = & f_5(1, k_old) + delta*(f_5(2, k_old) & + delta*(f_5(3, k_old) + delta*f_5(4, k_old))) dPDTii_dlnGAMI = & f_5(2, k_old) + 2*delta*(f_5(3, k_old) + 1.5d0*delta*f_5(4, k_old)) - + PDRii = & f_6(1, k_old) + delta*(f_6(2, k_old) & + delta*(f_6(3, k_old) + delta*f_6(4, k_old))) dPDRii_dlnGAMI = & f_6(2, k_old) + 2*delta*(f_6(3, k_old) + 1.5d0*delta*f_6(4, k_old)) - + contains - - + + subroutine build_FITION9_data(ierr) use interp_1d_def, only : pm_work_size use interp_1d_lib, only : interp_pm @@ -162,22 +162,22 @@ subroutine build_FITION9_data(ierr) real(dp) :: lnGAMI, GAMI, FION, UION, PION, CVii, PDTii, PDRii integer :: j include 'formats' - + ierr = 0 !write(*,'(a)') 'eosPC build_FITION9_data' - + allocate(FITION9_lnGAMIs(nlnGAMI), work(pm_work_size*nlnGAMI)) do j=1,FITION_vals fi => FITION_data(j) allocate(fi% f1(4*nlnGAMI)) fi% f(1:4, 1:nlnGAMI) => fi% f1(1:4*nlnGAMI) end do - + do j=1,nlnGAMI-1 FITION9_lnGAMIs(j) = lnGAMI_min + (j-1)*dlnGAMI end do FITION9_lnGAMIs(nlnGAMI) = lnGAMI_max - + do j=1,nlnGAMI lnGAMI = FITION9_lnGAMIs(j) GAMI = exp(lnGAMI) @@ -189,20 +189,20 @@ subroutine build_FITION9_data(ierr) fi => FITION_data(iPDTii); fi% f(1,j) = PDTii fi => FITION_data(iPDRii); fi% f(1,j) = PDRii end do - + do j=1,FITION_vals fi => FITION_data(j) call interp_pm(FITION9_lnGAMIs, nlnGAMI, & fi% f1, pm_work_size, work, 'build_FITION9_data', ierr) if (ierr /= 0) return end do - + deallocate(work) !write(*,'(a)') 'done eosPC build_FITION9_data' - + end subroutine build_FITION9_data - + end subroutine get_FITION9 @@ -213,7 +213,7 @@ subroutine get_FSCRliq8(iZion, RS, GAME, & CVSCR, dCVSCR_dlnRS, dCVSCR_dlnGAME, & PDTSCR, dPDTSCR_dlnRS, dPDTSCR_dlnGAME, & PDRSCR, dPDRSCR_dlnRS, dPDRSCR_dlnGAME, & - skip, ierr) + skip, ierr) integer, intent(in) :: iZion real(dp), intent(in) :: RS, GAME real(dp), intent(out) :: & @@ -225,7 +225,7 @@ subroutine get_FSCRliq8(iZion, RS, GAME, & PDRSCR, dPDRSCR_dlnRS, dPDRSCR_dlnGAME logical, intent(out) :: skip integer, intent(out) :: ierr - + integer :: iRS, jGAME real(dp) :: lnRS, lnRS0, lnRS1, lnGAME, lnGAME0, lnGAME1 real(dp), dimension(nvals_FSCRliq8) :: fval, df_dlnRS, df_dlnGAME @@ -233,15 +233,15 @@ subroutine get_FSCRliq8(iZion, RS, GAME, & include 'formats' ierr = 0 skip = .false. - + if (iZion < 1 .or. iZion > max_FSCRliq8_Zion) then write(*,2) 'invalid value for Z ion in get_FSCRliq8', iZion ierr = -1 return end if - + fq => FSCRliq8_data(iZion) - + if (.not. FSCRliq8_Zion_loaded(iZion)) then !$OMP CRITICAL(eosPC_support_FSCRliq8_load) if (.not. FSCRliq8_Zion_loaded(iZion)) then @@ -260,34 +260,34 @@ subroutine get_FSCRliq8(iZion, RS, GAME, & skip = .true. return end if - + call Locate_lnRS(lnRS, & fq% nlnRS, fq% lnRS_min, fq% dlnRS, & iRS, lnRS0, lnRS1) call Locate_lnGAME(lnGAME, & fq% nlnGAME, fq% lnGAME_min, fq% dlnGAME, & jGAME, lnGAME0, lnGAME1) - + call Do_Interpolations( & 1, nvals_FSCRliq8, nvals_FSCRliq8, nvals_FSCRliq8, & fq% nlnRS, fq% lnRSs, fq% nlnGAME, fq% lnGAMEs, fq% tbl1, & iRS, jGAME, lnRS0, lnRS, lnRS1, lnGAME0, lnGAME, lnGAME1, & - fval, df_dlnRS, df_dlnGAME, ierr) + fval, df_dlnRS, df_dlnGAME, ierr) if (ierr /= 0) then write(*,1) 'Do_Interpolations failed in get_FSCRliq8' return end if - + FSCR = fval(iFSCR); dFSCR_dlnRS = df_dlnRS(iFSCR); dFSCR_dlnGAME = df_dlnGAME(iFSCR) USCR = fval(iUSCR); dUSCR_dlnRS = df_dlnRS(iUSCR); dUSCR_dlnGAME = df_dlnGAME(iUSCR) PSCR = fval(iPSCR); dPSCR_dlnRS = df_dlnRS(iPSCR); dPSCR_dlnGAME = df_dlnGAME(iPSCR) CVSCR = fval(iCVSCR); dCVSCR_dlnRS = df_dlnRS(iCVSCR); dCVSCR_dlnGAME = df_dlnGAME(iCVSCR) PDTSCR = fval(iPDTSCR); dPDTSCR_dlnRS = df_dlnRS(iPDTSCR); dPDTSCR_dlnGAME = df_dlnGAME(iPDTSCR) PDRSCR = fval(iPDRSCR); dPDRSCR_dlnRS = df_dlnRS(iPDRSCR); dPDRSCR_dlnGAME = df_dlnGAME(iPDRSCR) - - end subroutine get_FSCRliq8 - - + + end subroutine get_FSCRliq8 + + subroutine get_EXCOR7(RS, GAME, & FXC, dFXC_dlnRS, dFXC_dlnGAME, & UXC, dUXC_dlnRS, dUXC_dlnGAME, & @@ -296,7 +296,7 @@ subroutine get_EXCOR7(RS, GAME, & SXC, dSXC_dlnRS, dSXC_dlnGAME, & PDTXC, dPDTXC_dlnRS, dPDTXC_dlnGAME, & PDRXC, dPDRXC_dlnRS, dPDRXC_dlnGAME, & - skip, ierr) + skip, ierr) real(dp), intent(in) :: RS, GAME real(dp), intent(out) :: & FXC, dFXC_dlnRS, dFXC_dlnGAME, & @@ -308,7 +308,7 @@ subroutine get_EXCOR7(RS, GAME, & PDRXC, dPDRXC_dlnRS, dPDRXC_dlnGAME logical, intent(out) :: skip integer, intent(out) :: ierr - + integer :: iRS, jGAME real(dp) :: lnRS, lnRS0, lnRS1, lnGAME, lnGAME0, lnGAME1 real(dp), dimension(nvals_EXCOR7) :: fval, df_dlnRS, df_dlnGAME @@ -318,7 +318,7 @@ subroutine get_EXCOR7(RS, GAME, & skip = .false. fq => EXCOR7_data - + if (.not. EXCOR7_table_loaded) then !$OMP CRITICAL(eosPC_EXCOR7_support_load) if (.not. EXCOR7_table_loaded) then @@ -337,22 +337,22 @@ subroutine get_EXCOR7(RS, GAME, & skip = .true. return end if - + call Locate_lnRS(lnRS, & fq% nlnRS, fq% lnRS_min, fq% dlnRS, iRS, lnRS0, lnRS1) call Locate_lnGAME(lnGAME, & fq% nlnGAME, fq% lnGAME_min, fq% dlnGAME, jGAME, lnGAME0, lnGAME1) - + call Do_Interpolations( & 1, nvals_EXCOR7, nvals_EXCOR7, nvals_EXCOR7, & fq% nlnRS, fq% lnRSs, fq% nlnGAME, fq% lnGAMEs, & fq% tbl1, iRS, jGAME, lnRS0, lnRS, lnRS1, lnGAME0, lnGAME, lnGAME1, & - fval, df_dlnRS, df_dlnGAME, ierr) + fval, df_dlnRS, df_dlnGAME, ierr) if (ierr /= 0) then write(*,1) 'Do_Interpolations failed in get_EXCOR7' return end if - + FXC = fval(jFXC); dFXC_dlnRS = df_dlnRS(jFXC); dFXC_dlnGAME = df_dlnGAME(jFXC) UXC = fval(jUXC); dUXC_dlnRS = df_dlnRS(jUXC); dUXC_dlnGAME = df_dlnGAME(jUXC) PXC = fval(jPXC); dPXC_dlnRS = df_dlnRS(jPXC); dPXC_dlnGAME = df_dlnGAME(jPXC) @@ -360,10 +360,10 @@ subroutine get_EXCOR7(RS, GAME, & SXC = fval(jSXC); dSXC_dlnRS = df_dlnRS(jSXC); dSXC_dlnGAME = df_dlnGAME(jSXC) PDTXC = fval(jPDTXC); dPDTXC_dlnRS = df_dlnRS(jPDTXC); dPDTXC_dlnGAME = df_dlnGAME(jPDTXC) PDRXC = fval(jPDRXC); dPDRXC_dlnRS = df_dlnRS(jPDRXC); dPDRXC_dlnGAME = df_dlnGAME(jPDRXC) - + end subroutine get_EXCOR7 - + subroutine Locate_lnRS( & lnRS, nlnRS, lnRS_min, dlnRS, iQ, lnRS0, lnRS1) real(dp), intent(inout) :: lnRS @@ -371,8 +371,8 @@ subroutine Locate_lnRS( & real(dp), intent(in) :: lnRS_min, dlnRS integer, intent(out) :: iQ real(dp), intent(out) :: lnRS0, lnRS1 - iQ = int((lnRS - lnRS_min)/dlnRS + 1d-4) + 1 - if (iQ < 1 .or. iQ >= nlnRS) then + iQ = int((lnRS - lnRS_min)/dlnRS + 1d-4) + 1 + if (iQ < 1 .or. iQ >= nlnRS) then if (iQ < 1) then iQ = 1 lnRS0 = lnRS_min @@ -383,14 +383,14 @@ subroutine Locate_lnRS( & lnRS0 = lnRS_min + (iQ-1)*dlnRS lnRS1 = lnRS0 + dlnRS lnRS = lnRS1 - end if - else + end if + else lnRS0 = lnRS_min + (iQ-1)*dlnRS lnRS1 = lnRS0 + dlnRS end if end subroutine Locate_lnRS - + subroutine Locate_lnGAME( & lnGAME, nlnGAME, lnGAME_min, dlnGAME, iQ, lnGAME0, lnGAME1) real(dp), intent(inout) :: lnGAME @@ -398,8 +398,8 @@ subroutine Locate_lnGAME( & real(dp), intent(in) :: lnGAME_min, dlnGAME integer, intent(out) :: iQ real(dp), intent(out) :: lnGAME0, lnGAME1 - iQ = int((lnGAME - lnGAME_min)/dlnGAME + 1d-4) + 1 - if (iQ < 1 .or. iQ >= nlnGAME) then + iQ = int((lnGAME - lnGAME_min)/dlnGAME + 1d-4) + 1 + if (iQ < 1 .or. iQ >= nlnGAME) then if (iQ < 1) then iQ = 1 lnGAME0 = lnGAME_min @@ -410,14 +410,14 @@ subroutine Locate_lnGAME( & lnGAME0 = lnGAME_min + (iQ-1)*dlnGAME lnGAME1 = lnGAME0 + dlnGAME lnGAME = lnGAME1 - end if - else + end if + else lnGAME0 = lnGAME_min + (iQ-1)*dlnGAME lnGAME1 = lnGAME0 + dlnGAME end if end subroutine Locate_lnGAME - - + + subroutine Do_Interpolations( & nvlo, nvhi, nvals, n, nlnGAMI, x, ny, y, fin1, i, j, & x0, xget, x1, y0, yget, y1, & @@ -439,14 +439,14 @@ subroutine Do_Interpolations( & real(dp) :: sixth_hx2_hyi, sixth_hy, z36th_hx2_hy integer :: k, ip1, jp1 real(dp), pointer :: fin(:,:,:,:) - + include 'formats' - + ierr = 0 - + fin(1:4,1:n,1:nlnGAMI,1:ny) => & fin1(1:4*n*nlnGAMI*ny) - + hx=x1-x0 hxi=1d0/hx hx2=hx*hx @@ -459,7 +459,7 @@ subroutine Do_Interpolations( & ax=xp2*(3d0-2d0*xp) axbar=1d0-ax - + bx=-xp2*xpi bxbar=xpi2*xp @@ -473,14 +473,14 @@ subroutine Do_Interpolations( & hy2=hy*hy yp=(yget-y0)*hyi - + ypi=1d0-yp yp2=yp*yp ypi2=ypi*ypi ay=yp2*(3d0-2d0*yp) aybar=1d0-ay - + by=-yp2*ypi bybar=ypi2*yp @@ -488,26 +488,26 @@ subroutine Do_Interpolations( & cyi=ypi*(ypi2-1d0) cyd=3d0*yp2-1d0 cydi=-3d0*ypi2+1d0 - + sixth_hx2 = one_sixth*hx2 sixth_hy2 = one_sixth*hy2 z36th_hx2_hy2 = sixth_hx2*sixth_hy2 - + sixth_hx = one_sixth*hx sixth_hxi_hy2 = one_sixth*hxi*hy2 z36th_hx_hy2 = sixth_hx*sixth_hy2 - + sixth_hx2_hyi = sixth_hx2*hyi sixth_hy = one_sixth*hy z36th_hx2_hy = sixth_hx2*sixth_hy - + ip1 = i+1 jp1 = j+1 - + !$omp simd do k = nvlo, nvhi ! bicubic spline interpolation - + ! f(1,i,j) = f(x(i),y(j)) ! f(2,i,j) = d2f/dx2(x(i),y(j)) ! f(3,i,j) = d2f/dy2(x(i),y(j)) @@ -526,7 +526,7 @@ subroutine Do_Interpolations( & +z36th_hx2_hy2*( & cxi*(cyi*fin(4,k,i,j) +cy*fin(4,k,i,jp1))+ & cx*(cyi*fin(4,k,ip1,j)+cy*fin(4,k,ip1,jp1))) - + ! derivatives of bicubic splines df_dx(k) = & hxi*( & @@ -555,13 +555,13 @@ subroutine Do_Interpolations( & +z36th_hx2_hy*( & cxi*(cydi*fin(4,k,i,j) +cyd*fin(4,k,i,jp1))+ & cx*(cydi*fin(4,k,ip1,j)+cyd*fin(4,k,ip1,jp1))) - + end do - + end subroutine Do_Interpolations - - subroutine load_eosPC_support_Info(fq, iZion, ierr) + + subroutine load_eosPC_support_Info(fq, iZion, ierr) use const_def, only: mesa_data_dir use utils_lib, only: alloc_iounit, free_iounit use create_EXCOR7_table, only: do_create_EXCOR7_table @@ -569,7 +569,7 @@ subroutine load_eosPC_support_Info(fq, iZion, ierr) type (eosPC_Support_Info), pointer :: fq integer, intent(in) :: iZion ! 0 means EXCOR7 integer, intent(out) :: ierr - + integer :: io_unit, n, j, i, iQ, nparams, nvals character (len=256) :: filename, fname, cache_fname, temp_cache_fname character (len=1000) :: message @@ -577,11 +577,11 @@ subroutine load_eosPC_support_Info(fq, iZion, ierr) real(dp), target :: vec_ary(50) real(dp), pointer :: vec(:) real(dp) :: lnGAME, lnRS - + include 'formats' ierr = 0 vec => vec_ary - + if (iZion == 0) then filename = 'EXCOR7' else if (iZion < 10) then @@ -592,12 +592,12 @@ subroutine load_eosPC_support_Info(fq, iZion, ierr) fname = trim(mesa_data_dir) // '/eosPC_support_data/' // trim(filename) // '.data' cache_fname = trim(mesa_data_dir) // '/eosPC_support_data/cache/' // trim(filename) // '.bin' temp_cache_fname = trim(mesa_temp_caches_dir) // '/' // trim(filename) // '.bin' - + io_unit = alloc_iounit(ierr) if (ierr /= 0) then write(*,'(a)') 'failed to alloc_iounit' call mesa_error(__FILE__,__LINE__) - end if + end if open(unit=io_unit, FILE=trim(fname), ACTION='READ', STATUS='OLD', IOSTAT=ierr) if (ierr /= 0) then ! need to open the table file ierr = 0 @@ -607,16 +607,16 @@ subroutine load_eosPC_support_Info(fq, iZion, ierr) call do_create_FSCRliq8_table(fname,iZion) end if open(unit=io_unit, FILE=trim(fname), ACTION='READ', STATUS='OLD', IOSTAT=ierr) - if (ierr /= 0) then + if (ierr /= 0) then write(*,'(a)') 'failed to create ' // trim(fname) write(*,'(A)') call mesa_error(__FILE__,__LINE__) end if end if - + read(io_unit,*,iostat=ierr) ! skip line 1 if (ierr /= 0) return - + if (iZion == 0) then nparams = 8 nvals = nvals_EXCOR7 @@ -632,43 +632,43 @@ subroutine load_eosPC_support_Info(fq, iZion, ierr) ierr = -1 return end if - + read(io_unit,*,iostat=ierr) ! line 3 if (ierr /= 0) return - + fq% Zion = iZion fq% nvals = nvals fq% nlnRS = int(vec(1)) fq% lnRS_min = vec(2)*ln10 fq% lnRS_max = vec(3)*ln10 fq% dlnRS = vec(4)*ln10 - + fq% nlnGAME = int(vec(5)) fq% lnGAME_min = vec(6)*ln10 fq% lnGAME_max = vec(7)*ln10 fq% dlnGAME = vec(8)*ln10 - + if (iZion > 0 .and. int(vec(9)) /= iZion) then write(*,*) 'bad value for Zion in file', int(vec(9)), iZion close(io_unit) ierr = -1 return end if - + if (show_allocations) write(*,2) 'allocate pc_support', & 4*nvals*fq% nlnRS*fq% nlnGAME + fq% nlnRS + fq% nlnGAME allocate(fq% tbl1(4*nvals*fq% nlnRS*fq% nlnGAME), & fq% lnRSs(fq% nlnRS), fq% lnGAMEs(fq% nlnGAME), STAT=ierr) - if (ierr /= 0) return + if (ierr /= 0) return fq% tbl(1:4, 1:nvals, 1:fq% nlnRS, 1:fq% nlnGAME) => & fq% tbl1(1:4*nvals*fq% nlnRS*fq% nlnGAME) - + fq% lnRSs(1) = fq% lnRS_min do i = 2, fq% nlnRS-1 fq% lnRSs(i) = fq% lnRSs(i-1) + fq% dlnRS end do fq% lnRSs(fq% nlnRS) = fq% lnRS_max - + fq% lnGAMEs(1) = fq% lnGAME_min do i = 2, fq% nlnGAME-1 fq% lnGAMEs(i) = fq% lnGAMEs(i-1) + fq% dlnGAME @@ -684,18 +684,18 @@ subroutine load_eosPC_support_Info(fq, iZion, ierr) end if ierr = 0 end if - + allocate(tbl2_1(nvals*fq% nlnRS*fq% nlnGAME), STAT=ierr) if (ierr .ne. 0) return - + tbl2(1:nvals, 1:fq% nlnRS, 1:fq% nlnGAME) => & tbl2_1(1:nvals*fq% nlnRS*fq% nlnGAME) do iQ=1,fq% nlnRS - - read(io_unit,*,iostat=ierr) + + read(io_unit,*,iostat=ierr) if (failed('skip line1')) return - + read(io_unit,'(a)',iostat=ierr) message if (ierr == 0) call str_to_double(message, vec(1), ierr) if (failed('read lnRS')) return @@ -703,12 +703,12 @@ subroutine load_eosPC_support_Info(fq, iZion, ierr) read(io_unit,*,iostat=ierr) if (failed('skip line2')) return - + read(io_unit,*,iostat=ierr) if (failed('skip line3')) return - + do i=1,fq% nlnGAME - + read(io_unit,'(a)',iostat=ierr) message if (failed('read line')) then write(*,'(a)') trim(message) @@ -718,7 +718,7 @@ subroutine load_eosPC_support_Info(fq, iZion, ierr) write(*,*) 'bad input line?' call mesa_error(__FILE__,__LINE__) end if - + call str_to_vector(message, vec, n, ierr) if (ierr /= 0 .or. n < 1+nvals) then write(*,'(a)') trim(message) @@ -732,25 +732,25 @@ subroutine load_eosPC_support_Info(fq, iZion, ierr) do j=1,nvals tbl2(j,iQ,i) = vec(1+j) end do - + enddo - + if(iQ == fq% nlnRS) exit read(io_unit,*,iostat=ierr) if (failed('skip line4')) return read(io_unit,*,iostat=ierr) if (failed('skip line5')) return - + end do - + close(io_unit) - + call Make_Interpolation_Data(fq, nvals, tbl2_1, ierr) deallocate(tbl2_1) if (failed('Make_Interpolation_Data')) return - + call Check_Interpolation_Data - + if (.not. use_cache_for_eos) then call free_iounit(io_unit) return @@ -769,15 +769,15 @@ subroutine load_eosPC_support_Info(fq, iZion, ierr) if (use_mesa_temp_cache) call mv(temp_cache_fname, cache_fname, .true.) end if call free_iounit(io_unit) - + if (iZion == 0) then EXCOR7_table_loaded = .true. else FSCRliq8_Zion_loaded(iZion) = .true. end if - + contains - + subroutine Check_Interpolation_Data integer :: i, j, iQ, jtemp do i = 1, 4 @@ -792,17 +792,17 @@ subroutine Check_Interpolation_Data end do end do end subroutine Check_Interpolation_Data - + logical function failed(str) character (len=*), intent(in) :: str failed = (ierr /= 0) if (failed) write(*,*) 'load_eosPC_support_Info failed: ' // trim(str) if (failed) call mesa_error(__FILE__,__LINE__,'load_eosPC_support_Info') end function failed - + end subroutine load_eosPC_support_Info - - + + subroutine Make_Interpolation_Data(fq, nvals, tbl2_1, ierr) use interp_2d_lib_db type (eosPC_Support_Info), pointer :: fq @@ -823,9 +823,9 @@ subroutine Make_Interpolation_Data(fq, nvals, tbl2_1, ierr) integer :: ili_lnRSs ! =1: logRho grid is "nearly" equally spaced integer :: ili_lnGAMEs ! =1: lnGAME grid is "nearly" equally spaced integer :: ier ! =0 on exit if there is no error. - + integer :: v, i, j - + include 'formats' ierr = 0 @@ -835,7 +835,7 @@ subroutine Make_Interpolation_Data(fq, nvals, tbl2_1, ierr) ibcxmax = 0; bcxmax(:) = 0 ibcymin = 0; bcymin(:) = 0 ibcymax = 0; bcymax(:) = 0 - + tbl2(1:nvals, 1:fq% nlnRS, 1:fq% nlnGAME) => & tbl2_1(1:nvals*fq% nlnRS*fq% nlnGAME) ! copy file variables to internal interpolation tables @@ -844,16 +844,16 @@ subroutine Make_Interpolation_Data(fq, nvals, tbl2_1, ierr) do v = 1, nvals fq% tbl(1,v,i,j) = tbl2(v,i,j) end do - end do + end do end do - + allocate(f1_ary(4 * fq% nlnRS * fq% nlnGAME)) - + f1 => f1_ary f(1:4, 1:fq% nlnRS, 1:fq% nlnGAME) => & f1_ary(1:4*fq% nlnRS*fq% nlnGAME) - ! create tables for bicubic spline interpolation + ! create tables for bicubic spline interpolation do v = 1, nvals do i=1,fq% nlnRS do j=1,fq% nlnGAME @@ -878,10 +878,10 @@ subroutine Make_Interpolation_Data(fq, nvals, tbl2_1, ierr) end do end do end do - + end subroutine Make_Interpolation_Data - - + + subroutine Read_Cache(fq, cache_fname, ierr) use utils_lib, only: alloc_iounit, free_iounit type (eosPC_Support_Info), pointer :: fq @@ -892,40 +892,40 @@ subroutine Read_Cache(fq, cache_fname, ierr) lnRS_min_in, lnRS_max_in, dlnRS_in integer :: Zion_in, nlnRS_in, nlnGAME_in, io_unit real(dp), parameter :: tiny = 1d-10 - + include 'formats' - + ierr = 0 - + io_unit = alloc_iounit(ierr) if (ierr /= 0) then write(*,'(a)') 'failed to alloc_iounit' call mesa_error(__FILE__,__LINE__) - end if + end if open(unit=io_unit, file=trim(cache_fname), action='read', & status='old', iostat=ierr, form='unformatted') if (ierr /= 0) then call free_iounit(io_unit) return end if - + !write(*,'(a)') 'read ' // trim(cache_fname) - + read(io_unit, iostat=ierr) & Zion_in, nlnGAME_in, lnGAME_min_in, lnGAME_max_in, dlnGAME_in, & nlnRS_in, lnRS_min_in, lnRS_max_in, dlnRS_in if (ierr /= 0) then write(*,*) 'read cache failed' - end if + end if if (fq% Zion /= Zion_in) then ierr = 1 write(*,*) 'read cache failed for Zion' - end if + end if if (fq% nlnRS /= nlnRS_in) then ierr = 1 write(*,*) 'read cache failed for nlnRS' - end if + end if if (fq% nlnGAME /= nlnGAME_in) then ierr = 1 write(*,*) 'read cache failed for nlnGAME' @@ -933,19 +933,19 @@ subroutine Read_Cache(fq, cache_fname, ierr) if (abs(fq% lnGAME_min-lnGAME_min_in) > tiny) then ierr = 1 write(*,*) 'read cache failed for eos_lnGAME_min' - end if + end if if (abs(fq% lnGAME_max-lnGAME_max_in) > tiny) then ierr = 1 write(*,*) 'read cache failed for eos_lnGAME_max' - end if + end if if (abs(fq% dlnGAME-dlnGAME_in) > tiny) then ierr = 1 write(*,*) 'read cache failed for eos_dlnGAME' - end if + end if if (abs(fq% lnRS_min-lnRS_min_in) > tiny) then ierr = 1 write(*,*) 'read cache failed for eos_lnRS_min' - end if + end if if (abs(fq% lnRS_max-lnRS_max_in) > tiny) then ierr = 1 write(*,*) 'read cache failed for eos_lnRS_max' @@ -954,7 +954,7 @@ subroutine Read_Cache(fq, cache_fname, ierr) ierr = 1 write(*,*) 'read cache failed for eos_dlnRS' end if - + if (ierr /= 0) then write(*,*) 'read cache file failed 1' call mesa_error(__FILE__,__LINE__,'Read_Cache') @@ -972,7 +972,7 @@ subroutine Read_Cache(fq, cache_fname, ierr) call free_iounit(io_unit) end subroutine Read_Cache - + ! ================== ELECTRON-ION COULOMB LIQUID =================== * subroutine FITION9(GAMI, & @@ -1020,5 +1020,5 @@ subroutine FITION9(GAMI, & return end subroutine FITION9 - + end module pc_support diff --git a/eos/private/skye.f90 b/eos/private/skye.f90 index 0fad82da5..ef206e5c2 100644 --- a/eos/private/skye.f90 +++ b/eos/private/skye.f90 @@ -8,14 +8,14 @@ module skye logical, parameter :: dbg = .false. !logical, parameter :: dbg = .true. - - + + private public :: Get_Skye_EOS_Results, Get_Skye_alfa, Get_Skye_alfa_simple, get_Skye_for_eosdt contains - subroutine Get_Skye_alfa( & + subroutine Get_Skye_alfa( & rq, logRho, logT, Z, abar, zbar, & alfa, d_alfa_dlogT, d_alfa_dlogRho, & ierr) @@ -36,12 +36,12 @@ subroutine Get_Skye_alfa( & type (Helm_Table), pointer :: ht ierr = 0 - ht => eos_ht + ht => eos_ht skye_blend_width = 0.1d0 ! Avoid catastrophic loss of precision in HELM tables bounds(1,1) = ht% logdlo - bounds(1,2) = 8.3d0 + bounds(1,2) = 8.3d0 ! Rough ionization temperature from Jermyn+2021 Equation 52 (treating denominator as ~1). ! We put a lower bound of logT=7.3 to ensure that solar models never use Skye. @@ -186,11 +186,11 @@ subroutine get_Skye_for_eosdt(handle, dbg, Z, X, abar, zbar, species, chem_id, n ! mark this one res(i_frac_Skye) = 1.0 - end subroutine get_Skye_for_eosdt + end subroutine get_Skye_for_eosdt subroutine Get_Skye_EOS_Results( & rq, Z, X, abar, zbar, Rho, logRho, T, logT, & - species, chem_id, xa, res, d_dlnd, d_dlnT, d_dxa, ierr) + species, chem_id, xa, res, d_dlnd, d_dlnT, d_dxa, ierr) type (EoS_General_Info), pointer :: rq real(dp), intent(in) :: Z, X, abar, zbar real(dp), intent(in) :: Rho, logRho, T, logT @@ -200,9 +200,9 @@ subroutine Get_Skye_EOS_Results( & integer, intent(out) :: ierr real(dp), intent(out), dimension(nv) :: res, d_dlnd, d_dlnT real(dp), intent(out), dimension(nv, species) :: d_dxa - + real(dp) :: logT_ion, logT_neutral - + include 'formats' ierr = 0 @@ -231,22 +231,22 @@ subroutine Get_Skye_EOS_Results( & call mesa_error(__FILE__,__LINE__,'Get_Skye_EOS_Results') end if return - end if + end if end subroutine Get_Skye_EOS_Results - !>..given a temperature temp [K], density den [g/cm**3], and a composition - !!..this routine returns most of the other - !!..thermodynamic quantities. of prime interest is the pressure [erg/cm**3], - !!..specific thermal energy [erg/gr], the entropy [erg/g/K], along with + !>..given a temperature temp [K], density den [g/cm**3], and a composition + !!..this routine returns most of the other + !!..thermodynamic quantities. of prime interest is the pressure [erg/cm**3], + !!..specific thermal energy [erg/gr], the entropy [erg/g/K], along with !!..their derivatives with respect to temperature, density, abar, and zbar. !!..other quantites such the normalized chemical potential eta (plus its - !!..derivatives), number density of electrons and positron pair (along - !!..with their derivatives), adiabatic indices, specific heats, and + !!..derivatives), number density of electrons and positron pair (along + !!..with their derivatives), adiabatic indices, specific heats, and !!..relativistically correct sound speed are also returned. !!.. - !!..this routine assumes planckian photons, an ideal gas of ions, + !!..this routine assumes planckian photons, an ideal gas of ions, !!..and an electron-positron gas with an arbitrary degree of relativity !!..and degeneracy. interpolation in a table of the helmholtz free energy !!..is used to return the electron-positron thermodynamic quantities. @@ -286,7 +286,7 @@ subroutine skye_eos( & integer, intent(out) :: ierr real(dp), intent(out), dimension(nv) :: res, d_dlnd, d_dlnT real(dp), intent(out), dimension(nv, species) :: d_dxa - + integer :: relevant_species, lookup(species) type(auto_diff_real_2var_order3) :: temp, logtemp, den, logden, din real(dp) :: AZION(species), ACMI(species), A(species), select_xa(species), ya(species) diff --git a/eos/private/skye_coulomb.f90 b/eos/private/skye_coulomb.f90 index 0d9e4dc97..c75700eb7 100644 --- a/eos/private/skye_coulomb.f90 +++ b/eos/private/skye_coulomb.f90 @@ -14,9 +14,9 @@ module skye_coulomb private public :: nonideal_corrections - + contains - + !! Computes the non-ideal free energy correction for a Coulomb system. !! This is done for both the liquid phase and the solid phase, and the resulting !! free energies are then combined in a way that blends from the solid phase when @@ -110,7 +110,7 @@ subroutine nonideal_corrections(NMIX,AY,AZion,ACMI, min_gamma_for_solid, max_gam end if end subroutine nonideal_corrections - + !> Computes the free energy, phase, and latent heat across the phase transition !! between liquid and solid. The latent heat is blurred / smeared out over a finite @@ -155,11 +155,11 @@ subroutine decide_phase(dF_liq, dF_sol, kT, temp, rho, dF, phase, latent_ddlnT, ! Latent entropy latent_S = -(differentiate_1(dF_blur)) ! S = -dF/dT - ! T dS/dlnT = T^2 dS/dT + ! T dS/dlnT = T^2 dS/dT latent_ddlnT = differentiate_1(latent_S) * pow2(temp) ! T dS/dlnRho = T Rho dS/dRho - latent_ddlnRho = temp * rho * differentiate_2(latent_S) + latent_ddlnRho = temp * rho * differentiate_2(latent_S) end subroutine decide_phase @@ -230,7 +230,7 @@ function nonideal_corrections_phase(NMIX,AY,AZion,ACMI,min_gamma_for_solid, max_ f = f + ocp_liquid_screening_free_energy_correction(AZion(i), ACMI(i), GAME, RS) ! screening corrections else f = f + ocp_solid_screening_free_energy_correction(AZion(i), ACMI(i), GAME, RS) ! screening corrections - end if + end if dF = dF + AY(i) * f end if @@ -255,7 +255,7 @@ end function nonideal_corrections_phase !! @param temp Temperature (K) !! @param RS Electron density parameter !! @param Zion Charge of the species of interest in electron charges. - !! @param CMI Mass of the species of interest in AMU. + !! @param CMI Mass of the species of interest in AMU. !! @param F non-ideal free energy per ion per kT function extrapolate_free_energy(LIQSOL, temp, RS, Zion, CMI, min_gamma_for_solid, max_gamma_for_liquid) result(F) ! Inputs @@ -297,7 +297,7 @@ function extrapolate_free_energy(LIQSOL, temp, RS, Zion, CMI, min_gamma_for_soli temp_boundary = temp%val * GAMI%val / gamma_boundary ! Make d(temp_boundary)/dT = 1 so we can extract dF/dT at the boundary. - temp_boundary%d1val1 = 1d0 + temp_boundary%d1val1 = 1d0 ! Compute new (differentiable) Gamma and TPT at the boundary g = pre_z(int(Zion))% z5_3 * qe * qe / (rbohr * boltzm * temp_boundary * RS) ! ion Coulomb parameter Gamma_i @@ -350,7 +350,7 @@ end function extrapolate_free_energy !! !! @param LIQSOL Integer specifying the phase: 0 for liquid, 1 for solid. !! @param Zion Charge of the species of interest in electron charges. - !! @param CMI Mass of the species of interest in AMU. + !! @param CMI Mass of the species of interest in AMU. !! @param GAMI Ion coupling parameter (Gamma_i) !! @param TPT effective T_p/T - ion quantum parameter !! @param F non-ideal free energy per ion per kT @@ -366,7 +366,7 @@ function ocp_free_energy(LIQSOL, Zion, CMI, GAMI, TPT) result(F) if (LIQSOL == 0) then F = classical_ocp_liquid_free_energy(GAMI) ! classical ion-ion interaction F = F + quantum_ocp_liquid_free_energy_correction(TPT) ! quantum ion-ion corrections - else + else F = ocp_solid_harmonic_free_energy(GAMI,TPT) ! harmonic classical and quantum ion-ion corrections F = F + ocp_solid_anharmonic_free_energy(GAMI,TPT) ! anharmonic classical and quantum ion-ion corrections endif diff --git a/eos/private/skye_coulomb_liquid.f90 b/eos/private/skye_coulomb_liquid.f90 index 02ef79eca..c05573269 100644 --- a/eos/private/skye_coulomb_liquid.f90 +++ b/eos/private/skye_coulomb_liquid.f90 @@ -7,7 +7,7 @@ module skye_coulomb_liquid implicit none real(dp), parameter :: me_in_amu = me / amu - + contains !> Calculates the free energy of a classical one-component @@ -35,17 +35,17 @@ function classical_ocp_liquid_free_energy(g) result(F) real(dp), parameter :: B2 = 211.6d0 real(dp), parameter :: B3 = -1d-4 real(dp), parameter :: B4 = 4.62d-3 - + FA = A1 * (sqrt(g * (A2 + g)) - A2 * log(sqrt(g / A2) + sqrt(1 + g / A2))) & + 2d0 * A3 * (sqrt(g) - atan(sqrt(g))) FB = B1 * (g - B2 * log(1d0 + g / B2)) + 0.5d0 * B3 * log(1d0 + pow2(g) / B4) - F = FA + FB + F = FA + FB end function classical_ocp_liquid_free_energy - !> Calculates the quantum corrections to the free energy of a - !! one-component plasma in the liquid phase using the fits due to + !> Calculates the quantum corrections to the free energy of a + !! one-component plasma in the liquid phase using the fits due to !! Baiko & Yakovlev 2019. !! !! @param TPT effective T_p/T - ion quantum parameter @@ -120,7 +120,7 @@ function liquid_mixing_rule_correction(RS,GAME,Zmean,Z2mean,Z52,Z53,Z321) result type(auto_diff_real_2var_order3) :: GAMImean, Dif0, DifR, DifFDH, D type(auto_diff_real_2var_order3) :: P3, D0, GP, FMIX0, Q, R, GQ - + type(auto_diff_real_2var_order3) :: FMIX real(dp), parameter :: TINY = 1d-9 @@ -131,7 +131,7 @@ function liquid_mixing_rule_correction(RS,GAME,Zmean,Z2mean,Z52,Z53,Z321) result FMIX=0d0 return end if - + GAMImean=GAME*Z53 if (RS.lt.TINY) then ! OCP Dif0=Z52-sqrt(Z2mean*Z2mean*Z2mean/Zmean) diff --git a/eos/private/skye_coulomb_solid.f90 b/eos/private/skye_coulomb_solid.f90 index aac38d964..ccb6a0173 100644 --- a/eos/private/skye_coulomb_solid.f90 +++ b/eos/private/skye_coulomb_solid.f90 @@ -62,7 +62,7 @@ function ocp_solid_harmonic_free_energy(GAMI,TPT_in) result(F) ! Intermediates type(auto_diff_real_2var_order3) :: TPT, UP, DN, EA, EB, EG, E0 type(auto_diff_real_2var_order3) :: Fth, U0 - + ! Output type(auto_diff_real_2var_order3) :: F @@ -239,13 +239,13 @@ end function deltaG_PC13 !> Calculates the correction to the linear mixing rule for a Coulomb solid mixture !! by extending a two-component deltaG prescription to the multi-component case, using the !! prescription of Medin & Cumming 2010. - !! + !! !! @param n Number of species !! @param AY Array of length NMIX holding the masses of species !! @param AZion Array of length NMIX holding the charges of species !! @param GAME election interaction parameter !! @param F mixing free energy correction per ion per kT. - function solid_mixing_rule_correction(Skye_solid_mixing_rule, n, AY, AZion, GAME) result(F) + function solid_mixing_rule_correction(Skye_solid_mixing_rule, n, AY, AZion, GAME) result(F) ! Inputs character(len=128), intent(in) :: Skye_solid_mixing_rule integer, intent(in) :: n @@ -302,7 +302,7 @@ function solid_mixing_rule_correction(Skye_solid_mixing_rule, n, AY, AZion, GAME if (unique_charges(j) < unique_charges(i)) cycle RZ = unique_charges(j)/unique_charges(i) ! Charge ratio - + ! max avoids divergence. ! The contribution to F scales as abundance_sum^2, so in cases where the max returns eps ! we don't care much about the error this incurs. diff --git a/eos/private/skye_ideal.f90 b/eos/private/skye_ideal.f90 index ed8dc16f1..dc3055b90 100644 --- a/eos/private/skye_ideal.f90 +++ b/eos/private/skye_ideal.f90 @@ -189,7 +189,7 @@ subroutine compute_ideal_ele(temp_in, den_in, din_in, logtemp_in, logden_in, zba dindaz = -den*ww dinddaa = 2.0d0*ye*ww dinddaz = -ww - dindzz = 0.0d0 + dindzz = 0.0d0 !..hash locate this temperature and density @@ -281,7 +281,7 @@ subroutine compute_ideal_ele(temp_in, den_in, din_in, logtemp_in, logden_in, zba ddsi0t = ddpsi0(xt) * ht% dt2i_sav(jat) ddsi1t = ddpsi1(xt) * ht% dti_sav(jat) ddsi2t = ddpsi2(xt) - + ddsi0mt = ddpsi0(mxt) * ht% dt2i_sav(jat) ddsi1mt = -ddpsi1(mxt) * ht% dti_sav(jat) ddsi2mt = ddpsi2(mxt) @@ -298,7 +298,7 @@ subroutine compute_ideal_ele(temp_in, den_in, din_in, logtemp_in, logden_in, zba dddsi0t = dddpsi0(xt) * ht% dt3i_sav(jat) dddsi1t = dddpsi1(xt) * ht% dt2i_sav(jat) dddsi2t = dddpsi2(xt) * ht% dti_sav(jat) - + dddsi0mt = -dddpsi0(mxt) * ht% dt3i_sav(jat) dddsi1mt = dddpsi1(mxt) * ht% dt2i_sav(jat) dddsi2mt = -dddpsi2(mxt) * ht% dti_sav(jat) @@ -362,7 +362,7 @@ subroutine compute_ideal_ele(temp_in, den_in, din_in, logtemp_in, logden_in, zba si0t, si1t, si2t, si0mt, si1mt, si2mt, & dddsi0d, dddsi1d, dddsi2d, dddsi0md, dddsi1md, dddsi2md) -!..now get the pressure derivative with density, chemical potential, and +!..now get the pressure derivative with density, chemical potential, and !..electron positron number densities !..get the cubic interpolation weight functions @@ -407,7 +407,7 @@ subroutine compute_ideal_ele(temp_in, den_in, din_in, logtemp_in, logden_in, zba dddsi0d = xdddpsi0(xd) * ht% dd3i_sav(iat) dddsi1d = xdddpsi1(xd) * ht% dd2i_sav(iat) dddsi0md = -xdddpsi0(mxd) * ht% dd3i_sav(iat) - dddsi1md = xdddpsi1(mxd) * ht% dd2i_sav(iat) + dddsi1md = xdddpsi1(mxd) * ht% dd2i_sav(iat) !..look in the electron chemical potential table only once fi(1) = ht% ef(iat,jat) @@ -438,7 +438,7 @@ subroutine compute_ideal_ele(temp_in, den_in, din_in, logtemp_in, logden_in, zba x = h3(iat,jat,fi, & si0t, si1t, si0mt, si1mt, & dsi0d, dsi1d, dsi0md, dsi1md) - detadd = ye * x + detadd = ye * x detadt = h3(iat,jat,fi, & dsi0t, dsi1t, dsi0mt, dsi1mt, & si0d, si1d, si0md, si1md) @@ -462,14 +462,14 @@ subroutine compute_ideal_ele(temp_in, den_in, din_in, logtemp_in, logden_in, zba detadta = z * dinda detadtz = z * dindz detadaa = (y*din + 2.0d0*x)*din*ww - detadaz = -(y*dindz*din + x*den*ytot1)*ytot1 + detadaz = -(y*dindz*din + x*den*ytot1)*ytot1 detadzz = y*dindz*den*ytot1 !..third derivatives y = h3(iat,jat,fi, & si0t, si1t, si0mt, si1mt, & - dddsi0d, dddsi1d, dddsi0md, dddsi1md) - detadddd = ye * ye * ye * y ! Actual interpolation variable is ye * rho, so we multiply by ye to get d/d(density) + dddsi0d, dddsi1d, dddsi0md, dddsi1md) + detadddd = ye * ye * ye * y ! Actual interpolation variable is ye * rho, so we multiply by ye to get d/d(density) ! ! d/drho^3 detadttt = h3(iat,jat,fi, & @@ -478,12 +478,12 @@ subroutine compute_ideal_ele(temp_in, den_in, din_in, logtemp_in, logden_in, zba y = h3(iat,jat,fi, & dsi0t, dsi1t, dsi0mt, dsi1mt, & - ddsi0d, ddsi1d, ddsi0md, ddsi1md) + ddsi0d, ddsi1d, ddsi0md, ddsi1md) detadddt = ye * ye * y ! d/drho^2 d/dT y = h3(iat,jat,fi, & ddsi0t, ddsi1t, ddsi0mt, ddsi1mt, & - dsi0d, dsi1d, dsi0md, dsi1md) + dsi0d, dsi1d, dsi0md, dsi1md) detaddtt = ye * y ! d/drho d/dT^2 @@ -546,7 +546,7 @@ subroutine compute_ideal_ele(temp_in, den_in, din_in, logtemp_in, logden_in, zba y = h3(iat,jat,fi, & si0t, si1t, si0mt, si1mt, & ddsi0d, ddsi1d, ddsi0md, ddsi1md) - dxneddd = ye * ye * y + dxneddd = ye * ye * y z = h3(iat,jat,fi, & dsi0t, dsi1t, dsi0mt, dsi1mt, & dsi0d, dsi1d, dsi0md, dsi1md) @@ -559,14 +559,14 @@ subroutine compute_ideal_ele(temp_in, den_in, din_in, logtemp_in, logden_in, zba dxnedta = z * dinda dxnedtz = z * dindz dxnedaa = (y*din + 2.0d0*x)*din*ytot1*ytot1 - dxnedaz = -(y*dindz*din + x*den*ytot1)*ytot1 + dxnedaz = -(y*dindz*din + x*den*ytot1)*ytot1 dxnedzz = y*dindz*den*ytot1 !..third derivatives y = h3(iat,jat,fi, & si0t, si1t, si0mt, si1mt, & - dddsi0d, dddsi1d, dddsi0md, dddsi1md) - dxneferdddd = ye * ye * ye * y ! Actual interpolation variable is ye * rho, so we multiply by ye to get d/d(density) + dddsi0d, dddsi1d, dddsi0md, dddsi1md) + dxneferdddd = ye * ye * ye * y ! Actual interpolation variable is ye * rho, so we multiply by ye to get d/d(density) ! ! d/drho^3 dxneferdttt = h3(iat,jat,fi, & @@ -576,12 +576,12 @@ subroutine compute_ideal_ele(temp_in, den_in, din_in, logtemp_in, logden_in, zba y = h3(iat,jat,fi, & dsi0t, dsi1t, dsi0mt, dsi1mt, & - ddsi0d, ddsi1d, ddsi0md, ddsi1md) + ddsi0d, ddsi1d, ddsi0md, ddsi1md) dxneferdddt = ye * ye * y ! d/drho^2 d/dT y = h3(iat,jat,fi, & ddsi0t, ddsi1t, ddsi0mt, ddsi1mt, & - dsi0d, dsi1d, dsi0md, dsi1md) + dsi0d, dsi1d, dsi0md, dsi1md) dxneferddtt = ye * y ! d/drho d/dT^2 diff --git a/eos/private/skye_thermodynamics.f90 b/eos/private/skye_thermodynamics.f90 index 63173ca50..6b2cd2b9f 100644 --- a/eos/private/skye_thermodynamics.f90 +++ b/eos/private/skye_thermodynamics.f90 @@ -126,14 +126,14 @@ subroutine pack_for_export(F_ideal_ion, F_coul, F_rad, F_ele, temp, dens, xnefer ! Compute base thermodynamic quantities call thermodynamics_from_free_energy(F_gas, temp, dens, sgas, egas, pgas) - + ! Write the radiation terms explicitly to avoid having rho^2/rho^2 term that ! auto_diff gives for prad when calling thermodynamics_from_free_energy on F_rad. ! This avoids some subtractions for quantities that should be 0 like chid. prad = crad * pow4(temp) / 3d0 erad = crad * pow4(temp) / dens srad = 4d0 * crad * pow3(temp) / (3d0 * dens) - + p = prad + pgas e = erad + egas s = srad + sgas @@ -146,7 +146,7 @@ subroutine pack_for_export(F_ideal_ion, F_coul, F_rad, F_ele, temp, dens, xnefer lnS = log(s) lnE = log(e) lnPgas = log(pgas) - + ! assuming complete ionization mu = abar / (1d0 + zbar) lnfree_e = log(max(1d-99, xnefer)/(avo*dens)) @@ -192,7 +192,7 @@ subroutine pack_for_export(F_ideal_ion, F_coul, F_rad, F_ele, temp, dens, xnefer d_dlnT(i_eta) = etaele%d1val1 * temp%val d_dlnT(i_phase) = phase%d1val1 * temp%val d_dlnT(i_latent_ddlnT) = latent_ddlnT%d1val1 * temp%val - d_dlnT(i_latent_ddlnRho) = latent_ddlnRho%d1val1 * temp%val + d_dlnT(i_latent_ddlnRho) = latent_ddlnRho%d1val1 * temp%val d_dlnRho(i_lnS) = lnS%d1val2 * dens%val d_dlnRho(i_lnE) = lnE%d1val2 * dens%val diff --git a/eos/public/eos_def.f90 b/eos/public/eos_def.f90 index dfb4b2f56..36450f54b 100644 --- a/eos/public/eos_def.f90 +++ b/eos/public/eos_def.f90 @@ -25,12 +25,12 @@ ! *********************************************************************** module eos_def - + use const_def, only: dp, use_mesa_temp_cache, strlen use chem_def, only: max_el_z - + implicit none - + ! interfaces for procedure pointers abstract interface @@ -91,45 +91,45 @@ end subroutine other_eos_interface logical, parameter :: show_allocations = .false. ! for debugging memory usage integer, parameter :: eos_name_length = 20 ! String length for storing EOS variable names - - + + ! cgs units ! the basic eos results - + integer, parameter :: i_lnPgas = 1 ! gas pressure (total pressure minus radiation pressure) - integer, parameter :: i_lnE = i_lnPgas+1 + integer, parameter :: i_lnE = i_lnPgas+1 ! internal energy per gram - integer, parameter :: i_lnS = i_lnE+1 + integer, parameter :: i_lnS = i_lnE+1 ! entropy per gram - integer, parameter :: i_mu = i_lnS+1 + integer, parameter :: i_mu = i_lnS+1 ! mean molecular weight per gas particle (ions + free electrons) integer, parameter :: i_lnfree_e = i_mu+1 ! free_e := total combined number per nucleon of free electrons - integer, parameter :: i_eta = i_lnfree_e+1 + integer, parameter :: i_eta = i_lnfree_e+1 ! electron degeneracy parameter (eta > 1 for significant degeneracy) ! eta = ratio of electron chemical potential to kT integer, parameter :: i_grad_ad = i_eta+1 ! dlnT_dlnP at constant S integer, parameter :: i_chiRho = i_grad_ad+1 ! dlnP_dlnRho at constant T - integer, parameter :: i_chiT = i_chiRho+1 + integer, parameter :: i_chiT = i_chiRho+1 ! dlnP_dlnT at constant Rho integer, parameter :: i_Cp = i_chiT+1 ! dh_dT at constant P, specific heat at constant total pressure ! where h is enthalpy, h = E + P/Rho - integer, parameter :: i_Cv = i_Cp+1 + integer, parameter :: i_Cv = i_Cp+1 ! dE_dT at constant Rho, specific heat at constant volume integer, parameter :: i_dE_dRho = i_Cv+1 ! at constant T - integer, parameter :: i_dS_dT = i_dE_dRho+1 + integer, parameter :: i_dS_dT = i_dE_dRho+1 ! at constant Rho - integer, parameter :: i_dS_dRho = i_dS_dT+1 + integer, parameter :: i_dS_dRho = i_dS_dT+1 ! at constant T - integer, parameter :: i_gamma1 = i_dS_dRho+1 + integer, parameter :: i_gamma1 = i_dS_dRho+1 ! dlnP_dlnRho at constant S - integer, parameter :: i_gamma3 = i_gamma1+1 + integer, parameter :: i_gamma3 = i_gamma1+1 ! gamma3 - 1 = dlnT_dlnRho at constant S integer, parameter :: i_phase = i_gamma3+1 ! phase: 1 for solid, 0 for liquid, in-between for blend @@ -165,7 +165,7 @@ end subroutine other_eos_interface ! i_frac:i_frac+num_eos_frac_results-1 integer, parameter :: i_frac = i_frac_HELM ! first frac entry integer, parameter :: num_eos_frac_results = 7 - + integer, parameter :: num_eos_basic_results = i_frac_ideal integer, parameter :: nv = num_eos_basic_results @@ -181,21 +181,21 @@ end subroutine other_eos_interface integer, parameter :: i_logPtot = 0 ! log10 total pressure (gas + radiation) integer, parameter :: i_egas = -1 ! gas specific energy density (no radiation) - - ! NOTE: the calculation of eta is based on the following equation for ne, + + ! NOTE: the calculation of eta is based on the following equation for ne, ! the mean number of free electrons per cm^3, ! assuming non-relativistic electrons (okay for T < 10^9 at least) ! ! ne = 4 Pi / h^3 (2 me k T)^1.5 F[1/2,eta] -- see, for example, Clayton, eqn 2-57 - ! where F is the fermi-dirac integral: + ! where F is the fermi-dirac integral: ! F[beta,eta] := Integrate[(u^beta)/(1+E^(u-eta)),{u,0,Infinity}] - ! - ! CAVEAT: when free_e, the mean number of free electrons per nucleon gets really small, + ! + ! CAVEAT: when free_e, the mean number of free electrons per nucleon gets really small, ! eta isn't very interesting because there aren't a lot of free electrons to be degenerate! ! our calculation of eta gets flaky at this point as well. - ! we sweep this problem under the rug by making eta tend to a fairly large negative value + ! we sweep this problem under the rug by making eta tend to a fairly large negative value ! when free_e < 0.01 or so. this roughly corresponds to T < 10^4 or less. - + integer, parameter :: eosdt_OPAL_SCVH = 1 integer, parameter :: eosdt_max_FreeEOS = 2 @@ -204,7 +204,7 @@ end subroutine other_eos_interface integer, parameter :: num_eosDT_Zs = 3 integer, parameter :: num_eosDT_Xs = 6 - + integer, parameter :: num_FreeEOS_Zs = 15 integer, parameter :: num_FreeEOS_Xs = 12 @@ -214,7 +214,7 @@ end subroutine other_eos_interface integer :: nXs_for_Z(max_num_DT_Zs) real(dp) :: Xs_for_Z(max_num_DT_Xs, max_num_DT_Zs) end type DT_XZ_Info - + type (DT_XZ_Info), target :: eosDT_XZ_struct, FreeEOS_XZ_struct integer, parameter :: sz_per_eos_point = 4 ! for bicubic spline interpolation @@ -226,7 +226,7 @@ end subroutine other_eos_interface real(dp) :: logT_all_HELM ! all HELM for lgT >= this real(dp) :: logT_low_all_HELM ! all HELM for lgT <= this real(dp) :: coulomb_temp_cut_HELM, coulomb_den_cut_HELM - + ! limits for OPAL_SCVH logical :: use_OPAL_SCVH real(dp) :: logT_low_all_SCVH ! SCVH for lgT >= this @@ -237,7 +237,7 @@ end subroutine other_eos_interface real(dp) :: logQ_max_OPAL_SCVH ! no OPAL/SCVH for logQ > this real(dp) :: logQ_min_OPAL_SCVH ! no OPAL/SCVH for logQ <= this. real(dp) :: Z_all_OPAL ! all OPAL for Z <= this - + ! limits for FreeEOS logical :: use_FreeEOS real(dp) :: logQ_max_FreeEOS_hi @@ -262,7 +262,7 @@ end subroutine other_eos_interface real(dp) :: logT_cut_FreeEOS_hi real(dp) :: logT_cut_FreeEOS_lo character (len=30) :: suffix_for_FreeEOS_Z(num_FreeEOS_Zs) - + ! limits for CMS logical :: use_CMS, CMS_use_fixed_composition integer :: CMS_fixed_composition_index ! in [0,10] @@ -272,9 +272,9 @@ end subroutine other_eos_interface real(dp) :: logRho_max_for_all_CMS, logRho_max_for_any_CMS ! for upper blend zone in logRho real(dp) :: logRho_min_for_all_CMS, logRho_min_for_any_CMS ! for lower blend zone in logRho real(dp) :: logT_max_for_all_CMS, logT_max_for_any_CMS ! for upper blend zone in logT - real(dp) :: logT_min_for_all_CMS, logT_min_for_any_CMS ! for lower blend zone in logT + real(dp) :: logT_min_for_all_CMS, logT_min_for_any_CMS ! for lower blend zone in logT real(dp) :: logT_max_for_all_CMS_pure_He, logT_max_for_any_CMS_pure_He ! upper logT blend zone is different for pure He - + ! limits for PC logical :: use_PC real(dp) :: mass_fraction_limit_for_PC ! skip any species with abundance < this @@ -307,11 +307,11 @@ end subroutine other_eos_interface logical :: include_radiation, include_elec_pos logical :: eosDT_use_linear_interp_for_X logical :: eosDT_use_linear_interp_to_HELM - + character(len=128) :: eosDT_file_prefix logical :: okay_to_convert_ierr_to_skip - + ! other eos logical :: use_other_eos_component procedure (other_eos_frac_interface), pointer, nopass :: & @@ -321,14 +321,14 @@ end subroutine other_eos_interface logical :: use_other_eos_results procedure (other_eos_interface), pointer, nopass :: & other_eos_results => null() - + ! debugging logical :: dbg real(dp) :: logT_lo, logT_hi real(dp) :: logRho_lo, logRho_hi real(dp) :: X_lo, X_hi real(dp) :: Z_lo, Z_hi - + ! bookkeeping integer :: handle logical :: in_use @@ -342,17 +342,17 @@ end subroutine other_eos_interface end type EoS_General_Info - + include 'helm_def.dek' ! THE FOLLOWING ARE PRIVATE DEFS -- NOT FOR USE BY CLIENTS - - + + ! data table types - + type (HELM_Table), pointer :: eos_ht - + ! for mesa (logQ,logT) tables type EosDT_XZ_Info real(dp) :: logQ_min ! logQ = logRho - 2*logT + 12 @@ -378,7 +378,7 @@ end subroutine other_eos_interface logical, dimension(num_eosDT_Xs, num_eosDT_Zs) :: & eosDT_XZ_loaded, eosSCVH_XZ_loaded, eosCMS_XZ_loaded logical, dimension(num_FreeEOS_Xs, num_FreeEOS_Zs) :: FreeEOS_XZ_loaded - + ! interpolation info for eosPC support tables FITION9 type FITION_Info @@ -396,10 +396,10 @@ end subroutine other_eos_interface real(dp) :: lnGAME_min, lnGAME_max, dlnGAME real(dp), pointer :: lnRSs(:) ! (nlnRS) real(dp), pointer :: lnGAMEs(:) ! (nlnGAME) - real(dp), pointer :: tbl1(:) ! (4,nvals,nlnRS,nlnGAME) + real(dp), pointer :: tbl1(:) ! (4,nvals,nlnRS,nlnGAME) real(dp), pointer :: tbl(:,:,:,:) ! => tbl1(:) end type eosPC_Support_Info - + integer, parameter :: max_FSCRliq8_Zion = max_el_z type (eosPC_Support_Info), target :: FSCRliq8_data(max_FSCRliq8_Zion) logical, dimension(max_FSCRliq8_Zion) :: FSCRliq8_Zion_loaded @@ -409,7 +409,7 @@ end subroutine other_eos_interface integer, parameter :: max_eos_handles = 10 type (EoS_General_Info), target :: eos_handles(max_eos_handles) - + logical :: use_cache_for_eos = .true. logical :: eos_root_is_initialized = .false. @@ -418,16 +418,16 @@ end subroutine other_eos_interface logical :: eos_test_partials real(dp) :: eos_test_partials_val, eos_test_partials_dval_dx ! for dfridr from star - - + + contains - - + + subroutine eos_def_init integer :: i type (DT_XZ_Info), pointer :: eosDT_XZ_ptr, FreeEOS_XZ_ptr include 'formats' - + use_cache_for_eos = .true. eos_root_is_initialized = .false. eos_test_partials = .false. @@ -469,12 +469,12 @@ subroutine eos_def_init end do FreeEOS_XZ_ptr% Xs_for_Z(1:2,14) = (/ 0.0d0, 0.1d0 /) ! 0.9 FreeEOS_XZ_ptr% Xs_for_Z(1,15) = 0.0d0 ! 1.0 - + eosDT_XZ_loaded(:,:) = .false. eosSCVH_XZ_loaded(:,:)=.false. FreeEOS_XZ_loaded(:,:)=.false. eosCMS_XZ_loaded(:,:)=.false. - + eosDT_result_names(i_lnPgas) = 'lnPgas' eosDT_result_names(i_lnE) = 'lnE' eosDT_result_names(i_lnS) = 'lnS' @@ -504,7 +504,7 @@ subroutine eos_def_init end subroutine eos_def_init - + integer function do_alloc_eos(ierr) result(handle) integer, intent(out) :: ierr integer :: i @@ -543,10 +543,10 @@ subroutine init_eos_handle_data(handle) rq% other_eos_frac => null_other_eos_frac rq% other_eos_component => null_other_eos_component rq% other_eos_results => null_other_eos_results - + end subroutine init_eos_handle_data - - + + subroutine do_free_eos_handle(handle) integer, intent(in) :: handle type (EoS_General_Info), pointer :: rq @@ -555,12 +555,12 @@ subroutine do_free_eos_handle(handle) eos_handles(handle)% in_use = .false. end if end subroutine do_free_eos_handle - + subroutine get_eos_ptr(handle,rq,ierr) integer, intent(in) :: handle type (EoS_General_Info), pointer :: rq - integer, intent(out):: ierr + integer, intent(out):: ierr if (handle < 1 .or. handle > max_eos_handles) then ierr = -1 return @@ -568,8 +568,8 @@ subroutine get_eos_ptr(handle,rq,ierr) rq => eos_handles(handle) ierr = 0 end subroutine get_eos_ptr - - + + subroutine eos_def_shutdown type (eosPC_Support_Info), pointer :: fq type (FITION_Info), pointer :: fi @@ -600,19 +600,19 @@ subroutine eos_def_shutdown fq => EXCOR7_data call free_eosPC_support_Info(fq) EXCOR7_table_loaded = .false. - + do iz = 1, max_FSCRliq8_Zion if (.not. FSCRliq8_Zion_loaded(iz)) cycle fq => FSCRliq8_data(iz) call free_eosPC_support_Info(fq) end do FSCRliq8_Zion_loaded(:) = .false. - + eos_root_is_initialized = .false. - - + + contains - + subroutine free_eosPC_support_Info(fq) type (eosPC_Support_Info), pointer :: fq if (ASSOCIATED(fq% lnRSs)) deallocate(fq% lnRSs) @@ -620,7 +620,7 @@ subroutine free_eosPC_support_Info(fq) if (ASSOCIATED(fq% tbl1)) deallocate(fq% tbl1) nullify(fq% tbl) end subroutine free_eosPC_support_Info - + subroutine free_EosDT_XZ_Info(d, flgs, numXs, numZs) integer, intent(in) :: numXs, numZs type (EosDT_XZ_Info), dimension(numXs, numZs) :: d @@ -646,4 +646,4 @@ end subroutine eos_def_shutdown end module eos_def - + diff --git a/eos/public/eos_lib.f90 b/eos/public/eos_lib.f90 index ecd4aed41..fb575e225 100644 --- a/eos/public/eos_lib.f90 +++ b/eos/public/eos_lib.f90 @@ -34,54 +34,54 @@ module eos_lib contains ! the procedure interface for the library ! client programs should only call these routines. - - + + subroutine eos_init( & - eosDT_cache_dir, use_cache, info) + eosDT_cache_dir, use_cache, info) use eos_initialize, only : Init_eos character(*), intent(in) :: eosDT_cache_dir ! blank string means use default logical, intent(in) :: use_cache - integer, intent(out) :: info ! 0 means AOK. + integer, intent(out) :: info ! 0 means AOK. info = 0 call Init_eos( & eosDT_cache_dir, use_cache, info) - if (info /= 0) return - end subroutine eos_init - + if (info /= 0) return + end subroutine eos_init + subroutine eos_shutdown use eos_def use helm_alloc,only:free_helm_table if (associated(eos_ht)) call free_helm_table(eos_ht) call eos_def_shutdown end subroutine eos_shutdown - - + + ! after eos_init has finished, you can allocate a "handle" ! and set control parameter values using an inlist - + integer function alloc_eos_handle(ierr) result(handle) - integer, intent(out) :: ierr ! 0 means AOK. - character (len=0) :: inlist + integer, intent(out) :: ierr ! 0 means AOK. + character (len=0) :: inlist handle = alloc_eos_handle_using_inlist(inlist, ierr) - end function alloc_eos_handle - + end function alloc_eos_handle + integer function alloc_eos_handle_using_inlist(inlist,ierr) result(handle) use eos_def, only:do_alloc_eos use eos_ctrls_io, only:read_namelist character (len=*), intent(in) :: inlist ! empty means just use defaults. - integer, intent(out) :: ierr ! 0 means AOK. + integer, intent(out) :: ierr ! 0 means AOK. ierr = 0 handle = do_alloc_eos(ierr) if (ierr /= 0) return call read_namelist(handle, inlist, ierr) - end function alloc_eos_handle_using_inlist - + end function alloc_eos_handle_using_inlist + subroutine free_eos_handle(handle) ! frees the handle and all associated data use eos_def,only:do_free_eos_handle integer, intent(in) :: handle call do_free_eos_handle(handle) - end subroutine free_eos_handle + end subroutine free_eos_handle subroutine eos_ptr(handle,rq,ierr) @@ -92,29 +92,29 @@ subroutine eos_ptr(handle,rq,ierr) call get_eos_ptr(handle,rq,ierr) end subroutine eos_ptr - + ! as a convenience - + elemental real(dp) function Radiation_Pressure(T) use const_def, only: crad real(dp), intent(in) :: T Radiation_Pressure = crad*T*T*T*T/3d0 end function Radiation_Pressure - + elemental real(dp) function Radiation_Energy(T) use const_def, only: crad real(dp), intent(in) :: T Radiation_Energy = crad*T*T*T*T end function Radiation_Energy - - - + + + ! eos evaluation - + ! you can call these routines after you've allocated a handle. ! NOTE: the information referenced via the handle is read-only, - ! so you can do multiple evaluations in parallel using the same handle. - + ! so you can do multiple evaluations in parallel using the same handle. + subroutine eosDT_get( & handle, species, chem_id, net_iso, xa, & @@ -127,11 +127,11 @@ subroutine eosDT_get( & integer, intent(in) :: species ! number of species integer, pointer :: chem_id(:) ! maps species to chem id integer, pointer :: net_iso(:) ! maps chem id to species number - real(dp), intent(in) :: xa(:) ! mass fractions + real(dp), intent(in) :: xa(:) ! mass fractions real(dp), intent(in) :: Rho, logRho ! the density - real(dp), intent(in) :: T, logT ! the temperature - real(dp), intent(inout) :: res(:) ! (num_eos_basic_results) - real(dp), intent(inout) :: d_dlnd(:) ! (num_eos_basic_results) + real(dp), intent(in) :: T, logT ! the temperature + real(dp), intent(inout) :: res(:) ! (num_eos_basic_results) + real(dp), intent(inout) :: d_dlnd(:) ! (num_eos_basic_results) real(dp), intent(inout) :: d_dlnT(:) ! (num_eos_basic_results) real(dp), intent(inout) :: d_dxa(:,:) ! (num_eos_d_dxa_results,species) integer, intent(out) :: ierr ! 0 means AOK. @@ -155,7 +155,7 @@ subroutine eosDT_get( & ! only return 1st two d_dxa results (lnE and lnPgas) to star d_dxa(1:num_eos_d_dxa_results,1:species) = d_dxa_eos(1:num_eos_d_dxa_results, 1:species) end subroutine eosDT_get - + subroutine eosDT_get_component( & handle, which_eos, & @@ -169,39 +169,39 @@ subroutine eosDT_get_component( & use eosDT_eval, only: Test_one_eosDT_component ! INPUT - + integer, intent(in) :: handle ! eos handle; from star, pass s% eos_handle - + integer, intent(in) :: which_eos ! see eos_def: i_eos_ integer, intent(in) :: species ! number of species integer, pointer :: chem_id(:) ! maps species to chem id ! index from 1 to species - ! value is between 1 and num_chem_isos + ! value is between 1 and num_chem_isos integer, pointer :: net_iso(:) ! maps chem id to species number ! index from 1 to num_chem_isos (defined in chem_def) ! value is 0 if the iso is not in the current net ! else is value between 1 and number of species in current net real(dp), intent(in) :: xa(:) ! mass fractions - + real(dp), intent(in) :: Rho, log10Rho ! the density ! provide both if you have them. else pass one and set the other to arg_not_provided ! "arg_not_provided" is defined in mesa const_def - + real(dp), intent(in) :: T, log10T ! the temperature ! provide both if you have them. else pass one and set the other to arg_not_provided - + ! OUTPUT - + real(dp), intent(inout) :: res(:) ! (num_eos_basic_results) ! partial derivatives of the basic results wrt lnd and lnT - - real(dp), intent(inout) :: d_dlnRho_const_T(:) ! (num_eos_basic_results) + + real(dp), intent(inout) :: d_dlnRho_const_T(:) ! (num_eos_basic_results) ! d_dlnRho_const_T(i) = d(res(i))/dlnd|T,X where X = composition - real(dp), intent(inout) :: d_dlnT_const_Rho(:) ! (num_eos_basic_results) + real(dp), intent(inout) :: d_dlnT_const_Rho(:) ! (num_eos_basic_results) ! d_dlnT(i) = d(res(i))/dlnT|Rho,X where X = composition real(dp), intent(inout) :: d_dxa_const_TRho(:,:) ! (num_eos_d_dxa_results,species) - + integer, intent(out) :: ierr ! 0 means AOK. real(dp), allocatable :: d_dxa_eos(:,:) ! eos internally returns derivs of all quantities @@ -209,7 +209,7 @@ subroutine eosDT_get_component( & type (EoS_General_Info), pointer :: rq real(dp) :: X, Y, Z, abar, zbar, z2bar, z53bar, ye, mass_correction, sumx - + call get_eos_ptr(handle,rq,ierr) if (ierr /= 0) then write(*,*) 'invalid handle for eos_get -- did you call alloc_eos_handle?' @@ -230,7 +230,7 @@ subroutine eosDT_get_component( & ! only return 1st two d_dxa results (lnE and lnPgas) d_dxa_const_TRho(1:num_eos_d_dxa_results,1:species) = d_dxa_eos(1:num_eos_d_dxa_results, 1:species) - + end subroutine eosDT_get_component @@ -239,7 +239,7 @@ subroutine helmeos2_eval( & coulomb_temp_cut, coulomb_den_cut, helm_res, & clip_to_table_boundaries, include_radiation, & include_elec_pos, & - off_table, ierr) + off_table, ierr) use helm real(dp), intent(in) :: T, logT, Rho, logRho, abar, zbar, & coulomb_temp_cut, coulomb_den_cut @@ -253,8 +253,8 @@ subroutine helmeos2_eval( & helm_res, clip_to_table_boundaries, include_radiation, include_elec_pos, & off_table, ierr) end subroutine helmeos2_eval - - + + ! the following routine uses gas pressure and temperature as input variables subroutine eosPT_get( & handle, & @@ -337,35 +337,35 @@ subroutine eosPT_get( & d_dxa_const_TRho(1:num_eos_d_dxa_results,1:species) = d_dxa_eos(1:num_eos_d_dxa_results, 1:species) end subroutine eosPT_get - - + + ! gamma law eos routines -- ignores radiation (e.g.., P = Pgas only) - - + + subroutine eos_gamma_DP_get_ET( & abar, rho, P, gamma, energy, T, ierr) use const_def, only: avo, kerg real(dp), intent(in) :: abar, rho, P, gamma real(dp), intent(out) :: energy, T integer, intent(out) :: ierr - ierr = 0 + ierr = 0 energy = (P/rho)/(gamma - 1d0) T = (gamma - 1d0)*energy*abar/(avo*kerg) end subroutine eos_gamma_DP_get_ET - - + + subroutine eos_gamma_DE_get_PT( & abar, rho, energy, gamma, P, T, ierr) use const_def, only: avo, kerg real(dp), intent(in) :: abar, rho, energy, gamma real(dp), intent(out) :: P, T integer, intent(out) :: ierr - ierr = 0 + ierr = 0 P = (gamma - 1d0)*energy*rho T = (gamma - 1d0)*energy*abar/(avo*kerg) end subroutine eos_gamma_DE_get_PT - - + + subroutine eos_gamma_DT_get_P_energy( & abar, rho, T, gamma, P, energy, ierr) use const_def, only: avo, kerg @@ -376,8 +376,8 @@ subroutine eos_gamma_DT_get_P_energy( & P = avo*kerg*rho*T/abar energy = (P/rho)/(gamma - 1d0) end subroutine eos_gamma_DT_get_P_energy - - + + subroutine eos_gamma_PRho_get_T_energy( & abar, P, rho, gamma, T, energy, ierr) use const_def, only: avo, kerg @@ -388,8 +388,8 @@ subroutine eos_gamma_PRho_get_T_energy( & energy = (P/rho)/(gamma - 1d0) T = (gamma - 1d0)*energy*abar/(avo*kerg) end subroutine eos_gamma_PRho_get_T_energy - - + + subroutine eos_gamma_PT_get_rho_energy( & abar, P, T, gamma, rho, energy, ierr) use const_def, only: avo, kerg @@ -400,8 +400,8 @@ subroutine eos_gamma_PT_get_rho_energy( & rho = (P/T)*abar/(avo*kerg) energy = (P/rho)/(gamma - 1d0) end subroutine eos_gamma_PT_get_rho_energy - - + + subroutine eos_gamma_DE_get( & handle, abar, energy, log10E, rho, log10Rho, gamma, & T, log10T, res, d_dlnRho_const_T, d_dlnT_const_Rho, & @@ -409,12 +409,12 @@ subroutine eos_gamma_DE_get( & dlnPgas_dlnE_c_Rho, dlnPgas_dlnd_c_E, ierr) use eos_def use eosDE_eval, only: Get_eos_gamma_DE_Results - integer, intent(in) :: handle + integer, intent(in) :: handle real(dp), intent(in) :: abar, energy, log10E, Rho, log10Rho, gamma real(dp), intent(out) :: T, log10T real(dp), intent(inout), dimension(:) :: & res, d_dlnRho_const_T, d_dlnT_const_Rho - real(dp), intent(out) :: & + real(dp), intent(out) :: & dlnT_dlnE_c_Rho, dlnT_dlnd_c_E, & dlnPgas_dlnE_c_Rho, dlnPgas_dlnd_c_E integer, intent(out) :: ierr @@ -444,14 +444,14 @@ subroutine eos_gamma_PT_get( & use eos_def use eosDE_eval, only: Get_eos_gamma_DE_Results use math_lib - integer, intent(in) :: handle + integer, intent(in) :: handle real(dp), intent(in) :: abar, P, log10P, T, log10T, gamma real(dp), intent(out) :: rho, log10Rho real(dp), intent(inout), dimension(:) :: & res, d_dlnRho_const_T, d_dlnT_const_Rho integer, intent(out) :: ierr type (EoS_General_Info), pointer :: rq - real(dp) :: energy, temp, log10temp, & + real(dp) :: energy, temp, log10temp, & dlnT_dlnE_c_Rho, dlnT_dlnd_c_E, & dlnPgas_dlnE_c_Rho, dlnPgas_dlnd_c_E call get_eos_ptr(handle,rq,ierr) @@ -483,14 +483,14 @@ subroutine eos_gamma_DT_get( & use eos_def use eosDE_eval, only: Get_eos_gamma_DE_Results use math_lib - integer, intent(in) :: handle + integer, intent(in) :: handle real(dp), intent(in) :: abar, rho, log10Rho, T, log10T, gamma real(dp), intent(inout), dimension(:) :: & res, d_dlnRho_const_T, d_dlnT_const_Rho real(dp), intent(out) :: Pgas, Prad, energy, entropy integer, intent(out) :: ierr type (EoS_General_Info), pointer :: rq - real(dp) :: P, temp, log10temp, & + real(dp) :: P, temp, log10temp, & dlnT_dlnE_c_Rho, dlnT_dlnd_c_E, & dlnPgas_dlnE_c_Rho, dlnPgas_dlnd_c_E call get_eos_ptr(handle,rq,ierr) @@ -519,16 +519,16 @@ end subroutine eos_gamma_DT_get ! misc - + subroutine eos_fermi_dirac_integral(dk, eta, theta, fd, fdeta, fdtheta) !..from Frank Timmes' site, http://www.cococubed.com/code_pages/fermi_dirac.shtml - !..this routine computes the fermi-dirac integrals of + !..this routine computes the fermi-dirac integrals of !..index dk, with degeneracy parameter eta and relativity parameter theta. !..input is dk the real(dp) index of the fermi-dirac function, !..eta the degeneracy parameter, and theta the relativity parameter. !..theta = (k * T)/(mass_electron * c^2), k = Boltzmann const. - !..the output is fd is computed by applying three 10-point + !..the output is fd is computed by applying three 10-point !..gauss-legendre and one 10-point gauss-laguerre rules over !..four appropriate subintervals. the derivative with respect to eta is !..output in fdeta, and the derivative with respct to theta is in fdtheta. @@ -538,7 +538,7 @@ subroutine eos_fermi_dirac_integral(dk, eta, theta, fd, fdeta, fdtheta) !.. !..reference: j.m. aparicio, apjs 117, 632 1998 use gauss_fermi, only: dfermi - + real(dp), intent(in) :: dk real(dp), intent(in) :: eta real(dp), intent(in) :: theta @@ -547,14 +547,14 @@ subroutine eos_fermi_dirac_integral(dk, eta, theta, fd, fdeta, fdtheta) real(dp), intent(out) :: fdtheta call dfermi(dk, eta, theta, fd, fdeta, fdtheta) end subroutine eos_fermi_dirac_integral - + subroutine eos_get_helm_results( & X, abar, zbar, Rho, log10Rho, T, log10T, & coulomb_temp_cut, coulomb_den_cut, & include_radiation, include_elec_pos, & res, ierr) - ! direct call to the helm eos. + ! direct call to the helm eos. ! returns much more info than the standard use eos_def @@ -563,29 +563,29 @@ subroutine eos_get_helm_results( & ! INPUT real(dp), intent(in) :: X ! the hydrogen mass fraction - + real(dp), intent(in) :: abar ! mean atomic number (nucleons per nucleus; grams per mole) real(dp), intent(in) :: zbar ! mean charge per nucleus - + real(dp), intent(in) :: Rho, log10Rho ! the density - ! provide both if you have them. + ! provide both if you have them. ! else pass one and set the other to arg_not_provided - + real(dp), intent(in) :: T, log10T ! the temperature - ! provide both if you have them. + ! provide both if you have them. ! else pass one and set the other to arg_not_provided real(dp), intent(in) :: coulomb_temp_cut, coulomb_den_cut logical, intent(in) :: include_radiation, include_elec_pos - + ! OUTPUT - + real(dp), intent(inout) :: res(:) ! (num_helm_results) ! array to hold the results - integer, intent(out) :: ierr ! 0 means AOK. - + integer, intent(out) :: ierr ! 0 means AOK. + logical :: off_table call Get_HELM_Results( & @@ -593,17 +593,17 @@ subroutine eos_get_helm_results( & coulomb_temp_cut, coulomb_den_cut, & include_radiation, include_elec_pos, & res, off_table, ierr) - + end subroutine eos_get_helm_results - - + + !subroutine eos_convert_helm_results( & ! helm_res, Z, X, abar, zbar, Rho, T, res, & - ! d_dlnRho_const_T, d_dlnT_const_Rho, ierr) + ! d_dlnRho_const_T, d_dlnT_const_Rho, ierr) subroutine eos_convert_helm_results( & helm_res, Z, X, abar, zbar, Rho, T, basic_flag, res, & d_dlnRho_const_T, d_dlnT_const_Rho, & - d_dabar_const_TRho, d_dzbar_const_TRho, ierr) + d_dabar_const_TRho, d_dzbar_const_TRho, ierr) use eos_def use eos_helm_eval, only: do_convert_helm_results real(dp), intent(in) :: helm_res(:) ! (num_helm_results) @@ -612,22 +612,22 @@ subroutine eos_convert_helm_results( & real(dp), intent(inout) :: res(:) ! (num_eos_basic_results) real(dp), intent(inout) :: d_dlnRho_const_T(:) ! (num_eos_basic_results) real(dp), intent(inout) :: d_dlnT_const_Rho(:) ! (num_eos_basic_results) - real(dp), intent(inout) :: d_dabar_const_TRho(:) ! (num_eos_basic_results) - real(dp), intent(inout) :: d_dzbar_const_TRho(:) ! (num_eos_basic_results) + real(dp), intent(inout) :: d_dabar_const_TRho(:) ! (num_eos_basic_results) + real(dp), intent(inout) :: d_dzbar_const_TRho(:) ! (num_eos_basic_results) !real(dp), intent(inout), dimension(:) :: d2_dlnd2, d2_dlnd_dlnT, d2_dlnT2 - integer, intent(out) :: ierr + integer, intent(out) :: ierr d_dabar_const_TRho = 0 d_dzbar_const_TRho = 0 call do_convert_helm_results( & helm_res, Z, abar, zbar, Rho, T, & res, d_dlnRho_const_T, d_dlnT_const_Rho, & d_dabar_const_TRho, d_dzbar_const_TRho, & - ierr) + ierr) end subroutine eos_convert_helm_results - + ! eosDT search routines. these use num_lib safe_root to find T or Rho. - + subroutine eosDT_get_T( & handle, & species, chem_id, net_iso, xa, & @@ -880,7 +880,7 @@ subroutine eosPT_get_T( & deallocate(d_dxa_eos) end subroutine eosPT_get_T - + subroutine num_eos_files_loaded( & num_DT, num_FreeEOS) diff --git a/eos/test/src/eos_support.f90 b/eos/test/src/eos_support.f90 index 0b9a4e54a..4e7badf2a 100644 --- a/eos/test/src/eos_support.f90 +++ b/eos/test/src/eos_support.f90 @@ -14,28 +14,28 @@ module eos_support !logical, parameter :: use_shared_data_dir = .false. - + real(dp) :: X, Z, Zinit, Y, dXC, dXO, XC, XO, abar, zbar, z2bar, z53bar, ye integer, parameter :: species = 7 integer, parameter :: h1=1, he4=2, c12=3, n14=4, o16=5, ne20=6, mg24=7 integer, target :: chem_id_array(species) integer, pointer, dimension(:) :: chem_id, net_iso real(dp) :: xa(species) - - + + real(dp), allocatable :: d_dxa(:,:) ! (num_d_dxa_basic_results,species) integer :: handle type (EoS_General_Info), pointer :: rq character (len=eos_name_length) :: eos_names(num_eos_basic_results) - + ! if false, then test using data from mesa/eos/data/eos_data ! if true, then test using data from mesa/data/eos_data - + contains - + subroutine Init_Composition(X_in, Zinit_in, XC_in, XO_in) use chem_lib @@ -45,15 +45,15 @@ subroutine Init_Composition(X_in, Zinit_in, XC_in, XO_in) real(dp), parameter :: Zfrac_N = 0.053177d0 real(dp), parameter :: Zfrac_O = 0.482398d0 real(dp), parameter :: Zfrac_Ne = 0.098675d0 - + real(dp) :: Z, frac, dabar_dx(species), dzbar_dx(species), sumx, & mass_correction, dmc_dx(species) - + chem_id => chem_id_array - + allocate(net_iso(num_chem_isos)) net_iso(:) = 0 - + chem_id(h1) = ih1; net_iso(ih1) = h1 chem_id(he4) = ihe4; net_iso(ihe4) = he4 chem_id(c12) = ic12; net_iso(ic12) = c12 @@ -61,7 +61,7 @@ subroutine Init_Composition(X_in, Zinit_in, XC_in, XO_in) chem_id(o16) = io16; net_iso(io16) = o16 chem_id(ne20) = ine20; net_iso(ine20) = ne20 chem_id(mg24) = img24; net_iso(img24) = mg24 - + X = X_in Zinit = Zinit_in XC = XC_in; XO = XO_in @@ -81,7 +81,7 @@ subroutine Init_Composition(X_in, Zinit_in, XC_in, XO_in) end if if (Y < 0) Y = 0 end if - + xa(h1) = X xa(he4) = Y xa(c12) = Zinit * Zfrac_C + XC @@ -89,7 +89,7 @@ subroutine Init_Composition(X_in, Zinit_in, XC_in, XO_in) xa(o16) = Zinit * Zfrac_O + XO xa(ne20) = Zinit * Zfrac_Ne xa(species) = 1 - sum(xa(1:species-1)) - + call composition_info( & species, chem_id, xa, X, Y, Z, abar, zbar, z2bar, z53bar, & ye, mass_correction, sumx, dabar_dx, dzbar_dx, dmc_dx) @@ -105,21 +105,21 @@ subroutine Setup_eos character (len=256) :: my_mesa_dir integer :: info logical :: use_cache - + info = 0 allocate(d_dxa(num_eos_d_dxa_results,species),stat=info) if (info /= 0) then write(*,*) 'allocate failed for Setup_eos' call mesa_error(__FILE__,__LINE__) end if - + my_mesa_dir = '../..' call const_init(my_mesa_dir,info) if (info /= 0) then write(*,*) 'const_init failed' call mesa_error(__FILE__,__LINE__) end if - + call math_init() call chem_init('isotopes.data', info) @@ -127,9 +127,9 @@ subroutine Setup_eos write(*,*) 'chem_init failed' call mesa_error(__FILE__,__LINE__) end if - + use_cache = .true. - + call eos_init(' ', use_cache, info) if (info /= 0) then write(*,*) 'failed in eos_init' @@ -148,17 +148,17 @@ subroutine Setup_eos write(*,*) 'failed in eos_ptr' call mesa_error(__FILE__,__LINE__) end if - + end subroutine Setup_eos - - + + subroutine Shutdown_eos call free_eos_handle(handle) call eos_shutdown deallocate(d_dxa) end subroutine Shutdown_eos - - + + end module eos_support diff --git a/eos/test/src/sample_eos.f90 b/eos/test/src/sample_eos.f90 index 1ce5ba4c8..e05f8112f 100644 --- a/eos/test/src/sample_eos.f90 +++ b/eos/test/src/sample_eos.f90 @@ -27,23 +27,23 @@ program sample_eos use chem_lib use const_lib use math_lib - + implicit none - + ! this program shows how to setup and use the mesa eos in an interactive manner. - + real(dp) :: X, Y, abar, zbar, z2bar, z53bar, ye integer, parameter :: species = 7 integer, parameter :: h1 = 1, he4 = 2, c12 = 3, n14 = 4, o16 = 5, ne20 = 6, mg24 = 7 integer, pointer, dimension(:) :: net_iso, chem_id real(dp) :: xa(species) - + call Sample - + contains - + subroutine Sample - + integer :: handle real(dp) :: Rho, T real(dp), dimension(num_eos_basic_results) :: res, d_dlnd, d_dlnT @@ -52,41 +52,41 @@ subroutine Sample integer :: ierr character(len=32) :: my_mesa_dir character(len=80) :: string - + ! explicitly set my_mesa_dir to your $MESA_DIR, or use a blank string, in which case your $MESA_DIR is automagically used - + my_mesa_dir = '../..' ! my_mesa_dir = '' - + ! initialize ierr = 0 - + call const_init(my_mesa_dir, ierr) if (ierr /= 0) call mesa_error(__FILE__, __LINE__) - + call math_init() - + call chem_init('isotopes.data', ierr) if (ierr /= 0) call mesa_error(__FILE__, __LINE__) - + call Setup_eos(handle) allocate (net_iso(num_chem_isos), chem_id(species), stat=ierr) if (ierr /= 0) call mesa_error(__FILE__, __LINE__) - + call Init_Composition - + ! keep returning to here do xa(:) = 0.0d0 - + ! get the temperature, density and composition - + write (6, *) write (6, *) 'give the temperature, density, and mass fractions (h1, he4, c12, n14, o16, ne20, mg24) =>' write (6, *) 'hit return for T = 1e9 K, Rho = 1e4 g/cc, x(c12) = 1 ; enter -1 to stop' write (6, *) read (5, '(a)') string - + ! stop if (string(1:2) .eq. '-1') then call Shutdown_eos(handle) @@ -94,36 +94,36 @@ subroutine Sample if (ierr /= 0) call mesa_error(__FILE__, __LINE__) ! exit call mesa_error(__FILE__, __LINE__, 'normal termination') - + ! read the conditions else if (string(1:6) .ne. ' ') then read (string, *) T, Rho, xa(h1), xa(he4), xa(c12), xa(n14), xa(o16), xa(ne20), xa(mg24) - + ! or set some defaults else T = 1.0d9; Rho = 1.0d4; xa(c12) = 1.0d0 end if end if - + ! get some composition variables call composition_info( & species, chem_id, xa, X, Y, xz, abar, zbar, z2bar, z53bar, ye, mass_correction, & sumx, dabar_dx, dzbar_dx, dmc_dx) - + ! call the density-temperature based eos - + ! composition derivatives by isotope - + call eosDT_get( & handle, species, chem_id, net_iso, xa, & Rho, log10(Rho), T, log10(T), & res, d_dlnd, d_dlnT, d_dxa, ierr) - + ! report the results - + call PrettyOut(Rho, T, abar, zbar, res, d_dlnd, d_dlnT) - + ! example calling the pressure-temperature based eos ! Pgas = exp(res(i_lnPgas)) ! call eosPT_get( & @@ -132,31 +132,31 @@ subroutine Sample ! Pgas, log10(Pgas), T, log10(T), & ! Rho, log10Rho, dlnRho_dlnPgas_const_T, dlnRho_dlnT_const_Pgas, & ! res, d_dlnd, d_dlnT, d_dabar, d_dzbar, ierr) - + ! back for another one end do - + end subroutine Sample - + subroutine Setup_eos(handle) ! allocate and load the eos tables use eos_def use eos_lib integer, intent(out) :: handle - + integer :: ierr logical, parameter :: use_cache = .true. - + call eos_init(' ', use_cache, ierr) if (ierr /= 0) call mesa_error(__FILE__, __LINE__) - + write (*, *) 'loading eos tables' - + handle = alloc_eos_handle(ierr) if (ierr /= 0) call mesa_error(__FILE__, __LINE__) - + end subroutine Setup_eos - + subroutine Shutdown_eos(handle) use eos_def use eos_lib @@ -164,12 +164,12 @@ subroutine Shutdown_eos(handle) call free_eos_handle(handle) call eos_shutdown end subroutine Shutdown_eos - + subroutine Init_Composition use chem_lib - + net_iso(:) = 0 - + chem_id(h1) = ih1; net_iso(ih1) = h1 chem_id(he4) = ihe4; net_iso(ihe4) = he4 chem_id(c12) = ic12; net_iso(ic12) = c12 @@ -177,18 +177,18 @@ subroutine Init_Composition chem_id(o16) = io16; net_iso(io16) = o16 chem_id(ne20) = ine20; net_iso(ine20) = ne20 chem_id(mg24) = img24; net_iso(img24) = mg24 - + end subroutine Init_Composition - + subroutine PrettyOut(Rho, T, abar, zbar, res, d_dlnd, d_dlnT) use eos_def use eos_lib use chem_lib - + ! declare the pass real(dp) :: Rho, T, abar, zbar real(dp), dimension(num_eos_basic_results) :: res, d_dlnd, d_dlnT - + ! local variables real(dp) :: my_ptot, my_dptotdd, my_dptotdt, my_dptotddd, my_dptotddt, my_dptotdtt, & my_etot, my_detotdd, my_detotdt, my_detotddd, my_detotddt, my_detotdtt, & @@ -204,14 +204,14 @@ subroutine PrettyOut(Rho, T, abar, zbar, res, d_dlnd, d_dlnT) my_g1, my_dg1dd, my_dg1dt, my_g2, my_dg2dd, my_dg2dt, my_g3, my_dg3dd, my_dg3dt, & my_grad, my_dgraddd, my_dgraddt, my_chit, my_dchitdd, my_dchitdt, my_chir, my_dchirdd, my_dchirdt, & my_cs, my_dcsdd, my_dcsdt, x, z, xx, yy, ww, dfk, dse, dpe, dsp - + ! popular format statements character(len=*), parameter :: fmt1 = "(1x, t2, a, t16, a, t31, a, t46, a, t59, a, t74, a, t89, a)" character(len=*), parameter :: fmt2 = "(1x, t2, a, 1p7e15.6)" character(len=*), parameter :: fmt3 = "(1x, t2, a7, 1pe14.6, t24, a7, 1pe14.6, t46, a7, 1pe14.6, t68, a7, 1pe14.6)" - + ! indices for the res, d_dlnd, and d_dlnt arrays are defined in $MESA_DIR/eos/public/eos_def.f90 - + ! radiation my_prad = crad*one_third*T*T*T*T my_dpraddd = 0.0d0 @@ -219,14 +219,14 @@ subroutine PrettyOut(Rho, T, abar, zbar, res, d_dlnd, d_dlnT) my_dpradddd = 0.0d0 my_dpradddt = 0.0d0 my_dpraddtt = 4.0d0*crad*T*T - + my_erad = 3.0d0*my_prad/Rho my_deraddd = -my_erad/Rho my_deraddt = 3.0d0*my_dpraddt/Rho my_deradddd = -2.0d0*my_deraddd/Rho my_deradddt = -my_deraddt/Rho my_deraddtt = 3.0d0*my_dpraddtt/Rho - + my_srad = (my_prad/Rho + my_erad)/T my_dsraddd = (my_dpraddd/Rho - my_prad/(Rho*Rho) + my_deraddd)/T my_dsraddt = (my_dpraddt/Rho + my_deraddt - my_srad)/T @@ -236,83 +236,83 @@ subroutine PrettyOut(Rho, T, abar, zbar, res, d_dlnd, d_dlnT) my_dsradddt = ((my_dpradddt - my_dpraddt/Rho)/Rho & + my_deradddt - my_dsraddd)/T my_dsraddtt = ((my_dpraddtt/Rho + my_deraddtt - my_dsraddt) - my_dsraddt)/T - + ! gas and totals ! pressure my_pgas = exp(res(i_lnPgas)) my_dpgasdd = my_pgas/Rho*d_dlnd(i_lnPgas) my_dpgasdt = my_pgas/T*d_dlnt(i_lnPgas) - + my_ptot = my_pgas + my_prad my_dptotdd = my_dpgasdd + my_dpraddd my_dptotdt = my_dpgasdt + my_dpraddt - + ! energy my_etot = exp(res(i_lnE)) my_detotdd = my_etot/Rho*d_dlnd(i_lnE) my_detotdt = my_etot/T*d_dlnt(i_lnE) - + my_egas = my_etot - my_erad my_degasdd = my_detotdd - my_deraddd my_degasdt = my_detotdt - my_deraddt - + ! entropy my_stot = exp(res(i_lnS)) my_dstotdd = my_stot/Rho*d_dlnd(i_lnS) my_dstotdt = my_stot/T*d_dlnt(i_lnS) - + my_sgas = my_stot - my_srad my_dsgasdd = my_dstotdd - my_dsraddd my_dsgasdt = my_dstotdt - my_dsraddt - + ! number densities and electron degeneracy my_xni = avo*Rho/abar my_dxnidd = avo/abar my_dxnidt = 0.0d0 - + my_xne = abar*my_xni*exp(res(i_lnfree_e)) my_dxnedd = abar*my_xni*exp(res(i_lnfree_e))/Rho*d_dlnd(i_lnfree_e) + abar*my_dxnidd*exp(res(i_lnfree_e)) my_dxnedt = abar*my_xni*exp(res(i_lnfree_e))/T*d_dlnt(i_lnfree_e) + abar*my_dxnidt*exp(res(i_lnfree_e)) - + my_eta = res(i_eta) my_detadd = d_dlnd(i_eta)/Rho my_detadt = d_dlnt(i_eta)/T - + ! total specific heats my_cv = res(i_Cv) my_dcvdd = d_dlnd(i_Cv)/Rho my_dcvdt = d_dlnt(i_Cv)/T - + my_cp = res(i_Cp) my_dcpdd = d_dlnd(i_Cp)/Rho my_dcpdt = d_dlnt(i_Cp)/T - + ! total gammas my_grad = res(i_grad_ad) my_dgraddd = d_dlnd(i_grad_ad)/Rho my_dgraddt = d_dlnt(i_grad_ad)/T - + my_g1 = res(i_gamma1) my_dg1dd = d_dlnd(i_gamma1)/Rho my_dg1dt = d_dlnt(i_gamma1)/T - + my_g2 = 1.0d0/(1.0d0 - my_grad) my_dg2dd = my_g2*my_g2*my_dgraddd my_dg2dt = my_g2*my_g2*my_dgraddt - + my_g3 = res(i_gamma3) my_dg3dd = d_dlnd(i_gamma3)/Rho my_dg3dt = d_dlnt(i_gamma3)/T - + ! total adiabatic exponents my_chit = res(i_chiT) my_dchitdd = d_dlnd(i_chiT)/Rho my_dchitdt = d_dlnt(i_chiT)/T - + my_chir = res(i_chiRho) my_dchirdd = d_dlnd(i_chiRho)/Rho my_dchirdt = d_dlnt(i_chiRho)/T - + ! total sound speed x = my_etot + clight*clight z = 1.0d0 + x*Rho/my_ptot @@ -323,89 +323,88 @@ subroutine PrettyOut(Rho, T, abar, zbar, res, d_dlnd, d_dlnT) yy = 0.5d0*my_cs/dfk my_dcsdd = yy*((my_dg1dd - dfk)*xx*(my_detotdd*Rho - ww*my_dptotdd + x)/my_ptot) my_dcsdt = yy*((my_dg1dt - dfk)*xx*(my_detotdt*Rho - ww*my_dptotdt)/my_ptot) - + ! maxwell relations; each is at flaoting point if the consistency is perfect dse = T*my_dstotdt/my_detotdt - 1.0d0 dpe = (my_detotdd*Rho*Rho + T*my_dptotdt)/my_ptot - 1.0d0 dsp = -my_dstotdd*(Rho*Rho/my_dptotdt) - 1.0d0 - + ! and finally some second derivatives - + ! pressure my_dpgasddd = my_pgas/Rho*my_dchirdd my_dpgasddt = my_pgas/Rho*my_dchirdt my_dpgasdtt = my_pgas/T*my_dchitdt - + my_dptotddd = my_dpgasddd + my_dpradddd my_dptotddt = my_dpgasddt + my_dpradddt my_dptotdtt = my_dpgasdtt + my_dpraddtt - + ! energy my_detotddd = d_dlnd(i_dE_dRho)/Rho my_detotddt = d_dlnT(i_dE_dRho)/T my_detotdtt = my_dcvdt - + my_degasddd = my_detotddd - my_deradddd my_degasddt = my_detotddt - my_deradddt my_degasdtt = my_detotdtt - my_deraddtt - + ! entropy my_dstotddd = d_dlnd(i_dS_dRho)/Rho my_dstotddt = d_dlnT(i_dS_dRho)/T my_dstotdtt = d_dlnT(i_dS_dT)/T - + my_dsgasddd = my_dstotddd - my_dsradddd my_dsgasddt = my_dstotddt - my_dsradddt my_dsgasdtt = my_dstotdtt - my_dsraddtt - + ! write 'em - + write (6, fmt3) 'T =', T, 'Rho =', Rho, 'abar =', abar, 'zbar =', zbar write (6, fmt3) 'h1 =', xa(h1), 'he4 =', xa(he4), 'c12 =', xa(c12), 'n14 =', xa(n14) write (6, fmt3) 'o16 =', xa(o16), 'ne20 =', xa(ne20), 'mg24 =', xa(mg24) - + write (6, *) ' ' write (6, fmt1) 'quantity', 'value', 'd/d(Rho)', 'd/d(T)', 'd^2/d(Rho)^2', 'd^2/d(Rho)d(T)', 'd^2/d(T)^2' - + ! pressure, energy, entropy write (6, fmt2) 'p tot =', my_ptot, my_dptotdd, my_dptotdt, my_dptotddd, my_dptotddt, my_dptotdtt write (6, fmt2) 'p gas =', my_pgas, my_dpgasdd, my_dpgasdt, my_dpgasddd, my_dpgasddt, my_dpgasdtt write (6, fmt2) 'p rad =', my_prad, my_dpraddd, my_dpraddt, my_dpradddd, my_dpradddt, my_dpraddtt - + write (6, '(A)') write (6, fmt2) 'e tot =', my_etot, my_detotdd, my_detotdt, my_detotddd, my_detotddt, my_detotdtt write (6, fmt2) 'e gas =', my_egas, my_degasdd, my_degasdt, my_degasddd, my_degasddt, my_degasdtt write (6, fmt2) 'e rad =', my_erad, my_deraddd, my_deraddt, my_deradddd, my_deradddt, my_deraddtt - + write (6, '(A)') write (6, fmt2) 's tot =', my_stot, my_dstotdd, my_dstotdt, my_dstotddd, my_dstotddt, my_dstotdtt write (6, fmt2) 's gas =', my_sgas, my_dsgasdd, my_dsgasdt, my_dsgasddd, my_dsgasddt, my_dsgasdtt write (6, fmt2) 's rad =', my_srad, my_dsraddd, my_dsraddt, my_dsradddd, my_dsradddt, my_dsraddtt - + ! ion and free electron matter number density, electron degeneracy parameter write (6, '(A)') write (6, fmt2) 'n_ion =', my_xni, my_dxnidd, my_dxnidt write (6, fmt2) 'n_ele =', my_xne, my_dxnedd, my_dxnedt write (6, fmt2) 'eta_e =', my_eta, my_detadd, my_detadt - + ! specific heats, 3 gammas, sound speed, chit and chid for the gas and the total write (6, fmt2) 'cv =', my_cv, my_dcvdd, my_dcvdt write (6, fmt2) 'cp =', my_cp, my_dcpdd, my_dcpdt - + write (6, fmt2) 'gamma_1 =', my_g1, my_dg1dd, my_dg1dt write (6, fmt2) 'gamma_2 =', my_g2, my_dg2dd, my_dg2dt write (6, fmt2) 'gamma_3 =', my_g3, my_dg3dd, my_dg3dt write (6, fmt2) 'grad_ad =', my_grad, my_dgraddd, my_dgraddt - + write (6, fmt2) 'chi_t =', my_chit, my_dchitdd, my_dchitdt write (6, fmt2) 'chi_d =', my_chir, my_dchirdd, my_dchirdt - + write (6, fmt2) 'c_sound =', my_cs, my_dcsdd, my_dcsdt - + write (6, '(A)') write (6, fmt3) 'dsp =', dse, 'dpe =', dpe, 'dsp =', dsp - + end subroutine PrettyOut - + end program sample_eos - \ No newline at end of file diff --git a/eos/test/src/test_eos.f90 b/eos/test/src/test_eos.f90 index 9b78b44d9..25c44b96e 100644 --- a/eos/test/src/test_eos.f90 +++ b/eos/test/src/test_eos.f90 @@ -4,18 +4,18 @@ program test_eos use math_lib use auto_diff use test_eos_blend - + implicit none - + logical, parameter :: quietly = .false. call Setup_eos - + call Do_One(quietly) call test1_eosPT_for_ck(quietly) - + call do_test_eos_blend() - end + end diff --git a/eos/test/src/test_eos_quietly.f90 b/eos/test/src/test_eos_quietly.f90 index 1d13bc51d..5a229d1b3 100644 --- a/eos/test/src/test_eos_quietly.f90 +++ b/eos/test/src/test_eos_quietly.f90 @@ -1,14 +1,14 @@ program test_eos_quietly use test_eos_support - + implicit none - + logical, parameter :: quietly = .true. - + call Setup_eos call Do_One(quietly) call test1_eosPT_for_ck(quietly) - end + end diff --git a/eos/test/src/test_eos_support.f90 b/eos/test/src/test_eos_support.f90 index 6ed01006a..f23603888 100644 --- a/eos/test/src/test_eos_support.f90 +++ b/eos/test/src/test_eos_support.f90 @@ -7,12 +7,12 @@ module test_eos_support use const_def use eos_support use math_lib - + implicit none contains - - + + subroutine test1_eosPT_for_ck(quietly) logical, intent(in) :: quietly real(dp) :: Z, X, logPgas, logT, logRho, logP @@ -24,7 +24,7 @@ subroutine test1_eosPT_for_ck(quietly) call test1_eosPT(Z, X, logPgas, logT, .false., quietly, logRho, logP) end subroutine test1_eosPT_for_ck - + subroutine test_eosPT(which) integer, intent(in) :: which real(dp) :: Z, X, logPgas, logT, logRho, logP @@ -34,8 +34,8 @@ subroutine test_eosPT(which) logPgas = 5d0 call test1_eosPT(Z, X, logPgas, logT, .false., .false., logRho, logP) end subroutine test_eosPT - - + + subroutine test1_eosPT(Z, X, logPgas, logT, do_compare, quietly, logRho, logP) logical, intent(in) :: quietly real(dp) :: Z, X, logPgas, logT @@ -50,14 +50,14 @@ subroutine test1_eosPT(Z, X, logPgas, logT, do_compare, quietly, logRho, logP) d_dlnT2(num_eos_basic_results) integer:: ierr, i character (len=eos_name_length) :: names(num_eos_basic_results) - - + + include 'formats' - + ierr = 0 call Init_Composition(X, Z, 0d0, 0d0) ! sets abar and zbar - + if (.false.) then ! TESTING z = 0d0 x = 0.72d0 @@ -67,7 +67,7 @@ subroutine test1_eosPT(Z, X, logPgas, logT, do_compare, quietly, logRho, logP) logPgas = 4.8066181993619859D+00 logT = 3.7569035961895620D+00 end if - + T = exp10(logT) Pgas = exp10(logPgas) @@ -94,13 +94,13 @@ subroutine test1_eosPT(Z, X, logPgas, logT, do_compare, quietly, logRho, logP) write(*,*) 'ierr in eosPT_get for test1_eosPT' call mesa_error(__FILE__,__LINE__) end if - + Prad = crad*T*T*T*T/3 P = Pgas + Prad logP = log10(P) - + if (quietly) return - + write(*,'(A)') write(*,1) 'rho', rho write(*,1) 'logRho', logRho @@ -109,7 +109,7 @@ subroutine test1_eosPT(Z, X, logPgas, logT, do_compare, quietly, logRho, logP) write(*,'(A)') names = eosDT_result_names - + if (.not. do_compare) then ! simple form of output write(*,1) 'dlnRho_dlnPgas_c_T', dlnRho_dlnPgas_c_T write(*,1) 'dlnRho_dlnT_c_Pgas', dlnRho_dlnT_c_Pgas @@ -134,9 +134,9 @@ subroutine test1_eosPT(Z, X, logPgas, logT, do_compare, quietly, logRho, logP) write(*,*) 'ierr in eosDT_get for test1_eosPT' call mesa_error(__FILE__,__LINE__) end if - + write(*,'(A)') - + write(*,1) 'dlnRho_dlnPgas_c_T', dlnRho_dlnPgas_c_T write(*,1) 'dlnRho_dlnT_c_Pgas', dlnRho_dlnT_c_Pgas do i=1, num_eos_basic_results @@ -144,28 +144,28 @@ subroutine test1_eosPT(Z, X, logPgas, logT, do_compare, quietly, logRho, logP) (res(i)-res2(i)) / max(1d0, abs(res(i)), abs(res2(i))) end do write(*,'(A)') - + do i=1, num_eos_basic_results write(*,1) 'd_dlnd ' // trim(names(i)), d_dlnd(i), d_dlnd2(i), & (d_dlnd(i)-d_dlnd2(i)) / max(1d0, abs(d_dlnd(i)), abs(d_dlnd2(i))) end do write(*,'(A)') - + do i=1, num_eos_basic_results write(*,1) 'd_dlnT ' // trim(names(i)), d_dlnT(i), & d_dlnT2(i), (d_dlnT(i)-d_dlnT2(i)) / max(1d0, abs(d_dlnT(i)), abs(d_dlnT2(i))) end do write(*,'(A)') - + end subroutine test1_eosPT - - + + subroutine Do_One(quietly) logical, intent(in) :: quietly real(dp) :: T, rho real(dp), dimension(num_eos_basic_results) :: res real(dp) :: dXC - + if (.true.) then ! pure Helium X = 0.00d0 @@ -192,7 +192,7 @@ subroutine Do_One(quietly) dXC = 0.00d0 call doit('solar') end if - + if (.true.) then ! do get_Rho and get_T X = 0.70d+00 Zinit = 0.02d0 @@ -207,22 +207,22 @@ subroutine Do_One(quietly) call test_get_Rho_T if (.not. quietly) write(*,*) end if - + contains - + subroutine doit(str) character (len=*), intent(in) :: str - + if (.false.) then T = 2d8; rho = 100 call Do_One_TRho(quietly,T,Rho,X,Zinit,dXC,dXO,Y,Z,res) ! scvh stop end if - + if (.not. quietly) write(*,*) trim(str) - + T = 1d6; rho = 1d-2 call Do_One_TRho(quietly,T,Rho,X,Zinit,dXC,dXO,Y,Z,res) ! opal T = 1d4; rho = 1d-1 @@ -231,9 +231,9 @@ subroutine doit(str) call Do_One_TRho(quietly,T,Rho,X,Zinit,dXC,dXO,Y,Z,res) ! opal-scvh overlap T = 2d8; rho = 1d2 call Do_One_TRho(quietly,T,Rho,X,Zinit,dXC,dXO,Y,Z,res) ! helm - + if (.not. quietly) write(*,*) - + end subroutine @@ -247,9 +247,9 @@ subroutine test_get_Rho_T ! using most recent values from subroutine Do_One_TRho d_dlnd, d_dlnT real(dp), dimension(num_eos_d_dxa_results, species) :: & d_dxa - + if (.not. quietly) write(*,*) - + log10_rho = log10(rho) log10_T = log10(T) lnS = res(i_lnS) @@ -260,7 +260,7 @@ subroutine test_get_Rho_T ! using most recent values from subroutine Do_One_TRho othertol = 1d-12 1 format(a30,1pe24.16) - + if (.not. quietly) then write(*,'(A)') write(*,1) ' tolerance', tol @@ -295,7 +295,7 @@ subroutine test_get_Rho_T ! using most recent values from subroutine Do_One_TRho write(*,1) ' got logS', res(i_lnS)/ln10 write(*,'(A)') end if - + result = T*2d0 ! initial guess result_log10 = log10(result) res = 0 @@ -365,11 +365,11 @@ subroutine test_get_Rho_T ! using most recent values from subroutine Do_One_TRho end subroutine test_get_Rho_T end subroutine Do_One - - - + + + subroutine test1_eosPT_get_T - + real(dp) :: & energy, abar, zbar, X, Z, logPgas, logT_tol, other_tol, other, & logT_guess, logT_bnd1, logT_bnd2, other_at_bnd1, other_at_bnd2, & @@ -377,15 +377,15 @@ subroutine test1_eosPT_get_T res(num_eos_basic_results), d_dlnd(num_eos_basic_results), & d_dxa(num_eos_d_dxa_results, species), & d_dlnT(num_eos_basic_results), & - Rho, log10Rho, dlnRho_dlnPgas_const_T, dlnRho_dlnT_const_Pgas + Rho, log10Rho, dlnRho_dlnPgas_const_T, dlnRho_dlnT_const_Pgas integer:: ierr, which_other, eos_calls, max_iter - + 1 format(a40,1pe26.16) - + call Setup_eos - + ierr = 0 - + write(*,*) 'test1_eosPT_get_T' Z = 0.02d0 @@ -443,9 +443,9 @@ subroutine test1_eosPT_get_T write(*,'(A)') write(*,*) 'eos_calls', eos_calls write(*,'(A)') - + end subroutine test1_eosPT_get_T - + subroutine test_components @@ -456,13 +456,13 @@ subroutine test_components res, d_dlnd, d_dlnT integer:: ierr include 'formats' - + write(*,*) 'test_components' - + call Setup_eos - + ierr = 0 - + X_test = 0.12d0 Z = 0.03d0 XC_test = 0d0 @@ -472,7 +472,7 @@ subroutine test_components logT = 6.0d0 logRho = 3.5d0 - + write(*,1) 'logT', logT write(*,1) 'logRho', logRho write(*,'(A)') @@ -498,7 +498,7 @@ subroutine test_components write(*,'(A)') contains - + subroutine test1(which_eos, str) integer, intent(in) :: which_eos character (len=*), intent(in) :: str @@ -512,15 +512,15 @@ subroutine test1(which_eos, str) write(*,1) trim(str) // ' no results' else write(*,1) trim(str), Pgas, energy, entropy - end if + end if end subroutine test1 - + end subroutine test_components - - + + subroutine test1_eosDT_get_T_given_egas - + real(dp) :: & X, Z, abar, zbar, logRho, egas_want, egas_tol, logT_tol, logT_guess, & logT_bnd1, logT_bnd2, egas_at_bnd1, egas_at_bnd2, logT_result, erad, egas, energy, & @@ -528,35 +528,35 @@ subroutine test1_eosDT_get_T_given_egas d_dxa(num_eos_d_dxa_results, species), & d_dlnT(num_eos_basic_results) integer:: ierr, eos_calls, max_iter - + 1 format(a40,1pe26.16) - + call Setup_eos - + ierr = 0 - + Z = 0.7D-02 X = 7.3D-01 call Init_Composition(X, Z, 0d0, 0d0) ! sets abar and zbar - + write(*,*) 'test1_eosDT_get_T_given_egas' abar = 1.2559567378472252D+00 zbar = 1.0864043570945732D+00 logRho = -9.4201625429594529D+00 - + egas_want = 2.0596457989663662D+12 egas_tol = egas_want*1d-11 logT_tol = 1d-11 logT_guess = 3.6962155439999007D+00 - + logT_bnd1 = arg_not_provided logT_bnd2 = arg_not_provided egas_at_bnd1 = arg_not_provided egas_at_bnd2 = arg_not_provided - + max_iter = 100 @@ -595,15 +595,15 @@ subroutine test1_eosDT_get_T_given_egas write(*,'(A)') write(*,*) 'eos_calls', eos_calls write(*,'(A)') - - + + end subroutine test1_eosDT_get_T_given_egas - - + + subroutine Do_One_TRho(quietly,T,Rho,X,Zinit,dXC,dXO,Y,Z,res) logical, intent(in) :: quietly real(dp), intent(in) :: T, Rho, X, Zinit, dXC, dXO @@ -619,13 +619,13 @@ subroutine Do_One_TRho(quietly,T,Rho,X,Zinit,dXC,dXO,Y,Z,res) 101 format(a30,4x,1pe24.16) 102 format(a30,3x,1pe24.16) - - + + Z = Zinit + dXC + dXO Y = 1 - (X+Z) - + call Init_Composition(X, Zinit, dXC, dXO) - + if (.not. quietly) then write(*,'(A)') write(*,'(A)') @@ -639,7 +639,7 @@ subroutine Do_One_TRho(quietly,T,Rho,X,Zinit,dXC,dXO,Y,Z,res) write(*,102) 'T6', T * 1d-6 write(*,'(A)') end if - + call eosDT_get( & handle, & species, chem_id, net_iso, xa, & @@ -650,9 +650,9 @@ subroutine Do_One_TRho(quietly,T,Rho,X,Zinit,dXC,dXO,Y,Z,res) write(*,*) 'failed in Do_One_TRho' call mesa_error(__FILE__,__LINE__) end if - + if (.not. quietly) then - + write(*,*) 'eosDT_get' Prad = crad*T*T*T*T/3 Pgas = exp(res(i_lnPgas)) @@ -666,7 +666,7 @@ subroutine Do_One_TRho(quietly,T,Rho,X,Zinit,dXC,dXO,Y,Z,res) write(*,101) trim(eos_names(i_gamma1)), res(i_gamma1) write(*,101) trim(eos_names(i_gamma3)), res(i_gamma3) write(*,101) trim(eos_names(i_eta)), res(i_eta) - + if (.false.) then ! debugging do i = 1, num_eos_basic_results write(*,101) 'd_dlnd ' // trim(eos_names(i)), d_dlnd(i) @@ -677,12 +677,12 @@ subroutine Do_One_TRho(quietly,T,Rho,X,Zinit,dXC,dXO,Y,Z,res) end do write(*,'(A)') end if - + end if end subroutine Do_One_TRho - + subroutine test_dirac_integrals real(dp) :: T, eta, theta, fdph, fdmh, fdeta, fdtheta, theta_e 1 format(a40,1pe26.16) @@ -701,4 +701,4 @@ subroutine test_dirac_integrals end subroutine test_dirac_integrals - end module test_eos_support + end module test_eos_support diff --git a/interp_1d/private/interp_1d_misc.f90 b/interp_1d/private/interp_1d_misc.f90 index e5c0fb790..3d02a5388 100644 --- a/interp_1d/private/interp_1d_misc.f90 +++ b/interp_1d/private/interp_1d_misc.f90 @@ -24,15 +24,15 @@ ! *********************************************************************** module interp_1d_misc - + use const_lib, only: dp use auto_diff - + implicit none - + contains - - + + subroutine do_integrate_values(init_x, nx, f1, nv, x, vals, ierr) real(dp), intent(in) :: init_x(:) ! (nx) ! junction points, strictly monotonic integer, intent(in) :: nx ! length of init_x vector @@ -44,28 +44,28 @@ subroutine do_integrate_values(init_x, nx, f1, nv, x, vals, ierr) ! for i > 1, vals(i) = integral of interpolating poly from x(i-1) to x(i) ! vals(1) = 0 integer, intent(out) :: ierr ! 0 means aok - + integer :: k_old, k_new real(dp) :: xk_old, xkp1_old, xk_new, xk_prev, sum - logical :: increasing + logical :: increasing real(dp), pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) increasing = (init_x(1) < init_x(nx)) - + if (increasing .and. (x(1) < init_x(1) .or. x(nv) > init_x(nx)) & .or. ((.not. increasing) .and. (x(1) > init_x(1) .or. x(nv) < init_x(nx)))) then ierr = -1 return end if - + ierr = 0 - + k_old = 1; xk_old = init_x(k_old); xkp1_old = init_x(k_old+1) sum = 0; xk_prev = x(1); vals(1) = 0 - + do k_new = 2, nv - + xk_new = x(k_new) do while ((increasing .and. xk_new > xkp1_old) .or. ((.not. increasing) .and. xk_new < xkp1_old)) k_old = k_old + 1 @@ -78,21 +78,21 @@ subroutine do_integrate_values(init_x, nx, f1, nv, x, vals, ierr) xk_old = xkp1_old xkp1_old = init_x(k_old+1) end do - + call add_to_integral(k_old, xk_new) vals(k_new) = sum sum = 0 - + end do - + contains - + subroutine add_to_integral(k, x2) integer, intent(in) :: k real(dp), intent(in) :: x2 - + real(dp) :: x0, x1, a1, a2, d1, d2, area - + x0 = init_x(k) x1 = xk_prev if (x1 == x2) return @@ -109,13 +109,13 @@ subroutine add_to_integral(k, x2) end if sum = sum + area xk_prev = x2 - + end subroutine add_to_integral - - + + end subroutine do_integrate_values - - + + subroutine do_interp_values(init_x, nx, f1, nv, x, vals, ierr) real(dp), intent(in) :: init_x(:) ! (nx) ! junction points, strictly monotonic integer, intent(in) :: nx ! length of init_x vector @@ -126,15 +126,15 @@ subroutine do_interp_values(init_x, nx, f1, nv, x, vals, ierr) ! values out of range of init_x's are clipped to boundaries of init_x's real(dp), intent(inout) :: vals(:) ! (nv) integer, intent(out) :: ierr ! 0 means aok - + integer :: k_old, k_new real(dp) :: xk_old, xkp1_old, xk_new, delta logical :: increasing real(dp), pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients - + ierr = 0 - - if (nx == 1) then + + if (nx == 1) then vals(1:nv) = f1(1) return end if @@ -142,11 +142,11 @@ subroutine do_interp_values(init_x, nx, f1, nv, x, vals, ierr) f(1:4,1:nx) => f1(1:4*nx) increasing = (init_x(1) < init_x(nx)) - + k_old = 1; xk_old = init_x(k_old); xkp1_old = init_x(k_old+1) - + do k_new = 1, nv - + xk_new = x(k_new) if (increasing) then if (xk_new > init_x(nx)) then @@ -171,16 +171,16 @@ subroutine do_interp_values(init_x, nx, f1, nv, x, vals, ierr) xk_old = xkp1_old xkp1_old = init_x(k_old+1) end do - + delta = xk_new - xk_old - + vals(k_new) = & f(1, k_old) + delta*(f(2, k_old) & + delta*(f(3, k_old) + delta*f(4, k_old))) - + end do - + end subroutine do_interp_values subroutine do_interp_values_autodiff(init_x, nx, f1, nv, x, vals, ierr) @@ -193,15 +193,15 @@ subroutine do_interp_values_autodiff(init_x, nx, f1, nv, x, vals, ierr) ! values out of range of init_x's are clipped to boundaries of init_x's type(auto_diff_real_2var_order1), intent(inout) :: vals(:) ! (nv) integer, intent(out) :: ierr ! 0 means aok - + integer :: k_old, k_new type(auto_diff_real_2var_order1) :: xk_old, xkp1_old, xk_new, delta logical :: increasing type(auto_diff_real_2var_order1), pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients - + ierr = 0 - - if (nx == 1) then + + if (nx == 1) then vals(1:nv) = f1(1) return end if @@ -211,11 +211,11 @@ subroutine do_interp_values_autodiff(init_x, nx, f1, nv, x, vals, ierr) if(init_x(1) < init_x(nx)) then increasing = .true. end if - + k_old = 1; xk_old = init_x(k_old); xkp1_old = init_x(k_old+1) - + do k_new = 1, nv - + xk_new = x(k_new) if (increasing) then if (xk_new > init_x(nx)) then @@ -240,18 +240,18 @@ subroutine do_interp_values_autodiff(init_x, nx, f1, nv, x, vals, ierr) xk_old = xkp1_old xkp1_old = init_x(k_old+1) end do - + delta = xk_new - xk_old - + vals(k_new) = & f(1, k_old) + delta*(f(2, k_old) & + delta*(f(3, k_old) + delta*f(4, k_old))) - + end do - + end subroutine do_interp_values_autodiff - + subroutine do_interp_values_and_slopes(init_x, nx, f1, nv, x, vals, slopes, ierr) real(dp), intent(in) :: init_x(:) ! (nx) ! junction points, strictly monotonic integer, intent(in) :: nx ! length of init_x vector @@ -263,27 +263,27 @@ subroutine do_interp_values_and_slopes(init_x, nx, f1, nv, x, vals, slopes, ierr real(dp), intent(inout) :: vals(:) ! (nv) real(dp), intent(inout) :: slopes(:) ! (nv) integer, intent(out) :: ierr ! 0 means aok - + integer :: k_old, k_new - real(dp) :: xk_old, xkp1_old, xk_new, delta - logical :: increasing + real(dp) :: xk_old, xkp1_old, xk_new, delta + logical :: increasing real(dp), pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - - ierr = 0 - + + ierr = 0 + if (nx == 1) then vals(1:nv) = f(1,1) slopes(1:nv) = 0 return end if - + k_old = 1; xk_old = init_x(k_old); xkp1_old = init_x(k_old+1) increasing = (init_x(1) < init_x(nx)) - + do k_new = 1, nv - + xk_new = x(k_new) if (increasing) then if (xk_new > init_x(nx)) then @@ -308,24 +308,24 @@ subroutine do_interp_values_and_slopes(init_x, nx, f1, nv, x, vals, slopes, ierr xk_old = xkp1_old xkp1_old = init_x(k_old+1) end do - + delta = xk_new - xk_old - + vals(k_new) = & f(1, k_old) + delta*(f(2, k_old) & + delta*(f(3, k_old) + delta*f(4, k_old))) - + slopes(k_new) = & f(2, k_old) + 2*delta*(f(3, k_old) + 1.5d0*delta*f(4, k_old)) - + end do - + end subroutine do_interp_values_and_slopes - - + + subroutine do_interp2_values_and_slopes( & init_x, nx, f1_1, f1_2, nv, x, vals_1, slopes_1, vals_2, slopes_2, ierr) real(dp), intent(in) :: init_x(:) ! (nx) ! junction points, strictly monotonic @@ -338,16 +338,16 @@ subroutine do_interp2_values_and_slopes( & real(dp), intent(inout) :: vals_1(:), vals_2(:) ! (nv) real(dp), intent(inout) :: slopes_1(:), slopes_2(:) ! (nv) integer, intent(out) :: ierr ! 0 means aok - + integer :: k_old, k_new - real(dp) :: xk_old, xkp1_old, xk_new, delta - logical :: increasing + real(dp) :: xk_old, xkp1_old, xk_new, delta + logical :: increasing real(dp), pointer :: f_1(:,:), f_2(:,:) ! (4, nx) ! data & interpolation coefficients f_1(1:4,1:nx) => f1_1(1:4*nx) f_2(1:4,1:nx) => f1_2(1:4*nx) - - ierr = 0 - + + ierr = 0 + if (nx == 1) then vals_1(1:nv) = f_1(1,1) slopes_1(1:nv) = 0 @@ -355,13 +355,13 @@ subroutine do_interp2_values_and_slopes( & slopes_2(1:nv) = 0 return end if - + k_old = 1; xk_old = init_x(k_old); xkp1_old = init_x(k_old+1) increasing = (init_x(1) < init_x(nx)) - + do k_new = 1, nv - + xk_new = x(k_new) if (increasing) then if (xk_new > init_x(nx)) then @@ -376,7 +376,7 @@ subroutine do_interp2_values_and_slopes( & xk_new = init_x(1) end if end if - + do while ((increasing .and. xk_new > xkp1_old) .or. ((.not. increasing) .and. xk_new < xkp1_old)) k_old = k_old + 1 if (k_old >= nx) then @@ -387,29 +387,29 @@ subroutine do_interp2_values_and_slopes( & xk_old = xkp1_old xkp1_old = init_x(k_old+1) end do - + delta = xk_new - xk_old - + vals_1(k_new) = & f_1(1, k_old) + delta*(f_1(2, k_old) & + delta*(f_1(3, k_old) + delta*f_1(4, k_old))) - + slopes_1(k_new) = & f_1(2, k_old) + 2*delta*(f_1(3, k_old) + 1.5d0*delta*f_1(4, k_old)) - + vals_2(k_new) = & f_2(1, k_old) + delta*(f_2(2, k_old) & + delta*(f_2(3, k_old) + delta*f_2(4, k_old))) - + slopes_2(k_new) = & f_2(2, k_old) + 2*delta*(f_2(3, k_old) + 1.5d0*delta*f_2(4, k_old)) - + end do - + end subroutine do_interp2_values_and_slopes - - + + subroutine do_interp3_values_and_slopes( & init_x, nx, f1_1, f1_2, f1_3, nv, x, & vals_1, slopes_1, vals_2, slopes_2, vals_3, slopes_3, ierr) @@ -423,17 +423,17 @@ subroutine do_interp3_values_and_slopes( & real(dp), intent(inout) :: vals_1(:), vals_2(:), vals_3(:) ! (nv) real(dp), intent(inout) :: slopes_1(:), slopes_2(:), slopes_3(:) ! (nv) integer, intent(out) :: ierr ! 0 means aok - + integer :: k_old, k_new - real(dp) :: xk_old, xkp1_old, xk_new, delta - logical :: increasing + real(dp) :: xk_old, xkp1_old, xk_new, delta + logical :: increasing real(dp), pointer :: f_1(:,:), f_2(:,:), f_3(:,:) ! (4, nx) ! data & interpolation coefficients f_1(1:4,1:nx) => f1_1(1:4*nx) f_2(1:4,1:nx) => f1_2(1:4*nx) f_3(1:4,1:nx) => f1_3(1:4*nx) - - ierr = 0 - + + ierr = 0 + if (nx == 1) then vals_1(1:nv) = f_1(1,1) slopes_1(1:nv) = 0 @@ -443,13 +443,13 @@ subroutine do_interp3_values_and_slopes( & slopes_3(1:nv) = 0 return end if - + k_old = 1; xk_old = init_x(k_old); xkp1_old = init_x(k_old+1) increasing = (init_x(1) < init_x(nx)) - + do k_new = 1, nv - + xk_new = x(k_new) if (increasing) then if (xk_new > init_x(nx)) then @@ -464,7 +464,7 @@ subroutine do_interp3_values_and_slopes( & xk_new = init_x(1) end if end if - + do while ((increasing .and. xk_new > xkp1_old) .or. ((.not. increasing) .and. xk_new < xkp1_old)) k_old = k_old + 1 if (k_old >= nx) then @@ -475,33 +475,33 @@ subroutine do_interp3_values_and_slopes( & xk_old = xkp1_old xkp1_old = init_x(k_old+1) end do - + delta = xk_new - xk_old - + vals_1(k_new) = & f_1(1, k_old) + delta*(f_1(2, k_old) & + delta*(f_1(3, k_old) + delta*f_1(4, k_old))) slopes_1(k_new) = & f_1(2, k_old) + 2*delta*(f_1(3, k_old) + 1.5d0*delta*f_1(4, k_old)) - + vals_2(k_new) = & f_2(1, k_old) + delta*(f_2(2, k_old) & + delta*(f_2(3, k_old) + delta*f_2(4, k_old))) slopes_2(k_new) = & f_2(2, k_old) + 2*delta*(f_2(3, k_old) + 1.5d0*delta*f_2(4, k_old)) - + vals_3(k_new) = & f_3(1, k_old) + delta*(f_3(2, k_old) & + delta*(f_3(3, k_old) + delta*f_3(4, k_old))) slopes_3(k_new) = & f_3(2, k_old) + 2*delta*(f_3(3, k_old) + 1.5d0*delta*f_3(4, k_old)) - + end do - + end subroutine do_interp3_values_and_slopes - - + + subroutine do_interp6_values_and_slopes( & init_x, nx, f1_1, f1_2, f1_3, f1_4, f1_5, f1_6, nv, x, & vals_1, slopes_1, vals_2, slopes_2, vals_3, slopes_3, & @@ -518,10 +518,10 @@ subroutine do_interp6_values_and_slopes( & vals_1, slopes_1, vals_2, slopes_2, vals_3, slopes_3, & vals_4, slopes_4, vals_5, slopes_5, vals_6, slopes_6 integer, intent(out) :: ierr ! 0 means aok - + integer :: k_old, k_new - real(dp) :: xk_old, xkp1_old, xk_new, delta - logical :: increasing + real(dp) :: xk_old, xkp1_old, xk_new, delta + logical :: increasing real(dp), pointer, dimension(:,:) :: f_1, f_2, f_3, f_4, f_5, f_6 f_1(1:4,1:nx) => f1_1(1:4*nx) f_2(1:4,1:nx) => f1_2(1:4*nx) @@ -529,9 +529,9 @@ subroutine do_interp6_values_and_slopes( & f_4(1:4,1:nx) => f1_4(1:4*nx) f_5(1:4,1:nx) => f1_5(1:4*nx) f_6(1:4,1:nx) => f1_6(1:4*nx) - - ierr = 0 - + + ierr = 0 + if (nx == 1) then vals_1(1:nv) = f_1(1,1); slopes_1(1:nv) = 0 vals_2(1:nv) = f_2(1,1); slopes_2(1:nv) = 0 @@ -541,13 +541,13 @@ subroutine do_interp6_values_and_slopes( & vals_6(1:nv) = f_6(1,1); slopes_6(1:nv) = 0 return end if - + k_old = 1; xk_old = init_x(k_old); xkp1_old = init_x(k_old+1) increasing = (init_x(1) < init_x(nx)) - + do k_new = 1, nv - + xk_new = x(k_new) if (increasing) then if (xk_new > init_x(nx)) then @@ -562,7 +562,7 @@ subroutine do_interp6_values_and_slopes( & xk_new = init_x(1) end if end if - + do while ((increasing .and. xk_new > xkp1_old) .or. ((.not. increasing) .and. xk_new < xkp1_old)) k_old = k_old + 1 if (k_old >= nx) then @@ -573,72 +573,72 @@ subroutine do_interp6_values_and_slopes( & xk_old = xkp1_old xkp1_old = init_x(k_old+1) end do - + delta = xk_new - xk_old - + vals_1(k_new) = & f_1(1, k_old) + delta*(f_1(2, k_old) & + delta*(f_1(3, k_old) + delta*f_1(4, k_old))) slopes_1(k_new) = & f_1(2, k_old) + 2*delta*(f_1(3, k_old) + 1.5d0*delta*f_1(4, k_old)) - + vals_2(k_new) = & f_2(1, k_old) + delta*(f_2(2, k_old) & + delta*(f_2(3, k_old) + delta*f_2(4, k_old))) slopes_2(k_new) = & f_2(2, k_old) + 2*delta*(f_2(3, k_old) + 1.5d0*delta*f_2(4, k_old)) - + vals_3(k_new) = & f_3(1, k_old) + delta*(f_3(2, k_old) & + delta*(f_3(3, k_old) + delta*f_3(4, k_old))) slopes_3(k_new) = & f_3(2, k_old) + 2*delta*(f_3(3, k_old) + 1.5d0*delta*f_3(4, k_old)) - + vals_4(k_new) = & f_4(1, k_old) + delta*(f_4(2, k_old) & + delta*(f_4(3, k_old) + delta*f_4(4, k_old))) slopes_4(k_new) = & f_4(2, k_old) + 2*delta*(f_4(3, k_old) + 1.5d0*delta*f_4(4, k_old)) - + vals_5(k_new) = & f_5(1, k_old) + delta*(f_5(2, k_old) & + delta*(f_5(3, k_old) + delta*f_5(4, k_old))) slopes_5(k_new) = & f_5(2, k_old) + 2*delta*(f_5(3, k_old) + 1.5d0*delta*f_5(4, k_old)) - + vals_6(k_new) = & f_6(1, k_old) + delta*(f_6(2, k_old) & + delta*(f_6(3, k_old) + delta*f_6(4, k_old))) slopes_6(k_new) = & f_6(2, k_old) + 2*delta*(f_6(3, k_old) + 1.5d0*delta*f_6(4, k_old)) - + end do - + end subroutine do_interp6_values_and_slopes - - + + real(dp) function minmod1(f1, f2) - real(dp), intent(in) :: f1, f2 - minmod1 = 0.5d0 * (sign(1d0, f1) + sign(1d0, f2)) * min(abs(f1), abs(f2)) + real(dp), intent(in) :: f1, f2 + minmod1 = 0.5d0 * (sign(1d0, f1) + sign(1d0, f2)) * min(abs(f1), abs(f2)) end function minmod1 - - + + real(dp) function median1(f1, f2, f3) real(dp), intent(in) :: f1, f2, f3 median1 = f1 + minmod1(f2 - f1, f3 - f1) end function median1 - + subroutine minmod(z, n, f1, f2) - real(dp), intent(inout) :: z(:) + real(dp), intent(inout) :: z(:) integer, intent(in) :: n ! length of vectors - real(dp), intent(in) :: f1(:), f2(:) - z(1:n) = 0.5d0 * (sign(1d0, f1(1:n)) + sign(1d0, f2(1:n))) * min(abs(f1(1:n)), abs(f2(1:n))) + real(dp), intent(in) :: f1(:), f2(:) + z(1:n) = 0.5d0 * (sign(1d0, f1(1:n)) + sign(1d0, f2(1:n))) * min(abs(f1(1:n)), abs(f2(1:n))) end subroutine minmod - + subroutine minmod4(z, n, f1, f2, f3, f4) - real(dp), intent(inout) :: z(:) + real(dp), intent(inout) :: z(:) integer, intent(in) :: n ! length of vectors real(dp), intent(in) :: f1(:), f2(:), f3(:), f4(:) call minmod(z, n, f1, f2) diff --git a/interp_1d/private/interp_1d_misc_sg.f90 b/interp_1d/private/interp_1d_misc_sg.f90 index 3ffcebacc..9664eed03 100644 --- a/interp_1d/private/interp_1d_misc_sg.f90 +++ b/interp_1d/private/interp_1d_misc_sg.f90 @@ -26,9 +26,9 @@ module interp_1d_misc_sg implicit none - + contains - + subroutine do_integrate_values_sg(init_x, nx, f1, nv, x, vals, ierr) real, intent(in) :: init_x(:) ! (nx) ! junction points, strictly monotonic integer, intent(in) :: nx ! length of init_x vector @@ -40,28 +40,28 @@ subroutine do_integrate_values_sg(init_x, nx, f1, nv, x, vals, ierr) ! for i > 1, vals(i) = integral of interpolating poly from x(i-1) to x(i) ! vals(1) = 0 integer, intent(out) :: ierr ! 0 means aok - + integer :: k_old, k_new real :: xk_old, xkp1_old, xk_new, xk_prev, sum - logical :: increasing + logical :: increasing real, pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) increasing = (init_x(1) < init_x(nx)) - + if (increasing .and. (x(1) < init_x(1) .or. x(nv) > init_x(nx)) & .or. ((.not. increasing) .and. (x(1) > init_x(1) .or. x(nv) < init_x(nx)))) then ierr = -1 return end if - + ierr = 0 - + k_old = 1; xk_old = init_x(k_old); xkp1_old = init_x(k_old+1) sum = 0; xk_prev = x(1); vals(1) = 0 - + do k_new = 2, nv - + xk_new = x(k_new) do while ((increasing .and. xk_new > xkp1_old) .or. ((.not. increasing) .and. xk_new < xkp1_old)) k_old = k_old + 1 @@ -74,21 +74,21 @@ subroutine do_integrate_values_sg(init_x, nx, f1, nv, x, vals, ierr) xk_old = xkp1_old xkp1_old = init_x(k_old+1) end do - + call add_to_integral(k_old, xk_new) vals(k_new) = sum sum = 0 - + end do - + contains - + subroutine add_to_integral(k, x2) integer, intent(in) :: k real, intent(in) :: x2 - + real :: x0, x1, a1, a2, d1, d2, area - + x0 = init_x(k) x1 = xk_prev if (x1 == x2) return @@ -105,13 +105,13 @@ subroutine add_to_integral(k, x2) end if sum = sum + area xk_prev = x2 - + end subroutine add_to_integral - - + + end subroutine do_integrate_values_sg - - + + subroutine do_interp_values_sg(init_x, nx, f1, nv, x, vals, ierr) real, intent(in) :: init_x(:) ! (nx) ! junction points, strictly monotonic integer, intent(in) :: nx ! length of init_x vector @@ -122,15 +122,15 @@ subroutine do_interp_values_sg(init_x, nx, f1, nv, x, vals, ierr) ! values out of range of init_x's are clipped to boundaries of init_x's real, intent(inout) :: vals(:) ! (nv) integer, intent(out) :: ierr ! 0 means aok - + integer :: k_old, k_new real :: xk_old, xkp1_old, xk_new, delta logical :: increasing real, pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - - ierr = 0 - + + ierr = 0 + if (nx == 1) then vals(1:nv) = f1(1) return @@ -139,11 +139,11 @@ subroutine do_interp_values_sg(init_x, nx, f1, nv, x, vals, ierr) f(1:4,1:nx) => f1(1:4*nx) increasing = (init_x(1) < init_x(nx)) - + k_old = 1; xk_old = init_x(k_old); xkp1_old = init_x(k_old+1) - + do k_new = 1, nv - + xk_new = x(k_new) if (increasing) then if (xk_new > init_x(nx)) then @@ -168,19 +168,19 @@ subroutine do_interp_values_sg(init_x, nx, f1, nv, x, vals, ierr) xk_old = xkp1_old xkp1_old = init_x(k_old+1) end do - + delta = xk_new - xk_old - + vals(k_new) = & f(1, k_old) + delta*(f(2, k_old) & + delta*(f(3, k_old) + delta*f(4, k_old))) - + end do - + end subroutine do_interp_values_sg - - + + subroutine do_interp_values_and_slopes_sg(init_x, nx, f1, nv, x, vals, slopes, ierr) real, intent(in) :: init_x(:) ! (nx) ! junction points, strictly monotonic integer, intent(in) :: nx ! length of init_x vector @@ -192,21 +192,21 @@ subroutine do_interp_values_and_slopes_sg(init_x, nx, f1, nv, x, vals, slopes, i real, intent(inout) :: vals(:) ! (nv) real, intent(inout) :: slopes(:) ! (nv) integer, intent(out) :: ierr ! 0 means aok - + integer :: k_old, k_new - real :: xk_old, xkp1_old, xk_new, delta - logical :: increasing + real :: xk_old, xkp1_old, xk_new, delta + logical :: increasing real, pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - - ierr = 0 - + + ierr = 0 + k_old = 1; xk_old = init_x(k_old); xkp1_old = init_x(k_old+1) increasing = (init_x(1) < init_x(nx)) - + do k_new = 1, nv - + xk_new = x(k_new) if (increasing) then if (xk_new > init_x(nx)) then @@ -231,54 +231,54 @@ subroutine do_interp_values_and_slopes_sg(init_x, nx, f1, nv, x, vals, slopes, i xk_old = xkp1_old xkp1_old = init_x(k_old+1) end do - + delta = xk_new - xk_old - + vals(k_new) = & f(1, k_old) + delta*(f(2, k_old) & + delta*(f(3, k_old) + delta*f(4, k_old))) - + slopes(k_new) = & f(2, k_old) + 2*delta*(f(3, k_old) + 1.5*delta*f(4, k_old)) - + end do - + end subroutine do_interp_values_and_slopes_sg - - + + real function minmod1_sg(f1, f2) - real, intent(in) :: f1, f2 - minmod1_sg = 0.5 * (sign(1.0, f1) + sign(1.0, f2)) * min(abs(f1), abs(f2)) + real, intent(in) :: f1, f2 + minmod1_sg = 0.5 * (sign(1.0, f1) + sign(1.0, f2)) * min(abs(f1), abs(f2)) end function minmod1_sg - - + + real function median1_sg(f1, f2, f3) real, intent(in) :: f1, f2, f3 median1_sg = f1 + minmod1_sg(f2 - f1, f3 - f1) end function median1_sg - + subroutine minmod_sg(z, n, f1, f2) - real, intent(inout) :: z(:) ! (n) + real, intent(inout) :: z(:) ! (n) integer, intent(in) :: n ! length of vectors - real, intent(in) :: f1(:), f2(:) ! (n) - z(1:n) = 0.5 * (sign(1.0, f1(1:n)) + sign(1.0, f2(1:n))) * min(abs(f1(1:n)), abs(f2(1:n))) + real, intent(in) :: f1(:), f2(:) ! (n) + z(1:n) = 0.5 * (sign(1.0, f1(1:n)) + sign(1.0, f2(1:n))) * min(abs(f1(1:n)), abs(f2(1:n))) end subroutine minmod_sg - + subroutine minmod4_sg(z, n, f1, f2, f3, f4) - real, intent(inout) :: z(:) ! (n) + real, intent(inout) :: z(:) ! (n) integer, intent(in) :: n ! length of vectors real, intent(in) :: f1(:), f2(:), f3(:), f4(:) call minmod_sg(z, n, f1, f2) call minmod_sg(z, n, z, f3) call minmod_sg(z, n, z, f4) end subroutine minmod4_sg - - + + subroutine median_sg(z, n, f1, f2, f3) - real, intent(out) :: z(:) + real, intent(out) :: z(:) integer, intent(in) :: n ! length of vectors real, intent(in) :: f1(:), f2(:), f3(:) real, target :: tmp1_ary(n), tmp2_ary(n) diff --git a/interp_1d/private/interp_1d_mp.f90 b/interp_1d/private/interp_1d_mp.f90 index d881095f9..570433117 100644 --- a/interp_1d/private/interp_1d_mp.f90 +++ b/interp_1d/private/interp_1d_mp.f90 @@ -24,17 +24,17 @@ ! *********************************************************************** module interp_1d_mp ! high accuracy monotonicity preserving algorithms - + use const_lib, only: dp implicit none private public :: m3, m3_on_uniform_grid - + contains - - - subroutine m3(x, nx, f1, which, slope_only, nwork, work1, str, ierr) + + + subroutine m3(x, nx, f1, which, slope_only, nwork, work1, str, ierr) use interp_1d_def use interp_1d_misc use interp_1d_pm, only: mk_pmlinear, mk_pmquad @@ -47,7 +47,7 @@ subroutine m3(x, nx, f1, which, slope_only, nwork, work1, str, ierr) real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str integer, intent(out) :: ierr - + real(dp), dimension(:), pointer :: h, s_mid, s, d, d_mid, e_mid, hd_mid, & spL, spR, t, tmax, tmp, tmp1, tmp2 real(dp), parameter :: tiny = 1d-20 @@ -56,26 +56,26 @@ subroutine m3(x, nx, f1, which, slope_only, nwork, work1, str, ierr) f(1:4,1:nx) => f1(1:4*nx) ierr = 0 - + if (nx < 2) then return end if - + if (nx == 2) then call mk_pmlinear(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nx == 3) then call mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nwork < mp_work_size) then ierr = -1 return end if - + i = 0 h(1:nx) => work1(i+1:i+nx); i = i+nx s_mid(1:nx) => work1(i+1:i+nx); i = i+nx @@ -104,53 +104,53 @@ subroutine m3(x, nx, f1, which, slope_only, nwork, work1, str, ierr) return end if end do - + ! divided differences do i=1,nx-1 - s_mid(i) = (f(1,i+1) - f(1,i)) / h(i) ! eqn 2.1 + s_mid(i) = (f(1,i+1) - f(1,i)) / h(i) ! eqn 2.1 end do - do i=2,nx-1 + do i=2,nx-1 d(i) = (s_mid(i) - s_mid(i-1)) / (x(i+1) - x(i-1)) ! eqn 3.1 end do ! need to extend d to full range. simplest way is just to copy from neighbor d(1) = d(2) d(nx) = d(nx-1) - + ! d_mid eqn(3.4) -- modified according to eqn (2.27) of Suresh & Huynh, 1997 do i=1,nx-1 tmp1(i) = 4*d(i+1) - d(i) tmp2(i) = 4*d(i) - d(i+1) end do call minmod4(d_mid(1:nx-1), nx-1, d(2:nx), d(1:nx-1), tmp1(1:nx-1), tmp2(1:nx-1)) - + do i=1,nx-1 hd_mid(i) = h(i)*d_mid(i) end do - + ! spL(i) = p'(i-1/2)(xi) = smid(i-1) + h(i-1)*d_mid(i-1) from Theorem 1 do i=1,nx-1 - spL(i+1) = s_mid(i) + hd_mid(i) + spL(i+1) = s_mid(i) + hd_mid(i) end do - + ! spR(i) = p'(i+1/2)(xi) = smid(i) - h(i)*d_mid(i) from Theorem 1 do i=1,nx-1 - spR(i) = s_mid(i) - hd_mid(i) + spR(i) = s_mid(i) - hd_mid(i) end do - + call minmod(s(2:nx-1), nx-2, s_mid(1:nx-2), s_mid(2:nx-1)) ! eqn (2.8) call minmod(t(2:nx-1), nx-2, spL(2:nx-1), spR(2:nx-1)) - + if (which == average) then - - do i=2,nx-1 + + do i=2,nx-1 f(2,i) = sign(1d0, t(i))* & min((dabs(spL(i)+spR(i)))/2d0, & - max(3*dabs(s(i)), 1.5d0*dabs(t(i)))) + max(3*dabs(s(i)), 1.5d0*dabs(t(i)))) end do else if (which == quartic) then - - do i=2,nx-2 + + do i=2,nx-2 e_mid(i) = (d(i+1) - d(i)) / (x(i+2) - x(i-1)) ! eqn 4.1 end do ! eqn 3.5b for p'(i); eqn 4.20 for quadratic f'(i) @@ -162,7 +162,7 @@ subroutine m3(x, nx, f1, which, slope_only, nwork, work1, str, ierr) end do ! finish off ends with average f(2,2) = sign(1d0, t(2))* & - min((dabs(spL(2)+spR(2)))/2d0, max(3*dabs(s(2)), 1.5d0*dabs(t(2)))) + min((dabs(spL(2)+spR(2)))/2d0, max(3*dabs(s(2)), 1.5d0*dabs(t(2)))) f(2,nx-1) = sign(1d0, t(nx-1))* & min((dabs(spL(nx-1)+spR(nx-1)))/2d0, & max(3*dabs(s(nx-1)), 1.5d0*dabs(t(nx-1)))) @@ -171,31 +171,31 @@ subroutine m3(x, nx, f1, which, slope_only, nwork, work1, str, ierr) tmp2(i) = tmp1(i) end do call median(tmp1(2:nx-1), nx-2, tmp2(2:nx-1), spL(2:nx-1), spR(2:nx-1)) - do i=2,nx-1 + do i=2,nx-1 f(2,i) = tmp1(i) end do - do i=2,nx-1 + do i=2,nx-1 tmax(i) = sign(1d0, t(i))* & max(3*dabs(s(i)), 1.5d0*dabs(t(i))) end do - do i=2,nx-1 + do i=2,nx-1 tmp1(i) = f(2,i) end do call minmod(tmp2(2:nx-1), nx-2, tmp1(2:nx-1), tmax(2:nx-1)) - do i=2,nx-1 + do i=2,nx-1 f(2,i) = tmp2(i) end do - + else !if (which == super_bee) then - - do i=2,nx-1 + + do i=2,nx-1 f(2,i) = sign(1d0, t(i))* & min(max(dabs(spL(i)), dabs(spR(i))), & max(3*dabs(s(i)), 1.5d0*dabs(t(i)))) end do end if - + ! slope at i=1 !f(2, 1) = minmod1(spR(1), 3*s_mid(1)) ! eqn (5.2) f(2,1) = minmod1(s_mid(1), s_mid(2)) ! stablize the ends @@ -203,21 +203,21 @@ subroutine m3(x, nx, f1, which, slope_only, nwork, work1, str, ierr) ! slope at i=nx !f(2, nx) = minmod1(spL(nx), 3*s_mid(nx-1)) ! eqn (5.2) f(2,nx) = minmod1(s_mid(nx-2), s_mid(nx-1)) ! stablize the ends - + if (slope_only) return ! 2nd and 3rd derivatives do i=1,nx-1 - f(3,i) = (3*s_mid(i) - 2*f(2,i) - f(2,i+1)) / h(i) + f(3,i) = (3*s_mid(i) - 2*f(2,i) - f(2,i+1)) / h(i) f(4,i) = (f(2,i) + f(2,i+1) - 2*s_mid(i)) / (h(i)*h(i)) end do f(3,nx) = (3*f(1, nx-1) - 3*f(1, nx) + (f(2, nx-1) + 2*f(2, nx)) * h(nx-1)) / (h(nx-1)*h(nx-1)) f(4,nx) = (-2*f(1, nx-1) + 2*f(1, nx) - (f(2, nx-1) + f(2, nx))*h(nx-1)) / (h(nx-1)*h(nx-1)*h(nx-1)) - + end subroutine m3 - - subroutine m3_on_uniform_grid(dx, nx, f1, which, slope_only, nwork, work1, str, ierr) + + subroutine m3_on_uniform_grid(dx, nx, f1, which, slope_only, nwork, work1, str, ierr) use interp_1d_def use interp_1d_misc use interp_1d_pm, only: mk_pmlinear, mk_pmquad @@ -231,9 +231,9 @@ subroutine m3_on_uniform_grid(dx, nx, f1, which, slope_only, nwork, work1, str, real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str integer, intent(out) :: ierr - + real(dp), dimension(:), pointer :: s_mid, s, d, d_mid, e_mid, spL, spR, t, tmax, & - tmp, tmp1, tmp2 + tmp, tmp1, tmp2 real(dp), parameter :: tiny = 1d-20 real(dp) :: x(3) integer :: i @@ -241,18 +241,18 @@ subroutine m3_on_uniform_grid(dx, nx, f1, which, slope_only, nwork, work1, str, f(1:4,1:nx) => f1(1:4*nx) ierr = 0 - + if (nx < 2) then return end if - + if (nx == 2) then x(1) = 0 x(2) = dx call mk_pmlinear(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nx == 3) then x(1) = 0 x(2) = dx @@ -265,7 +265,7 @@ subroutine m3_on_uniform_grid(dx, nx, f1, which, slope_only, nwork, work1, str, ierr = -1 return end if - + if (nwork < mp_work_size) then ierr = -1 return @@ -284,49 +284,49 @@ subroutine m3_on_uniform_grid(dx, nx, f1, which, slope_only, nwork, work1, str, tmp(1:nx) => work1(i+1:i+nx); i = i+nx tmp1(1:nx) => work1(i+1:i+nx); i = i+nx tmp2(1:nx) => work1(i+1:i+nx); i = i+nx - + ! divided differences do i=1,nx-1 - s_mid(i) = (f(1,i+1) - f(1,i)) / dx ! eqn 2.1 + s_mid(i) = (f(1,i+1) - f(1,i)) / dx ! eqn 2.1 end do - do i=2,nx-1 + do i=2,nx-1 d(i) = (s_mid(i) - s_mid(i-1)) / (2*dx) ! eqn 3.1 end do ! need to extend d to full range. simplest way is just to copy from neighbor d(1) = d(2) d(nx) = d(nx-1) - + ! d_mid eqn(3.4) -- modified according to eqn (2.27) of Suresh & Huynh, 1997 do i=1,nx-1 tmp1(i) = 4*d(i+1) - d(i) tmp2(i) = 4*d(i) - d(i+1) end do call minmod4(d_mid(1:nx-1), nx-1, d(2:nx), d(1:nx-1), tmp1(1:nx-1), tmp2(1:nx-1)) - + ! spL(i) = p'(i-1/2)(xi) = smid(i-1) + h(i-1)*d_mid(i-1) from Theorem 1 do i=1,nx-1 - spL(i+1) = s_mid(i) + dx*d_mid(i) + spL(i+1) = s_mid(i) + dx*d_mid(i) end do - + ! spR(i) = p'(i+1/2)(xi) = smid(i) - h(i)*d_mid(i) from Theorem 1 do i=1,nx-1 - spR(i) = s_mid(i) - dx*d_mid(i) + spR(i) = s_mid(i) - dx*d_mid(i) end do - + call minmod(s(2:nx-1), nx-2, s_mid(1:nx-2), s_mid(2:nx-1)) ! eqn (2.8) call minmod(t(2:nx-1), nx-2, spL(2:nx-1), spR(2:nx-1)) - + if (which == average) then - - do i=2,nx-1 + + do i=2,nx-1 f(2,i) = sign(1d0, t(i))* & min((dabs(spL(i)+spR(i)))/2d0, & max(3*dabs(s(i)), 1.5d0*dabs(t(i)))) end do - + else if (which == quartic) then - - do i=2,nx-2 + + do i=2,nx-2 e_mid(i) = (d(i+1) - d(i)) / (3*dx) ! eqn 4.1 end do ! eqn 3.5b for p'(i); eqn 4.20 for quadratic f'(i) @@ -336,7 +336,7 @@ subroutine m3_on_uniform_grid(dx, nx, f1, which, slope_only, nwork, work1, str, end do ! finish off ends with average f(2,2) = sign(1d0, t(2))* & - min((dabs(spL(2)+spR(2)))/2d0, max(3*dabs(s(2)), 1.5d0*dabs(t(2)))) + min((dabs(spL(2)+spR(2)))/2d0, max(3*dabs(s(2)), 1.5d0*dabs(t(2)))) f(2,nx-1) = sign(1d0, t(nx-1))* & min((dabs(spL(nx-1)+spR(nx-1)))/2d0, & max(3*dabs(s(nx-1)), 1.5d0*dabs(t(nx-1)))) @@ -345,49 +345,49 @@ subroutine m3_on_uniform_grid(dx, nx, f1, which, slope_only, nwork, work1, str, tmp2(i) = tmp1(i) end do call median(tmp1(2:nx-1), nx-2, tmp2(2:nx-1), spL(2:nx-1), spR(2:nx-1)) - do i=2,nx-1 + do i=2,nx-1 f(2,i) = tmp1(i) end do - do i=2,nx-1 + do i=2,nx-1 tmax(i) = sign(1d0, t(i))* & max(3*dabs(s(i)), 1.5d0*dabs(t(i))) end do - do i=2,nx-1 + do i=2,nx-1 tmp1(i) = f(2,i) end do call minmod(tmp2(2:nx-1), nx-2, tmp1(2:nx-1), tmax(2:nx-1)) - do i=2,nx-1 + do i=2,nx-1 f(2,i) = tmp2(i) end do - + else !if (which == super_bee) then - - do i=2,nx-1 + + do i=2,nx-1 f(2,i) = sign(1d0, t(i))* & min(max(dabs(spL(i)), dabs(spR(i))), & max(3*dabs(s(i)), 1.5d0*dabs(t(i)))) end do end if - + ! slope at i=1 !f(2, 1) = minmod1(spR(1), 3*s_mid(1)) ! eqn (5.2) f(2,1) = minmod1(s_mid(1), s_mid(2)) ! stablize the ends - + ! slope at i=nx !f(2, nx) = minmod1(spL(nx), 3*s_mid(nx-1)) ! eqn (5.2) f(2, nx) = minmod1(s_mid(nx-2), s_mid(nx-1)) ! stablize the ends - + if (slope_only) return - + ! 2nd and 3rd derivatives do i=1,nx-1 - f(3,i) = (3*s_mid(i) - 2*f(2,i) - f(2,i+1)) / dx + f(3,i) = (3*s_mid(i) - 2*f(2,i) - f(2,i+1)) / dx f(4,i) = (f(2,i) + f(2,i+1) - 2*s_mid(i)) / (dx*dx) end do f(3, nx) = (3*f(1, nx-1) - 3*f(1, nx) + (f(2, nx-1) + 2*f(2, nx)) * dx) / (dx*dx) f(4, nx) = (-2*f(1, nx-1) + 2*f(1, nx) - (f(2, nx-1) + f(2, nx))*dx) / (dx*dx*dx) - + end subroutine m3_on_uniform_grid diff --git a/interp_1d/private/interp_1d_mp_autodiff.f90 b/interp_1d/private/interp_1d_mp_autodiff.f90 index 6a3847baa..341521e8c 100644 --- a/interp_1d/private/interp_1d_mp_autodiff.f90 +++ b/interp_1d/private/interp_1d_mp_autodiff.f90 @@ -24,18 +24,18 @@ ! *********************************************************************** module interp_1d_mp_autodiff ! high accuracy monotonicity preserving algorithms - + use const_lib, only: dp use auto_diff implicit none private public :: m3_autodiff, m3_on_uniform_grid_autodiff - + contains - - - subroutine m3_autodiff(x, nx, f1, which, slope_only, nwork, work1, str, ierr) + + + subroutine m3_autodiff(x, nx, f1, which, slope_only, nwork, work1, str, ierr) use interp_1d_def use auto_diff use interp_1d_misc @@ -49,7 +49,7 @@ subroutine m3_autodiff(x, nx, f1, which, slope_only, nwork, work1, str, ierr) type(auto_diff_real_2var_order1), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str integer, intent(out) :: ierr - + type(auto_diff_real_2var_order1), dimension(:), pointer :: h, s_mid, s, d, d_mid, e_mid, hd_mid, & spL, spR, t, tmax, tmp, tmp1, tmp2 real(dp), parameter :: tiny = 1d-20 @@ -58,26 +58,26 @@ subroutine m3_autodiff(x, nx, f1, which, slope_only, nwork, work1, str, ierr) f(1:4,1:nx) => f1(1:4*nx) ierr = 0 - + if (nx < 2) then return end if - + if (nx == 2) then call mk_pmlinear(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nx == 3) then call mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nwork < mp_work_size) then ierr = -1 return end if - + i = 0 h(1:nx) => work1(i+1:i+nx); i = i+nx s_mid(1:nx) => work1(i+1:i+nx); i = i+nx @@ -106,53 +106,53 @@ subroutine m3_autodiff(x, nx, f1, which, slope_only, nwork, work1, str, ierr) return end if end do - + ! divided differences do i=1,nx-1 - s_mid(i) = (f(1,i+1) - f(1,i)) / h(i) ! eqn 2.1 + s_mid(i) = (f(1,i+1) - f(1,i)) / h(i) ! eqn 2.1 end do - do i=2,nx-1 + do i=2,nx-1 d(i) = (s_mid(i) - s_mid(i-1)) / (x(i+1) - x(i-1)) ! eqn 3.1 end do ! need to extend d to full range. simplest way is just to copy from neighbor d(1) = d(2) d(nx) = d(nx-1) - + ! d_mid eqn(3.4) -- modified according to eqn (2.27) of Suresh & Huynh, 1997 do i=1,nx-1 tmp1(i) = 4*d(i+1) - d(i) tmp2(i) = 4*d(i) - d(i+1) end do call minmod4_autodiff(d_mid(1:nx-1), nx-1, d(2:nx), d(1:nx-1), tmp1(1:nx-1), tmp2(1:nx-1)) - + do i=1,nx-1 hd_mid(i) = h(i)*d_mid(i) end do - + ! spL(i) = p'(i-1/2)(xi) = smid(i-1) + h(i-1)*d_mid(i-1) from Theorem 1 do i=1,nx-1 - spL(i+1) = s_mid(i) + hd_mid(i) + spL(i+1) = s_mid(i) + hd_mid(i) end do - + ! spR(i) = p'(i+1/2)(xi) = smid(i) - h(i)*d_mid(i) from Theorem 1 do i=1,nx-1 - spR(i) = s_mid(i) - hd_mid(i) + spR(i) = s_mid(i) - hd_mid(i) end do - + call minmod_autodiff(s(2:nx-1), nx-2, s_mid(1:nx-2), s_mid(2:nx-1)) ! eqn (2.8) call minmod_autodiff(t(2:nx-1), nx-2, spL(2:nx-1), spR(2:nx-1)) - + if (which == average) then - - do i=2,nx-1 + + do i=2,nx-1 f(2,i) = sign(t(i))* & min((abs(spL(i)+spR(i)))/2d0, & max(3*abs(s(i)), 1.5d0*abs(t(i)))) end do else if (which == quartic) then - - do i=2,nx-2 + + do i=2,nx-2 e_mid(i) = (d(i+1) - d(i)) / (x(i+2) - x(i-1)) ! eqn 4.1 end do ! eqn 3.5b for p'(i); eqn 4.20 for quadratic f'(i) @@ -173,31 +173,31 @@ subroutine m3_autodiff(x, nx, f1, which, slope_only, nwork, work1, str, ierr) tmp2(i) = tmp1(i) end do call median_autodiff(tmp1(2:nx-1), nx-2, tmp2(2:nx-1), spL(2:nx-1), spR(2:nx-1)) - do i=2,nx-1 + do i=2,nx-1 f(2,i) = tmp1(i) end do - do i=2,nx-1 + do i=2,nx-1 tmax(i) = sign(t(i))* & max(3*abs(s(i)), 1.5d0*abs(t(i))) end do - do i=2,nx-1 + do i=2,nx-1 tmp1(i) = f(2,i) end do call minmod_autodiff(tmp2(2:nx-1), nx-2, tmp1(2:nx-1), tmax(2:nx-1)) - do i=2,nx-1 + do i=2,nx-1 f(2,i) = tmp2(i) end do - + else !if (which == super_bee) then - - do i=2,nx-1 + + do i=2,nx-1 f(2,i) = sign(t(i))* & min(max(abs(spL(i)), abs(spR(i))), & max(3*abs(s(i)), 1.5d0*abs(t(i)))) end do end if - + ! slope at i=1 !f(2, 1) = minmod1_autodiff(spR(1), 3*s_mid(1)) ! eqn (5.2) f(2,1) = minmod1_autodiff(s_mid(1), s_mid(2)) ! stablize the ends @@ -205,21 +205,21 @@ subroutine m3_autodiff(x, nx, f1, which, slope_only, nwork, work1, str, ierr) ! slope at i=nx !f(2, nx) = minmod1_autodiff(spL(nx), 3*s_mid(nx-1)) ! eqn (5.2) f(2,nx) = minmod1_autodiff(s_mid(nx-2), s_mid(nx-1)) ! stablize the ends - + if (slope_only) return ! 2nd and 3rd derivatives do i=1,nx-1 - f(3,i) = (3*s_mid(i) - 2*f(2,i) - f(2,i+1)) / h(i) + f(3,i) = (3*s_mid(i) - 2*f(2,i) - f(2,i+1)) / h(i) f(4,i) = (f(2,i) + f(2,i+1) - 2*s_mid(i)) / (h(i)*h(i)) end do f(3,nx) = (3*f(1, nx-1) - 3*f(1, nx) + (f(2, nx-1) + 2*f(2, nx)) * h(nx-1)) / (h(nx-1)*h(nx-1)) f(4,nx) = (-2*f(1, nx-1) + 2*f(1, nx) - (f(2, nx-1) + f(2, nx))*h(nx-1)) / (h(nx-1)*h(nx-1)*h(nx-1)) - + end subroutine m3_autodiff - - subroutine m3_on_uniform_grid_autodiff(dx, nx, f1, which, slope_only, nwork, work1, str, ierr) + + subroutine m3_on_uniform_grid_autodiff(dx, nx, f1, which, slope_only, nwork, work1, str, ierr) use interp_1d_def use auto_diff use interp_1d_misc @@ -234,9 +234,9 @@ subroutine m3_on_uniform_grid_autodiff(dx, nx, f1, which, slope_only, nwork, wor type(auto_diff_real_2var_order1), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str integer, intent(out) :: ierr - + type(auto_diff_real_2var_order1), dimension(:), pointer :: s_mid, s, d, d_mid, e_mid, spL, spR, t, tmax, & - tmp, tmp1, tmp2 + tmp, tmp1, tmp2 real(dp), parameter :: tiny = 1d-20 type(auto_diff_real_2var_order1) :: x(3) integer :: i @@ -244,18 +244,18 @@ subroutine m3_on_uniform_grid_autodiff(dx, nx, f1, which, slope_only, nwork, wor f(1:4,1:nx) => f1(1:4*nx) ierr = 0 - + if (nx < 2) then return end if - + if (nx == 2) then x(1) = 0 x(2) = dx call mk_pmlinear(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nx == 3) then x(1) = 0 x(2) = dx @@ -268,7 +268,7 @@ subroutine m3_on_uniform_grid_autodiff(dx, nx, f1, which, slope_only, nwork, wor ierr = -1 return end if - + if (nwork < mp_work_size) then ierr = -1 return @@ -287,49 +287,49 @@ subroutine m3_on_uniform_grid_autodiff(dx, nx, f1, which, slope_only, nwork, wor tmp(1:nx) => work1(i+1:i+nx); i = i+nx tmp1(1:nx) => work1(i+1:i+nx); i = i+nx tmp2(1:nx) => work1(i+1:i+nx); i = i+nx - + ! divided differences do i=1,nx-1 - s_mid(i) = (f(1,i+1) - f(1,i)) / dx ! eqn 2.1 + s_mid(i) = (f(1,i+1) - f(1,i)) / dx ! eqn 2.1 end do - do i=2,nx-1 + do i=2,nx-1 d(i) = (s_mid(i) - s_mid(i-1)) / (2*dx) ! eqn 3.1 end do ! need to extend d to full range. simplest way is just to copy from neighbor d(1) = d(2) d(nx) = d(nx-1) - + ! d_mid eqn(3.4) -- modified according to eqn (2.27) of Suresh & Huynh, 1997 do i=1,nx-1 tmp1(i) = 4*d(i+1) - d(i) tmp2(i) = 4*d(i) - d(i+1) end do call minmod4_autodiff(d_mid(1:nx-1), nx-1, d(2:nx), d(1:nx-1), tmp1(1:nx-1), tmp2(1:nx-1)) - + ! spL(i) = p'(i-1/2)(xi) = smid(i-1) + h(i-1)*d_mid(i-1) from Theorem 1 do i=1,nx-1 - spL(i+1) = s_mid(i) + dx*d_mid(i) + spL(i+1) = s_mid(i) + dx*d_mid(i) end do - + ! spR(i) = p'(i+1/2)(xi) = smid(i) - h(i)*d_mid(i) from Theorem 1 do i=1,nx-1 - spR(i) = s_mid(i) - dx*d_mid(i) + spR(i) = s_mid(i) - dx*d_mid(i) end do - + call minmod_autodiff(s(2:nx-1), nx-2, s_mid(1:nx-2), s_mid(2:nx-1)) ! eqn (2.8) call minmod_autodiff(t(2:nx-1), nx-2, spL(2:nx-1), spR(2:nx-1)) - + if (which == average) then - - do i=2,nx-1 + + do i=2,nx-1 f(2,i) = sign(t(i))* & min((abs(spL(i)+spR(i)))/2d0, & max(3*abs(s(i)), 1.5d0*abs(t(i)))) end do - + else if (which == quartic) then - - do i=2,nx-2 + + do i=2,nx-2 e_mid(i) = (d(i+1) - d(i)) / (3*dx) ! eqn 4.1 end do ! eqn 3.5b for p'(i); eqn 4.20 for quadratic f'(i) @@ -348,49 +348,49 @@ subroutine m3_on_uniform_grid_autodiff(dx, nx, f1, which, slope_only, nwork, wor tmp2(i) = tmp1(i) end do call median_autodiff(tmp1(2:nx-1), nx-2, tmp2(2:nx-1), spL(2:nx-1), spR(2:nx-1)) - do i=2,nx-1 + do i=2,nx-1 f(2,i) = tmp1(i) end do - do i=2,nx-1 + do i=2,nx-1 tmax(i) = sign(t(i))* & max(3*abs(s(i)), 1.5d0*abs(t(i))) end do - do i=2,nx-1 + do i=2,nx-1 tmp1(i) = f(2,i) end do call minmod_autodiff(tmp2(2:nx-1), nx-2, tmp1(2:nx-1), tmax(2:nx-1)) - do i=2,nx-1 + do i=2,nx-1 f(2,i) = tmp2(i) end do - + else !if (which == super_bee) then - - do i=2,nx-1 + + do i=2,nx-1 f(2,i) = sign(t(i))* & min(max(abs(spL(i)), abs(spR(i))), & max(3*abs(s(i)), 1.5d0*abs(t(i)))) end do end if - + ! slope at i=1 !f(2, 1) = minmod1_autodiff(spR(1), 3*s_mid(1)) ! eqn (5.2) f(2,1) = minmod1_autodiff(s_mid(1), s_mid(2)) ! stablize the ends - + ! slope at i=nx !f(2, nx) = minmod1_autodiff(spL(nx), 3*s_mid(nx-1)) ! eqn (5.2) f(2, nx) = minmod1_autodiff(s_mid(nx-2), s_mid(nx-1)) ! stablize the ends - + if (slope_only) return - + ! 2nd and 3rd derivatives do i=1,nx-1 - f(3,i) = (3*s_mid(i) - 2*f(2,i) - f(2,i+1)) / dx + f(3,i) = (3*s_mid(i) - 2*f(2,i) - f(2,i+1)) / dx f(4,i) = (f(2,i) + f(2,i+1) - 2*s_mid(i)) / (dx*dx) end do f(3, nx) = (3*f(1, nx-1) - 3*f(1, nx) + (f(2, nx-1) + 2*f(2, nx)) * dx) / (dx*dx) f(4, nx) = (-2*f(1, nx-1) + 2*f(1, nx) - (f(2, nx-1) + f(2, nx))*dx) / (dx*dx*dx) - + end subroutine m3_on_uniform_grid_autodiff diff --git a/interp_1d/private/interp_1d_mp_sg.f90 b/interp_1d/private/interp_1d_mp_sg.f90 index faf3afc99..a738212f9 100644 --- a/interp_1d/private/interp_1d_mp_sg.f90 +++ b/interp_1d/private/interp_1d_mp_sg.f90 @@ -28,11 +28,11 @@ module interp_1d_mp_sg ! high accuracy monotonicity preserving algorithms implicit none private public :: m3_sg, m3_on_uniform_grid_sg - + contains - - - subroutine m3_sg(x,nx, f1, which, slope_only, nwork, work1, str, ierr) + + + subroutine m3_sg(x,nx, f1, which, slope_only, nwork, work1, str, ierr) ! make piecewise monotonic cubic interpolant use interp_1d_def use interp_1d_misc_sg @@ -46,7 +46,7 @@ subroutine m3_sg(x,nx, f1, which, slope_only, nwork, work1, str, ierr) real, intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str integer, intent(out) :: ierr - + real, dimension(:), pointer :: h, s_mid, s, d, d_mid, e_mid, hd_mid, & spL, spR, t, tmax, tmp, tmp1, tmp2 real, parameter :: tiny = 1e-20 @@ -55,26 +55,26 @@ subroutine m3_sg(x,nx, f1, which, slope_only, nwork, work1, str, ierr) f(1:4,1:nx) => f1(1:4*nx) ierr = 0 - + if (nx < 2) then return end if - + if (nx == 2) then call mk_pmlinear_sg(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nx == 3) then call mk_pmquad_sg(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nwork < mp_work_size) then ierr = -1 return end if - + i = 0 h(1:nx) => work1(i+1:i+nx); i = i+nx s_mid(1:nx) => work1(i+1:i+nx); i = i+nx @@ -103,51 +103,51 @@ subroutine m3_sg(x,nx, f1, which, slope_only, nwork, work1, str, ierr) return end if end do - + ! divided differences do i=1,nx-1 - s_mid(i) = (f(1,i+1) - f(1,i)) / h(i) ! eqn 2.1 + s_mid(i) = (f(1,i+1) - f(1,i)) / h(i) ! eqn 2.1 end do - do i=2,nx-1 + do i=2,nx-1 d(i) = (s_mid(i) - s_mid(i-1)) / (x(i+1) - x(i-1)) ! eqn 3.1 end do ! need to extend d to full range. simplest way is just to copy from neighbor d(1) = d(2) d(nx) = d(nx-1) - + ! d_mid eqn(3.4) -- modified according to eqn (2.27) of Suresh & Huynh, 1997 do i=1,nx-1 tmp1(i) = 4*d(i+1) - d(i) tmp2(i) = 4*d(i) - d(i+1) end do call minmod4_sg(d_mid(1:nx-1),nx-1, d(2:nx), d(1:nx-1), tmp1(1:nx-1), tmp2(1:nx-1)) - + do i=1,nx-1 hd_mid(i) = h(i)*d_mid(i) end do ! spL(i) = p'(i-1/2)(xi) = smid(i-1) + h(i-1)*d_mid(i-1) from Theorem 1 do i=1,nx-1 - spL(i+1) = s_mid(i) + hd_mid(i) + spL(i+1) = s_mid(i) + hd_mid(i) end do ! spR(i) = p'(i+1/2)(xi) = smid(i) - h(i)*d_mid(i) from Theorem 1 do i=1,nx-1 - spR(i) = s_mid(i) - hd_mid(i) + spR(i) = s_mid(i) - hd_mid(i) end do - + call minmod_sg(s(2:nx-1),nx-2, s_mid(1:nx-2), s_mid(2:nx-1)) ! eqn (2.8) call minmod_sg(t(2:nx-1),nx-2, spL(2:nx-1), spR(2:nx-1)) - + if (which == average) then - - do i=2,nx-1 + + do i=2,nx-1 f(2,i) = sign(1.0, t(i))* & min((abs(spL(i)+spR(i)))/2, & - max(3*abs(s(i)), 1.5*abs(t(i)))) + max(3*abs(s(i)), 1.5*abs(t(i)))) end do else if (which == quartic) then - - do i=2,nx-2 + + do i=2,nx-2 e_mid(i) = (d(i+1) - d(i)) / (x(i+2) - x(i-1)) ! eqn 4.1 end do ! eqn 3.5b for p'(i); eqn 4.20 for quadratic f'(i) @@ -159,7 +159,7 @@ subroutine m3_sg(x,nx, f1, which, slope_only, nwork, work1, str, ierr) end do ! finish off ends with average f(2,2) = sign(1.0, t(2))* & - min((abs(spL(2)+spR(2)))/2, max(3*abs(s(2)), 1.5*abs(t(2)))) + min((abs(spL(2)+spR(2)))/2, max(3*abs(s(2)), 1.5*abs(t(2)))) f(2,nx-1) = sign(1.0, t(nx-1))* & min((abs(spL(nx-1)+spR(nx-1)))/2, & max(3*abs(s(nx-1)), 1.5*abs(t(nx-1)))) @@ -168,31 +168,31 @@ subroutine m3_sg(x,nx, f1, which, slope_only, nwork, work1, str, ierr) tmp2(i) = tmp1(i) end do call median_sg(tmp1(2:nx-1),nx-2, tmp2(2:nx-1), spL(2:nx-1), spR(2:nx-1)) - do i=2,nx-1 + do i=2,nx-1 f(2,i) = tmp1(i) end do - do i=2,nx-1 + do i=2,nx-1 tmax(i) = sign(1.0, t(i))* & max(3*abs(s(i)), 1.5*abs(t(i))) end do - do i=2,nx-1 + do i=2,nx-1 tmp1(i) = f(2,i) end do call minmod_sg(tmp2(2:nx-1),nx-2, tmp1(2:nx-1), tmax(2:nx-1)) - do i=2,nx-1 + do i=2,nx-1 f(2,i) = tmp2(i) end do - + else !if (which == super_bee) then - - do i=2,nx-1 + + do i=2,nx-1 f(2,i) = sign(1.0, t(i))* & min(max(abs(spL(i)), abs(spR(i))), & max(3*abs(s(i)), 1.5*abs(t(i)))) end do end if - + ! slope at i=1 !f(2, 1) = minmod1_sg(spR(1), 3*s_mid(1)) ! eqn (5.2) f(2,1) = minmod1_sg(s_mid(1), s_mid(2)) ! stablize the ends @@ -200,21 +200,21 @@ subroutine m3_sg(x,nx, f1, which, slope_only, nwork, work1, str, ierr) ! slope at i=nx !f(2,nx) = minmod1_sg(spL(nx), 3*s_mid(nx-1)) ! eqn (5.2) f(2,nx) = minmod1_sg(s_mid(nx-2), s_mid(nx-1)) ! stablize the ends - + if (slope_only) return ! 2nd and 3rd derivatives do i=1,nx-1 - f(3,i) = (3*s_mid(i) - 2*f(2,i) - f(2,i+1)) / h(i) + f(3,i) = (3*s_mid(i) - 2*f(2,i) - f(2,i+1)) / h(i) f(4,i) = (f(2,i) + f(2,i+1) - 2*s_mid(i)) / (h(i)*h(i)) end do f(3,nx) = (3*f(1,nx-1) - 3*f(1,nx) + (f(2,nx-1) + 2*f(2,nx)) * h(nx-1)) / (h(nx-1)*h(nx-1)) f(4,nx) = (-2*f(1,nx-1) + 2*f(1,nx) - (f(2,nx-1) + f(2,nx))*h(nx-1)) / (h(nx-1)*h(nx-1)*h(nx-1)) - + end subroutine m3_sg - - subroutine m3_on_uniform_grid_sg(dx,nx, f1, which, slope_only, nwork, work1, str, ierr) + + subroutine m3_on_uniform_grid_sg(dx,nx, f1, which, slope_only, nwork, work1, str, ierr) use interp_1d_def use interp_1d_misc_sg use interp_1d_pm_sg, only: mk_pmlinear_sg, mk_pmquad_sg @@ -228,9 +228,9 @@ subroutine m3_on_uniform_grid_sg(dx,nx, f1, which, slope_only, nwork, work1, str real, intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str integer, intent(out) :: ierr - + real, dimension(:), pointer :: s_mid, s, d, d_mid, e_mid, spL, spR, t, tmax, & - tmp, tmp1, tmp2 + tmp, tmp1, tmp2 real, parameter :: tiny = 1e-20 real :: x(3) integer :: i @@ -238,18 +238,18 @@ subroutine m3_on_uniform_grid_sg(dx,nx, f1, which, slope_only, nwork, work1, str f(1:4,1:nx) => f1(1:4*nx) ierr = 0 - + if (nx < 2) then return end if - + if (nx == 2) then x(1) = 0 x(2) = dx call mk_pmlinear_sg(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nx == 3) then x(1) = 0 x(2) = dx @@ -262,12 +262,12 @@ subroutine m3_on_uniform_grid_sg(dx,nx, f1, which, slope_only, nwork, work1, str ierr = -1 return end if - + if (nwork < mp_work_size) then ierr = -1 return end if - + i = 0 s_mid(1:nx) => work1(i+1:i+nx); i = i+nx s(1:nx) => work1(i+1:i+nx); i = i+nx @@ -281,48 +281,48 @@ subroutine m3_on_uniform_grid_sg(dx,nx, f1, which, slope_only, nwork, work1, str tmp(1:nx) => work1(i+1:i+nx); i = i+nx tmp1(1:nx) => work1(i+1:i+nx); i = i+nx tmp2(1:nx) => work1(i+1:i+nx); i = i+nx - + ! divided differences do i=1,nx-1 - s_mid(i) = (f(1,i+1) - f(1,i)) / dx ! eqn 2.1 + s_mid(i) = (f(1,i+1) - f(1,i)) / dx ! eqn 2.1 end do - do i=2,nx-1 + do i=2,nx-1 d(i) = (s_mid(i) - s_mid(i-1)) / (2*dx) ! eqn 3.1 end do ! need to extend d to full range. simplest way is just to copy from neighbor d(1) = d(2) d(nx) = d(nx-1) - + ! d_mid eqn(3.4) -- modified according to eqn (2.27) of Suresh & Huynh, 1997 do i=1,nx-1 tmp1(i) = 4*d(i+1) - d(i) tmp2(i) = 4*d(i) - d(i+1) end do call minmod4_sg(d_mid(1:nx-1),nx-1, d(2:nx), d(1:nx-1), tmp1(1:nx-1), tmp2(1:nx-1)) - + ! spL(i) = p'(i-1/2)(xi) = smid(i-1) + h(i-1)*d_mid(i-1) from Theorem 1 - do i=1,nx-1 - spL(i+1) = s_mid(i) + dx*d_mid(i) + do i=1,nx-1 + spL(i+1) = s_mid(i) + dx*d_mid(i) end do ! spR(i) = p'(i+1/2)(xi) = smid(i) - h(i)*d_mid(i) from Theorem 1 - do i=1,nx-1 - spR(i) = s_mid(i) - dx*d_mid(i) + do i=1,nx-1 + spR(i) = s_mid(i) - dx*d_mid(i) end do - + call minmod_sg(s(2:nx-1),nx-2, s_mid(1:nx-2), s_mid(2:nx-1)) ! eqn (2.8) call minmod_sg(t(2:nx-1),nx-2, spL(2:nx-1), spR(2:nx-1)) - + if (which == average) then - - do i=2,nx-1 + + do i=2,nx-1 f(2,i) = sign(1.0, t(i))* & min((abs(spL(i)+spR(i)))/2, & max(3*abs(s(i)), 1.5*abs(t(i)))) end do - + else if (which == quartic) then - - do i=2,nx-2 + + do i=2,nx-2 e_mid(i) = (d(i+1) - d(i)) / (3*dx) ! eqn 4.1 end do ! eqn 3.5b for p'(i); eqn 4.20 for quadratic f'(i) @@ -332,7 +332,7 @@ subroutine m3_on_uniform_grid_sg(dx,nx, f1, which, slope_only, nwork, work1, str end do ! finish off ends with average f(2,2) = sign(1.0, t(2))* & - min((abs(spL(2)+spR(2)))/2, max(3*abs(s(2)), 1.5*abs(t(2)))) + min((abs(spL(2)+spR(2)))/2, max(3*abs(s(2)), 1.5*abs(t(2)))) f(2,nx-1) = sign(1.0, t(nx-1))* & min((abs(spL(nx-1)+spR(nx-1)))/2, & max(3*abs(s(nx-1)), 1.5*abs(t(nx-1)))) @@ -341,49 +341,49 @@ subroutine m3_on_uniform_grid_sg(dx,nx, f1, which, slope_only, nwork, work1, str tmp2(i) = tmp1(i) end do call median_sg(tmp1(2:nx-1),nx-2, tmp2(2:nx-1), spL(2:nx-1), spR(2:nx-1)) - do i=2,nx-1 + do i=2,nx-1 f(2,i) = tmp1(i) end do - do i=2,nx-1 + do i=2,nx-1 tmax(i) = sign(1.0, t(i))* & max(3*abs(s(i)), 1.5*abs(t(i))) end do - do i=2,nx-1 + do i=2,nx-1 tmp1(i) = f(2,i) end do call minmod_sg(tmp2(2:nx-1),nx-2, tmp1(2:nx-1), tmax(2:nx-1)) - do i=2,nx-1 + do i=2,nx-1 f(2,i) = tmp2(i) end do - + else !if (which == super_bee) then - - do i=2,nx-1 + + do i=2,nx-1 f(2,i) = sign(1.0, t(i))* & min(max(abs(spL(i)), abs(spR(i))), & max(3*abs(s(i)), 1.5*abs(t(i)))) end do end if - + ! slope at i=1 !f(2, 1) = minmod1_sg(spR(1), 3*s_mid(1)) ! eqn (5.2) f(2,1) = minmod1_sg(s_mid(1), s_mid(2)) ! stablize the ends - + ! slope at i=nx !f(2,nx) = minmod1_sg(spL(nx), 3*s_mid(nx-1)) ! eqn (5.2) f(2,nx) = minmod1_sg(s_mid(nx-2), s_mid(nx-1)) ! stablize the ends - + if (slope_only) return - + ! 2nd and 3rd derivatives do i=1,nx-1 - f(3,i) = (3*s_mid(i) - 2*f(2,i) - f(2,i+1)) / dx + f(3,i) = (3*s_mid(i) - 2*f(2,i) - f(2,i+1)) / dx f(4,i) = (f(2,i) + f(2,i+1) - 2*s_mid(i)) / (dx*dx) end do f(3,nx) = (3*f(1,nx-1) - 3*f(1,nx) + (f(2,nx-1) + 2*f(2,nx)) * dx) / (dx*dx) f(4,nx) = (-2*f(1,nx-1) + 2*f(1,nx) - (f(2,nx-1) + f(2,nx))*dx) / (dx*dx*dx) - + end subroutine m3_on_uniform_grid_sg diff --git a/interp_1d/private/interp_1d_pm.f90 b/interp_1d/private/interp_1d_pm.f90 index 7ce6b0966..1a70e45d4 100644 --- a/interp_1d/private/interp_1d_pm.f90 +++ b/interp_1d/private/interp_1d_pm.f90 @@ -24,21 +24,21 @@ ! *********************************************************************** module interp_1d_pm ! piecewise monotonic algorithms - + use const_lib, only: dp implicit none - + contains - ! the following produce piecewise monotonic interpolants + ! the following produce piecewise monotonic interpolants ! rather than monotonicity preserving - ! this stricter limit never introduces interpolated values exceeding the given values, + ! this stricter limit never introduces interpolated values exceeding the given values, ! even in places where the given values are not monotonic. ! the downside is reduced accuracy on smooth data compared to the mp routines. - - - subroutine mk_pmcub(x, nx, f1, slope_only, nwork, work1, str, ierr) + + + subroutine mk_pmcub(x, nx, f1, slope_only, nwork, work1, str, ierr) ! make piecewise monotonic cubic interpolant use interp_1d_def integer, intent(in) :: nx ! length of x vector (nx >= 2) @@ -55,43 +55,43 @@ subroutine mk_pmcub(x, nx, f1, slope_only, nwork, work1, str, ierr) logical, parameter :: dbg = .true. real(dp), pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - + include 'formats' - + ierr = 0 - + if (nx < 2) then return end if - + if (nx == 2) then call mk_pmlinear(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nx == 3) then call mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nx == 4) then call mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nwork < pm_work_size) then ierr = -1 return end if - + h(1:nx) => work1(1:nx) s(1:nx) => work1(1+nx:2*nx) p(1:nx) => work1(1+2*nx:3*nx) - + if (dbg) then h(:) = 0; s(:) = 0; p(:) = 0 end if - + do i=1,nx-1 h(i) = x(i+1) - x(i) ! width of interval end do @@ -103,22 +103,22 @@ subroutine mk_pmcub(x, nx, f1, slope_only, nwork, work1, str, ierr) return end if end do - + do i=1,nx-1 s(i) = (f(1,i+1) - f(1,i)) / h(i) ! slope across interval end do - - do i=2,nx-1 - p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) + + do i=2,nx-1 + p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) ! slope at i of parabola through i-1, i, and i+1 end do - do i=2,nx-1 + do i=2,nx-1 f(2,i) = (dsign(1d0, s(i-1))+dsign(1d0, s(i)))* & min(abs(s(i-1)), abs(s(i)), 0.5d0*abs(p(i))) ! "safe" slope at i to ensure monotonic -- see Steffen's paper for explanation. end do - - p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) + + p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) ! slope at 1 of parabola through 1st 3 points if (p(1)*s(1) <= 0) then f(2, 1) = 0 @@ -127,9 +127,9 @@ subroutine mk_pmcub(x, nx, f1, slope_only, nwork, work1, str, ierr) else f(2, 1) = p(1) end if - + p(nx) = s(nx-1)*(1 + h(nx-1) / (h(nx-1) + h(nx-2))) & - - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) + - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) ! slope at nx of parabola through last 3 points if (p(nx)*s(nx-1) <= 0) then f(2,nx) = 0 @@ -138,7 +138,7 @@ subroutine mk_pmcub(x, nx, f1, slope_only, nwork, work1, str, ierr) else f(2,nx) = p(nx) end if - + if (slope_only) return do i=1,nx-1 @@ -147,10 +147,10 @@ subroutine mk_pmcub(x, nx, f1, slope_only, nwork, work1, str, ierr) end do f(3,nx) = 0 f(4,nx) = 0 - + end subroutine mk_pmcub - + ! optimize special case for nx = 4 subroutine mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) use interp_1d_def @@ -167,18 +167,18 @@ subroutine mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) integer :: i real(dp), pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - + ierr = 0 - + if (nwork < pm_work_size) then ierr = -1 return end if - + h(1:nx) => work1(1:nx) s(1:nx) => work1(1+nx:2*nx) p(1:nx) => work1(1+2*nx:3*nx) - + do i=1,nx-1 h(i) = x(i+1) - x(i) ! width of interval end do @@ -190,21 +190,21 @@ subroutine mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) return end if end do - + do i=1,nx-1 s(i) = (f(1,i+1) - f(1,i)) / h(i) ! slope across interval end do - do i=2,nx-1 - p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) + do i=2,nx-1 + p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) ! slope at i of parabola through i-1, i, and i+1 end do - do i=2,nx-1 + do i=2,nx-1 f(2,i) = (dsign(1d0, s(i-1))+dsign(1d0, s(i)))* & min(abs(s(i-1)), abs(s(i)), 0.5d0*abs(p(i))) ! "safe" slope at i to ensure monotonic -- see Steffen's paper for explanation. end do - p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) + p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) ! slope at 1 of parabola through 1st 3 points if (p(1)*s(1) <= 0) then f(2, 1) = 0 @@ -213,9 +213,9 @@ subroutine mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) else f(2, 1) = p(1) end if - + p(nx) = s(nx-1)*(1 + h(nx-1) / (h(nx-1) + h(nx-2))) & - - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) + - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) ! slope at nx of parabola through last 3 points if (p(nx)*s(nx-1) <= 0) then f(2, nx) = 0 @@ -224,7 +224,7 @@ subroutine mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) else f(2, nx) = p(nx) end if - + if (slope_only) return do i=1,nx-1 @@ -233,12 +233,12 @@ subroutine mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) end do f(3,nx) = 0 f(4,nx) = 0 - + end subroutine mk_pmcub4 - - + + ! optimize special case for nx = 3 - subroutine mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) + subroutine mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) ! make piecewise monotonic quadratic interpolant use interp_1d_def integer, parameter :: nx = 3 @@ -254,17 +254,17 @@ subroutine mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) integer :: i real(dp), pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - + if (nwork < pm_work_size) then ierr = -1 return end if ierr = 0 - + h(1:nx) => work1(1:nx) s(1:nx) => work1(1+nx:2*nx) p(1:nx) => work1(1+2*nx:3*nx) - + do i=1,nx-1 h(i) = x(i+1) - x(i) ! width of interval end do @@ -276,21 +276,21 @@ subroutine mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) return end if end do - + do i=1,nx-1 s(i) = (f(1,i+1) - f(1,i)) / h(i) ! slope across interval end do - do i=2,nx-1 - p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) + do i=2,nx-1 + p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) ! slope at i of parabola through i-1, i, and i+1 end do - do i=2,nx-1 + do i=2,nx-1 f(2,i) = (dsign(1d0, s(i-1))+dsign(1d0, s(i)))* & min(abs(s(i-1)), abs(s(i)), 0.5d0*abs(p(i))) ! "safe" slope at i to ensure monotonic -- see Steffen's paper for explanation. end do - p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) + p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) ! slope at 1 of parabola through 1st 3 points if (p(1)*s(1) <= 0) then f(2, 1) = 0 @@ -299,9 +299,9 @@ subroutine mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) else f(2, 1) = p(1) end if - + p(nx) = s(nx-1)*(1 + h(nx-1) / (h(nx-1) + h(nx-2))) & - - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) + - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) ! slope at nx of parabola through last 3 points if (p(nx)*s(nx-1) <= 0) then f(2, nx) = 0 @@ -310,19 +310,19 @@ subroutine mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) else f(2, nx) = p(nx) end if - + if (slope_only) return - + do i=1,nx-1 f(3,i) = (3*s(i) - 2*f(2,i) - f(2,i+1)) / h(i) f(4,i) = (f(2,i) + f(2,i+1) - 2*s(i)) / (h(i)*h(i)) end do - f(3,nx) = 0 + f(3,nx) = 0 f(4,nx) = 0 - + end subroutine mk_pmquad - - + + ! optimize special case for nx = 2 subroutine mk_pmlinear(x, f1, slope_only, nwork, work1, str, ierr) use interp_1d_def @@ -338,14 +338,14 @@ subroutine mk_pmlinear(x, f1, slope_only, nwork, work1, str, ierr) real(dp) :: h, s real(dp), pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - + ierr = 0 - + if (nwork < pm_work_size) then ierr = -1 return end if - + h = x(2) - x(1) ! width of interval if (h == 0) then ierr = -1 @@ -353,20 +353,20 @@ subroutine mk_pmlinear(x, f1, slope_only, nwork, work1, str, ierr) 'same interpolation x values at', 1, 2, 'for ' // trim(str) return end if - + s = (f(1, 2) - f(1, 1)) / h ! slope across interval f(2, 1) = s f(2, 2) = 0 - + if (slope_only) return f(3, 1:2) = 0 f(4, 1:2) = 0 - + end subroutine mk_pmlinear - - - subroutine mk_pmcub_uniform(dx, n, f1, slope_only, nwork, work1, str, ierr) + + + subroutine mk_pmcub_uniform(dx, n, f1, slope_only, nwork, work1, str, ierr) ! make piecewise monotonic cubic interpolant on unit spaced mesh use interp_1d_def integer, intent(in) :: n ! length of vector @@ -383,13 +383,13 @@ subroutine mk_pmcub_uniform(dx, n, f1, slope_only, nwork, work1, str, ierr) integer :: i real(dp), pointer :: f(:,:) ! (4, n) ! data & interpolation coefficients f(1:4,1:n) => f1(1:4*n) - + ierr = 0 - + if (n < 2) then return end if - + if (n == 2) then x(1) = 0 x(2) = dx @@ -401,31 +401,31 @@ subroutine mk_pmcub_uniform(dx, n, f1, slope_only, nwork, work1, str, ierr) ierr = -1 return end if - + if (nwork < pm_work_size) then ierr = -1 return end if ierr = 0 - + s(1:n) => work1(1:n) p(1:n) => work1(1+n:2*n) ierr = 0 - - do i=1,n-1 + + do i=1,n-1 s(i) = f(1,i+1) - f(1,i) ! slope across interval end do - do i=2,n-1 - p(i) = 0.5d0*(s(i-1) + s(i)) + do i=2,n-1 + p(i) = 0.5d0*(s(i-1) + s(i)) ! slope at i of parabola through i-1, i, and i+1 end do - do i=2,n-1 + do i=2,n-1 f(2,i) = (sign(1d0, s(i-1))+sign(1d0, s(i)))* & min(abs(s(i-1)), abs(s(i)), 0.5d0*abs(p(i))) ! "safe" slope at i to ensure monotonic -- see Steffen's paper for explanation. end do - + p(1) = 1.5d0 * s(1) - 0.5d0 * s(2) ! slope at 1 of parabola through 1st 3 points if (p(1)*s(1) <= 0) then @@ -435,7 +435,7 @@ subroutine mk_pmcub_uniform(dx, n, f1, slope_only, nwork, work1, str, ierr) else f(2, 1) = p(1) end if - + p(n) = 1.5d0 * s(n-1) - 0.5d0 * s(n-2) ! slope at n of parabola through last 3 points if (p(n)*s(n-1) <= 0) then @@ -445,19 +445,19 @@ subroutine mk_pmcub_uniform(dx, n, f1, slope_only, nwork, work1, str, ierr) else f(2, n) = p(n) end if - + f(2, 1:n) = f(2, 1:n) / dx - + if (slope_only) return - + ! 2nd and 3rd derivatives do i=1,n-1 - f(3,i) = (3*s(i) - 2*f(2,i) - f(2,i+1)) / dx + f(3,i) = (3*s(i) - 2*f(2,i) - f(2,i+1)) / dx f(4,i) = (f(2,i) + f(2,i+1) - 2*s(i)) / (dx*dx) end do f(3,n) = (3*f(1, n-1) - 3*f(1, n) + (f(2, n-1) + 2*f(2, n)) * dx) / (dx*dx*dx) f(4,n) = (-2*f(1, n-1) + 2*f(1, n) - (f(2, n-1) + f(2, n))*dx) / (dx*dx*dx) - + end subroutine mk_pmcub_uniform diff --git a/interp_1d/private/interp_1d_pm_autodiff.f90 b/interp_1d/private/interp_1d_pm_autodiff.f90 index 6e8255e03..581932ece 100644 --- a/interp_1d/private/interp_1d_pm_autodiff.f90 +++ b/interp_1d/private/interp_1d_pm_autodiff.f90 @@ -24,21 +24,21 @@ ! *********************************************************************** module interp_1d_pm_autodiff ! piecewise monotonic algorithms - + use const_lib, only: dp use auto_diff - + implicit none - + contains - ! the following produce piecewise monotonic interpolants + ! the following produce piecewise monotonic interpolants ! rather than monotonicity preserving - ! this stricter limit never introduces interpolated values exceeding the given values, + ! this stricter limit never introduces interpolated values exceeding the given values, ! even in places where the given values are not monotonic. ! the downside is reduced accuracy on smooth data compared to the mp routines. - - + + subroutine mk_pmcub_autodiff(x, nx, f1, slope_only, nwork, work1, str, ierr) ! make piecewise monotonic cubic interpolant use interp_1d_def @@ -57,43 +57,43 @@ subroutine mk_pmcub_autodiff(x, nx, f1, slope_only, nwork, work1, str, ierr) logical, parameter :: dbg = .true. type(auto_diff_real_2var_order1), pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - + include 'formats' - + ierr = 0 - + if (nx < 2) then return end if - + if (nx == 2) then call mk_pmlinear(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nx == 3) then call mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nx == 4) then call mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nwork < pm_work_size) then ierr = -1 return end if - + h(1:nx) => work1(1:nx) s(1:nx) => work1(1+nx:2*nx) p(1:nx) => work1(1+2*nx:3*nx) - + !if (dbg) then ! h(:) = 0; s(:) = 0; p(:) = 0 !end if - + do i=1,nx-1 h(i) = x(i+1) - x(i) ! width of interval end do @@ -105,22 +105,22 @@ subroutine mk_pmcub_autodiff(x, nx, f1, slope_only, nwork, work1, str, ierr) return end if end do - + do i=1,nx-1 s(i) = (f(1,i+1) - f(1,i)) / h(i) ! slope across interval end do - - do i=2,nx-1 - p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) + + do i=2,nx-1 + p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) ! slope at i of parabola through i-1, i, and i+1 end do - do i=2,nx-1 + do i=2,nx-1 f(2,i) = (sign(s(i-1))+sign(s(i)))* & min(min(abs(s(i-1)), abs(s(i))), 0.5d0*abs(p(i))) ! "safe" slope at i to ensure monotonic -- see Steffen's paper for explanation. end do - - p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) + + p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) ! slope at 1 of parabola through 1st 3 points if (p(1)*s(1) <= 0) then f(2, 1) = 0d0 @@ -129,9 +129,9 @@ subroutine mk_pmcub_autodiff(x, nx, f1, slope_only, nwork, work1, str, ierr) else f(2, 1) = p(1) end if - + p(nx) = s(nx-1)*(1 + h(nx-1) / (h(nx-1) + h(nx-2))) & - - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) + - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) ! slope at nx of parabola through last 3 points if (p(nx)*s(nx-1) <= 0) then f(2,nx) = 0 @@ -140,7 +140,7 @@ subroutine mk_pmcub_autodiff(x, nx, f1, slope_only, nwork, work1, str, ierr) else f(2,nx) = p(nx) end if - + if (slope_only) return do i=1,nx-1 @@ -149,10 +149,10 @@ subroutine mk_pmcub_autodiff(x, nx, f1, slope_only, nwork, work1, str, ierr) end do f(3,nx) = 0d0 f(4,nx) = 0d0 - + end subroutine mk_pmcub_autodiff - + ! optimize special case for nx = 4 subroutine mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) use interp_1d_def @@ -170,18 +170,18 @@ subroutine mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) integer :: i type(auto_diff_real_2var_order1), pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - + ierr = 0 - + if (nwork < pm_work_size) then ierr = -1 return end if - + h(1:nx) => work1(1:nx) s(1:nx) => work1(1+nx:2*nx) p(1:nx) => work1(1+2*nx:3*nx) - + do i=1,nx-1 h(i) = x(i+1) - x(i) ! width of interval end do @@ -193,21 +193,21 @@ subroutine mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) return end if end do - + do i=1,nx-1 s(i) = (f(1,i+1) - f(1,i)) / h(i) ! slope across interval end do - do i=2,nx-1 - p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) + do i=2,nx-1 + p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) ! slope at i of parabola through i-1, i, and i+1 end do - do i=2,nx-1 + do i=2,nx-1 f(2,i) = (sign(s(i-1))+sign(s(i)))* & min(min(abs(s(i-1)), abs(s(i))), 0.5d0*abs(p(i))) ! "safe" slope at i to ensure monotonic -- see Steffen's paper for explanation. end do - p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) + p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) ! slope at 1 of parabola through 1st 3 points if (p(1)*s(1) <= 0) then f(2, 1) = 0 @@ -216,9 +216,9 @@ subroutine mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) else f(2, 1) = p(1) end if - + p(nx) = s(nx-1)*(1 + h(nx-1) / (h(nx-1) + h(nx-2))) & - - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) + - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) ! slope at nx of parabola through last 3 points if (p(nx)*s(nx-1) <= 0) then f(2, nx) = 0 @@ -227,7 +227,7 @@ subroutine mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) else f(2, nx) = p(nx) end if - + if (slope_only) return do i=1,nx-1 @@ -236,12 +236,12 @@ subroutine mk_pmcub4(x, f1, slope_only, nwork, work1, str, ierr) end do f(3,nx) = 0d0 f(4,nx) = 0d0 - + end subroutine mk_pmcub4 - - + + ! optimize special case for nx = 3 - subroutine mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) + subroutine mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) ! make piecewise monotonic quadratic interpolant use interp_1d_def use auto_diff @@ -258,17 +258,17 @@ subroutine mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) integer :: i type(auto_diff_real_2var_order1), pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - + if (nwork < pm_work_size) then ierr = -1 return end if ierr = 0 - + h(1:nx) => work1(1:nx) s(1:nx) => work1(1+nx:2*nx) p(1:nx) => work1(1+2*nx:3*nx) - + do i=1,nx-1 h(i) = x(i+1) - x(i) ! width of interval end do @@ -280,21 +280,21 @@ subroutine mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) return end if end do - + do i=1,nx-1 s(i) = (f(1,i+1) - f(1,i)) / h(i) ! slope across interval end do - do i=2,nx-1 - p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) + do i=2,nx-1 + p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) ! slope at i of parabola through i-1, i, and i+1 end do - do i=2,nx-1 + do i=2,nx-1 f(2,i) = (sign(s(i-1))+sign(s(i)))* & min(min(abs(s(i-1)), abs(s(i))), 0.5d0*abs(p(i))) ! "safe" slope at i to ensure monotonic -- see Steffen's paper for explanation. end do - p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) + p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) ! slope at 1 of parabola through 1st 3 points if (p(1)*s(1) <= 0) then f(2, 1) = 0 @@ -303,9 +303,9 @@ subroutine mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) else f(2, 1) = p(1) end if - + p(nx) = s(nx-1)*(1 + h(nx-1) / (h(nx-1) + h(nx-2))) & - - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) + - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) ! slope at nx of parabola through last 3 points if (p(nx)*s(nx-1) <= 0) then f(2, nx) = 0 @@ -314,19 +314,19 @@ subroutine mk_pmquad(x, f1, slope_only, nwork, work1, str, ierr) else f(2, nx) = p(nx) end if - + if (slope_only) return - + do i=1,nx-1 f(3,i) = (3*s(i) - 2*f(2,i) - f(2,i+1)) / h(i) f(4,i) = (f(2,i) + f(2,i+1) - 2*s(i)) / (h(i)*h(i)) end do - f(3,nx) = 0 + f(3,nx) = 0 f(4,nx) = 0 - + end subroutine mk_pmquad - - + + ! optimize special case for nx = 2 subroutine mk_pmlinear(x, f1, slope_only, nwork, work1, str, ierr) use interp_1d_def @@ -343,14 +343,14 @@ subroutine mk_pmlinear(x, f1, slope_only, nwork, work1, str, ierr) type(auto_diff_real_2var_order1) :: h, s type(auto_diff_real_2var_order1), pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - + ierr = 0 - + if (nwork < pm_work_size) then ierr = -1 return end if - + h = x(2) - x(1) ! width of interval if (h == 0) then ierr = -1 @@ -358,22 +358,22 @@ subroutine mk_pmlinear(x, f1, slope_only, nwork, work1, str, ierr) 'same interpolation x values at', 1, 2, 'for ' // trim(str) return end if - + s = (f(1, 2) - f(1, 1)) / h ! slope across interval f(2, 1) = s f(2, 2) = 0 - + if (slope_only) return f(3,1) = 0d0 f(3,2) = 0d0 f(4,1) = 0d0 f(4,2) = 0d0 - + end subroutine mk_pmlinear - - - subroutine mk_pmcub_uniform(dx, n, f1, slope_only, nwork, work1, str, ierr) + + + subroutine mk_pmcub_uniform(dx, n, f1, slope_only, nwork, work1, str, ierr) ! make piecewise monotonic cubic interpolant on unit spaced mesh use interp_1d_def use auto_diff @@ -391,13 +391,13 @@ subroutine mk_pmcub_uniform(dx, n, f1, slope_only, nwork, work1, str, ierr) integer :: i type(auto_diff_real_2var_order1), pointer :: f(:,:) ! (4, n) ! data & interpolation coefficients f(1:4,1:n) => f1(1:4*n) - + ierr = 0 - + if (n < 2) then return end if - + if (n == 2) then x(1) = 0 x(2) = dx @@ -409,31 +409,31 @@ subroutine mk_pmcub_uniform(dx, n, f1, slope_only, nwork, work1, str, ierr) ierr = -1 return end if - + if (nwork < pm_work_size) then ierr = -1 return end if ierr = 0 - + s(1:n) => work1(1:n) p(1:n) => work1(1+n:2*n) ierr = 0 - - do i=1,n-1 + + do i=1,n-1 s(i) = f(1,i+1) - f(1,i) ! slope across interval end do - do i=2,n-1 - p(i) = 0.5d0*(s(i-1) + s(i)) + do i=2,n-1 + p(i) = 0.5d0*(s(i-1) + s(i)) ! slope at i of parabola through i-1, i, and i+1 end do - do i=2,n-1 + do i=2,n-1 f(2,i) = (sign(s(i-1))+sign(s(i)))* & min(min(abs(s(i-1)), abs(s(i))), 0.5d0*abs(p(i))) ! "safe" slope at i to ensure monotonic -- see Steffen's paper for explanation. end do - + p(1) = 1.5d0 * s(1) - 0.5d0 * s(2) ! slope at 1 of parabola through 1st 3 points if (p(1)*s(1) <= 0) then @@ -443,7 +443,7 @@ subroutine mk_pmcub_uniform(dx, n, f1, slope_only, nwork, work1, str, ierr) else f(2, 1) = p(1) end if - + p(n) = 1.5d0 * s(n-1) - 0.5d0 * s(n-2) ! slope at n of parabola through last 3 points if (p(n)*s(n-1) <= 0) then @@ -457,17 +457,17 @@ subroutine mk_pmcub_uniform(dx, n, f1, slope_only, nwork, work1, str, ierr) do i = 1,n f(2,i) = f(2,i) / dx end do - + if (slope_only) return - + ! 2nd and 3rd derivatives do i=1,n-1 - f(3,i) = (3*s(i) - 2*f(2,i) - f(2,i+1)) / dx + f(3,i) = (3*s(i) - 2*f(2,i) - f(2,i+1)) / dx f(4,i) = (f(2,i) + f(2,i+1) - 2*s(i)) / (dx*dx) end do f(3,n) = (3*f(1, n-1) - 3*f(1, n) + (f(2, n-1) + 2*f(2, n)) * dx) / (dx*dx*dx) f(4,n) = (-2*f(1, n-1) + 2*f(1, n) - (f(2, n-1) + f(2, n))*dx) / (dx*dx*dx) - + end subroutine mk_pmcub_uniform diff --git a/interp_1d/private/interp_1d_pm_sg.f90 b/interp_1d/private/interp_1d_pm_sg.f90 index f1c89631b..768faea9f 100644 --- a/interp_1d/private/interp_1d_pm_sg.f90 +++ b/interp_1d/private/interp_1d_pm_sg.f90 @@ -26,17 +26,17 @@ module interp_1d_pm_sg ! piecewise monotonic algorithms implicit none - + contains - ! the following produce piecewise monotonic interpolants + ! the following produce piecewise monotonic interpolants ! rather than monotonicity preserving - ! this stricter limit never introduces interpolated values exceeding the given values, + ! this stricter limit never introduces interpolated values exceeding the given values, ! even in places where the given values are not monotonic. ! the downside is reduced accuracy on smooth data compared to the mp routines. - - - subroutine mk_pmcub_sg(x, nx, f1, slope_only, nwork, work1, str, ierr) + + + subroutine mk_pmcub_sg(x, nx, f1, slope_only, nwork, work1, str, ierr) ! make piecewise monotonic cubic interpolant use interp_1d_def integer, intent(in) :: nx ! length of x vector (nx >= 2) @@ -53,43 +53,43 @@ subroutine mk_pmcub_sg(x, nx, f1, slope_only, nwork, work1, str, ierr) logical, parameter :: dbg = .true. real, pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - + include 'formats' - + ierr = 0 - + if (nx < 2) then return end if - + if (nx == 2) then call mk_pmlinear_sg(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nx == 3) then call mk_pmquad_sg(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nx == 4) then call mk_pmcub4_sg(x, f1, slope_only, nwork, work1, str, ierr) return end if - + if (nwork < pm_work_size) then ierr = -1 return end if - + h(1:nx) => work1(1:nx) s(1:nx) => work1(1+nx:2*nx) p(1:nx) => work1(1+2*nx:3*nx) - + if (dbg) then h(:) = 0; s(:) = 0; p(:) = 0 end if - + do i=1,nx-1 h(i) = x(i+1) - x(i) ! width of interval end do @@ -101,21 +101,21 @@ subroutine mk_pmcub_sg(x, nx, f1, slope_only, nwork, work1, str, ierr) return end if end do - + do i=1,nx-1 s(i) = (f(1,i+1) - f(1,i)) / h(i) ! slope across interval end do - do i=2,nx-1 - p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) + do i=2,nx-1 + p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) ! slope at i of parabola through i-1, i, and i+1 end do - do i=2,nx-1 + do i=2,nx-1 f(2,i) = (sign(1.0, s(i-1))+sign(1.0, s(i)))* & min(abs(s(i-1)), abs(s(i)), 0.5*abs(p(i))) ! "safe" slope at i to ensure monotonic -- see Steffen's paper for explanation. end do - p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) + p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) ! slope at 1 of parabola through 1st 3 points if (p(1)*s(1) <= 0) then f(2, 1) = 0 @@ -124,9 +124,9 @@ subroutine mk_pmcub_sg(x, nx, f1, slope_only, nwork, work1, str, ierr) else f(2, 1) = p(1) end if - + p(nx) = s(nx-1)*(1 + h(nx-1) / (h(nx-1) + h(nx-2))) & - - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) + - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) ! slope at nx of parabola through last 3 points if (p(nx)*s(nx-1) <= 0) then f(2,nx) = 0 @@ -135,7 +135,7 @@ subroutine mk_pmcub_sg(x, nx, f1, slope_only, nwork, work1, str, ierr) else f(2,nx) = p(nx) end if - + if (slope_only) return do i=1,nx-1 @@ -144,10 +144,10 @@ subroutine mk_pmcub_sg(x, nx, f1, slope_only, nwork, work1, str, ierr) end do f(3,nx) = 0 f(4,nx) = 0 - + end subroutine mk_pmcub_sg - + ! optimize special case for nx = 4 subroutine mk_pmcub4_sg(x, f1, slope_only, nwork, work1, str, ierr) use interp_1d_def @@ -164,18 +164,18 @@ subroutine mk_pmcub4_sg(x, f1, slope_only, nwork, work1, str, ierr) integer :: i real, pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - + ierr = 0 - + if (nwork < pm_work_size) then ierr = -1 return end if - + h(1:nx) => work1(1:nx) s(1:nx) => work1(1+nx:2*nx) p(1:nx) => work1(1+2*nx:3*nx) - + do i=1,nx-1 h(i) = x(i+1) - x(i) ! width of interval end do @@ -187,21 +187,21 @@ subroutine mk_pmcub4_sg(x, f1, slope_only, nwork, work1, str, ierr) return end if end do - + do i=1,nx-1 s(i) = (f(1,i+1) - f(1,i)) / h(i) ! slope across interval end do - do i=2,nx-1 - p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) + do i=2,nx-1 + p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) ! slope at i of parabola through i-1, i, and i+1 end do - do i=2,nx-1 + do i=2,nx-1 f(2,i) = (sign(1.0, s(i-1))+sign(1.0, s(i)))* & min(abs(s(i-1)), abs(s(i)), 0.5*abs(p(i))) ! "safe" slope at i to ensure monotonic -- see Steffen's paper for explanation. end do - p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) + p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) ! slope at 1 of parabola through 1st 3 points if (p(1)*s(1) <= 0) then f(2, 1) = 0 @@ -210,9 +210,9 @@ subroutine mk_pmcub4_sg(x, f1, slope_only, nwork, work1, str, ierr) else f(2, 1) = p(1) end if - + p(nx) = s(nx-1)*(1 + h(nx-1) / (h(nx-1) + h(nx-2))) & - - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) + - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) ! slope at nx of parabola through last 3 points if (p(nx)*s(nx-1) <= 0) then f(2, nx) = 0 @@ -221,7 +221,7 @@ subroutine mk_pmcub4_sg(x, f1, slope_only, nwork, work1, str, ierr) else f(2, nx) = p(nx) end if - + if (slope_only) return do i=1,nx-1 @@ -230,12 +230,12 @@ subroutine mk_pmcub4_sg(x, f1, slope_only, nwork, work1, str, ierr) end do f(3,nx) = 0 f(4,nx) = 0 - + end subroutine mk_pmcub4_sg - - + + ! optimize special case for nx = 3 - subroutine mk_pmquad_sg(x, f1, slope_only, nwork, work1, str, ierr) + subroutine mk_pmquad_sg(x, f1, slope_only, nwork, work1, str, ierr) ! make piecewise monotonic quadratic interpolant use interp_1d_def integer, parameter :: nx = 3 @@ -251,17 +251,17 @@ subroutine mk_pmquad_sg(x, f1, slope_only, nwork, work1, str, ierr) integer :: i real, pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - + if (nwork < pm_work_size) then ierr = -1 return end if ierr = 0 - + h(1:nx) => work1(1:nx) s(1:nx) => work1(1+nx:2*nx) p(1:nx) => work1(1+2*nx:3*nx) - + do i=1,nx-1 h(i) = x(i+1) - x(i) ! width of interval if (h(i) == 0) then @@ -271,21 +271,21 @@ subroutine mk_pmquad_sg(x, f1, slope_only, nwork, work1, str, ierr) return end if end do - + do i=1,nx-1 s(i) = (f(1,i+1) - f(1,i)) / h(i) ! slope across interval end do - do i=2,nx-1 - p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) + do i=2,nx-1 + p(i) = (s(i-1)*h(i) + s(i)*h(i-1))/(h(i-1)+h(i)) ! slope at i of parabola through i-1, i, and i+1 end do - do i=2,nx-1 + do i=2,nx-1 f(2,i) = (sign(1.0, s(i-1))+sign(1.0, s(i)))* & min(abs(s(i-1)), abs(s(i)), 0.5*abs(p(i))) ! "safe" slope at i to ensure monotonic -- see Steffen's paper for explanation. end do - p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) + p(1) = s(1)*(1 + h(1) / (h(1) + h(2))) - s(2) * h(1) / (h(1) + h(2)) ! slope at 1 of parabola through 1st 3 points if (sign(1.0,p(1)) /= sign(1.0,s(1))) then f(2, 1) = 0 @@ -294,9 +294,9 @@ subroutine mk_pmquad_sg(x, f1, slope_only, nwork, work1, str, ierr) else f(2, 1) = p(1) end if - + p(nx) = s(nx-1)*(1 + h(nx-1) / (h(nx-1) + h(nx-2))) & - - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) + - s(nx-2)*h(nx-1) / (h(nx-1) + h(nx-2)) ! slope at nx of parabola through last 3 points if (sign(1.0,p(nx)) /= sign(1.0,s(nx-1))) then f(2, nx) = 0 @@ -305,19 +305,19 @@ subroutine mk_pmquad_sg(x, f1, slope_only, nwork, work1, str, ierr) else f(2, nx) = p(nx) end if - + if (slope_only) return - + do i=1,nx-1 f(3,i) = (3*s(i) - 2*f(2,i) - f(2,i+1)) / h(i) f(4,i) = (f(2,i) + f(2,i+1) - 2*s(i)) / (h(i)*h(i)) end do - f(3,nx) = 0 + f(3,nx) = 0 f(4,nx) = 0 - + end subroutine mk_pmquad_sg - - + + ! optimize special case for nx = 2 subroutine mk_pmlinear_sg(x, f1, slope_only, nwork, work1, str, ierr) use interp_1d_def @@ -333,14 +333,14 @@ subroutine mk_pmlinear_sg(x, f1, slope_only, nwork, work1, str, ierr) real :: h, s real, pointer :: f(:,:) ! (4, nx) ! data & interpolation coefficients f(1:4,1:nx) => f1(1:4*nx) - + ierr = 0 - + if (nwork < pm_work_size) then ierr = -1 return end if - + h = x(2) - x(1) ! width of interval if (h == 0) then write(*, '(a,1x,2i5,1x,a)') & @@ -348,20 +348,20 @@ subroutine mk_pmlinear_sg(x, f1, slope_only, nwork, work1, str, ierr) ierr = -1 return end if - + s = (f(1, 2) - f(1, 1)) / h ! slope across interval f(2, 1) = s f(2, 2) = 0 - + if (slope_only) return f(3, 1:2) = 0 f(4, 1:2) = 0 - + end subroutine mk_pmlinear_sg - - - subroutine mk_pmcub_uniform_sg(dx, n, f1, slope_only, nwork, work1, str, ierr) + + + subroutine mk_pmcub_uniform_sg(dx, n, f1, slope_only, nwork, work1, str, ierr) ! make piecewise monotonic cubic interpolant on unit spaced mesh use interp_1d_def integer, intent(in) :: n ! length of vector @@ -378,13 +378,13 @@ subroutine mk_pmcub_uniform_sg(dx, n, f1, slope_only, nwork, work1, str, ierr) integer :: i real, pointer :: f(:,:) ! (4, n) ! data & interpolation coefficients f(1:4,1:n) => f1(1:4*n) - + ierr = 0 - + if (n < 2) then return end if - + if (n == 2) then x(1) = 0 x(2) = dx @@ -396,23 +396,23 @@ subroutine mk_pmcub_uniform_sg(dx, n, f1, slope_only, nwork, work1, str, ierr) ierr = -1 return end if - + if (nwork < pm_work_size) then ierr = -1 return end if ierr = 0 - + s(1:n) => work1(1:n) p(1:n) => work1(1+n:2*n) ierr = 0 - - do i=1,n-1 + + do i=1,n-1 s(i) = f(1,i+1) - f(1,i) ! slope across interval end do - do i=2,n-1 - p(i) = 0.5*(s(i-1) + s(i)) + do i=2,n-1 + p(i) = 0.5*(s(i-1) + s(i)) ! slope at i of parabola through i-1, i, and i+1 end do do i=2,n-1 @@ -420,7 +420,7 @@ subroutine mk_pmcub_uniform_sg(dx, n, f1, slope_only, nwork, work1, str, ierr) min(abs(s(i-1)), abs(s(i)), 0.5*abs(p(i))) ! "safe" slope at i to ensure monotonic -- see Steffen's paper for explanation. end do - + p(1) = 1.5 * s(1) - 0.5 * s(2) ! slope at 1 of parabola through 1st 3 points if (p(1)*s(1) <= 0) then @@ -430,7 +430,7 @@ subroutine mk_pmcub_uniform_sg(dx, n, f1, slope_only, nwork, work1, str, ierr) else f(2, 1) = p(1) end if - + p(n) = 1.5 * s(n-1) - 0.5 * s(n-2) ! slope at n of parabola through last 3 points if (p(n)*s(n-1) <= 0) then @@ -440,19 +440,19 @@ subroutine mk_pmcub_uniform_sg(dx, n, f1, slope_only, nwork, work1, str, ierr) else f(2, n) = p(n) end if - + f(2, 1:n) = f(2, 1:n) / dx - + if (slope_only) return - + ! 2nd and 3rd derivatives do i=1,n-1 - f(3,i) = (3*s(i) - 2*f(2,i) - f(2,i+1)) / dx + f(3,i) = (3*s(i) - 2*f(2,i) - f(2,i+1)) / dx f(4,i) = (f(2,i) + f(2,i+1) - 2*s(i)) / (dx*dx) end do f(3,n) = (3*f(1, n-1) - 3*f(1, n) + (f(2, n-1) + 2*f(2, n)) * dx) / (dx*dx) f(4,n) = (-2*f(1, n-1) + 2*f(1, n) - (f(2, n-1) + f(2, n))*dx) / (dx*dx*dx) - + end subroutine mk_pmcub_uniform_sg diff --git a/interp_1d/public/interp_1d_def.f90 b/interp_1d/public/interp_1d_def.f90 index 043dd5e7a..bfdf8008a 100644 --- a/interp_1d/public/interp_1d_def.f90 +++ b/interp_1d/public/interp_1d_def.f90 @@ -26,13 +26,13 @@ module interp_1d_def implicit none - - + + integer, parameter :: mp_work_size = 14 integer, parameter :: pm_work_size = 3 ! these are the limiter options for the monotonicity preserving interpolation - + integer, parameter :: average = 1 integer, parameter :: quartic = 2 integer, parameter :: super_bee = 3 diff --git a/interp_1d/public/interp_1d_lib.f90 b/interp_1d/public/interp_1d_lib.f90 index 9ecb3a8b4..7a6a41f34 100644 --- a/interp_1d/public/interp_1d_lib.f90 +++ b/interp_1d/public/interp_1d_lib.f90 @@ -26,11 +26,11 @@ module interp_1d_lib use const_lib, only: dp use auto_diff - + implicit none - + contains - + ! this routine is a simply wrapper for making an interpolant and then using it. subroutine interpolate_vector( & n_old, x_old, n_new, x_new, v_old, v_new, interp_vec, nwork, work1, str, ierr) @@ -117,7 +117,7 @@ end subroutine interp_vec_autodiff call interp_values_autodiff(x_old, n_old, f1, n_new, x_new, v_new, ierr) deallocate(f1) end subroutine interpolate_vector_autodiff - + ! this routine is a simply wrapper for making an interpolant with interp_pm and then using it. subroutine interpolate_vector_pm( & n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) @@ -147,9 +147,9 @@ subroutine interpolate_vector_pm( & call interp_values(x_old, n_old, f1, n_new, x_new, v_new, ierr) deallocate(f1) end subroutine interpolate_vector_pm - - - subroutine interp_4_to_1(pdqm1, pdq00, pdqp1, ndq00, pfm1, pf00, pfp1, pfp2, nf00, str, ierr) + + + subroutine interp_4_to_1(pdqm1, pdq00, pdqp1, ndq00, pfm1, pf00, pfp1, pfp2, nf00, str, ierr) ! 4 points in, 1 point out ! piecewise monotonic cubic interpolation use interp_1d_def, only: pm_work_size @@ -164,7 +164,7 @@ subroutine interp_4_to_1(pdqm1, pdq00, pdqp1, ndq00, pfm1, pf00, pfp1, pfp2, nf0 real(dp), target :: work1_ary(n_old*pm_work_size) real(dp), pointer :: work1(:) work1 => work1_ary - ierr = 0 + ierr = 0 x_old(1) = 0d0 x_old(2) = pdqm1 x_old(3) = pdqm1+pdq00 @@ -173,14 +173,14 @@ subroutine interp_4_to_1(pdqm1, pdq00, pdqp1, ndq00, pfm1, pf00, pfp1, pfp2, nf0 v_old(2) = pf00 v_old(3) = pfp1 v_old(4) = pfp2 - x_new(1) = ndq00 + x_new(1) = ndq00 call interpolate_vector_pm( & - n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) - nf00 = v_new(1) + n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) + nf00 = v_new(1) end subroutine interp_4_to_1 - - - subroutine interp_3_to_1(pdqm1, pdq00, ndqm1, pfm1, pf00, pfp1, nf00, str, ierr) + + + subroutine interp_3_to_1(pdqm1, pdq00, ndqm1, pfm1, pf00, pfp1, nf00, str, ierr) ! 3 points in, 1 point out ! piecewise monotonic quadratic interpolation use interp_1d_def, only: pm_work_size @@ -195,21 +195,21 @@ subroutine interp_3_to_1(pdqm1, pdq00, ndqm1, pfm1, pf00, pfp1, nf00, str, ierr) real(dp), target :: work1_ary(n_old*pm_work_size) real(dp), pointer :: work1(:) work1 => work1_ary - ierr = 0 + ierr = 0 x_old(1) = 0d0 x_old(2) = pdqm1 x_old(3) = pdqm1+pdq00 v_old(1) = pfm1 v_old(2) = pf00 v_old(3) = pfp1 - x_new(1) = ndqm1 + x_new(1) = ndqm1 call interpolate_vector_pm( & - n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) + n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) nf00 = v_new(1) end subroutine interp_3_to_1 - - - subroutine interp_3_to_2(pdqm1, pdq00, ndqm1, ndq00, pfm1, pf00, pfp1, nf00, nfp1, str, ierr) + + + subroutine interp_3_to_2(pdqm1, pdq00, ndqm1, ndq00, pfm1, pf00, pfp1, nf00, nfp1, str, ierr) ! 3 points in, 2 points out ! piecewise monotonic quadratic interpolation use interp_1d_def, only: pm_work_size @@ -220,32 +220,32 @@ subroutine interp_3_to_2(pdqm1, pdq00, ndqm1, ndq00, pfm1, pf00, pfp1, nf00, nfp character (len=*) :: str ! for debugging integer, intent(out) :: ierr integer, parameter :: n_old=3, n_new=2 - real(dp) :: x_old(n_old), v_old(n_old), x_new(n_new), v_new(n_new) + real(dp) :: x_old(n_old), v_old(n_old), x_new(n_new), v_new(n_new) real(dp), target :: work1_ary(n_old*pm_work_size) real(dp), pointer :: work1(:) work1 => work1_ary - ierr = 0 + ierr = 0 x_old(1) = 0d0 x_old(2) = pdqm1 x_old(3) = pdqm1+pdq00 v_old(1) = pfm1 v_old(2) = pf00 v_old(3) = pfp1 - x_new(1) = ndqm1 - x_new(2) = ndqm1+ndq00 + x_new(1) = ndqm1 + x_new(2) = ndqm1+ndq00 call interpolate_vector_pm( & - n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) + n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) nf00 = v_new(1) - nfp1 = v_new(2) + nfp1 = v_new(2) end subroutine interp_3_to_2 - + ! general routines - + ! these routines use previously created interpolant information (f) ! the interpolant can come from either the piecewise monotonic routines, or ! from the monotonicity preserving routines -- they use the same format for f. - + subroutine interp_values(init_x, nx, f1, nv, x, vals, ierr) use interp_1d_def use interp_1d_misc @@ -276,7 +276,7 @@ subroutine interp_values_autodiff(init_x, nx, f1, nv, x, vals, ierr) call do_interp_values_autodiff(init_x, nx, f1, nv, x, vals, ierr) end subroutine interp_values_autodiff - + subroutine interp_value(init_x, nx, f1, xval, val, ierr) use interp_1d_def use interp_1d_misc @@ -292,8 +292,8 @@ subroutine interp_value(init_x, nx, f1, xval, val, ierr) call do_interp_values(init_x, nx, f1, nv, x, vals, ierr) val = vals(1) end subroutine interp_value - - + + subroutine interp_values_and_slopes(init_x, nx, f1, nv, x, vals, slopes, ierr) use interp_1d_def use interp_1d_misc @@ -309,8 +309,8 @@ subroutine interp_values_and_slopes(init_x, nx, f1, nv, x, vals, slopes, ierr) integer, intent(out) :: ierr ! 0 means AOK call do_interp_values_and_slopes(init_x, nx, f1, nv, x, vals, slopes, ierr) end subroutine interp_values_and_slopes - - + + subroutine interp_value_and_slope(init_x, nx, f1, xval, val, slope, ierr) use interp_1d_def use interp_1d_misc @@ -327,8 +327,8 @@ subroutine interp_value_and_slope(init_x, nx, f1, xval, val, slope, ierr) val = vals(1) slope = slopes(1) end subroutine interp_value_and_slope - - + + subroutine interp2_values_and_slopes( & init_x, nx, f1_1, f1_2, nv, x, vals_1, slopes_1, vals_2, slopes_2, ierr) use interp_1d_def @@ -346,8 +346,8 @@ subroutine interp2_values_and_slopes( & call do_interp2_values_and_slopes( & init_x, nx, f1_1, f1_2, nv, x, vals_1, slopes_1, vals_2, slopes_2, ierr) end subroutine interp2_values_and_slopes - - + + subroutine interp2_value_and_slope(init_x, nx, f1_1, f1_2, xval, val_1, slope_1, val_2, slope_2, ierr) use interp_1d_def use interp_1d_misc @@ -367,8 +367,8 @@ subroutine interp2_value_and_slope(init_x, nx, f1_1, f1_2, xval, val_1, slope_1, val_2 = vals_2(1) slope_2 = slopes_2(1) end subroutine interp2_value_and_slope - - + + subroutine interp3_values_and_slopes( & init_x, nx, f1_1, f1_2, f1_3, nv, x, & vals_1, slopes_1, vals_2, slopes_2, vals_3, slopes_3, ierr) @@ -388,8 +388,8 @@ subroutine interp3_values_and_slopes( & init_x, nx, f1_1, f1_2, f1_3, nv, x, & vals_1, slopes_1, vals_2, slopes_2, vals_3, slopes_3, ierr) end subroutine interp3_values_and_slopes - - + + subroutine interp3_value_and_slope( & init_x, nx, f1_1, f1_2, f1_3, xval, & val_1, slope_1, val_2, slope_2, val_3, slope_3, ierr) @@ -414,8 +414,8 @@ subroutine interp3_value_and_slope( & val_3 = vals_3(1) slope_3 = slopes_3(1) end subroutine interp3_value_and_slope - - + + subroutine interp6_values_and_slopes( & init_x, nx, f1_1, f1_2, f1_3, f1_4, f1_5, f1_6, nv, x, & vals_1, slopes_1, vals_2, slopes_2, vals_3, slopes_3, & @@ -440,8 +440,8 @@ subroutine interp6_values_and_slopes( & vals_4, slopes_4, vals_5, slopes_5, vals_6, slopes_6, & ierr) end subroutine interp6_values_and_slopes - - + + subroutine interp6_value_and_slope( & init_x, nx, f1_1, f1_2, f1_3, f1_4, f1_5, f1_6, xval, & val_1, slope_1, val_2, slope_2, val_3, slope_3, & @@ -455,7 +455,7 @@ subroutine interp6_value_and_slope( & real(dp), intent(out) :: val_1, slope_1, val_2, slope_2, val_3, slope_3, & val_4, slope_4, val_5, slope_5, val_6, slope_6 integer, intent(out) :: ierr ! 0 means AOK - + integer, parameter :: nv = 1 real(dp), dimension(nv) :: x, & vals_1, slopes_1, vals_2, slopes_2, vals_3, slopes_3, & @@ -475,7 +475,7 @@ subroutine interp6_value_and_slope( & val_6 = vals_6(1); slope_6 = slopes_6(1) end subroutine interp6_value_and_slope - + subroutine integrate_values(init_x, nx, f1, nv, x, vals, ierr) use interp_1d_def use interp_1d_misc @@ -492,22 +492,22 @@ subroutine integrate_values(init_x, nx, f1, nv, x, vals, ierr) integer, intent(out) :: ierr ! 0 means AOK call do_integrate_values(init_x, nx, f1, nv, x, vals, ierr) - + end subroutine integrate_values - - + + ! piecewise monotonic routines ! the following produce piecewise monotonic interpolants rather than monotonicity preserving - ! this stricter limit never introduces interpolated values exceeding the given values, + ! this stricter limit never introduces interpolated values exceeding the given values, ! even in places where the given values are not monotonic. ! the downside is reduced accuracy on smooth data compared to the mp routines. - - - ! Steffen, M., "A simple method for monotonic interpolation in one dimension", + + + ! Steffen, M., "A simple method for monotonic interpolation in one dimension", ! Astron. Astrophys., (239) 1990, 443-450. - - + + subroutine interp_pm(x, nx, f1, nwork, work1, str, ierr) ! make piecewise monotonic cubic interpolant use interp_1d_def use interp_1d_pm @@ -517,8 +517,8 @@ subroutine interp_pm(x, nx, f1, nwork, work1, str, ierr) ! make piecewise monoto integer, intent(in) :: nwork ! nwork must be >= pm_work_size (see interp_1d_def) real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging - integer, intent(out) :: ierr - call mk_pmcub(x, nx, f1, .false., nwork, work1, str, ierr) + integer, intent(out) :: ierr + call mk_pmcub(x, nx, f1, .false., nwork, work1, str, ierr) end subroutine interp_pm subroutine interp_pm_autodiff(x, nx, f1, nwork, work1, str, ierr) ! make piecewise monotonic cubic interpolant @@ -530,10 +530,10 @@ subroutine interp_pm_autodiff(x, nx, f1, nwork, work1, str, ierr) ! make piecewi integer, intent(in) :: nwork ! nwork must be >= pm_work_size (see interp_1d_def) type(auto_diff_real_2var_order1), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging - integer, intent(out) :: ierr - call mk_pmcub_autodiff(x, nx, f1, .false., nwork, work1, str, ierr) + integer, intent(out) :: ierr + call mk_pmcub_autodiff(x, nx, f1, .false., nwork, work1, str, ierr) end subroutine interp_pm_autodiff - + subroutine interp_pm_slopes_only(x, nx, f1, nwork, work1, str, ierr) ! identical to interp_pm, but only calculates slopes and stores them in f(2,:) ! this is a little faster for the special case in which you just want the slopes at x @@ -545,18 +545,18 @@ subroutine interp_pm_slopes_only(x, nx, f1, nwork, work1, str, ierr) integer, intent(in) :: nwork ! nwork must be >= pm_work_size (see interp_1d_def) real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging - integer, intent(out) :: ierr - call mk_pmcub(x, nx, f1, .true., nwork, work1, str, ierr) + integer, intent(out) :: ierr + call mk_pmcub(x, nx, f1, .true., nwork, work1, str, ierr) end subroutine interp_pm_slopes_only - - - subroutine interp_4pt_pm(x, y, a) + + + subroutine interp_4pt_pm(x, y, a) ! returns coefficients for monotonic cubic interpolation from x(2) to x(3) real(dp), intent(in) :: x(4) ! junction points, strictly monotonic real(dp), intent(in) :: y(4) ! data values at x's real(dp), intent(inout) :: a(3) ! coefficients real(dp) :: h1, h2, h3, s1, s2, s3, p2, p3, as2, ss2, yp2, yp3 - ! for x(2) <= x <= x(3) and dx = x-x(2), + ! for x(2) <= x <= x(3) and dx = x-x(2), ! y(x) = y(2) + dx*(a(1) + dx*(a(2) + dx*a(3))) h1 = x(2)-x(1) h2 = x(3)-x(2) @@ -574,9 +574,9 @@ subroutine interp_4pt_pm(x, y, a) a(2) = (3*s2-2*yp2-yp3)/h2 a(3) = (yp2+yp3-2*s2)/(h2*h2) end subroutine interp_4pt_pm - - - subroutine interp_pm_on_uniform_grid(dx, nx, f1, nwork, work1, str, ierr) + + + subroutine interp_pm_on_uniform_grid(dx, nx, f1, nwork, work1, str, ierr) ! make piecewise monotonic cubic interpolant on uniformly spaced mesh use interp_1d_def use interp_1d_pm @@ -587,20 +587,20 @@ subroutine interp_pm_on_uniform_grid(dx, nx, f1, nwork, work1, str, ierr) real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call mk_pmcub_uniform(dx, nx, f1, .false., nwork, work1, str, ierr) + call mk_pmcub_uniform(dx, nx, f1, .false., nwork, work1, str, ierr) end subroutine interp_pm_on_uniform_grid - - - + + + ! monotonicity preserving routines - + ! Huynh, H.T., "Accurate Monotone Cubic Interpolation", SIAM J Numer. Anal. (30) 1993, 57-100. - + ! Suresh, A, and H.T. Huynh, "Accurate Monotonicity-Preserving Schemes with Runge-Kutta ! Time Stepping", JCP (136) 1997, 83-99. - - - subroutine interp_m3(x, nx, f1, which, nwork, work1, str, ierr) + + + subroutine interp_m3(x, nx, f1, which, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on arbitrarily spaced grid use interp_1d_def use interp_1d_mp @@ -612,11 +612,11 @@ subroutine interp_m3(x, nx, f1, which, nwork, work1, str, ierr) real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3(x, nx, f1, which, .false., nwork, work1, str, ierr) + call m3(x, nx, f1, which, .false., nwork, work1, str, ierr) end subroutine interp_m3 - subroutine interp_m3a(x, nx, f1, nwork, work1, str, ierr) + subroutine interp_m3a(x, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on arbitrarily spaced grid use interp_1d_def use interp_1d_mp @@ -627,11 +627,11 @@ subroutine interp_m3a(x, nx, f1, nwork, work1, str, ierr) real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3(x, nx, f1, average, .false., nwork, work1, str, ierr) + call m3(x, nx, f1, average, .false., nwork, work1, str, ierr) end subroutine interp_m3a - subroutine interp_m3q(x, nx, f1, nwork, work1, str, ierr) + subroutine interp_m3q(x, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on arbitrarily spaced grid use interp_1d_def use interp_1d_mp @@ -642,11 +642,11 @@ subroutine interp_m3q(x, nx, f1, nwork, work1, str, ierr) real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3(x, nx, f1, quartic, .false., nwork, work1, str, ierr) + call m3(x, nx, f1, quartic, .false., nwork, work1, str, ierr) end subroutine interp_m3q - subroutine interp_m3b(x, nx, f1, nwork, work1, str, ierr) + subroutine interp_m3b(x, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on arbitrarily spaced grid use interp_1d_def use interp_1d_mp @@ -657,10 +657,10 @@ subroutine interp_m3b(x, nx, f1, nwork, work1, str, ierr) real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3(x, nx, f1, super_bee, .false., nwork, work1, str, ierr) + call m3(x, nx, f1, super_bee, .false., nwork, work1, str, ierr) end subroutine interp_m3b - - + + subroutine interp_m3_on_uniform_grid(dx, nx, f1, which, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on uniformly spaced grid use interp_1d_def @@ -673,10 +673,10 @@ subroutine interp_m3_on_uniform_grid(dx, nx, f1, which, nwork, work1, str, ierr) real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_on_uniform_grid(dx, nx, f1, which, .false., nwork, work1, str, ierr) + call m3_on_uniform_grid(dx, nx, f1, which, .false., nwork, work1, str, ierr) end subroutine interp_m3_on_uniform_grid - - + + subroutine interp_m3a_on_uniform_grid(dx, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on uniformly spaced grid use interp_1d_def @@ -688,10 +688,10 @@ subroutine interp_m3a_on_uniform_grid(dx, nx, f1, nwork, work1, str, ierr) real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_on_uniform_grid(dx, nx, f1, average, .false., nwork, work1, str, ierr) + call m3_on_uniform_grid(dx, nx, f1, average, .false., nwork, work1, str, ierr) end subroutine interp_m3a_on_uniform_grid - - + + subroutine interp_m3b_on_uniform_grid(dx, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on uniformly spaced grid use interp_1d_def @@ -703,10 +703,10 @@ subroutine interp_m3b_on_uniform_grid(dx, nx, f1, nwork, work1, str, ierr) real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_on_uniform_grid(dx, nx, f1, super_bee, .false., nwork, work1, str, ierr) + call m3_on_uniform_grid(dx, nx, f1, super_bee, .false., nwork, work1, str, ierr) end subroutine interp_m3b_on_uniform_grid - - + + subroutine interp_m3q_on_uniform_grid(dx, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on uniformly spaced grid use interp_1d_def @@ -718,11 +718,11 @@ subroutine interp_m3q_on_uniform_grid(dx, nx, f1, nwork, work1, str, ierr) real(dp), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_on_uniform_grid(dx, nx, f1, quartic, .false., nwork, work1, str, ierr) + call m3_on_uniform_grid(dx, nx, f1, quartic, .false., nwork, work1, str, ierr) end subroutine interp_m3q_on_uniform_grid - - subroutine interp_m3_autodiff(x, nx, f1, which, nwork, work1, str, ierr) + + subroutine interp_m3_autodiff(x, nx, f1, which, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on arbitrarily spaced grid use interp_1d_def use interp_1d_mp_autodiff @@ -734,11 +734,11 @@ subroutine interp_m3_autodiff(x, nx, f1, which, nwork, work1, str, ierr) type(auto_diff_real_2var_order1), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_autodiff(x, nx, f1, which, .false., nwork, work1, str, ierr) + call m3_autodiff(x, nx, f1, which, .false., nwork, work1, str, ierr) end subroutine interp_m3_autodiff - subroutine interp_m3a_autodiff(x, nx, f1, nwork, work1, str, ierr) + subroutine interp_m3a_autodiff(x, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on arbitrarily spaced grid use interp_1d_def use interp_1d_mp_autodiff @@ -749,11 +749,11 @@ subroutine interp_m3a_autodiff(x, nx, f1, nwork, work1, str, ierr) type(auto_diff_real_2var_order1), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_autodiff(x, nx, f1, average, .false., nwork, work1, str, ierr) + call m3_autodiff(x, nx, f1, average, .false., nwork, work1, str, ierr) end subroutine interp_m3a_autodiff - subroutine interp_m3q_autodiff(x, nx, f1, nwork, work1, str, ierr) + subroutine interp_m3q_autodiff(x, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on arbitrarily spaced grid use interp_1d_def use interp_1d_mp_autodiff @@ -764,11 +764,11 @@ subroutine interp_m3q_autodiff(x, nx, f1, nwork, work1, str, ierr) type(auto_diff_real_2var_order1), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_autodiff(x, nx, f1, quartic, .false., nwork, work1, str, ierr) + call m3_autodiff(x, nx, f1, quartic, .false., nwork, work1, str, ierr) end subroutine interp_m3q_autodiff - subroutine interp_m3b_autodiff(x, nx, f1, nwork, work1, str, ierr) + subroutine interp_m3b_autodiff(x, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on arbitrarily spaced grid use interp_1d_def use interp_1d_mp_autodiff @@ -779,10 +779,10 @@ subroutine interp_m3b_autodiff(x, nx, f1, nwork, work1, str, ierr) type(auto_diff_real_2var_order1), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_autodiff(x, nx, f1, super_bee, .false., nwork, work1, str, ierr) + call m3_autodiff(x, nx, f1, super_bee, .false., nwork, work1, str, ierr) end subroutine interp_m3b_autodiff - - + + subroutine interp_m3_on_uniform_grid_autodiff(dx, nx, f1, which, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on uniformly spaced grid use interp_1d_def @@ -795,10 +795,10 @@ subroutine interp_m3_on_uniform_grid_autodiff(dx, nx, f1, which, nwork, work1, s type(auto_diff_real_2var_order1), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_on_uniform_grid_autodiff(dx, nx, f1, which, .false., nwork, work1, str, ierr) + call m3_on_uniform_grid_autodiff(dx, nx, f1, which, .false., nwork, work1, str, ierr) end subroutine interp_m3_on_uniform_grid_autodiff - - + + subroutine interp_m3a_on_uniform_grid_autodiff(dx, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on uniformly spaced grid use interp_1d_def @@ -810,10 +810,10 @@ subroutine interp_m3a_on_uniform_grid_autodiff(dx, nx, f1, nwork, work1, str, ie type(auto_diff_real_2var_order1), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_on_uniform_grid_autodiff(dx, nx, f1, average, .false., nwork, work1, str, ierr) + call m3_on_uniform_grid_autodiff(dx, nx, f1, average, .false., nwork, work1, str, ierr) end subroutine interp_m3a_on_uniform_grid_autodiff - - + + subroutine interp_m3b_on_uniform_grid_autodiff(dx, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on uniformly spaced grid use interp_1d_def @@ -825,10 +825,10 @@ subroutine interp_m3b_on_uniform_grid_autodiff(dx, nx, f1, nwork, work1, str, ie type(auto_diff_real_2var_order1), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_on_uniform_grid_autodiff(dx, nx, f1, super_bee, .false., nwork, work1, str, ierr) + call m3_on_uniform_grid_autodiff(dx, nx, f1, super_bee, .false., nwork, work1, str, ierr) end subroutine interp_m3b_on_uniform_grid_autodiff - - + + subroutine interp_m3q_on_uniform_grid_autodiff(dx, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on uniformly spaced grid use interp_1d_def @@ -840,7 +840,7 @@ subroutine interp_m3q_on_uniform_grid_autodiff(dx, nx, f1, nwork, work1, str, ie type(auto_diff_real_2var_order1), intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_on_uniform_grid_autodiff(dx, nx, f1, quartic, .false., nwork, work1, str, ierr) + call m3_on_uniform_grid_autodiff(dx, nx, f1, quartic, .false., nwork, work1, str, ierr) end subroutine interp_m3q_on_uniform_grid_autodiff diff --git a/interp_1d/public/interp_1d_lib_sg.f90 b/interp_1d/public/interp_1d_lib_sg.f90 index 7495defc7..4faf3ed67 100644 --- a/interp_1d/public/interp_1d_lib_sg.f90 +++ b/interp_1d/public/interp_1d_lib_sg.f90 @@ -25,10 +25,10 @@ module interp_1d_lib_sg implicit none - + contains - + ! this routine is a simply wrapper for making an interpolant and then using it. subroutine interpolate_vector_sg( & n_old, x_old, n_new, x_new, v_old, v_new, interp_vec_sg, nwork, work1, str, ierr) @@ -68,8 +68,8 @@ end subroutine interp_vec_sg call interp_values_sg(x_old, n_old, f1, n_new, x_new, v_new, ierr) deallocate(f1) end subroutine interpolate_vector_sg - - + + ! this routine is a simply wrapper for making an interpolant with interp_pm and then using it. subroutine interpolate_vector_pm_sg( & n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) @@ -97,10 +97,10 @@ subroutine interpolate_vector_pm_sg( & call interp_values_sg(x_old, n_old, f1, n_new, x_new, v_new, ierr) deallocate(f1) end subroutine interpolate_vector_pm_sg - - + + subroutine interp_4_to_1_sg( & - pdqm1, pdq00, pdqp1, ndq00, pfm1, pf00, pfp1, pfp2, nf00, str, ierr) + pdqm1, pdq00, pdqp1, ndq00, pfm1, pf00, pfp1, pfp2, nf00, str, ierr) ! 4 points in, 1 point out ! piecewise monotonic cubic interpolation use interp_1d_def, only: pm_work_size @@ -124,14 +124,14 @@ subroutine interp_4_to_1_sg( & v_old(2) = pf00 v_old(3) = pfp1 v_old(4) = pfp2 - x_new(1) = ndq00 + x_new(1) = ndq00 call interpolate_vector_pm_sg( & - n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) - nf00 = v_new(1) + n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) + nf00 = v_new(1) end subroutine interp_4_to_1_sg - - - subroutine interp_3_to_1_sg(pdqm1, pdq00, ndqm1, pfm1, pf00, pfp1, nf00, str, ierr) + + + subroutine interp_3_to_1_sg(pdqm1, pdq00, ndqm1, pfm1, pf00, pfp1, nf00, str, ierr) ! 3 points in, 1 point out ! piecewise monotonic quadratic interpolation use interp_1d_def, only: pm_work_size @@ -146,21 +146,21 @@ subroutine interp_3_to_1_sg(pdqm1, pdq00, ndqm1, pfm1, pf00, pfp1, nf00, str, ie real, target :: work1_ary(n_old*pm_work_size) real, pointer :: work1(:) work1 => work1_ary - ierr = 0 + ierr = 0 x_old(1) = 0.0 x_old(2) = pdqm1 x_old(3) = pdqm1+pdq00 v_old(1) = pfm1 v_old(2) = pf00 v_old(3) = pfp1 - x_new(1) = ndqm1 + x_new(1) = ndqm1 call interpolate_vector_pm_sg( & - n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) + n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) nf00 = v_new(1) end subroutine interp_3_to_1_sg - - - subroutine interp_3_to_2_sg(pdqm1, pdq00, ndqm1, ndq00, pfm1, pf00, pfp1, nf00, nfp1, str, ierr) + + + subroutine interp_3_to_2_sg(pdqm1, pdq00, ndqm1, ndq00, pfm1, pf00, pfp1, nf00, nfp1, str, ierr) ! 3 points in, 2 points out ! piecewise monotonic quadratic interpolation use interp_1d_def, only: pm_work_size @@ -175,28 +175,28 @@ subroutine interp_3_to_2_sg(pdqm1, pdq00, ndqm1, ndq00, pfm1, pf00, pfp1, nf00, real, target :: work1_ary(n_old*pm_work_size) real, pointer :: work1(:) work1 => work1_ary - ierr = 0 + ierr = 0 x_old(1) = 0d0 x_old(2) = pdqm1 x_old(3) = pdqm1+pdq00 v_old(1) = pfm1 v_old(2) = pf00 v_old(3) = pfp1 - x_new(1) = ndqm1 - x_new(2) = ndqm1+ndq00 + x_new(1) = ndqm1 + x_new(2) = ndqm1+ndq00 call interpolate_vector_pm_sg( & - n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) + n_old, x_old, n_new, x_new, v_old, v_new, work1, str, ierr) nf00 = v_new(1) - nfp1 = v_new(2) + nfp1 = v_new(2) end subroutine interp_3_to_2_sg - + ! general routines - + ! these routines use previously created interpolant information (f) ! the interpolant can come from either the piecewise monotonic routines, or ! from the monotonicity preserving routines -- they use the same format for f. - + subroutine interp_values_sg(init_x, nx, f1, nv, x, vals, ierr) use interp_1d_def use interp_1d_misc_sg @@ -211,8 +211,8 @@ subroutine interp_values_sg(init_x, nx, f1, nv, x, vals, ierr) integer, intent(out) :: ierr ! 0 means AOK call do_interp_values_sg(init_x, nx, f1, nv, x, vals, ierr) end subroutine interp_values_sg - - + + subroutine interp_value_sg(init_x, nx, f1, xval, val, ierr) use interp_1d_def use interp_1d_misc_sg @@ -228,8 +228,8 @@ subroutine interp_value_sg(init_x, nx, f1, xval, val, ierr) call do_interp_values_sg(init_x, nx, f1, nv, x, vals, ierr) val = vals(1) end subroutine interp_value_sg - - + + subroutine interp_values_and_slopes_sg(init_x, nx, f1, nv, x, vals, slopes, ierr) use interp_1d_def use interp_1d_misc_sg @@ -245,8 +245,8 @@ subroutine interp_values_and_slopes_sg(init_x, nx, f1, nv, x, vals, slopes, ierr integer, intent(out) :: ierr ! 0 means AOK call do_interp_values_and_slopes_sg(init_x, nx, f1, nv, x, vals, slopes, ierr) end subroutine interp_values_and_slopes_sg - - + + subroutine interp_value_and_slope_sg(init_x, nx, f1, xval, val, slope, ierr) use interp_1d_def use interp_1d_misc_sg @@ -264,7 +264,7 @@ subroutine interp_value_and_slope_sg(init_x, nx, f1, xval, val, slope, ierr) slope = slopes(1) end subroutine interp_value_and_slope_sg - + subroutine integrate_values_sg(init_x, nx, f1, nv, x, vals, ierr) use interp_1d_def use interp_1d_misc_sg @@ -281,23 +281,23 @@ subroutine integrate_values_sg(init_x, nx, f1, nv, x, vals, ierr) integer, intent(out) :: ierr ! 0 means AOK call do_integrate_values_sg(init_x, nx, f1, nv, x, vals, ierr) - + end subroutine integrate_values_sg - - + + ! piecewise monotonic routines ! the following produce piecewise monotonic interpolants rather than monotonicity preserving - ! this stricter limit never introduces interpolated values exceeding the given values, + ! this stricter limit never introduces interpolated values exceeding the given values, ! even in places where the given values are not monotonic. ! the downside is reduced accuracy on smooth data compared to the mp routines. - - - ! Steffen, M., "A simple method for monotonic interpolation in one dimension", + + + ! Steffen, M., "A simple method for monotonic interpolation in one dimension", ! Astron. Astrophys., (239) 1990, 443-450. - - - subroutine interp_pm_sg(x, nx, f1, nwork, work1, str, ierr) + + + subroutine interp_pm_sg(x, nx, f1, nwork, work1, str, ierr) ! make piecewise monotonic cubic interpolant use interp_1d_def use interp_1d_pm_sg @@ -307,11 +307,11 @@ subroutine interp_pm_sg(x, nx, f1, nwork, work1, str, ierr) integer, intent(in) :: nwork ! nwork must be >= pm_work_size (see interp_1d_def) real, intent(inout), pointer :: work1(:) ! =(nx,nwork) character (len=*) :: str ! for debugging - integer, intent(out) :: ierr - call mk_pmcub_sg(x, nx, f1, .false., nwork, work1, str, ierr) + integer, intent(out) :: ierr + call mk_pmcub_sg(x, nx, f1, .false., nwork, work1, str, ierr) end subroutine interp_pm_sg - - + + subroutine interp_pm_slopes_only_sg(x, nx, f1, nwork, work1, str, ierr) ! identical to interp_pm, but only calculates slopes and stores them in f(2,:) ! this is a little faster for the special case in which you just want the slopes at x @@ -323,18 +323,18 @@ subroutine interp_pm_slopes_only_sg(x, nx, f1, nwork, work1, str, ierr) integer, intent(in) :: nwork ! nwork must be >= pm_work_size (see interp_1d_def) real, intent(inout), pointer :: work1(:) ! =(nx,nwork) character (len=*) :: str ! for debugging - integer, intent(out) :: ierr - call mk_pmcub_sg(x, nx, f1, .true., nwork, work1, str, ierr) + integer, intent(out) :: ierr + call mk_pmcub_sg(x, nx, f1, .true., nwork, work1, str, ierr) end subroutine interp_pm_slopes_only_sg - - - subroutine interp_4pt_pm_sg(x, y, a) + + + subroutine interp_4pt_pm_sg(x, y, a) ! returns coefficients for monotonic cubic interpolation from x(2) to x(3) real, intent(in) :: x(4) ! junction points, strictly monotonic real, intent(in) :: y(4) ! data values at x's real, intent(inout) :: a(3) ! coefficients real :: h1, h2, h3, s1, s2, s3, p2, p3, as2, ss2, yp2, yp3 - ! for x(2) <= x <= x(3) and dx = x-x(2), + ! for x(2) <= x <= x(3) and dx = x-x(2), ! y(x) = y(2) + dx*(a(1) + dx*(a(2) + dx*a(3))) h1 = x(2)-x(1) h2 = x(3)-x(2) @@ -352,9 +352,9 @@ subroutine interp_4pt_pm_sg(x, y, a) a(2) = (3*s2-2*yp2-yp3)/h2 a(3) = (yp2+yp3-2*s2)/(h2*h2) end subroutine interp_4pt_pm_sg - - - subroutine interp_pm_on_uniform_grid_sg(dx, nx, f1, nwork, work1, str, ierr) + + + subroutine interp_pm_on_uniform_grid_sg(dx, nx, f1, nwork, work1, str, ierr) ! make piecewise monotonic cubic interpolant on uniformly spaced mesh use interp_1d_def use interp_1d_pm_sg @@ -365,20 +365,20 @@ subroutine interp_pm_on_uniform_grid_sg(dx, nx, f1, nwork, work1, str, ierr) real, intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call mk_pmcub_uniform_sg(dx, nx, f1, .false., nwork, work1, str, ierr) + call mk_pmcub_uniform_sg(dx, nx, f1, .false., nwork, work1, str, ierr) end subroutine interp_pm_on_uniform_grid_sg - - - + + + ! monotonicity preserving routines - + ! Huynh, H.T., "Accurate Monotone Cubic Interpolation", SIAM J Numer. Anal. (30) 1993, 57-100. - + ! Suresh, A, and H.T. Huynh, "Accurate Monotonicity-Preserving Schemes with Runge-Kutta ! Time Stepping", JCP (136) 1997, 83-99. - - - subroutine interp_m3_sg(x, nx, f1, which, nwork, work1, str, ierr) + + + subroutine interp_m3_sg(x, nx, f1, which, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on arbitrarily spaced grid use interp_1d_def use interp_1d_mp_sg @@ -390,11 +390,11 @@ subroutine interp_m3_sg(x, nx, f1, which, nwork, work1, str, ierr) real, intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_sg(x, nx, f1, which, .false., nwork, work1, str, ierr) + call m3_sg(x, nx, f1, which, .false., nwork, work1, str, ierr) end subroutine interp_m3_sg - subroutine interp_m3a_sg(x, nx, f1, nwork, work1, str, ierr) + subroutine interp_m3a_sg(x, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on arbitrarily spaced grid use interp_1d_def use interp_1d_mp_sg @@ -405,11 +405,11 @@ subroutine interp_m3a_sg(x, nx, f1, nwork, work1, str, ierr) real, intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_sg(x, nx, f1, average, .false., nwork, work1, str, ierr) + call m3_sg(x, nx, f1, average, .false., nwork, work1, str, ierr) end subroutine interp_m3a_sg - subroutine interp_m3b_sg(x, nx, f1, nwork, work1, str, ierr) + subroutine interp_m3b_sg(x, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on arbitrarily spaced grid use interp_1d_def use interp_1d_mp_sg @@ -420,11 +420,11 @@ subroutine interp_m3b_sg(x, nx, f1, nwork, work1, str, ierr) real, intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_sg(x, nx, f1, super_bee, .false., nwork, work1, str, ierr) + call m3_sg(x, nx, f1, super_bee, .false., nwork, work1, str, ierr) end subroutine interp_m3b_sg - subroutine interp_m3q_sg(x, nx, f1, nwork, work1, str, ierr) + subroutine interp_m3q_sg(x, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on arbitrarily spaced grid use interp_1d_def use interp_1d_mp_sg @@ -435,10 +435,10 @@ subroutine interp_m3q_sg(x, nx, f1, nwork, work1, str, ierr) real, intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_sg(x, nx, f1, quartic, .false., nwork, work1, str, ierr) + call m3_sg(x, nx, f1, quartic, .false., nwork, work1, str, ierr) end subroutine interp_m3q_sg - - + + subroutine interp_m3_on_uniform_grid_sg(dx, nx, f1, which, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on uniformly spaced grid use interp_1d_def @@ -451,10 +451,10 @@ subroutine interp_m3_on_uniform_grid_sg(dx, nx, f1, which, nwork, work1, str, ie real, intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_on_uniform_grid_sg(dx, nx, f1, which, .false., nwork, work1, str, ierr) + call m3_on_uniform_grid_sg(dx, nx, f1, which, .false., nwork, work1, str, ierr) end subroutine interp_m3_on_uniform_grid_sg - - + + subroutine interp_m3a_on_uniform_grid_sg(dx, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on uniformly spaced grid use interp_1d_def @@ -466,10 +466,10 @@ subroutine interp_m3a_on_uniform_grid_sg(dx, nx, f1, nwork, work1, str, ierr) real, intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_on_uniform_grid_sg(dx, nx, f1, average, .false., nwork, work1, str, ierr) + call m3_on_uniform_grid_sg(dx, nx, f1, average, .false., nwork, work1, str, ierr) end subroutine interp_m3a_on_uniform_grid_sg - - + + subroutine interp_m3b_on_uniform_grid_sg(dx, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on uniformly spaced grid use interp_1d_def @@ -481,10 +481,10 @@ subroutine interp_m3b_on_uniform_grid_sg(dx, nx, f1, nwork, work1, str, ierr) real, intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_on_uniform_grid_sg(dx, nx, f1, super_bee, .false., nwork, work1, str, ierr) + call m3_on_uniform_grid_sg(dx, nx, f1, super_bee, .false., nwork, work1, str, ierr) end subroutine interp_m3b_on_uniform_grid_sg - - + + subroutine interp_m3q_on_uniform_grid_sg(dx, nx, f1, nwork, work1, str, ierr) ! make monotonicity preserving cubic interpolant on uniformly spaced grid use interp_1d_def @@ -496,8 +496,8 @@ subroutine interp_m3q_on_uniform_grid_sg(dx, nx, f1, nwork, work1, str, ierr) real, intent(inout), pointer :: work1(:) ! =(nx, nwork) character (len=*) :: str ! for debugging integer, intent(out) :: ierr - call m3_on_uniform_grid_sg(dx, nx, f1, quartic, .false., nwork, work1, str, ierr) + call m3_on_uniform_grid_sg(dx, nx, f1, quartic, .false., nwork, work1, str, ierr) end subroutine interp_m3q_on_uniform_grid_sg - + end module interp_1d_lib_sg diff --git a/ionization/private/ion_table_plot.f90 b/ionization/private/ion_table_plot.f90 index fe2721d53..48919489d 100644 --- a/ionization/private/ion_table_plot.f90 +++ b/ionization/private/ion_table_plot.f90 @@ -1,5 +1,5 @@ module ion_table_plot - + use const_def use ion_tables_eval use math_lib @@ -7,45 +7,45 @@ module ion_table_plot implicit none - + contains - - + + subroutine do_create_table_plot_files character (len=256) :: dir - + real(dp) :: lgT_min, lgT_max, lgRho_min, lgRho_max, dlgT, & dlgRho, lgRho, lgT, Rho, T, Z, X, lgQ_min, lgQ_max - + integer :: lgT_points, lgRho_points integer :: i, j, k, ierr, io, io_first, io_last, io_params, io_rho, io_tmp, num_vals integer, parameter :: io_unit0 = 40 real(dp), allocatable :: output_values(:,:,:) - + Z = 0.018 X = 0.72 !..set the sample size lgT_points = 300 lgRho_points = 300 - + !lgT_points = 100 !lgRho_points = 100 - + !lgT_points = 2 !lgRho_points = 2 - + !..set the ranges - + ! check opal/scvh lgT_max = 7.7d0 lgT_min = 2.0d0 lgRho_min = -5d0 lgRho_max = 5.5d0 - + ! table full range lgT_max = 8.2 lgT_min = 2.1 @@ -53,13 +53,13 @@ subroutine do_create_table_plot_files lgQ_max = 5.69 lgRho_min = -9 ! lgQ_min + 2*lgT_min - 12 lgRho_max = 8 ! lgQ_max + 2*lgT_max - 12 - + ! test lgT_max = 7.5d0 lgT_min = 3d0 lgRho_max = 3d0 lgRho_min = -7d0 - + io_params = io_unit0 io_rho = io_unit0+1 io_tmp = io_unit0+2 @@ -72,7 +72,7 @@ subroutine do_create_table_plot_files close(io_params) num_vals = io_last - io_first + 1 allocate(output_values(lgRho_points,lgT_points,num_vals)) - + dlgT = (lgT_max - lgT_min)/(lgT_points-1) dlgRho = (lgRho_max - lgRho_min)/(lgRho_points-1) @@ -88,7 +88,7 @@ subroutine do_create_table_plot_files if (ierr /= 0) call mesa_error(__FILE__,__LINE__) end do end do - + write(*,*) 'write plot files' do k = 1, num_vals write(*,*) k @@ -100,17 +100,17 @@ subroutine do_create_table_plot_files write(io_tmp,*) lgT end do close(io_tmp) - + do j=1,lgRho_points lgRho = lgRho_min + dlgRho*(j-1) write(io_rho,*) lgRho end do close(io_rho) - + do io=io_first,io_last close(io) end do - + deallocate(output_values) end subroutine do_create_table_plot_files @@ -125,9 +125,9 @@ subroutine plot_one( & real(dp), dimension(num_ion_vals) :: res integer :: k - + include 'formats' - + ierr = 0 call Get_ion_Results(Z, X, Rho, lgRho, T, lgT, res, ierr) if (ierr /= 0) then @@ -165,11 +165,11 @@ subroutine plot_one( & call save1('logpp_Mg', res(ion_ilogpp_Mg)) call save1('logpp_Si', res(ion_ilogpp_Si)) call save1('logpp_Fe', res(ion_ilogpp_Fe)) - + end if - + contains - + subroutine save1(str,v) character (len=*), intent(in) :: str real(dp), intent(in) :: v @@ -177,24 +177,24 @@ subroutine save1(str,v) end subroutine save1 end subroutine plot_one - - + + subroutine open_plot_files(io_first, io_last, io_params, io_rho, io_tmp, dir) integer, intent(IN) :: io_first, io_params, io_rho, io_tmp integer, intent(OUT) :: io_last character (len=256), intent(IN) :: dir character (len=256) :: fname integer :: io - + fname = trim(dir) // '/params.data' open(unit=io_params,file=trim(fname)) - + fname = trim(dir) // '/logRho.data' open(unit=io_rho,file=trim(fname)) - + fname = trim(dir) // '/logT.data' open(unit=io_tmp,file=trim(fname)) - + io = io_first-1 !call open1('logP') !call open1('logPgas') @@ -242,23 +242,23 @@ subroutine open_plot_files(io_first, io_last, io_params, io_rho, io_tmp, dir) !call open1('logE') !call open1('logW') io_last = io - - - contains - - + + + contains + + subroutine open1(name) character (len=*), intent(in) :: name fname = trim(dir) // '/' // trim(name) // '.data' io = io+1; open(unit=io,file=trim(fname)) end subroutine open1 - + end subroutine open_plot_files - - - + + + end module ion_table_plot diff --git a/ionization/private/ion_tables_eval.f90 b/ionization/private/ion_tables_eval.f90 index ea96cca75..289dea337 100644 --- a/ionization/private/ion_tables_eval.f90 +++ b/ionization/private/ion_tables_eval.f90 @@ -25,19 +25,19 @@ ! *********************************************************************** module ion_tables_eval - + use const_def, only: dp, one_sixth use ionization_def use math_lib use utils_lib, only: mesa_error implicit none - - + + logical, parameter :: dbg = .false. - - + + contains @@ -47,30 +47,30 @@ subroutine Get_ion_Results(& use const_def use utils_lib, only: is_bad use ion_tables_load, only: Load_ion_Table - + ! INPUT real(dp), intent(in) :: Z_in ! the desired Z real(dp), intent(in) :: X_in ! the desired X - + real(dp), intent(in) :: arho, alogrho ! the density ! provide both if you have them. else pass one and set the other to = arg_not_provided - + real(dp), intent(in) :: atemp, alogtemp ! the temperature ! provide both if you have them. else pass one and set the other to = arg_not_provided - - ! OUTPUT - + + ! OUTPUT + real(dp), intent(inout) :: res(num_ion_vals) integer, intent(out) :: ierr - + real(dp), dimension(num_ion_vals) :: res1, d_dlnRho_c_T1, d_dlnT_c_Rho1 real(dp), dimension(num_ion_vals) :: res2, d_dlnRho_c_T2, d_dlnT_c_Rho2 real(dp) :: X, Z, Rho, logRho, T, logT integer :: iregion character (len=256) :: message - + real(dp) :: alfa, beta, c_dx, c_dy, logRho_lo, logRho_hi, & logT1, logT2, logT7, logT8, logRho3, logRho4 real(dp) :: logQ, A, B, sin_pi_alfa, dA_dlnT, dA_dlnRho, dB_dlnT, dB_dlnRho @@ -84,14 +84,14 @@ subroutine Get_ion_Results(& real(dp), parameter :: dZ_transition = 0.01d0 ! must be > 0 real(dp), parameter :: logT_margin = 0.1d0 real(dp), parameter :: tiny = 1d-20 - + logical :: debug - + include 'formats' - + ierr = 0 debug = dbg - + if (.not. ion_is_initialized) then call Load_ion_Table(ierr) if (ierr /= 0) then @@ -99,16 +99,16 @@ subroutine Get_ion_Results(& return end if end if - + if (is_bad(X_in) .or. is_bad(Z_in)) then ierr = -1 return end if - + X = X_in; Z = Z_in if (X < tiny) X = 0 if (Z < tiny) Z = 0 - + !..get temp and rho args T = atemp; logT = alogtemp if (atemp == arg_not_provided .and. alogtemp == arg_not_provided) then @@ -116,24 +116,24 @@ subroutine Get_ion_Results(& end if if (alogtemp == arg_not_provided) logT = log10(T) if (atemp == arg_not_provided) T = exp10(logT) - + if (T <= 0) then ierr = -1 return end if - + Rho = arho; logrho = alogrho if (arho == arg_not_provided .and. alogrho == arg_not_provided) then ierr = -3; return end if if (alogrho == arg_not_provided) logRho = log10(Rho) if (arho == arg_not_provided) Rho = exp10(logRho) - + if (Rho <= 0) then ierr = -1 return end if - + if (is_bad(Rho) .or. is_bad(T)) then ierr = -1 return @@ -142,7 +142,7 @@ subroutine Get_ion_Results(& end subroutine Get_ion_Results - + subroutine Get_ion_ZResults(& Z, X, Rho, logRho, T, logT, & res, ierr) @@ -163,29 +163,29 @@ subroutine Get_ion_ZResults(& logical, parameter :: ion_dbg = dbg ierr = 0 - + if (num_ion_Zs < 3) then write(*, *) 'error: Get_ion_ZResults assumes num_ion_Zs >= 3' call mesa_error(__FILE__,__LINE__) end if - + if (ion_Zs(1) /= 0) then write(*, *) 'error: Get_ion_ZResults assumes ion_Zs(1) == 0' call mesa_error(__FILE__,__LINE__) end if - + if (abs(ion_Zs(1) - 2*ion_Zs(2) + ion_Zs(3)) > tiny) then write(*, *) 'error: Get_ion_ZResults assumes equal spaced Zs(1:3)' call mesa_error(__FILE__,__LINE__) end if - + if (Z < tiny) then call Get_ion_for_X(1, X, Rho, logRho, T, logT, res, ierr) return end if - + if (Z > ion_Zs(3)) then - + if (Z <= ion_Zs(4)) then call do_interp2(3,4,ierr) if (ierr /= 0) return @@ -196,9 +196,9 @@ subroutine Get_ion_ZResults(& call Get_ion_for_X(5, X, Rho, logRho, T, logT, res, ierr) return end if - + else - + do iz = 1, 3 call Get_ion_for_X(iz, X, Rho, logRho, T, logT, res_zx(:, iz), ierr) if (ierr /= 0) return @@ -208,15 +208,15 @@ subroutine Get_ion_ZResults(& denom = 2*dZ*dZ c(1) = (2*dZ*dZ - 3*dZ*Z + Z*Z)/denom c(2) = 2*(2*dZ-Z)*Z/denom - c(3) = Z*(Z-dZ)/denom + c(3) = Z*(Z-dZ)/denom end if - + res(:) = c(1)*res_zx(:, 1) + c(2)*res_zx(:, 2) + c(3)*res_zx(:, 3) - - + + contains - + subroutine do_interp2(iz1, iz2, ierr) use const_def, only: pi integer, intent(in) :: iz1, iz2 @@ -237,10 +237,10 @@ subroutine do_interp2(iz1, iz2, ierr) c(3) = 0 res_zx(:,3) = 0 end subroutine do_interp2 - + end subroutine Get_ion_ZResults - + subroutine Get_ion_for_X(iz, X, Rho, logRho, T, logT,res, ierr) integer, intent(in) :: iz ! the index in ion_Zs real(dp), intent(in) :: X, Rho, logRho, T, logT @@ -255,33 +255,33 @@ subroutine Get_ion_for_X(iz, X, Rho, logRho, T, logT,res, ierr) logical, parameter :: dbg_for_X = dbg ! .or. .true. ierr = 0 - + if (num_ion_Xs /= 6) then write(*, *) 'error: Get_ion_for_X assumes num_ion_Xs == 6' call mesa_error(__FILE__,__LINE__) end if - + if (ion_Xs(1) /= 0) then write(*, *) 'error: Get_ion_for_X assumes ion_Xs(1) == 0' call mesa_error(__FILE__,__LINE__) end if - + num_Xs = num_ion_Xs_for_Z(iz) - + if (X < tiny .or. num_Xs == 1) then call Get_ion_XTable_Results(1, iz, Rho, logRho, T, logT, res, ierr) return end if - + dX = ion_Xs(2)-ion_Xs(1) - + do ix = 3, num_Xs if (abs(dX - (ion_Xs(ix) - ion_Xs(ix-1))) > tiny) then write(*, *) 'error: Get_ion_for_X assumes equal spaced Xs' call mesa_error(__FILE__,__LINE__) end if end do - + ix_hi = -1 if (X <= ion_Xs(2)) then ix_lo = 1; ix_hi = 3 @@ -294,7 +294,7 @@ subroutine Get_ion_for_X(iz, X, Rho, logRho, T, logT,res, ierr) end if end do end if - + if (ix_hi < 0) then write(*, *) 'X', X write(*, *) 'ix_lo', ix_lo @@ -302,36 +302,36 @@ subroutine Get_ion_for_X(iz, X, Rho, logRho, T, logT,res, ierr) write(*, *) 'error: Get_ion_for_X logic bug' call mesa_error(__FILE__,__LINE__) end if - + if (dbg_for_X) then write(*, *) 'X', X write(*, *) 'ix_lo', ix_lo write(*, *) 'ix_hi', ix_hi end if - + do ix=ix_lo, ix_hi j = ix-ix_lo+1 call Get_ion_XTable_Results(ix, iz, Rho, logRho, T, logT, & res_zx(:, j), ierr) if (ierr /= 0) return end do - + delX = X - ion_Xs(ix_lo) if (ix_hi-ix_lo==2) then - + denom = 2*dX*dX c(1) = (2*dX*dX - 3*dX*delX + delX*delX)/denom c(2) = 2*(2*dX-delX)*delX/denom c(3) = delX*(delX-dX)/denom res(:) = c(1)*res_zx(:, 1) + c(2)*res_zx(:, 2) + c(3)*res_zx(:, 3) - 1 format(a30, e25.15) + 1 format(a30, e25.15) if (dbg_for_X) then end if - + else - - coef = (X-ion_Xs(ix_lo+1))/dX + + coef = (X-ion_Xs(ix_lo+1))/dX ! coef = fractional location of X between 2nd and 3rd X's for fit. ! coef is weight for the quadratic based on points 2, 3, 4 of fit. ! (1-coef) is weight for quadratic based on points 1, 2, 3 of fit. @@ -345,25 +345,25 @@ subroutine Get_ion_for_X(iz, X, Rho, logRho, T, logT,res, ierr) c(4) = coef*coef*(coef-1)/2 res(:) = c(1)*res_zx(:, 1) + c(2)*res_zx(:, 2) & + c(3)*res_zx(:, 3) + c(4)*res_zx(:, 4) - + end if - - + + end subroutine Get_ion_for_X - - + + subroutine Get_ion_XTable_Results(ix, iz, Rho, logRho_in, T, logT_in, & res, ierr) integer, intent(in) :: ix, iz real(dp), intent(in) :: Rho, logRho_in, T, logT_in real(dp), intent(inout) :: res(num_ion_vals) integer, intent(out) :: ierr - + real(dp) :: logQ0, logQ1, logT0, logT1 integer :: iQ, jtemp - + real(dp) :: logRho, logT, logQ - + include 'formats' logRho = logRho_in @@ -371,34 +371,34 @@ subroutine Get_ion_XTable_Results(ix, iz, Rho, logRho_in, T, logT_in, & logQ = logRho - 2*logT + 12 ierr = 0 - + call Locate_logQ(logQ, iQ, logQ0, logQ1, ierr) if (ierr /= 0) return - + call Locate_logT(logT, jtemp, logT0, logT1, ierr) if (ierr /= 0) return - + call Do_ion_Interpolations(& ion_num_logQs, ion_logQs, ion_num_logTs, ion_logTs, & ion_tbl(:, :, :, :, ix, iz), & iQ, jtemp, logQ0, logQ, logQ1, logT0, logT, logT1, & res, ierr) - + end subroutine Get_ion_XTable_Results - - + + subroutine Locate_logQ(logQ, iQ, logQ0, logQ1, ierr) real(dp), intent(inout) :: logQ integer, intent(out) :: iQ real(dp), intent(out) :: logQ0, logQ1 integer, intent(out) :: ierr - + ierr = 0 iQ = int((logQ - ion_logQ_min) / ion_del_logQ + 1d-4) + 1 - + if (iQ < 1 .or. iQ >= ion_num_logQs) then - + if (iQ < 1) then iQ = 1 logQ0 = ion_logQ_min @@ -410,28 +410,28 @@ subroutine Locate_logQ(logQ, iQ, logQ0, logQ1, ierr) logQ1 = logQ0 + ion_del_logQ logQ = logQ1 end if - + else - + logQ0 = ion_logQ_min + (iQ-1) * ion_del_logQ logQ1 = logQ0 + ion_del_logQ end if end subroutine Locate_logQ - - + + subroutine Locate_logT(logT, iT, logT0, logT1, ierr) real(dp), intent(inout) :: logT integer, intent(out) :: iT real(dp), intent(out) :: logT0, logT1 integer, intent(out) :: ierr - + ierr = 0 iT = int((logT - ion_logT_min) / ion_del_logT + 1d-4) + 1 - + if (iT < 1 .or. iT >= ion_num_logTs) then - + if (iT < 1) then iT = 1 logT0 = ion_logT_min @@ -443,17 +443,17 @@ subroutine Locate_logT(logT, iT, logT0, logT1, ierr) logT1 = logT0 + ion_del_logT logT = logT1 end if - + else - + logT0 = ion_logT_min + (iT-1) * ion_del_logT logT1 = logT0 + ion_del_logT end if end subroutine Locate_logT - - + + subroutine Do_ion_Interpolations(& nx, x, ny, y, fin, i, j, & x0, xget, x1, y0, yget, y1, & @@ -467,7 +467,7 @@ subroutine Do_ion_Interpolations(& real(dp), intent(in) :: y0, yget, y1 ! y0 <= yget <= y1; y0 = ys(j), y1 = ys(j+1) real(dp), intent(inout) :: res(num_ion_vals) integer, intent(out) :: ierr - + real(dp), parameter :: z36th = 1d0/36d0 real(dp) :: xp, xpi, xp2, xpi2, ax, axbar, bx, bxbar, cx, cxi, hx2, cxd, cxdi, hx, hxi real(dp) :: yp, ypi, yp2, ypi2, ay, aybar, by, bybar, cy, cyi, hy2, cyd, cydi, hy, hyi @@ -476,14 +476,14 @@ subroutine Do_ion_Interpolations(& real(dp) :: sixth_hx2_hyi, sixth_hy, z36th_hx2_hy integer :: k, ip1, jp1 real(dp) :: f(4,nx,ny) - + include 'formats' - + ierr = 0 hx=x1-x0 hxi=1.0/hx hx2=hx*hx - + xp=(xget-x0)*hxi xpi=1.0-xp xp2=xp*xp @@ -491,19 +491,19 @@ subroutine Do_ion_Interpolations(& ax=xp2*(3.0-2.0*xp) axbar=1.0-ax - + bx=-xp2*xpi bxbar=xpi2*xp - + cx=xp*(xp2-1.0) cxi=xpi*(xpi2-1.0) cxd=3.0*xp2-1.0 cxdi=-3.0*xpi2+1.0 - + hy=y1-y0 hyi=1.0/hy hy2=hy*hy - + yp=(yget-y0)*hyi ypi=1.0-yp yp2=yp*yp @@ -511,30 +511,30 @@ subroutine Do_ion_Interpolations(& ay=yp2*(3.0-2.0*yp) aybar=1.0-ay - + by=-yp2*ypi bybar=ypi2*yp - + cy=yp*(yp2-1.0) cyi=ypi*(ypi2-1.0) cyd=3.0*yp2-1.0 cydi=-3.0*ypi2+1.0 - + sixth_hx2 = one_sixth*hx2 sixth_hy2 = one_sixth*hy2 z36th_hx2_hy2 = z36th*hx2*hy2 - + sixth_hx = one_sixth*hx sixth_hxi_hy2 = one_sixth*hxi*hy2 z36th_hx_hy2 = z36th*hx*hy2 - + sixth_hx2_hyi = one_sixth*hx2*hyi sixth_hy = one_sixth*hy z36th_hx2_hy = z36th*hx2*hy - + ip1 = i+1 jp1 = j+1 - + do k=1,num_ion_vals ! bicubic spline interpolation res(k) = dble(& @@ -579,11 +579,11 @@ subroutine Do_ion_Interpolations(& ! > +z36th_hx2_hy*( ! > cxi*(cydi*fin(4,k,i,j) +cyd*fin(4,k,i,jp1))+ ! > cx*(cydi*fin(4,k,ip1,j)+cyd*fin(4,k,ip1,jp1))) - + end do - + end subroutine Do_ion_Interpolations end module ion_tables_eval - + diff --git a/ionization/private/ion_tables_load.f90 b/ionization/private/ion_tables_load.f90 index 6e451e2a1..e155f1869 100644 --- a/ionization/private/ion_tables_load.f90 +++ b/ionization/private/ion_tables_load.f90 @@ -33,8 +33,8 @@ module ion_tables_load contains - - + + subroutine Init_ion_tables(file_prefix, Z1_suffix, use_cache, ierr) character(*), intent(in) :: file_prefix, Z1_suffix logical, intent(in) :: use_cache @@ -48,8 +48,8 @@ subroutine Init_ion_tables(file_prefix, Z1_suffix, use_cache, ierr) if (ierr /= 0) return ion_root_is_initialized = .true. end subroutine Init_ion_tables - - + + subroutine ion_read_sizes(ierr) use utils_lib integer, intent(out) :: ierr @@ -57,9 +57,9 @@ subroutine ion_read_sizes(ierr) character (len=256) :: message, fname, cache_filename, temp_cache_filename integer :: iounit real(dp) :: xin, zz - + ierr = 0 - + call Get_ion_Table_Filenames(ion_Zs(1), ion_Xs(1), fname, cache_filename, temp_cache_filename) open(newunit=iounit, file=trim(fname), action='read', status='old', iostat=ierr) call check_for_error_in_ion_data(ierr, fname) @@ -73,12 +73,12 @@ subroutine ion_read_sizes(ierr) call check_for_error_in_ion_data(ierr, fname) close(iounit) - + if (ion_version < min_version) call request_user_to_reinstall end subroutine ion_read_sizes - - + + subroutine request_user_to_reinstall write(*,*) write(*,*) @@ -93,8 +93,8 @@ subroutine request_user_to_reinstall write(*,*) call mesa_error(__FILE__,__LINE__) end subroutine request_user_to_reinstall - - + + subroutine check_for_error_in_ion_data(ierr, fname) integer, intent(in) :: ierr character (len=*) :: fname @@ -111,24 +111,24 @@ subroutine check_for_error_in_ion_data(ierr, fname) write(*,*) call mesa_error(__FILE__,__LINE__) end subroutine check_for_error_in_ion_data - - + + subroutine Load_ion_Table(ierr) use utils_lib integer, intent(out) :: ierr - + integer :: iz, ix, i - + ierr = 0 !$OMP CRITICAL (load_ionization_table) call do_read !$OMP END CRITICAL (load_ionization_table) - + contains - + subroutine do_read integer :: sz_ion_tbl - + if (ion_is_initialized) return sz_ion_tbl = sz_per_ion_point*num_ion_vals* & ion_num_logQs*ion_num_logTs*num_ion_Xs*num_ion_Zs @@ -145,7 +145,7 @@ subroutine do_read ion_logQs(i) = ion_logQs(i-1) + ion_del_logQ end do ion_logQs(ion_num_logQs) = ion_logQ_max - + ion_logTs(1) = ion_logT_min do i = 2, ion_num_logTs-1 ion_logTs(i) = ion_logTs(i-1) + ion_del_logT @@ -159,18 +159,18 @@ subroutine do_read if (ierr /= 0) return end do end do - + ion_is_initialized = .true. end subroutine do_read - + subroutine read_one(ix,iz,ierr) integer, intent(in) :: ix, iz integer, intent(out) :: ierr character (len=256) :: fname, cache_filename, temp_cache_filename - + include 'formats' - + call Get_ion_Table_Filenames(& ion_Zs(iz), ion_Xs(ix), fname, cache_filename, temp_cache_filename) call Load1_ion_Table(& @@ -181,16 +181,16 @@ subroutine read_one(ix,iz,ierr) end if end subroutine read_one - + end subroutine Load_ion_Table - - + + subroutine Get_ion_Table_Filenames(Z, X, fname, cache_filename, temp_cache_filename) use const_def, only: mesa_data_dir real(dp), intent(in) :: Z, X character (len=*), intent(out) :: fname, cache_filename, temp_cache_filename character (len=256) :: Zstr, Xstr, suffix - + call setstr(Z,Zstr) call setstr(X,Xstr) if (Zstr == '100') then @@ -198,20 +198,20 @@ subroutine Get_ion_Table_Filenames(Z, X, fname, cache_filename, temp_cache_filen else suffix = '' end if - + fname = trim(mesa_data_dir) // & '/ionization_data/' // trim(ion_file_prefix) // '_' //& trim(Zstr) // 'z' // trim(Xstr) // 'x' // trim(suffix) // '.data' cache_filename = trim(ionization_cache_dir) // & '/' // trim(ion_file_prefix) // '_' //& trim(Zstr) // 'z' // trim(Xstr) // 'x' // trim(suffix) // '.bin' - + temp_cache_filename = trim(ionization_temp_cache_dir) // & '/' // trim(ion_file_prefix) // '_' //& trim(Zstr) // 'z' // trim(Xstr) // 'x' // trim(suffix) // '.bin' - + contains - + subroutine setstr(v,str) real(dp), intent(in) :: v character (len=*) :: str @@ -223,10 +223,10 @@ subroutine setstr(v,str) write(str, '(a,i1)') '0', floor(100d0 * v + 0.5d0) end if end subroutine setstr - + end subroutine Get_ion_Table_Filenames - - + + subroutine Load1_ion_Table(& X, Z, tbl, filename, cache_filename, temp_cache_filename, use_cache, info) real(dp), intent(in) :: X, Z @@ -236,17 +236,17 @@ subroutine Load1_ion_Table(& integer, intent(out) :: info integer :: io_unit, cache_io_unit - + integer :: num_logQs_in, num_logTs_in, version_in real(dp) :: logT_min_in, logT_max_in, del_logT_in, vals(num_ion_vals),& logQ_min_in, logQ_max_in, del_logQ_in, X_in, Z_in, logQ, logT integer :: j,i,k,iQ,ios,status,line_number character (len=500) :: message, input_line real(dp), parameter :: tiny = 1e-6 - + include 'formats' - info = 0 + info = 0 write(message,*) 'open ', trim(filename) open(NEWUNIT=io_unit, FILE=trim(filename), ACTION='READ', STATUS='OLD', IOSTAT=ios) @@ -294,7 +294,7 @@ subroutine Load1_ion_Table(& write(*,*) write(*,1) 'ion_logT_max', ion_logT_max write(*,1) 'logT_max_in', logT_max_in - stop + stop return end if @@ -305,7 +305,7 @@ subroutine Load1_ion_Table(& return end if end if - + do iQ=1,ion_num_logQs read(io_unit,*,iostat=info) if (failed('skip line')) return @@ -342,14 +342,14 @@ subroutine Load1_ion_Table(& if (failed('skip line')) return line_number = line_number + 1 end do - + close(io_unit) - + call Make_ion_Interpolation_Data(tbl, info) if (failed('Make_ion_Interpolation_Data')) return - + call Check_ion_Interpolation_Data(tbl) - + if (.not. use_cache) return open(NEWUNIT=cache_io_unit, file=trim(switch_str(temp_cache_filename, cache_filename, use_mesa_temp_cache)),& @@ -365,18 +365,18 @@ subroutine Load1_ion_Table(& close(cache_io_unit) if(use_mesa_temp_cache) call mv(temp_cache_filename, cache_filename,.true.) end if - + contains - + subroutine Check_ion_Interpolation_Data(tbl) use utils_lib,only:is_bad real(dp) :: tbl(sz_per_ion_point, num_ion_vals, ion_num_logQs, ion_num_logTs) - + ! for logT > 6.8 and logRho < -10, splines can get bogus higher order terms ! replace NaN's and Infinities with 0 - + integer :: i, j, iQ, jtemp - + do i = 1, sz_per_ion_point do j = 1, num_ion_vals do iQ = 1, ion_num_logQs @@ -388,9 +388,9 @@ subroutine Check_ion_Interpolation_Data(tbl) end do end do end do - + end subroutine Check_ion_Interpolation_Data - + logical function failed(str) character (len=*), intent(in) :: str failed = (info /= 0) @@ -401,11 +401,11 @@ logical function failed(str) ' Load1_ion_Table failed: ' // trim(str) // ' line', line_number end if end function failed - + end subroutine Load1_ion_Table - - + + subroutine Make_ion_Interpolation_Data(tbl, info) use interp_2d_lib_db use const_def, only: crad, ln10 @@ -433,15 +433,15 @@ subroutine Make_ion_Interpolation_Data(tbl, info) real(dp) :: gamma3, gamma1, grad_ad, Prad, E, S integer :: iQ, jtemp, ilogT, ilogQ real(dp) :: fval(num_ion_vals), df_dx(num_ion_vals), df_dy(num_ion_vals) - + integer :: v, vlist(3), var, i, j character (len=256) :: message - + allocate(f1_ary(sz_per_ion_point*ion_num_logQs*ion_num_logTs)) - + f1 => f1_ary f(1:sz_per_ion_point,1:ion_num_logQs,1:ion_num_logTs) => & - f1_ary(1:sz_per_ion_point*ion_num_logQs*ion_num_logTs) + f1_ary(1:sz_per_ion_point*ion_num_logQs*ion_num_logTs) info = 0 @@ -459,9 +459,9 @@ subroutine Make_ion_Interpolation_Data(tbl, info) ibcymin = 0; bcymin(:) = 0 ibcymax = 0; bcymax(:) = 0 - ! create tables for bicubic spline interpolation + ! create tables for bicubic spline interpolation do v = 1, num_ion_vals - + f(1,:,:) = tbl(1,v,:,:) call interp_mkbicub_db(& logQs,ion_num_logQs,logTs,ion_num_logTs,f1,ion_num_logQs,& @@ -474,12 +474,12 @@ subroutine Make_ion_Interpolation_Data(tbl, info) return end if tbl(2:4,v,:,:) = f(2:4,:,:) - + end do - + end subroutine Make_ion_Interpolation_Data - - + + subroutine Read_ion_Cache(X, Z, tbl, cache_filename, ios) real(dp), intent(in) :: X, Z real(dp) :: tbl(sz_per_ion_point, num_ion_vals, ion_num_logQs, ion_num_logTs) @@ -492,17 +492,17 @@ subroutine Read_ion_Cache(X, Z, tbl, cache_filename, ios) logQ_min_in, logQ_max_in, del_logQ_in integer :: num_logQs_in, num_logTs_in, version_in real(dp), parameter :: tiny = 1d-6 - + ios = 0 open(newunit=io_unit,file=trim(cache_filename),action='read',& status='old',iostat=ios,form='unformatted') if (ios /= 0) return - + read(io_unit, iostat=ios) & X_in, Z_in, num_logTs_in, logT_min_in, logT_max_in, del_logT_in, & num_logQs_in, logQ_min_in, logQ_max_in, del_logQ_in, version_in if (ios /= 0) return - + if (ion_version /= version_in) then ios = 1 write(*,*) 'read cache failed for version_in' @@ -510,7 +510,7 @@ subroutine Read_ion_Cache(X, Z, tbl, cache_filename, ios) if (ion_num_logQs /= num_logQs_in) then ios = 1 write(*,*) 'read cache failed for ion_num_logQs' - end if + end if if (ion_num_logTs /= num_logTs_in) then ios = 1 write(*,*) 'read cache failed for ion_num_logTs' @@ -526,19 +526,19 @@ subroutine Read_ion_Cache(X, Z, tbl, cache_filename, ios) if (abs(ion_logT_min-logT_min_in) > tiny) then ios = 1 write(*,*) 'read cache failed for ion_logT_min' - end if + end if if (abs(ion_logT_max-logT_max_in) > tiny) then ios = 1 write(*,*) 'read cache failed for ion_logT_max' - end if + end if if (abs(ion_del_logT-del_logT_in) > tiny) then ios = 1 write(*,*) 'read cache failed for ion_del_logT' - end if + end if if (abs(ion_logQ_min-logQ_min_in) > tiny) then ios = 1 write(*,*) 'read cache failed for ion_logQ_min' - end if + end if if (abs(ion_logQ_max-logQ_max_in) > tiny) then ios = 1 write(*,*) 'read cache failed for ion_logQ_max' @@ -547,7 +547,7 @@ subroutine Read_ion_Cache(X, Z, tbl, cache_filename, ios) ios = 1 write(*,*) 'read cache failed for ion_del_logQ' end if - + if (ios /= 0) then close(io_unit); return end if @@ -557,10 +557,10 @@ subroutine Read_ion_Cache(X, Z, tbl, cache_filename, ios) if (ios /= 0) then close(io_unit); return end if - + close(io_unit) end subroutine Read_ion_Cache - - + + end module ion_tables_load diff --git a/ionization/private/mod_ionization.f90 b/ionization/private/mod_ionization.f90 index c9de80384..1c02e5e9f 100644 --- a/ionization/private/mod_ionization.f90 +++ b/ionization/private/mod_ionization.f90 @@ -31,15 +31,15 @@ module mod_ionization use utils_lib, only: mesa_error implicit none - + logical, parameter :: dbg = .false. - + contains - subroutine do_init_ionization(ionization_cache_dir_in, use_cache, ierr) + subroutine do_init_ionization(ionization_cache_dir_in, use_cache, ierr) character (len=*), intent(in) :: ionization_cache_dir_in logical, intent(in) :: use_cache integer, intent(out) :: ierr @@ -51,32 +51,32 @@ end subroutine do_init_ionization subroutine do_load(ierr) use ionization_def integer, intent(out) :: ierr - + integer :: io_log_ne, io_logT, io_z integer, pointer :: ibound(:,:), tmp_version(:) integer, parameter :: num_log_ne_fe56_he4 = 105, num_logT_fe56_he4 = 30 - + ierr = 0 - fe_he_ptr => fe_he_info - + fe_he_ptr => fe_he_info + call load_table_summary( & 'log_ne_fe56_he4.data', 'logT_fe56_he4.data', 'z_fe56_he4.data', & num_log_ne_fe56_he4, num_logT_fe56_he4, fe_he_ptr, ierr) - if (ierr /= 0) return + if (ierr /= 0) return call create_interpolants(fe_he_ptr,num_log_ne_fe56_he4,num_logT_fe56_he4,ierr) - if (ierr /= 0) return - + if (ierr /= 0) return + table_is_initialized = .true. - + contains - + subroutine openfile(filename, iounit, ierr) character(len=*) :: filename integer, intent(inout) :: iounit integer, intent(out) :: ierr - if (dbg) write(*,*) 'read ' // trim(filename) + if (dbg) write(*,*) 'read ' // trim(filename) ierr = 0 open(newunit=iounit,file=trim(filename),action='read',status='old',iostat=ierr) if (ierr/= 0) then @@ -94,19 +94,19 @@ subroutine openfile(filename, iounit, ierr) call mesa_error(__FILE__,__LINE__) endif end subroutine openfile - - + + subroutine load_table_summary( & log_ne_fname, logT_fname, z_fname, num_log_ne, num_logT, p, ierr) character(len=*), intent(in) :: log_ne_fname, logT_fname, z_fname integer, intent(in) :: num_log_ne, num_logT type (Ionization_Info), pointer :: p integer, intent(out) :: ierr - + character(len=256) :: filename real(dp), pointer :: f(:,:,:) integer :: i, j - + ierr = 0 p% have_interpolation_info = .false. p% num_log_ne = num_log_ne @@ -119,8 +119,8 @@ subroutine load_table_summary( & call mesa_error(__FILE__,__LINE__) end if f(1:4,1:num_log_ne,1:num_logT) => p% f1(1:4*num_log_ne*num_logT) - - filename = trim(mesa_data_dir) // '/ionization_data/' // trim(z_fname) + + filename = trim(mesa_data_dir) // '/ionization_data/' // trim(z_fname) call openfile(filename, io_z, ierr) if (ierr /= 0) return do i=1,num_logT @@ -135,8 +135,8 @@ subroutine load_table_summary( & end do end do close(io_z) - - filename = trim(mesa_data_dir) // '/ionization_data/' // trim(log_ne_fname) + + filename = trim(mesa_data_dir) // '/ionization_data/' // trim(log_ne_fname) call openfile(filename, io_log_ne, ierr) if (ierr /= 0) return do i=1,num_log_ne @@ -147,8 +147,8 @@ subroutine load_table_summary( & end if end do close(io_log_ne) - - filename = trim(mesa_data_dir) // '/ionization_data/' // trim(logT_fname) + + filename = trim(mesa_data_dir) // '/ionization_data/' // trim(logT_fname) call openfile(filename, io_logT, ierr) if (ierr /= 0) return do i=1,num_logT @@ -159,13 +159,13 @@ subroutine load_table_summary( & end if end do close(io_logT) - + end subroutine load_table_summary end subroutine do_load - + subroutine create_interpolants(p,nx,ny,ierr) use interp_2d_lib_db type (Ionization_Info), pointer :: p @@ -200,25 +200,25 @@ real(dp) function charge_of_Fe56_in_He4(log_ne, logT, ierr) integer :: ict(6) ! code specifying output desired real(dp) :: fval(6) ! output data type (Ionization_Info), pointer :: p - + ierr = 0 charge_of_Fe56_in_He4 = 0 - + if (.not. table_is_initialized) then !$omp critical (ionization_table) if (.not. table_is_initialized) call do_load(ierr) !$omp end critical (ionization_table) if (ierr /= 0) return endif - + ict = 0; ict(1) = 1 ! just the result; no partials p => fe_he_ptr call interp_evbicub_db( & log_ne, logT, p% log_ne, p% num_log_ne, p% logT, p% num_logT, & p% ilinx, p% iliny, p% f1, p% num_log_ne, ict, fval, ierr) - + charge_of_Fe56_in_He4 = fval(1) - + end function charge_of_Fe56_in_He4 subroutine chi_info(a1, z1, T, log_T, rho, log_rho, chi, c0, c1, c2) @@ -231,13 +231,13 @@ subroutine chi_info(a1, z1, T, log_T, rho, log_rho, chi, c0, c1, c2) c2 = 29.38d0*z1*pow(rho/a1,one_third) ! c2 had a typo in eqn 21, now corrected to match Dupuis et al. (1992) eqn 3 end subroutine chi_info - + real(dp) function chi_effective(chi, c0, c1, c2, z1, z2) real(dp), intent(in) :: chi, c0, c1, c2, z1, z2 chi_effective = chi + c0/(z2*z2*z2) + & min(c1*z2, c2*(pow(z2/z1,two_thirds) + 0.6d0)) end function chi_effective - + end module mod_ionization diff --git a/ionization/public/ionization_def.f90 b/ionization/public/ionization_def.f90 index a073fe109..266d4c89d 100644 --- a/ionization/public/ionization_def.f90 +++ b/ionization/public/ionization_def.f90 @@ -25,11 +25,11 @@ ! *********************************************************************** module ionization_def - + use const_def, only: dp, use_mesa_temp_cache - + implicit none - + ! ionization results integer, parameter :: ion_ilogPgas = 1 ! log10 Pgas @@ -65,20 +65,20 @@ module ionization_def integer, parameter :: ion_ifneut_Fe = ion_ifneut_Si + 1 integer, parameter :: num_ion_vals = ion_ifneut_Fe - + character (len=20) :: ion_result_names(num_ion_vals) - + ! based on scheme for eos tables - + integer, parameter :: num_ion_Zs = 5 real(dp), parameter :: ion_Zs(num_ion_Zs) = (/ 0.00d0, 0.02d0, 0.04d0, 0.20d0, 1.00d0 /) integer, parameter :: num_ion_Xs_for_Z(num_ion_Zs) = (/ 6, 5, 5, 5, 1 /) - + integer, parameter :: num_ion_Xs = 6 real(dp), parameter :: ion_Xs(num_ion_Xs) = & (/ 0.0d0, 0.2d0, 0.4d0, 0.6d0, 0.8d0, 1.0d0 /) @@ -103,7 +103,7 @@ module ionization_def character(len=32) :: ion_file_prefix, ion_Z1_suffix character(len=1000) :: ionization_cache_dir, ionization_temp_cache_dir - + logical :: use_cache_for_ion = .true. logical :: ion_root_is_initialized = .false. logical :: ion_is_initialized = .false. @@ -112,7 +112,7 @@ module ionization_def integer, parameter :: table_version = 1 - + type Ionization_Info integer :: num_log_ne, num_logT real(dp), pointer :: log_ne(:), logT(:) @@ -120,8 +120,8 @@ module ionization_def logical :: have_interpolation_info integer :: ilinx, iliny end type Ionization_Info - - + + type (Ionization_Info), target :: fe_he_info type (Ionization_Info), pointer :: fe_he_ptr @@ -135,12 +135,12 @@ module ionization_def contains - + subroutine ion_def_init(ionization_cache_dir_in) use const_def, only: mesa_data_dir, mesa_caches_dir, mesa_temp_caches_dir use utils_lib, only : mkdir character (len=*), intent(in) :: ionization_cache_dir_in - + ion_is_initialized = .false. use_cache_for_ion = .true. @@ -152,7 +152,7 @@ subroutine ion_def_init(ionization_cache_dir_in) ionization_cache_dir = trim(mesa_data_dir) // '/ionization_data/cache' end if call mkdir(ionization_cache_dir) - + ionization_temp_cache_dir = trim(mesa_temp_caches_dir)//'/ionization_cache' if(use_mesa_temp_cache) call mkdir(ionization_temp_cache_dir) @@ -190,4 +190,4 @@ end subroutine ion_def_init end module ionization_def - + diff --git a/ionization/public/ionization_lib.f90 b/ionization/public/ionization_lib.f90 index 19f91d67c..a424c3989 100644 --- a/ionization/public/ionization_lib.f90 +++ b/ionization/public/ionization_lib.f90 @@ -24,9 +24,9 @@ ! *********************************************************************** module ionization_lib - + use const_def, only: dp - + implicit none @@ -34,7 +34,7 @@ module ionization_lib subroutine ionization_init( & - file_prefix, Z1_suffix, ionization_cache_dir, use_cache, ierr) + file_prefix, Z1_suffix, ionization_cache_dir, use_cache, ierr) use ionization_def, only: ion_def_init use ion_tables_load, only: Init_ion_tables use mod_ionization, only: do_init_ionization @@ -46,7 +46,7 @@ subroutine ionization_init( & call ion_def_init(ionization_cache_dir) call Init_ion_tables(file_prefix, Z1_suffix, use_cache, ierr) if (ierr /= 0) return - call do_init_ionization(ionization_cache_dir, use_cache, ierr) + call do_init_ionization(ionization_cache_dir, use_cache, ierr) end subroutine ionization_init ! EXPERIMENTAL @@ -58,16 +58,16 @@ subroutine eval_ionization(Z, X, Rho, log10Rho, T, log10T, res, ierr) real(dp), intent(in) :: Z ! metals mass fraction real(dp), intent(in) :: X ! hydrogen mass fraction real(dp), intent(in) :: Rho, log10Rho ! the density - ! provide both if you have them. + ! provide both if you have them. ! else pass one and set the other to = arg_not_provided real(dp), intent(in) :: T, log10T ! the temperature - ! provide both if you have them. - ! else pass one and set the other to = arg_not_provided + ! provide both if you have them. + ! else pass one and set the other to = arg_not_provided real(dp), intent(inout) :: res(num_ion_vals) ! see ionization_def integer, intent(out) :: ierr call Get_ion_Results(Z, X, Rho, log10Rho, T, log10T, res, ierr) end subroutine eval_ionization - + ! EXPERIMENTAL real(dp) function eval_charge_of_Fe56_in_He4(log10_ne, log10_T, ierr) use mod_ionization, only: charge_of_Fe56_in_He4 @@ -87,12 +87,12 @@ subroutine create_ion_table_files( & !call do_create_ion_table_files( & ! in_dir, out_dir_ion, out_dir_eosDT, out_dir_eosPT) end subroutine create_ion_table_files - - + + subroutine create_table_plot_files use ion_table_plot, only: do_create_table_plot_files call do_create_table_plot_files end subroutine create_table_plot_files - + end module ionization_lib diff --git a/kap/other/other_radiative_opacity.f90 b/kap/other/other_radiative_opacity.f90 index 6c7cc0684..41c38e044 100644 --- a/kap/other/other_radiative_opacity.f90 +++ b/kap/other/other_radiative_opacity.f90 @@ -60,7 +60,7 @@ subroutine null_other_radiative_opacity( & ierr = -1 ! can first call kap_lib routine to get standard results, if desired - + ! call kap_get_radiative_opacity( & ! handle, & ! X, Z, XC, XN, XO, XNe, logRho, logT, & diff --git a/kap/plotter/src/kap_plotter.f90 b/kap/plotter/src/kap_plotter.f90 index 0acad7bcb..0126d7d9b 100644 --- a/kap/plotter/src/kap_plotter.f90 +++ b/kap/plotter/src/kap_plotter.f90 @@ -312,7 +312,7 @@ program kap_plotter call set_nan(dlnkap_dlnRho) call set_nan(dlnkap_dlnT) call set_nan(dlnkap_dxa) - + call kap_get( & kap_handle, species, chem_id, net_iso, xa, log10Rho, log10T, & res(i_lnfree_e), d_dlnd(i_lnfree_e), d_dlnT(i_lnfree_e), & @@ -500,7 +500,7 @@ real(dp) function dfridr_func(delta_x) result(val) lnd = log10Rho*ln10 ! must call eos to get new lnfree_e info - + if (doing_d_dlnd) then log_var = (lnd + delta_x)/ln10 var = exp10(log_var) diff --git a/kap/private/condint.f90 b/kap/private/condint.f90 index c85a36a6b..a3df6d8ef 100644 --- a/kap/private/condint.f90 +++ b/kap/private/condint.f90 @@ -25,32 +25,32 @@ module condint - + use const_def, only: dp use math_lib use utils_lib, only: mesa_error - + implicit none integer, parameter :: num_logTs=29, num_logRhos=71, num_logzs=15 !!! NB: These parameters must be consistent with the table "condtabl.d"! logical :: initialized = .false. - + real(dp) :: logTs(num_logTs), logRhos(num_logRhos), logzs(num_logzs) real(dp), target :: f_ary(4*num_logRhos*num_logTs*num_logzs) ! for bicubic splines real(dp), pointer :: f(:,:,:,:) integer :: ilinx(num_logzs), iliny(num_logzs) - - + + contains - - + + subroutine init_potekhin(ierr) use kap_def, only: kap_dir use interp_2d_lib_db, only: interp_mkbicub_db integer, intent(out) :: ierr - + character (len=256) :: filename integer :: read_err, iz, it, ir, shift integer :: ibcxmin ! bc flag for x=xmin @@ -63,15 +63,15 @@ subroutine init_potekhin(ierr) real(dp) :: bcymax(num_logRhos) ! bc data vs. x at y=ymax real(dp) :: Z real(dp), pointer :: f1(:) - + include 'formats' - + ierr = 0 if (initialized) return - + shift = 4*num_logRhos*num_logTs f(1:4,1:num_logRhos,1:num_logTs,1:num_logzs) => f_ary(1:shift*num_logzs) - + filename = trim(kap_dir) // '/condtabl.data' open(1,file=trim(filename),status='OLD',iostat=ierr) if (ierr /= 0) then @@ -123,7 +123,7 @@ subroutine init_potekhin(ierr) ibcymin = 3; bcymin(1:num_logRhos) = 0d0 ibcymax = 3; bcymax(1:num_logRhos) = 0d0 do iz = 1, num_logzs - f1(1:shift) => f_ary(1+(iz-1)*shift:iz*shift) + f1(1:shift) => f_ary(1+(iz-1)*shift:iz*shift) call interp_mkbicub_db( & logRhos, num_logRhos, logTs, num_logTs, f1, num_logRhos, & ibcxmin, bcxmin, ibcxmax, bcxmax, & @@ -143,8 +143,8 @@ subroutine init_potekhin(ierr) end do initialized = .true. end subroutine init_potekhin - - + + subroutine do_electron_conduction_potekhin( & zbar, logRho_in, logT_in, kap, dlogkap_dlogRho, dlogkap_dlogT, ierr) @@ -152,7 +152,7 @@ subroutine do_electron_conduction_potekhin( & real(dp), intent(in) :: zbar, logRho_in, logT_in real(dp), intent(out) :: kap, dlogkap_dlogRho, dlogkap_dlogT integer, intent(out) :: ierr - + integer :: iz, iz1, iz2, shift real(dp) :: zlog, logRho, logT real(dp) :: alfa, beta, & @@ -164,7 +164,7 @@ subroutine do_electron_conduction_potekhin( & logical :: clipped_logRho, clipped_logT include 'formats' - + ierr = 0 shift = 4*num_logRhos*num_logTs @@ -191,7 +191,7 @@ subroutine do_electron_conduction_potekhin( & end if zlog = max(logzs(1),min(logzs(num_logzs),log10(max(1d-30,zbar)))) - + if (zlog <= logzs(1)) then ! use 1st call get1(1, logK, dlogK_dlogRho, dlogK_dlogT, ierr) else if (zlog >= logzs(num_logzs)) then ! use last @@ -212,19 +212,19 @@ subroutine do_electron_conduction_potekhin( & write(*,*) 'confusion in do_electron_conduction' call mesa_error(__FILE__,__LINE__) end if - + call get1(iz1, logK1, dlogK1_dlogRho, dlogK1_dlogT, ierr) if (ierr /= 0) then write(*,*) 'interp failed for iz1 in do_electron_conduction', iz1, logRho, logT call mesa_error(__FILE__,__LINE__) end if - + call get1(iz2, logK2, dlogK2_dlogRho, dlogK2_dlogT, ierr) if (ierr /= 0) then write(*,*) 'interp failed for iz2 in do_electron_conduction', iz2, logRho, logT call mesa_error(__FILE__,__LINE__) end if - + ! linear interpolation in zlog alfa = (zlog - logzs(iz1)) / (logzs(iz2) - logzs(iz1)) beta = 1d0-alfa @@ -246,14 +246,14 @@ subroutine do_electron_conduction_potekhin( & ! logkap = 3*logT - logRho - logK + log10(16*boltz_sigma/3) logkap = 3d0*logT_in - logRho_in - logK + log10(16d0 * boltz_sigma / 3d0) - + kap = exp10(logkap) dlogkap_dlogRho = -1d0 - dlogK_dlogRho dlogkap_dlogT = 3d0 - dlogK_dlogT contains - - + + subroutine get1(iz, logK, dlogK_dlogRho, dlogK_dlogT, ierr) use kap_eval_support, only: Do_Kap_Interpolations integer, intent(in) :: iz @@ -265,8 +265,8 @@ subroutine get1(iz, logK, dlogK_dlogRho, dlogK_dlogT, ierr) integer :: i_logRho, j_logT, k include 'formats' ierr = 0 - f1(1:shift) => f_ary(1+(iz-1)*shift:iz*shift) - + f1(1:shift) => f_ary(1+(iz-1)*shift:iz*shift) + if (logRho < logRhos(2)) then i_logRho = 1 else @@ -279,7 +279,7 @@ subroutine get1(iz, logK, dlogK_dlogRho, dlogK_dlogT, ierr) end if logRho0 = logRhos(i_logRho) logRho1 = logRhos(i_logRho+1) - + if (logT < logTs(2)) then j_logT = 1 else @@ -291,13 +291,13 @@ subroutine get1(iz, logK, dlogK_dlogRho, dlogK_dlogT, ierr) end do end if logT0 = logTs(j_logT) - logT1 = logTs(j_logT+1) - + logT1 = logTs(j_logT+1) + call Do_Kap_Interpolations( & f1, num_logRhos, num_logTs, i_logRho, j_logT, logRho0, & logRho, logRho1, logT0, logT, logT1, logK, dlogK_dlogRho, dlogK_dlogT) if (ierr /= 0) return - + end subroutine get1 diff --git a/kap/private/kap_aesopus.f90 b/kap/private/kap_aesopus.f90 index f1f81dea1..9f4ce52a9 100644 --- a/kap/private/kap_aesopus.f90 +++ b/kap/private/kap_aesopus.f90 @@ -87,7 +87,7 @@ subroutine read_kap_aesopus_tables(rq, ierr) character(len=30), parameter :: ffmt = '(A14, 99F8.3)' character(len=30), parameter :: ifmt = '(A14, I4)' - logical :: file_exists + logical :: file_exists ! get the filename filename = trim(aesopus_filename) @@ -116,7 +116,7 @@ subroutine read_kap_aesopus_tables(rq, ierr) ! open file (read-only) hi = hdf5io_t(filename, OPEN_FILE_RO) - + if (rq% show_info) write(*,*) 'AESOPUS composition parameters' ! read composition parameters @@ -175,7 +175,7 @@ subroutine read_kap_aesopus_tables(rq, ierr) call hi% alloc_read_dset('Zs', kA% Zs) kA% num_Zs = SIZE(kA% Zs) if (rq% show_info) write(*,ifmt) "num Zs =", kA% num_Zs - + if (debug) write(*,*) 'Zs', kA% Zs if (rq% show_info) then @@ -201,7 +201,7 @@ subroutine read_kap_aesopus_tables(rq, ierr) ! get group name and open group write(group_name, 100) kA% Zs(n) -100 format(F8.6) +100 format(F8.6) if (rq% show_info) then write(*,'(A)') diff --git a/kap/private/kap_ctrls_io.f90 b/kap/private/kap_ctrls_io.f90 index 22fa0fdd5..bae022e5c 100644 --- a/kap/private/kap_ctrls_io.f90 +++ b/kap/private/kap_ctrls_io.f90 @@ -88,7 +88,7 @@ module kap_ctrls_io logical, dimension(max_extra_inlists) :: read_extra_kap_inlist character (len=strlen), dimension(max_extra_inlists) :: extra_kap_inlist_name - + ! User supplied inputs real(dp) :: kap_ctrl(10) integer :: kap_integer_ctrl(10) @@ -97,7 +97,7 @@ module kap_ctrls_io namelist /kap/ & - Zbase, & + Zbase, & kap_file_prefix, kap_CO_prefix, kap_lowT_prefix, aesopus_filename, & @@ -215,7 +215,7 @@ recursive subroutine read_controls_file(rq, filename, level, ierr) read_extra_kap_inlist(i) = .false. extra(i) = extra_kap_inlist_name(i) extra_kap_inlist_name(i) = 'undefined' - + if (read_extra(i)) then call read_controls_file(rq, extra(i), level+1, ierr) if (ierr /= 0) return @@ -486,7 +486,7 @@ subroutine get_kap_controls(rq, name, val, ierr) upper_name = trim(StrUpCase(name))//'=' val = '' ! Search for name inside namelist - do + do read(iounit,'(A)',iostat=iostat) str ind = index(trim(str),trim(upper_name)) if( ind /= 0 ) then @@ -497,7 +497,7 @@ subroutine get_kap_controls(rq, name, val, ierr) exit end if if(is_iostat_end(iostat)) exit - end do + end do if(len_trim(val) == 0 .and. ind==0 ) ierr = -1 diff --git a/kap/private/kap_eval_co.f90 b/kap/private/kap_eval_co.f90 index 0fec331e7..cd0d710f5 100644 --- a/kap/private/kap_eval_co.f90 +++ b/kap/private/kap_eval_co.f90 @@ -28,9 +28,9 @@ module kap_eval_co use kap_eval_support use const_def, only: dp use math_lib - + implicit none - + contains @@ -39,7 +39,7 @@ subroutine Get1_kap_CO_Results( & logKap, dlnkap_dlnRho, dlnkap_dlnT, ierr) use kap_def use const_def - + ! INPUT type (Kap_General_Info), pointer :: rq real(dp), intent(in) :: Zbase, X, dXC, dXO @@ -49,19 +49,19 @@ subroutine Get1_kap_CO_Results( & ! OUTPUT real(dp), intent(out) :: logKap, dlnkap_dlnRho, dlnkap_dlnT integer, intent(out) :: ierr ! 0 means AOK. - + integer :: iz, use_iz, num_Zs, CO_option real(dp) :: Z0, Z1,log10_Zbase, log10_Z0, log10_Z1 real(dp) :: alfa, beta real(dp) :: logK0, dlogK0_dlogRho, dlogK0_dlogT, logK1, dlogK1_dlogRho, dlogK1_dlogT character (len=256) :: message - + logical, parameter :: use_closest_Z = .false. logical, parameter :: dbg = .false. - + include 'formats' - + CO_option = rq% kap_CO_option num_Zs = num_kap_CO_Zs(CO_option) @@ -70,8 +70,8 @@ subroutine Get1_kap_CO_Results( & ierr = -3 return end if - end if - + end if + if (num_Zs == 1 .or. & Zbase >= kap_co_z_tables(CO_option)% ar(num_Zs)% Zbase) then ! use the largest Zbase if (dbg) write(*,*) 'use the largest Zbase', & @@ -81,7 +81,7 @@ subroutine Get1_kap_CO_Results( & logKap, dlnkap_dlnRho, dlnkap_dlnT, ierr) return end if - + if (Zbase <= kap_co_z_tables(CO_option)% ar(1)% Zbase) then ! use the smallest Zbase if (dbg) then write(*,*) 'use the smallest Zbase' @@ -97,10 +97,10 @@ subroutine Get1_kap_CO_Results( & do iz = 1, num_Zs-1 if (Zbase < kap_co_z_tables(CO_option)% ar(iz+1)% Zbase) exit end do - + Z0 = kap_co_z_tables(CO_option)% ar(iz)% Zbase Z1 = kap_co_z_tables(CO_option)% ar(iz+1)% Zbase - + if (Zbase <= Z0) then ! use the Z0 table if (dbg) write(*,*) 'use the Z0 table', Z0 call Get_Kap_for_CO_X( & @@ -108,7 +108,7 @@ subroutine Get1_kap_CO_Results( & logKap, dlnkap_dlnRho, dlnkap_dlnT, ierr) return end if - + if (Zbase >= Z1) then ! use the Z1 table if (dbg) write(*,*) 'use the Z1 table', Z1 call Get_Kap_for_CO_X( & @@ -116,7 +116,7 @@ subroutine Get1_kap_CO_Results( & logKap, dlnkap_dlnRho, dlnkap_dlnT, ierr) return end if - + if (use_closest_Z) then log10_Z0 = kap_co_z_tables(CO_option)% ar(iz)% log10_Zbase log10_Z1 = kap_co_z_tables(CO_option)% ar(iz+1)% log10_Zbase @@ -132,7 +132,7 @@ subroutine Get1_kap_CO_Results( & logKap, dlnkap_dlnRho, dlnkap_dlnT, ierr) return end if - + if (dbg) then write(*,*) 'iz', iz write(*,*) ' Z0', Z0 @@ -140,7 +140,7 @@ subroutine Get1_kap_CO_Results( & write(*,*) ' Z1', Z1 write(*,'(A)') end if - + if (num_Zs >= 4 .and. rq% cubic_interpolation_in_Z) then if (dbg) write(*,*) 'call Get_Kap_for_CO_Z_cubic' call Get_Kap_for_CO_Z_cubic(rq, iz, Zbase, X, dXC, dXO, logRho, logT, & @@ -160,8 +160,8 @@ subroutine Get1_kap_CO_Results( & end if end subroutine Get1_kap_CO_Results - - + + ! use tables iz-1 to iz+2 to do piecewise monotonic cubic interpolation in Z subroutine Get_Kap_for_CO_Z_cubic(rq, iz, Z, X, dXC, dXO, logRho, logT, & logK, dlnkap_dlnRho, dlnkap_dlnT, ierr) @@ -176,7 +176,7 @@ subroutine Get_Kap_for_CO_Z_cubic(rq, iz, Z, X, dXC, dXO, logRho, logT, & real(dp), intent(inout) :: logRho, logT real(dp), intent(out) :: logK, dlnkap_dlnRho, dlnkap_dlnT integer, intent(out) :: ierr - + integer, parameter :: n_old = 4, n_new = 1 real(dp), dimension(n_old) :: logKs, dlogKs_dlogRho, dlogKs_dlogT type(auto_diff_real_2var_order1), dimension(n_old) :: logKs_ad @@ -185,16 +185,16 @@ subroutine Get_Kap_for_CO_Z_cubic(rq, iz, Z, X, dXC, dXO, logRho, logT, & type(auto_diff_real_2var_order1), target :: work_ary(n_old*pm_work_size) type(auto_diff_real_2var_order1), pointer :: work(:) integer :: i, i1, izz, num_Zs, CO_option - + logical, parameter :: dbg = .false. - + 11 format(a40,e20.10) - + ierr = 0 work => work_ary CO_option = rq% kap_CO_option num_Zs = num_kap_CO_Zs(CO_option) - + if (iz+2 > num_Zs) then i1 = num_Zs-2 else if (iz == 1) then @@ -202,7 +202,7 @@ subroutine Get_Kap_for_CO_Z_cubic(rq, iz, Z, X, dXC, dXO, logRho, logT, & else i1 = iz end if - + if (dbg) then write(*,*) 'n_old', n_old write(*,*) 'i1', i1 @@ -210,7 +210,7 @@ subroutine Get_Kap_for_CO_Z_cubic(rq, iz, Z, X, dXC, dXO, logRho, logT, & write(*,*) 'Z', Z write(*,'(A)') end if - + do i=1,n_old izz = i1-2+i z_old(i) %val= kap_co_z_tables(CO_option)% ar(izz)% Zbase @@ -248,14 +248,14 @@ subroutine Get_Kap_for_CO_Z_cubic(rq, iz, Z, X, dXC, dXO, logRho, logT, & dlnkap_dlnRho = logK_ad % d1val2 if (dbg) then - + do i=1,n_old write(*,*) 'z_old(i)', z_old(i) end do write(*,'(A)') write(*,*) 'z_new(1)', z_new(1) write(*,'(A)') - + do i=1,n_old write(*,*) 'logK', i, logKs(i) end do @@ -269,18 +269,18 @@ subroutine Get_Kap_for_CO_Z_cubic(rq, iz, Z, X, dXC, dXO, logRho, logT, & write(*,'(A)') write(*,*) 'dlnkap_dlnRho', dlnkap_dlnRho write(*,'(A)') - + do i=1,n_old write(*,*) 'dlogKs_dlogT', i, dlogKs_dlogT(i) end do write(*,'(A)') write(*,*) 'dlnkap_dlnT', dlnkap_dlnT write(*,'(A)') - + end if - + contains - + subroutine interp1(old, new, ierr) type(auto_diff_real_2var_order1), intent(in) :: old(n_old) type(auto_diff_real_2var_order1), intent(out) :: new @@ -295,10 +295,10 @@ subroutine interp1(old, new, ierr) 'Get_Kap_for_CO_Z_cubic', ierr) new = v_new(1) end subroutine interp1 - + end subroutine Get_Kap_for_CO_Z_cubic - - + + subroutine Get_Kap_for_CO_Z_linear( & rq, iz, Z, Z0, Z1, X, dXC, dXO, logRho, logT, & logKap, dlnkap_dlnRho, dlnkap_dlnT, ierr) @@ -312,7 +312,7 @@ subroutine Get_Kap_for_CO_Z_linear( & real(dp) :: logK0, dlogK0_dlogRho, dlogK0_dlogT, logK1, dlogK1_dlogRho, dlogK1_dlogT real(dp) :: alfa, beta - + logical, parameter :: dbg = .false. ierr = 0 @@ -322,7 +322,7 @@ subroutine Get_Kap_for_CO_Z_linear( & logK0, dlogK0_dlogRho, dlogK0_dlogT, ierr) if (ierr /= 0) return if (dbg) write(*,*) 'logK0', logK0 - + call Get_Kap_for_CO_X( & rq, dXC, dXO, iz+1, X, logRho, logT, & logK1, dlogK1_dlogRho, dlogK1_dlogT, ierr) @@ -337,8 +337,8 @@ subroutine Get_Kap_for_CO_Z_linear( & dlnkap_dlnT = beta*dlogK0_dlogT + alfa*dlogK1_dlogT end subroutine Get_Kap_for_CO_Z_linear - - + + subroutine Get_Kap_for_CO_X(rq, dXC, dXO, iz, X, logRho, logT, & logK, dlogK_dlogRho, dlogK_dlogT, ierr) use kap_def @@ -349,24 +349,24 @@ subroutine Get_Kap_for_CO_X(rq, dXC, dXO, iz, X, logRho, logT, & real(dp), intent(inout) :: logRho, logT real(dp), intent(out) :: logK, dlogK_dlogRho, dlogK_dlogT integer, intent(out) :: ierr - + type (Kap_CO_X_Table), dimension(:), pointer :: x_tables real(dp) :: logK0, dlogK0_dlogRho, dlogK0_dlogT, logK1, dlogK1_dlogRho, dlogK1_dlogT real(dp) :: X0, X1 real(dp) :: alfa, beta integer :: ix, i, num_Xs, CO_option - + logical, parameter :: dbg = .false. CO_option = rq% kap_CO_option num_Xs = num_kap_CO_Xs(CO_option) x_tables => kap_co_z_tables(CO_option)% ar(iz)% x_tables - + if (X < 0 .or. X > 1) then ierr = -3 return end if - + if (num_Xs > 1) then if (x_tables(1)% X >= x_tables(2)% X) then ierr = -3 @@ -379,9 +379,9 @@ subroutine Get_Kap_for_CO_X(rq, dXC, dXO, iz, X, logRho, logT, & call Get_Kap_for_dXCO( & rq, iz, x_tables, dXC, dXO, num_Xs, & logRho, logT, logK, dlogK_dlogRho, dlogK_dlogT, ierr) - return + return end if - + if (X <= x_tables(1)% X) then ! use the first X if (dbg) write(*,*) 'use the first X' call Get_Kap_for_dXCO( & @@ -398,36 +398,36 @@ subroutine Get_Kap_for_CO_X(rq, dXC, dXO, iz, X, logRho, logT, & ix = i; exit end if end do - + if (ix == num_Xs) then call Get_Kap_for_dXCO( & rq, iz, x_tables, dXC, dXO, num_Xs, & logRho, logT, logK, dlogK_dlogRho, dlogK_dlogT, ierr) return end if - + X0 = x_tables(ix)% X X1 = x_tables(ix+1)% X - + if (X1 <= X0) then ierr = 1 return end if - + if (X0 >= X) then ! use the X0 table call Get_Kap_for_dXCO( & rq, iz, x_tables, dXC, dXO, ix, & logRho, logT, logK, dlogK_dlogRho, dlogK_dlogT, ierr) return end if - + if (X1 <= X) then ! use the X1 table call Get_Kap_for_dXCO( & rq, iz, x_tables, dXC, dXO, ix+1, & logRho, logT, logK, dlogK_dlogRho, dlogK_dlogT, ierr) return end if - + if (num_Xs >= 4 .and. rq% cubic_interpolation_in_X) then call Get_Kap_for_CO_X_cubic( & rq, iz, ix, dXC, dXO, x_tables, X, logRho, logT, & @@ -437,10 +437,10 @@ subroutine Get_Kap_for_CO_X(rq, dXC, dXO, iz, X, logRho, logT, & rq, iz, ix, dXC, dXO, x_tables, X, X0, X1, logRho, logT, & logK, dlogK_dlogRho, dlogK_dlogT, ierr) end if - + end subroutine Get_Kap_for_CO_X - - + + ! use tables ix-1 to ix+2 to do piecewise monotonic cubic interpolation in X subroutine Get_Kap_for_CO_X_cubic( & rq, iz, ix, dXC, dXO, x_tables, X, logRho, logT, & @@ -458,7 +458,7 @@ subroutine Get_Kap_for_CO_X_cubic( & real(dp), intent(inout) :: logRho, logT real(dp), intent(out) :: logK, dlogK_dlogRho, dlogK_dlogT integer, intent(out) :: ierr - + integer, parameter :: n_old = 4, n_new = 1 real(dp), dimension(n_old) :: logKs, dlogKs_dlogRho, dlogKs_dlogT type(auto_diff_real_2var_order1), dimension(n_old) :: logKs_ad @@ -467,16 +467,16 @@ subroutine Get_Kap_for_CO_X_cubic( & type(auto_diff_real_2var_order1), target :: work_ary(n_old*pm_work_size) type(auto_diff_real_2var_order1), pointer :: work(:) integer :: i, i1, ixx, num_Xs - + logical, parameter :: dbg = .false. - + 11 format(a40,e20.10) - + ierr = 0 work => work_ary num_Xs = num_kap_CO_Xs(rq% kap_CO_option) - + if (ix+2 > num_Xs) then i1 = num_Xs-2 else if (ix == 1) then @@ -484,9 +484,9 @@ subroutine Get_Kap_for_CO_X_cubic( & else i1 = ix end if - + if (dbg) write(*,*) 'ix', ix - + do i=1,n_old ixx = i1-2+i if (dbg) write(*,*) 'ixx', ixx @@ -515,20 +515,20 @@ subroutine Get_Kap_for_CO_X_cubic( & call mesa_error(__FILE__,__LINE__,'failed in interp1 for logK') return end if - + ! unpack auto_diff pack into output reals logK = logK_ad % val dlogK_dlogT = logK_ad % d1val1 dlogK_dlogRho = logK_ad % d1val2 if (dbg) then - + do i=1,n_old write(*,*) 'x_old(i)', x_old(i) end do write(*,*) 'x_new(1)', x_new(1) write(*,'(A)') - + do i=1,n_old write(*,*) 'logKs(i)', logKs(i) end do @@ -540,17 +540,17 @@ subroutine Get_Kap_for_CO_X_cubic( & end do write(*,*) 'dlogK_dlogRho', dlogK_dlogRho write(*,'(A)') - + do i=1,n_old write(*,*) 'dlogKs_dlogT(i)', dlogKs_dlogT(i) end do write(*,*) 'dlogK_dlogT', dlogK_dlogT write(*,'(A)') - + end if - + contains - + subroutine interp1(old, new, ierr) type(auto_diff_real_2var_order1), intent(in) :: old(n_old) type(auto_diff_real_2var_order1), intent(out) :: new @@ -565,10 +565,10 @@ subroutine interp1(old, new, ierr) 'Get_Kap_for_CO_X_cubic', ierr) new = v_new(1) end subroutine interp1 - + end subroutine Get_Kap_for_CO_X_cubic - - + + subroutine Get_Kap_for_CO_X_linear( & rq, iz, ix, dXC, dXO, x_tables, X, X0, X1, logRho, logT, & logK, dlogK_dlogRho, dlogK_dlogT, ierr) @@ -581,11 +581,11 @@ subroutine Get_Kap_for_CO_X_linear( & real(dp), intent(inout) :: logRho, logT real(dp), intent(out) :: logK, dlogK_dlogRho, dlogK_dlogT integer, intent(out) :: ierr - + real(dp) :: logK0, dlogK0_dlogRho, dlogK0_dlogT, logK1, dlogK1_dlogRho, dlogK1_dlogT real(dp) :: alfa, beta integer :: i - + logical, parameter :: dbg = .false. ierr = 0 @@ -593,20 +593,20 @@ subroutine Get_Kap_for_CO_X_linear( & rq, iz, x_tables, dXC, dXO, ix, & logRho, logT, logK0, dlogK0_dlogRho, dlogK0_dlogT, ierr) if (ierr /= 0) return - + call Get_Kap_for_dXCO( & rq, iz, x_tables, dXC, dXO, ix+1, & logRho, logT, logK1, dlogK1_dlogRho, dlogK1_dlogT, ierr) if (ierr /= 0) return - + ! X0 result in logK0, X1 result in logK1 beta = (X - X1) / (X0 - X1) ! beta -> 1 as X -> X0 alfa = 1d0 - beta - + logK = beta*logK0 + alfa*logK1 dlogK_dlogRho = beta*dlogK0_dlogRho + alfa*dlogK1_dlogRho - dlogK_dlogT = beta*dlogK0_dlogT + alfa*dlogK1_dlogT - + dlogK_dlogT = beta*dlogK0_dlogT + alfa*dlogK1_dlogT + end subroutine Get_Kap_for_CO_X_linear @@ -623,7 +623,7 @@ subroutine Get_Kap_for_dXCO( & real(dp), intent(inout) :: logRho, logT real(dp), intent(out) :: logK, dlogK_dlogRho, dlogK_dlogT integer, intent(out) :: ierr - + type (Kap_CO_Table), dimension(:), pointer :: co_tables ! stored by table number real(dp) :: dXC, dXO, fac, dXCO_max, Z, dXC_lookup, dXO_lookup integer :: num_CO_tables, num_dXC_gt_dXO, i1, i2, i3, i4 @@ -635,16 +635,16 @@ subroutine Get_Kap_for_dXCO( & real(dp) :: logK_2_4, dlogK_2_4_dlogRho, dlogK_2_4_dlogT real(dp) :: logK_1_3, dlogK_1_3_dlogRho, dlogK_1_3_dlogT logical, parameter :: read_later = .false., dbg = .false. - + include 'formats' ierr = 0 - + if (dbg) write(*,1) 'enter Get_Kap_for_dXCO dXC_in dXO_in', dXC_in, dXO_in - + dXC = max(0.0_dp, dXC_in) dXO = max(0.0_dp, dXO_in) - + if (x_tables(ix)% not_loaded_yet) then ! avoid doing critical section if possible !$omp critical (load_co_table) if (x_tables(ix)% not_loaded_yet) then @@ -653,11 +653,11 @@ subroutine Get_Kap_for_dXCO( & !$omp end critical (load_co_table) end if if (ierr /= 0) return - + co_tables => x_tables(ix)% co_tables num_CO_tables = x_tables(ix)% num_CO_tables if (dbg) write(*,2) 'num_CO_tables', num_CO_tables - + if (num_CO_tables < 1) then ierr = -1 write(*,2) 'num_CO_tables', num_CO_tables @@ -673,10 +673,10 @@ subroutine Get_Kap_for_dXCO( & dXC = fac*dXC dXO = fac*dXO end if - + dXC_lookup = get_dX_lookup(dXC, Z) dXO_lookup = get_dX_lookup(dXO, Z) - + if (dbg) write(*,2) 'call Find_CO_Tables', ix call Find_CO_Tables(rq, x_tables, ix, x_tables(ix)% CO_table_numbers, & x_tables(ix)% next_dXO_table, x_tables(ix)% next_dXC_table, & @@ -686,27 +686,27 @@ subroutine Get_Kap_for_dXCO( & write(*,*) 'kap failed in Find_CO_Tables' return endif - + if (i1 > 0 .and. i2 <= 0 .and. i3 <= 0 .and. i4 <= 0) then call Get_CO_Kap_for_logRho_logT(rq, x_tables, ix, co_tables, i1, logRho, logT, & logK, dlogK_dlogRho, dlogK_dlogT, ierr) return end if - + if (i1 <= 0 .or. i2 <= 0 .or. i3 <= 0) call mesa_error(__FILE__,__LINE__,'error in result from Find_CO_Tables') - + if (matches_table(i2)) then call Get_CO_Kap_for_logRho_logT(rq, x_tables, ix, co_tables, i2, logRho, logT, & logK, dlogK_dlogRho, dlogK_dlogT, ierr) return end if - + if (matches_table(i3)) then call Get_CO_Kap_for_logRho_logT(rq, x_tables, ix, co_tables, i3, logRho, logT, & logK, dlogK_dlogRho, dlogK_dlogT, ierr) return end if - + if (i4 > 0) then if (matches_table(i4)) then call Get_CO_Kap_for_logRho_logT(rq, x_tables, ix, co_tables, i4, logRho, logT, & @@ -714,25 +714,25 @@ subroutine Get_Kap_for_dXCO( & return end if end if - + call Get_CO_Kap_for_logRho_logT(rq, x_tables, ix, co_tables, i1, logRho, logT, & logK1, dlogK1_dlogRho, dlogK1_dlogT, ierr) if (ierr /= 0) return dXC1_lookup = co_tables(i1)% dXC_lookup dXO1_lookup = co_tables(i1)% dXO_lookup - + call Get_CO_Kap_for_logRho_logT(rq, x_tables, ix, co_tables, i2, logRho, logT, & logK2, dlogK2_dlogRho, dlogK2_dlogT, ierr) if (ierr /= 0) return dXC2_lookup = co_tables(i2)% dXC_lookup dXO2_lookup = co_tables(i2)% dXO_lookup - + call Get_CO_Kap_for_logRho_logT(rq, x_tables, ix, co_tables, i3, logRho, logT, & logK3, dlogK3_dlogRho, dlogK3_dlogT, ierr) if (ierr /= 0) return dXC3_lookup = co_tables(i3)% dXC_lookup dXO3_lookup = co_tables(i3)% dXO_lookup - + if (i4 > 0) then call Get_CO_Kap_for_logRho_logT(rq, x_tables, ix, co_tables, i4, logRho, logT, & logK4, dlogK4_dlogRho, dlogK4_dlogT, ierr) @@ -746,14 +746,14 @@ subroutine Get_Kap_for_dXCO( & dXC4_lookup = dXC3_lookup dXO4_lookup = dXO3_lookup end if - + if (dXC >= dXO) then ! use values on lines i1-i3 and i2-i4 at dXO - + call Get_Kap_at_dXO(dXO_lookup, & dXC2_lookup, dXO2_lookup, logK2, dlogK2_dlogRho, dlogK2_dlogT, & dXC4_lookup, dXO4_lookup, logK4, dlogK4_dlogRho, dlogK4_dlogT, & logK_2_4, dlogK_2_4_dlogRho, dlogK_2_4_dlogT, dXC_2_4_lookup) - + call Get_Kap_at_dXO(dXO_lookup, & dXC1_lookup, dXO1_lookup, logK1, dlogK1_dlogRho, dlogK1_dlogT, & dXC3_lookup, dXO3_lookup, logK3, dlogK3_dlogRho, dlogK3_dlogT, & @@ -763,9 +763,9 @@ subroutine Get_Kap_for_dXCO( & else alfa = (dXC_lookup - dXC_2_4_lookup) / (dXC_1_3_lookup - dXC_2_4_lookup) end if - + else ! use values on lines i1-i3 and i2-i4 at dXC - + call Get_Kap_at_dXC(dXC_lookup, & dXC2_lookup, dXO2_lookup, logK2, dlogK2_dlogRho, dlogK2_dlogT, & dXC4_lookup, dXO4_lookup, logK4, dlogK4_dlogRho, dlogK4_dlogT, & @@ -780,7 +780,7 @@ subroutine Get_Kap_for_dXCO( & else alfa = (dXO_lookup - dXO_2_4_lookup) / (dXO_1_3_lookup - dXO_2_4_lookup) end if - + end if beta = 1d0 - alfa @@ -788,7 +788,7 @@ subroutine Get_Kap_for_dXCO( & logK = alfa*logK_1_3 + beta*logK_2_4 dlogK_dlogRho = alfa*dlogK_1_3_dlogRho + beta*dlogK_2_4_dlogRho dlogK_dlogT = alfa*dlogK_1_3_dlogT + beta*dlogK_2_4_dlogT - + if (is_bad(logK)) then ierr = -1 return @@ -810,10 +810,10 @@ subroutine Get_Kap_for_dXCO( & write(*,1) 'dXO', dXO call mesa_error(__FILE__,__LINE__,'Get_Kap_for_dXCO') end if - - contains - - + + contains + + logical function matches_table(i) integer :: i if (i < 1 .or. i > num_CO_tables) then @@ -841,24 +841,24 @@ subroutine Get_Kap_at_dXO(dXO_lookup, & real(dp), intent(in) :: logK_b, dlogK_b_dlogRho, dlogK_b_dlogT real(dp), intent(out) :: logK_a_b, dlogK_a_b_dlogRho, dlogK_a_b_dlogT real(dp), intent(out) :: dXC_a_b_lookup - + real(dp) :: alfa, beta - + if (dXO_a_lookup == dXO_b_lookup) then alfa = 0d0 else alfa = (dXO_lookup - dXO_b_lookup) / (dXO_a_lookup - dXO_b_lookup) end if - + dXC_a_b_lookup = dXC_b_lookup + (dXC_a_lookup - dXC_b_lookup)*alfa beta = 1d0 - alfa logK_a_b = alfa*logK_a + beta*logK_b dlogK_a_b_dlogRho = alfa*dlogK_a_dlogRho + beta*dlogK_b_dlogRho dlogK_a_b_dlogT = alfa*dlogK_a_dlogT + beta*dlogK_b_dlogT - + end subroutine Get_Kap_at_dXO - - + + subroutine Get_Kap_at_dXC(dXC_lookup, & dXC_a_lookup, dXO_a_lookup, logK_a, dlogK_a_dlogRho, dlogK_a_dlogT, & dXC_b_lookup, dXO_b_lookup, logK_b, dlogK_b_dlogRho, dlogK_b_dlogT, & @@ -870,44 +870,44 @@ subroutine Get_Kap_at_dXC(dXC_lookup, & real(dp), intent(in) :: logK_b, dlogK_b_dlogRho, dlogK_b_dlogT real(dp), intent(out) :: logK_a_b, dlogK_a_b_dlogRho, dlogK_a_b_dlogT real(dp), intent(out) :: dXO_a_b_lookup - + real(dp) :: alfa, beta - + if (dXC_a_lookup == dXC_b_lookup) then alfa = 0d0 else alfa = (dXC_lookup - dXC_b_lookup) / (dXC_a_lookup - dXC_b_lookup) end if - + dXO_a_b_lookup = dXO_b_lookup + (dXO_a_lookup - dXO_b_lookup)*alfa beta = 1d0 - alfa - + logK_a_b = alfa*logK_a + beta*logK_b dlogK_a_b_dlogRho = alfa*dlogK_a_dlogRho + beta*dlogK_b_dlogRho dlogK_a_b_dlogT = alfa*dlogK_a_dlogT + beta*dlogK_b_dlogT - + end subroutine Get_Kap_at_dXC end subroutine Get_Kap_for_dXCO - + subroutine Find_CO_Tables( & rq, x_tables, ix, CO_table_numbers, next_dXO_table, next_dXC_table, & co_tables, num_CO_tables, num_dXC_gt_dXO, & dXCO_max, dXC, dXO, dXC_lookup, dXO_lookup, i1, i2, i3, i4, ierr) - - ! for linear interpolation to be smooth, + + ! for linear interpolation to be smooth, ! must use the smallest convex hull around the given point use kap_def use load_CO_kap - + type (Kap_General_Info), pointer :: rq type (Kap_CO_X_Table), dimension(:), pointer :: x_tables integer :: ix integer, intent(in) :: CO_table_numbers(num_kap_CO_dXs,num_kap_CO_dXs) - integer, intent(in) :: next_dXO_table(max_num_CO_tables) - integer, intent(in) :: next_dXC_table(max_num_CO_tables) + integer, intent(in) :: next_dXO_table(max_num_CO_tables) + integer, intent(in) :: next_dXC_table(max_num_CO_tables) type (Kap_CO_Table), dimension(:), pointer :: co_tables integer, intent(in) :: num_CO_tables, num_dXC_gt_dXO real(dp), intent(in) :: dXCO_max, dXC, dXO, dXC_lookup, dXO_lookup @@ -917,11 +917,11 @@ subroutine Find_CO_Tables( & real(dp) :: dXC2_lookup, dXO2_lookup, dXC4_lookup, dXO4_lookup integer :: idXC, idXO real(dp), parameter :: tiny = 1d-7 - + logical, parameter :: dbg = .false. - + include 'formats' - + if (dbg) write(*,*) 'enter Find_CO_Tables' if (dbg) write(*,*) 'associated(co_tables)', associated(co_tables) if (dbg) write(*,*) 'size(co_tables,dim=1)', size(co_tables,dim=1) @@ -929,19 +929,19 @@ subroutine Find_CO_Tables( & if (dbg) write(*,2) 'num_CO_tables', num_CO_tables ierr = 0 - + ! find idXC s.t. kap_CO_dXs(idXC-1) < dXC <= kap_CO_dXs(idXC) do idXC = 2, num_kap_CO_dXs if (kap_CO_dXs(idXC) >= dXC) exit end do if (dbg) write(*,2) 'idXC', idXC - + ! find idXO s.t. kap_CO_dXs(idXO-1) < dXO <= kap_CO_dXs(idXO) do idXO = 2, num_kap_CO_dXs if (kap_CO_dXs(idXO) >= dXO) exit end do if (dbg) write(*,2) 'idXO', idXO - + i1 = CO_table_numbers(idXC-1,idXO-1) if (dbg) write(*,2) 'i1', i1 if (matches_table(i1)) then @@ -949,7 +949,7 @@ subroutine Find_CO_Tables( & if (dbg) write(*,2) 'matches_table(i1)', i1 return end if - + if (dbg) write(*,*) '(dXC >= dXO)', (dXC >= dXO) if (dXC >= dXO) then i2 = CO_table_numbers(idXC,idXO-1) @@ -967,20 +967,20 @@ subroutine Find_CO_Tables( & if (i4 > 0) then if (i1 <= 0 .or. i2 <= 0 .or. i3 <= 0) then - + write(*,2) 'i1', i1 write(*,2) 'i2', i2 write(*,2) 'i3', i3 write(*,2) 'i4', i4 write(*,2) 'idXC', idXC write(*,2) 'idXO', idXO - + write(*,1) 'dXCO_max', dble(dXCO_max) write(*,1) 'dXC', dble(dXC) write(*,1) 'dXO', dble(dXO) write(*,1) 'dXC_lookup', dble(dXC_lookup) write(*,1) 'dXO_lookup', dble(dXO_lookup) - + call mesa_error(__FILE__,__LINE__,'logical failure1 in looking for CO tables') end if if (matches_table(i2)) then @@ -994,7 +994,7 @@ subroutine Find_CO_Tables( & end if return end if - + if (on_midline(i1)) then ! middle triangle if (dXC >= dXO) then i2 = next_dXC_table(i1) @@ -1005,11 +1005,11 @@ subroutine Find_CO_Tables( & end if return end if - + ! trapezoid or triangle near the diagonal boundary - + if (dXC >= dXO) then - + if (i3 <= 0) then if (on_diagonal(i1)) then i3 = num_CO_tables @@ -1020,7 +1020,7 @@ subroutine Find_CO_Tables( & i3 = num_dXC_gt_dXO end if end if - + if (.not. on_diagonal(i3)) then i4 = next_dXC_table(i3) if (.not. on_diagonal(i4)) then ! bail -- just use i1 @@ -1029,8 +1029,8 @@ subroutine Find_CO_Tables( & end if if (i2 <= 0) i2 = next_dXC_table(i1) if (on_diagonal(i2)) return - - + + dXC4_lookup = co_tables(i4)% dXC_lookup if (dXC_lookup <= dXC4_lookup) return ! check if on smaller dXC_lookup side of the line from i2 to i4 @@ -1045,11 +1045,11 @@ subroutine Find_CO_Tables( & i2 = -1; i3 = -1; i4 = -1; return end if i3 = i4; i4 = -1 - + else ! dXC < dXO - + ! reverse roles of dXC and dXO - + if (i3 <= 0) then ! must be in one of the triangles if (on_diagonal(i1)) then i3 = num_dXC_gt_dXO @@ -1082,13 +1082,13 @@ subroutine Find_CO_Tables( & i2 = -1; i3 = -1; i4 = -1; return end if i3 = num_CO_tables; i4 = -1 - + end if - - + + contains - - + + logical function matches_table(i) integer :: i include 'formats' @@ -1101,8 +1101,8 @@ logical function matches_table(i) end if if (dbg) write(*,*) 'matches_table', matches_table end function matches_table - - + + logical function on_midline(i) integer :: i if (abs(co_tables(i)% dXC - co_tables(i)% dXO) < tiny) then @@ -1111,8 +1111,8 @@ logical function on_midline(i) on_midline = .false. end if end function on_midline - - + + logical function on_diagonal(i) integer :: i if (abs((co_tables(i)% dXC + co_tables(i)% dXO) - dXCO_max) < tiny) then @@ -1121,11 +1121,11 @@ logical function on_diagonal(i) on_diagonal = .false. end if end function on_diagonal - + end subroutine Find_CO_Tables - + subroutine Get_CO_Kap_for_logRho_logT( & rq, x_tables, ix, co_tables, ico, & logRho, logT, logK, dlogK_dlogRho, dlogK_dlogT, ierr) @@ -1145,16 +1145,16 @@ subroutine Get_CO_Kap_for_logRho_logT( & logical :: clipped_logR logical, parameter :: dbg = .false. - + include 'formats' - + if (dbg) write(*,1) 'enter Get_CO_Kap_for_logRho_logT', logRho, logT - + ierr = 0 ! logR from inputs logR_in = logRho - 3d0*logT + 18d0 - + ! blends at higher levels MUST prevent ! these tables from being called off their ! high/low T and low R edges @@ -1174,7 +1174,7 @@ subroutine Get_CO_Kap_for_logRho_logT( & return end if - + ! off the high R edge, we use the input temperature ! but clip logR to the table edge value @@ -1231,7 +1231,7 @@ subroutine Get_CO_Kap_for_logRho_logT( & iR, jtemp, logR0, logR, logR1, logT0, logT, logT1, & logK, df_dx, df_dy) if (clipped_logR) df_dx = 0 - + if (dbg) write(*,1) 'Do_Kap_Interpolations: logK', logK ! convert df_dx and df_dy to dlogK_dlogRho, dlogK_dlogT @@ -1244,4 +1244,4 @@ end subroutine Get_CO_Kap_for_logRho_logT end module kap_eval_co - + diff --git a/kap/private/kap_eval_fixed.f90 b/kap/private/kap_eval_fixed.f90 index ea963eed8..d1c6e593e 100644 --- a/kap/private/kap_eval_fixed.f90 +++ b/kap/private/kap_eval_fixed.f90 @@ -29,18 +29,18 @@ module kap_eval_fixed use const_def, only: dp, ln10 use math_lib use utils_lib, only: mesa_error - + implicit none - + contains - - + + subroutine Get1_kap_fixed_metal_Results( & z_tables, num_Zs, rq, Z, X, Rho, logRho, T, logT, & logKap, dlnkap_dlnRho, dlnkap_dlnT, ierr) use kap_def use const_def - + ! INPUT type (Kap_Z_Table), dimension(:), pointer :: z_tables integer, intent(in) :: num_Zs @@ -52,7 +52,7 @@ subroutine Get1_kap_fixed_metal_Results( & ! OUTPUT real(dp), intent(out) :: logKap, dlnkap_dlnRho, dlnkap_dlnT integer, intent(out) :: ierr ! 0 means AOK. - + integer :: iz, i real(dp) :: Z0, Z1, alfa, beta, lnZ, lnZ0, lnZ1 real(dp) :: K0, logK0, dlogK0_dlogRho, dlogK0_dlogT @@ -61,9 +61,9 @@ subroutine Get1_kap_fixed_metal_Results( & character (len=256) :: message logical :: dbg - + include 'formats' - + dbg = .false. if (dbg) write(*,1) 'Get1_kap_fixed_metal_Results logT', logT @@ -71,14 +71,14 @@ subroutine Get1_kap_fixed_metal_Results( & logKap = 0d0 dlnkap_dlnRho = 0d0 dlnkap_dlnT = 0d0 - + if (num_Zs > 1) then if (z_tables(1)% Z >= z_tables(2)% Z) then ierr = -3 return end if - end if - + end if + if (num_Zs == 1 .or. Z >= z_tables(num_Zs)% Z) then ! use the largest Z call Get_Kap_for_X( & z_tables, rq, num_Zs, X, logRho, logT, & @@ -86,7 +86,7 @@ subroutine Get1_kap_fixed_metal_Results( & if (dbg) write(*,1) 'logKap logT', logKap, logT return end if - + if (Z <= z_tables(1)% Z) then ! use the smallest Z if (dbg) then write(*,*) 'use the smallest Z' @@ -98,7 +98,7 @@ subroutine Get1_kap_fixed_metal_Results( & logKap, dlnkap_dlnRho, dlnkap_dlnT, ierr) return end if - + if (dbg) then do iz = 1, num_Zs write(*,*) 'Z(iz)', iz, z_tables(iz)% Z @@ -108,21 +108,21 @@ subroutine Get1_kap_fixed_metal_Results( & do iz = 1, num_Zs-1 if (Z < z_tables(iz+1)% Z) exit end do - + Z0 = z_tables(iz)% Z Z1 = z_tables(iz+1)% Z - + if (dbg) then write(*,*) 'Z0', Z0 write(*,*) 'Z ', Z write(*,*) 'Z1', Z1 end if - + if (Z1 <= Z0) then ierr = 1 return end if - + if (Z <= Z0) then ! use the Z0 table if (dbg) then write(*,*) 'use the Z0 table', iz, Z0, Z, Z-Z0 @@ -135,7 +135,7 @@ subroutine Get1_kap_fixed_metal_Results( & logKap, dlnkap_dlnRho, dlnkap_dlnT, ierr) return end if - + if (Z >= Z1) then ! use the Z1 table if (dbg) write(*,*) 'use the Z1 table', Z1 call Get_Kap_for_X( & @@ -143,7 +143,7 @@ subroutine Get1_kap_fixed_metal_Results( & logKap, dlnkap_dlnRho, dlnkap_dlnT, ierr) return end if - + if (num_Zs >= 4 .and. rq% cubic_interpolation_in_Z) then if (dbg) write(*,*) 'call Get_Kap_for_Z_cubic' call Get_Kap_for_Z_cubic(z_tables, num_Zs, rq, iz, Z, X, logRho, logT, & @@ -168,8 +168,8 @@ subroutine Get1_kap_fixed_metal_Results( & end if end subroutine Get1_kap_fixed_metal_Results - - + + ! use tables iz-1 to iz+2 to do piecewise monotonic cubic interpolation in Z subroutine Get_Kap_for_Z_cubic( & z_tables, num_Zs, rq, iz, Z, X, logRho, logT, & @@ -186,7 +186,7 @@ subroutine Get_Kap_for_Z_cubic( & real(dp), intent(inout) :: logK, logRho, logT real(dp), intent(out) :: dlnkap_dlnRho, dlnkap_dlnT integer, intent(out) :: ierr - + integer, parameter :: n_old = 4, n_new = 1 real(dp), dimension(n_old) :: logKs, dlogKs_dlogRho, dlogKs_dlogT type(auto_diff_real_2var_order1), dimension(n_old) :: logKs_ad @@ -197,12 +197,12 @@ subroutine Get_Kap_for_Z_cubic( & integer :: i, i1, izz logical, parameter :: dbg = .false. - + 11 format(a40,e20.10) - + ierr = 0 work => work_ary - + if (iz+2 > num_Zs) then i1 = num_Zs-2 else if (iz == 1) then @@ -210,9 +210,9 @@ subroutine Get_Kap_for_Z_cubic( & else i1 = iz end if - + if (dbg) write(*,*) 'iz', iz - + do i=1,n_old izz = i1-2+i if (dbg) write(*,*) 'izz', izz @@ -248,13 +248,13 @@ subroutine Get_Kap_for_Z_cubic( & dlnkap_dlnRho = logK_ad % d1val2 if (dbg) then - + do i=1,n_old write(*,*) 'z_old(i)', z_old(i) end do write(*,*) 'z_new(1)', z_new(1) write(*,'(A)') - + do i=1,n_old write(*,*) 'logKs(i)', logKs(i) end do @@ -266,17 +266,17 @@ subroutine Get_Kap_for_Z_cubic( & end do write(*,*) 'dlnkap_dlnRho', dlnkap_dlnRho write(*,'(A)') - + do i=1,n_old write(*,*) 'dlogKs_dlogT(i)', dlogKs_dlogT(i) end do write(*,*) 'dlnkap_dlnT', dlnkap_dlnT write(*,'(A)') - + end if - + contains - + subroutine interp1(old, new, ierr) type(auto_diff_real_2var_order1), intent(in) :: old(n_old) type(auto_diff_real_2var_order1), intent(out) :: new @@ -291,10 +291,10 @@ subroutine interp1(old, new, ierr) 'Get_Kap_for_Z_cubic', ierr) new = v_new(1) end subroutine interp1 - + end subroutine Get_Kap_for_Z_cubic - - + + subroutine Get_Kap_for_Z_linear(z_tables, rq, iz, Z, Z0, Z1, X, logRho, logT, & logKap, dlnkap_dlnRho, dlnkap_dlnT, ierr) use kap_def @@ -309,7 +309,7 @@ subroutine Get_Kap_for_Z_linear(z_tables, rq, iz, Z, Z0, Z1, X, logRho, logT, & real(dp) :: logK0, dlogK0_dlogRho, dlogK0_dlogT real(dp) :: logK1, dlogK1_dlogRho, dlogK1_dlogT real(dp) :: alfa, beta - + logical, parameter :: dbg = .false. ierr = 0 @@ -318,7 +318,7 @@ subroutine Get_Kap_for_Z_linear(z_tables, rq, iz, Z, Z0, Z1, X, logRho, logT, & logK0, dlogK0_dlogRho, dlogK0_dlogT, ierr) if (ierr /= 0) return if (dbg) write(*,*) 'logK0', logK0 - + call Get_Kap_for_X( & z_tables, rq, iz+1, X, logRho, logT, & logK1, dlogK1_dlogRho, dlogK1_dlogT, ierr) @@ -328,14 +328,14 @@ subroutine Get_Kap_for_Z_linear(z_tables, rq, iz, Z, Z0, Z1, X, logRho, logT, & ! Z0 result in logK0, Z1 result in logK1 beta = (Z - Z1) / (Z0 - Z1) ! beta -> 1 as Z -> Z0 alfa = 1d0 - beta - + logKap = beta * logK0 + alfa * logK1 dlnkap_dlnRho = beta * dlogK0_dlogRho + alfa * dlogK1_dlogRho dlnkap_dlnT = beta * dlogK0_dlogT + alfa * dlogK1_dlogT end subroutine Get_Kap_for_Z_linear - - + + subroutine Get_Kap_for_X(z_tables, rq, iz, X, logRho, logT, & logK, dlogK_dlogRho, dlogK_dlogT, ierr) use kap_def @@ -346,26 +346,26 @@ subroutine Get_Kap_for_X(z_tables, rq, iz, X, logRho, logT, & real(dp), intent(inout) :: logRho, logT real(dp), intent(out) :: logK, dlogK_dlogRho, dlogK_dlogT integer, intent(out) :: ierr - + type (Kap_X_Table), dimension(:), pointer :: x_tables real(dp) :: logK0, dlogK0_dlogRho, dlogK0_dlogT real(dp) :: logK1, dlogK1_dlogRho, dlogK1_dlogT real(dp) :: X0, X1 integer :: ix, i, num_Xs - + logical, parameter :: dbg = .false. - + include 'formats' - + ierr = 0 x_tables => z_tables(iz)% x_tables num_Xs = z_tables(iz)% num_Xs - + if (X < 0 .or. X > 1) then ierr = -3 return end if - + if (num_Xs > 1) then if (x_tables(1)% X >= x_tables(2)% X) then ierr = -3 @@ -377,24 +377,24 @@ subroutine Get_Kap_for_X(z_tables, rq, iz, X, logRho, logT, & write(*,2) 'X', i, x_tables(i)% X end do stop - + return end if end if - + if (num_Xs == 1 .or. X <= x_tables(1)% X) then ! use the first X call Get_Kap_for_logRho_logT( & z_tables, rq, iz, x_tables, 1, & logRho, logT, logK, dlogK_dlogRho, dlogK_dlogT, ierr) return end if - + if (X >= x_tables(num_Xs)% X) then ! use the last X if (dbg) write(*,*) 'use the last X: call Get_Kap_for_logRho_logT' call Get_Kap_for_logRho_logT( & z_tables, rq, iz, x_tables, num_Xs, & logRho, logT, logK, dlogK_dlogRho, dlogK_dlogT, ierr) - return + return end if ! search for the X @@ -405,7 +405,7 @@ subroutine Get_Kap_for_X(z_tables, rq, iz, X, logRho, logT, & ix = i; exit end if end do - + if (ix == num_Xs) then if (dbg) write(*,*) 'ix == num_Xs: call Get_Kap_for_logRho_logT' call Get_Kap_for_logRho_logT( & @@ -413,15 +413,15 @@ subroutine Get_Kap_for_X(z_tables, rq, iz, X, logRho, logT, & logRho, logT, logK, dlogK_dlogRho, dlogK_dlogT, ierr) return end if - + X0 = x_tables(ix)% X X1 = x_tables(ix+1)% X - + if (X1 <= X0) then ierr = 1 return end if - + if (X0 >= X) then ! use the X0 table if (dbg) write(*,*) 'use the X0 table' call Get_Kap_for_logRho_logT( & @@ -429,7 +429,7 @@ subroutine Get_Kap_for_X(z_tables, rq, iz, X, logRho, logT, & logRho, logT, logK, dlogK_dlogRho, dlogK_dlogT, ierr) return end if - + if (X1 <= X) then ! use the X1 table if (dbg) write(*,*) 'use the X1 table' call Get_Kap_for_logRho_logT( & @@ -457,15 +457,15 @@ subroutine Get_Kap_for_X(z_tables, rq, iz, X, logRho, logT, & return end if end if - + if (.false.) then write(*,1) 'logK at X for Z', logK, logT, logRho, X, z_tables(iz)% Z write(*,'(A)') end if - + end subroutine Get_Kap_for_X - - + + ! use tables ix-1 to ix+2 to do piecewise monotonic cubic interpolation in X subroutine Get_Kap_for_X_cubic( & z_tables, rq, iz, ix, num_Xs, x_tables, X, logRho, logT, & @@ -483,7 +483,7 @@ subroutine Get_Kap_for_X_cubic( & real(dp), intent(inout) :: logRho, logT real(dp), intent(out) :: logK, dlogK_dlogRho, dlogK_dlogT integer, intent(out) :: ierr - + integer, parameter :: n_old = 4, n_new = 1 real(dp), dimension(n_old) :: logKs, dlogKs_dlogRho, dlogKs_dlogT type(auto_diff_real_2var_order1), dimension(n_old) :: logKs_ad @@ -494,12 +494,12 @@ subroutine Get_Kap_for_X_cubic( & integer :: i, i1, ixx logical, parameter :: dbg = .false. - + 11 format(a40,e20.10) - + ierr = 0 work => work_ary - + if (ix+2 > num_Xs) then i1 = num_Xs-2 else if (ix == 1) then @@ -507,9 +507,9 @@ subroutine Get_Kap_for_X_cubic( & else i1 = ix end if - + if (dbg) write(*,*) 'ix', ix - + do i=1,n_old ixx = i1-2+i if (dbg) write(*,*) 'ixx', ixx @@ -532,7 +532,7 @@ subroutine Get_Kap_for_X_cubic( & x_new(1) % val = X x_new(1) % d1val1 = 0d0 x_new(1) % d1val2 = 0d0 - + call interp1(logKs_ad, logK_ad, ierr) if (ierr /= 0) then call mesa_error(__FILE__,__LINE__,'failed in interp1 for logK') @@ -543,15 +543,15 @@ subroutine Get_Kap_for_X_cubic( & logK = logK_ad % val dlogK_dlogT = logK_ad % d1val1 dlogK_dlogRho = logK_ad % d1val2 - + if (dbg) then - + do i=1,n_old write(*,*) 'x_old(i)', x_old(i) end do write(*,*) 'x_new(1)', x_new(1) write(*,'(A)') - + do i=1,n_old write(*,*) 'logKs(i)', logKs(i) end do @@ -563,17 +563,17 @@ subroutine Get_Kap_for_X_cubic( & end do write(*,*) 'dlogK_dlogRho', dlogK_dlogRho write(*,'(A)') - + do i=1,n_old write(*,*) 'dlogKs_dlogT(i)', dlogKs_dlogT(i) end do write(*,*) 'dlogK_dlogT', dlogK_dlogT write(*,'(A)') - + end if - + contains - + subroutine interp1(old, new, ierr) type(auto_diff_real_2var_order1), intent(in) :: old(n_old) type(auto_diff_real_2var_order1), intent(out) :: new @@ -588,10 +588,10 @@ subroutine interp1(old, new, ierr) 'Get_Kap_for_X_cubic', ierr) new = v_new(1) end subroutine interp1 - + end subroutine Get_Kap_for_X_cubic - - + + ! use tables ix and ix+1 to do linear interpolation in X subroutine Get_Kap_for_X_linear( & z_tables, rq, iz, ix, x_tables, X, X0, X1, logRho, logT, & @@ -605,34 +605,34 @@ subroutine Get_Kap_for_X_linear( & real(dp), intent(inout) :: logRho, logT real(dp), intent(out) :: logK, dlogK_dlogRho, dlogK_dlogT integer, intent(out) :: ierr - + real(dp) :: logK0, dlogK0_dlogRho, dlogK0_dlogT real(dp) :: logK1, dlogK1_dlogRho, dlogK1_dlogT real(dp) :: alfa, beta - + ierr = 0 - + call Get_Kap_for_logRho_logT( & z_tables, rq, iz, x_tables, ix, & logRho, logT, logK0, dlogK0_dlogRho, dlogK0_dlogT, ierr) if (ierr /= 0) return - + call Get_Kap_for_logRho_logT( & z_tables, rq, iz, x_tables, ix+1, & logRho, logT, logK1, dlogK1_dlogRho, dlogK1_dlogT, ierr) if (ierr /= 0) return - + ! X0 result in logK0, X1 result in logK1 beta = (X - X1) / (X0 - X1) ! beta -> 1 as X -> X0 alfa = 1d0 - beta - + logK = beta * logK0 + alfa * logK1 dlogK_dlogRho = beta * dlogK0_dlogRho + alfa * dlogK1_dlogRho dlogK_dlogT = beta * dlogK0_dlogT + alfa * dlogK1_dlogT - + end subroutine Get_Kap_for_X_linear - + subroutine Get_Kap_for_logRho_logT( & z_tables, rq, iz, x_tables, ix, & logRho, logT, logK, dlogK_dlogRho, dlogK_dlogT, ierr) @@ -651,11 +651,11 @@ subroutine Get_Kap_for_logRho_logT( & integer :: iR, jtemp, i, num_logRs, num_logTs logical :: clipped_logR logical, parameter :: read_later = .false. - + logical, parameter :: dbg = .false. - + include 'formats' - + ierr = 0 if (x_tables(ix)% not_loaded_yet) then ! avoid doing critical section if possible !$omp critical (load_kap_x_table) @@ -673,7 +673,7 @@ subroutine Get_Kap_for_logRho_logT( & ! logR from inputs logR_in = logRho - 3d0*logT + 18d0 - + ! blends at higher levels MUST prevent ! these tables from being called off their ! high/low T and low R edges @@ -693,7 +693,7 @@ subroutine Get_Kap_for_logRho_logT( & return end if - + ! off the high R edge, we use the input temperature ! but clip logR to the table edge value @@ -750,7 +750,7 @@ subroutine Get_Kap_for_logRho_logT( & iR, jtemp, logR0, logR, logR1, logT0, logT, logT1, & logK, df_dx, df_dy) if (clipped_logR) df_dx = 0 - + if (dbg) write(*,1) 'Do_Kap_Interpolations: logK', logK ! convert df_dx and df_dy to dlogK_dlogRho, dlogK_dlogT @@ -760,8 +760,8 @@ subroutine Get_Kap_for_logRho_logT( & if (dbg) then write(*,1) 'logK', logK, logT, logRho, x_tables(ix)% X, z_tables(iz)% Z end if - + end subroutine Get_Kap_for_logRho_logT - + end module kap_eval_fixed diff --git a/kap/private/kap_eval_support.f90 b/kap/private/kap_eval_support.f90 index d7eb4dc1d..6b6de82c0 100644 --- a/kap/private/kap_eval_support.f90 +++ b/kap/private/kap_eval_support.f90 @@ -27,12 +27,12 @@ module kap_eval_support use const_def, only: dp, one_sixth use math_lib - + implicit none - + contains - - + + subroutine Locate_log( & rq, num_logs, log_min_in, log_max_in, ili_logs, logs, log_find, i, log0, log1, ierr) use kap_def @@ -49,7 +49,7 @@ subroutine Locate_log( & integer, intent(out) :: ierr real(dp) :: dlog, log_min, log_max integer :: j - ierr = 0 + ierr = 0 log_min = max(log_min_in, logs(1)) log_max = min(log_max_in, logs(num_logs)) if (num_logs == 1) then @@ -59,11 +59,11 @@ subroutine Locate_log( & log1 = log_find return end if - if (log_find < log_min .or. log_find > log_max) then + if (log_find < log_min .or. log_find > log_max) then if (.not. clip_to_kap_table_boundaries) then ierr = -1 return - end if + end if if (log_find < log_min) then i = 1 log_find = log_min @@ -74,7 +74,7 @@ subroutine Locate_log( & else if (abs(log_find-log_max) < 1d-7) then i = num_logs-1 log_find = log_max - else if (ili_logs == 1) then ! logs equally spaced + else if (ili_logs == 1) then ! logs equally spaced dlog = (log_max-log_min)/(num_logs-1) i = int((log_find-log_min) / dlog) + 1 ! might not be exactly evenly spaced, so minor fixup if necessary @@ -84,7 +84,7 @@ subroutine Locate_log( & i = i+1 end if else - i = binary_search(num_logs, logs, 0, log_find) + i = binary_search(num_logs, logs, 0, log_find) if (i >= num_logs) then ierr = -1 return @@ -93,9 +93,9 @@ subroutine Locate_log( & write(*,*) 'num_logs', num_logs call mesa_error(__FILE__,__LINE__,'Locate_log') !$OMP end critical (kap_eval_crit1) - end if + end if end if - + if (i < 1 .or. i >= num_logs) then ierr = -1 return @@ -103,7 +103,7 @@ subroutine Locate_log( & write(*,*) 'num_logs', num_logs call mesa_error(__FILE__,__LINE__,'Locate_log') end if - + if (logs(i) > log_find .or. log_find > logs(i+1)) then ierr = -1 !$OMP critical (kap_eval_crit2) @@ -137,8 +137,8 @@ subroutine Locate_log( & !$OMP end critical (kap_eval_crit3) end if end subroutine Locate_log - - + + subroutine Locate_logT( & rq, num_logTs, logT_min, logT_max, ili_logTs, logTs, logT, iT, logT0, logT1, ierr) use kap_def @@ -153,7 +153,7 @@ subroutine Locate_logT( & call Locate_log( & rq, num_logTs, logT_min, logT_max, ili_logTs, logTs, logT, iT, logT0, logT1, ierr) end subroutine Locate_logT - + subroutine Locate_logR( & rq, num_logRs, logR_min, logR_max, ili_logRs, logRs, logR, iR, logR0, logR1, ierr) @@ -167,37 +167,37 @@ subroutine Locate_logR( & real(dp), intent(out) :: logR0, logR1 integer, intent(out) :: ierr call Locate_log( & - rq, num_logRs, logR_min, logR_max, ili_logRs, logRs, logR, iR, logR0, logR1, ierr) + rq, num_logRs, logR_min, logR_max, ili_logRs, logRs, logR, iR, logR0, logR1, ierr) end subroutine Locate_logR - - + + subroutine Do_Kap_Interpolations( & fin1, nx, ny, i, j, x0, xget, x1, y0, yget, y1, fval, df_dx, df_dy) - ! derived from routines in the PSPLINE package written by Doug McCune - + ! derived from routines in the PSPLINE package written by Doug McCune + real(dp), dimension(:), pointer :: fin1 ! the spline data array, dimensions (4, nx, ny) integer, intent(in) :: nx, ny, i, j ! target cell in the spline data real(dp), intent(in) :: x0, xget, x1 ! x0 <= xget <= x1; x0 = xs(i), x1 = xs(i+1) real(dp), intent(in) :: y0, yget, y1 ! y0 <= yget <= y1; y0 = ys(j), y1 = ys(j+1) real(dp), intent(out) :: fval, df_dx, df_dy - + real(dp), parameter :: z36th = 1d0 / 36d0 - + real(dp), pointer :: fin(:,:,:) real(dp) :: xp, xpi, xp2, xpi2, cx, cxi, hx2, cxd, cxdi, hx, hxi real(dp) :: yp, ypi, yp2, ypi2, cy, cyi, hy2, cyd, cydi, hy, hyi - + logical, parameter :: dbg = .false. - + include 'formats' - + fin(1:4,1:nx,1:ny) => fin1(1:4*nx*ny) - + hx=x1-x0 hxi=1d0/hx hx2=hx*hx - + xp=(xget-x0)*hxi xpi=1d0-xp xp2=xp*xp @@ -207,11 +207,11 @@ subroutine Do_Kap_Interpolations( & cxi=xpi*(xpi2-1d0) cxd=3d0*xp2-1d0 cxdi=-3d0*xpi2+1d0 - + hy=y1-y0 hyi=1d0/hy hy2=hy*hy - + yp=(yget-y0)*hyi ypi=1d0-yp yp2=yp*yp @@ -221,7 +221,7 @@ subroutine Do_Kap_Interpolations( & cyi=ypi*(ypi2-1d0) cyd=3d0*yp2-1d0 cydi=-3d0*ypi2+1d0 - + ! bicubic spline interpolation fval = & xpi*(ypi*fin(1,i,j) +yp*fin(1,i,j+1)) & @@ -235,7 +235,7 @@ subroutine Do_Kap_Interpolations( & +z36th*hx2*hy2*( & cxi*(cyi*fin(4,i,j) +cy*fin(4,i,j+1))+ & cx*(cyi*fin(4,i+1,j)+cy*fin(4,i+1,j+1))) - + if (.false.) then write(*,3) 'fin(1,i,j)', i, j, fin(1,i,j) write(*,3) 'fin(1,i,j+1)', i, j+1, fin(1,i,j+1) @@ -278,7 +278,7 @@ subroutine Do_Kap_Interpolations( & cx*(cyi*fin(4,i+1,j)+cy*fin(4,i+1,j+1))) write(*,1) 'fval', fval end if - + ! derivatives of bicubic splines df_dx = & hxi*( & @@ -312,4 +312,4 @@ end subroutine Do_Kap_Interpolations end module kap_eval_support - + diff --git a/kap/private/kapcn.f90 b/kap/private/kapcn.f90 index 04fc04c3b..6afc47f8e 100644 --- a/kap/private/kapcn.f90 +++ b/kap/private/kapcn.f90 @@ -1,9 +1,9 @@ -! kapCN by Aaron Dotter +! kapCN by Aaron Dotter ! This is a MESA module that reads in and interpolates the low-T ! opacities by M.T. Lederer & B. Aringer, 2009, A&A, 494, 403 ! see doc/ReadMe for details of the data files; it uses MESA ! modules for interpolation and a few other things -! kapCN_ZC=0.1644, kapCN_ZN=0.0532 +! kapCN_ZC=0.1644, kapCN_ZN=0.0532 module kapcn @@ -25,7 +25,7 @@ module kapcn integer :: ict(6) = [ 1, 1, 1, 0, 0, 0 ] real(dp), parameter :: bc(kapCN_num_logT) = 0d0 - + contains !for kapCN @@ -267,7 +267,7 @@ subroutine kapCN_interp(Z,X,fC,fN,logR,logT,result,ierr) x_new(1)=log10(my_Z) allocate(logZ_ary(iZ-1:iZ+2)) - + do i=iZ-1,iZ+2 logZ_ary(i) = log10(z_ary(i)) end do @@ -286,7 +286,7 @@ end subroutine kapCN_interp logical function outside_R_and_T_bounds(logR,logT) - real(dp), intent(in) :: logR, logT + real(dp), intent(in) :: logR, logT outside_R_and_T_bounds = & logR < kapCN_min_logR .or. logR > kapCN_max_logR .or. & logT < kapCN_min_logT .or. logT > kapCN_max_logT @@ -351,7 +351,7 @@ subroutine interp(a,b,x,n) ! {b} are coefficients of the interpolating polynomial ! x is the abscissa to be interpolated ! n is the number of points to be used, interpolating polynomial - ! has order n-1 + ! has order n-1 integer, intent(in) :: n real(dp), intent(in) :: a(n), x real(dp), intent(out) :: b(n) diff --git a/kap/private/load_co_kap.f90 b/kap/private/load_co_kap.f90 index 97612cf86..a71cf92ac 100644 --- a/kap/private/load_co_kap.f90 +++ b/kap/private/load_co_kap.f90 @@ -88,9 +88,9 @@ subroutine load_one_CO(rq, co_z_tables, iz, ix, read_later, ierr) kap_CO_Zs(iz, rq% kap_CO_option), kap_CO_Xs(ix, rq% kap_CO_option), kap_dir, fname, filename, & cache_filename, temp_cache_filename, ierr) if (ierr /= 0) return - + if (rq% show_info) write(*,*) 'read filename <' // trim(filename) // '>' - + call Prepare_Kap_CO_X_Table(rq, & iz, co_z_tables, co_z_tables(iz)% x_tables, & ix, kap_CO_Xs(ix, rq% kap_CO_option), kap_CO_Zs(iz, rq% kap_CO_option), & @@ -125,8 +125,8 @@ subroutine Prepare_Kap_CO_X_Table(rq, & type (Kap_CO_Table), dimension(:), pointer :: co_tables integer :: num_dXC_gt_dXO ! the number of tables with dXC > dXO integer :: CO_table_numbers(num_kap_CO_dXs,num_kap_CO_dXs) - integer :: next_dXO_table(max_num_CO_tables) - integer :: next_dXC_table(max_num_CO_tables) + integer :: next_dXO_table(max_num_CO_tables) + integer :: next_dXC_table(max_num_CO_tables) character (len=256) :: message real(dp), target :: vec_ary(30) real(dp), pointer :: vec(:) @@ -158,9 +158,9 @@ subroutine Prepare_Kap_CO_X_Table(rq, & write(*,'(A)') write(*,'(A)') write(*,*) 'NOTICE: missing kap data ' // trim(filename) - write(*,*) + write(*,*) write(*,*) 'Please check the validity of the kap_prefix string for this file.' - write(*,*) + write(*,*) write(*,*) 'If it is okay, you may need to install new kap data.' write(*,*) 'To do that, remove the directory mesa/data/kap_data,' write(*,*) 'and rerun the mesa ./install script.' @@ -438,7 +438,7 @@ subroutine Read_Kap_CO_X_Table(io_unit, reading_cache, ierr) read(io_unit, iostat=ierr) & x_tables(ix)% logRs(1:num_logRs), & - x_tables(ix)% logTs(1:num_logTs) + x_tables(ix)% logTs(1:num_logTs) if (ierr /= 0) return x_tables(ix)% num_dXC_gt_dXO = num_dXC_gt_dXO @@ -522,7 +522,7 @@ subroutine Read_Kap_CO_Table( & integer :: table_num, i, j, ios, status, iXC, iXO real(dp) :: X, Z, xin, zz, Y, dXC, dXO, err, logT real(dp), allocatable, target :: kap_table(:) ! data & spline coefficients - real(dp), pointer :: kap(:,:,:) + real(dp), pointer :: kap(:,:,:) real(dp) :: logKs(num_logRs), logRs(num_logRs) character (len=1000) :: message real(dp), target :: vec_ary(50) @@ -669,7 +669,7 @@ subroutine Read_Kap_CO_Table( & kap(1:sz_per_Kap_point,1:num_logRs,1:num_logTs) => & co_tables(n)% kap1(1:sz_per_Kap_point*num_logRs*num_logTs) - do i = 1, num_logTs + do i = 1, num_logTs read(io_unit,'(a)',iostat=ierr) message if (ierr == 0) call str_to_vector(message, vec, nvec, ierr) @@ -751,7 +751,7 @@ subroutine Make_CO_Interpolation_Data( & kap(1:sz_per_kap_point,1:num_logRs,1:num_logTs) => & co_tables(n)% kap1(1:sz_per_kap_point*num_logRs*num_logTs) - do j=1,num_logTs + do j=1,num_logTs do i=1,num_logRs table(1,i,j) = kap(1,i,j) end do @@ -771,7 +771,7 @@ subroutine Make_CO_Interpolation_Data( & call Check_Interpolation_Data - do i=1,sz_per_kap_point*num_logRs*num_logTs + do i=1,sz_per_kap_point*num_logRs*num_logTs co_tables(n)% kap1(i) = table1(i) end do @@ -817,7 +817,7 @@ subroutine Write_Kap_CO_X_Table_Cache(x_tables, ix, io_unit, num_logRs, num_logT real(dp) :: X, Z, Y, dXC, dXO real(dp), allocatable, target :: kap_table(:) ! data & spline coefficients include 'formats' - + if (show_allocations) write(*,2) 'Write_Kap_CO_X_Table_Cache', & sz_per_Kap_point*num_logRs*num_logTs allocate(kap_table(sz_per_Kap_point*num_logRs*num_logTs)) @@ -846,7 +846,7 @@ subroutine Write_Kap_CO_X_Table_Cache(x_tables, ix, io_unit, num_logRs, num_logT write(io_unit) & x_tables(ix)% logRs(1:num_logRs), & - x_tables(ix)% logTs(1:num_logTs) + x_tables(ix)% logTs(1:num_logTs) do n = 1, num_tables dXC = co_tables(n)% dXC @@ -903,7 +903,7 @@ subroutine Create_fname(rq, Z, X, fname,ierr) integer, intent(out) :: ierr character (len=16) :: zstr, xstr ierr=0 - call get_output_string(Z, zstr,ierr) + call get_output_string(Z, zstr,ierr) call get_output_string(X, xstr,ierr) write(fname,'(a)') trim(kap_CO_option_str(rq% kap_CO_option)) // '_z' // & diff --git a/kap/private/load_kap.f90 b/kap/private/load_kap.f90 index e53e4ae2e..ea50c6c25 100644 --- a/kap/private/load_kap.f90 +++ b/kap/private/load_kap.f90 @@ -61,13 +61,13 @@ subroutine Setup_Kap_Tables(rq, & kap_dir = trim(mesa_data_dir) // '/kap_data' kap_use_cache = use_cache - + call Setup_Kap_CO_Tables(rq, kap_CO_z_tables(rq% kap_CO_option)% ar, use_cache, load_on_demand, ierr) if (ierr /= 0) return - + call setup_lowT(kap_lowT_z_tables(rq% kap_lowT_option)% ar) call setup(kap_z_tables(rq% kap_option)% ar) - + rq% logT_Compton_blend_hi = & ! apply whichever is minimum for Type1 and Type2 options min(kap_z_tables(rq% kap_option)% ar(1)% x_tables(1)% logT_max - 0.01d0, & kap_CO_z_tables(rq% kap_CO_option)% ar(1)% x_tables(1)% logT_max - 0.01d0) @@ -201,7 +201,7 @@ subroutine load_one(rq, & call Get_Filenames(rq, z_tables, X, Z, & kap_dir, fname, filename, cache_filename, temp_cache_filename, ierr) if (ierr /= 0) return - + if (rq% show_info) write(*,*) 'read filename <' // trim(filename) // '>' call Prepare_Kap_X_Table(rq, & @@ -257,9 +257,9 @@ subroutine Prepare_Kap_X_Table(rq, & write(*,'(A)') write(*,'(A)') write(*,*) 'NOTICE: missing kap data ' // trim(filename) - write(*,*) + write(*,*) write(*,*) 'Please check the validity of the kap_prefix string for this file.' - write(*,*) + write(*,*) write(*,*) 'If it is okay, you may need to install new kap data.' write(*,*) 'To do that, remove the directory mesa/data/kap_data,' write(*,*) 'and rerun the mesa ./install script.' @@ -411,7 +411,7 @@ subroutine Setup_Kap_X_Table(ierr) return end if - x_tables(ix)% not_loaded_yet = .true. + x_tables(ix)% not_loaded_yet = .true. x_tables(ix)% X = X x_tables(ix)% Z = Z x_tables(ix)% logR_min = logR_min @@ -450,7 +450,7 @@ subroutine Read_Kap_X_Table(io_unit, reading_cache, ierr) vec => vec_ary nvec=-1 - + if (reading_cache) then ios = 0 @@ -495,7 +495,7 @@ subroutine Read_Kap_X_Table(io_unit, reading_cache, ierr) ierr = -1 return end if - + if (show_allocations) write(*,2) 'x_tables ' // trim(filename), & num_logRs + num_logTs + sz_per_Kap_point*num_logRs*num_logTs allocate(x_tables(ix)% logRs(num_logRs), x_tables(ix)% logTs(num_logTs), & @@ -578,7 +578,7 @@ subroutine Read_Kap_X_Table(io_unit, reading_cache, ierr) read(io_unit, iostat=ierr) & x_tables(ix)% logRs(1:num_logRs), & - x_tables(ix)% logTs(1:num_logTs) + x_tables(ix)% logTs(1:num_logTs) if (ierr /= 0) return read(io_unit, iostat=ierr) kap1 @@ -697,8 +697,8 @@ subroutine Write_Kap_X_Table_Cache(x_tables, ix, io_unit, version) x_tables(ix)% logT_max !write(io_unit) & ! x_tables(ix)% logRs(:), & - ! x_tables(ix)% logTs(:) - !write(io_unit) x_tables(ix)% kap(:,:,:) + ! x_tables(ix)% logTs(:) + !write(io_unit) x_tables(ix)% kap(:,:,:) else write(io_unit) version, x_tables(ix)% num_logTs, x_tables(ix)% num_logRs write(io_unit) & @@ -707,12 +707,12 @@ subroutine Write_Kap_X_Table_Cache(x_tables, ix, io_unit, version) x_tables(ix)% logR_min, & x_tables(ix)% logR_max, & x_tables(ix)% logT_min, & - x_tables(ix)% logT_max - write(io_unit) x_tables(ix)% ili_logRs, x_tables(ix)% ili_logTs + x_tables(ix)% logT_max + write(io_unit) x_tables(ix)% ili_logRs, x_tables(ix)% ili_logTs write(io_unit) & x_tables(ix)% logRs(:), & - x_tables(ix)% logTs(:) - write(io_unit) x_tables(ix)% kap1(:) + x_tables(ix)% logTs(:) + write(io_unit) x_tables(ix)% kap1(:) end if end subroutine Write_Kap_X_Table_Cache @@ -746,7 +746,7 @@ subroutine create_fname(rq, z_tables, X, Z, fname, cache_fname, ierr) character (len=256) :: zstr, xstr, prefix ierr=0 - + if (z_tables(1)% lowT_flag .and. rq% kap_lowT_option == kap_lowT_Freedman11) then call get_output_string(Z,zstr,ierr) fname = trim(kap_lowT_option_str(rq% kap_lowT_option)) // '_z' // trim(zstr) // '.data' diff --git a/kap/private/op_def.f90 b/kap/private/op_def.f90 index 9a869e080..37a9c6bc3 100644 --- a/kap/private/op_def.f90 +++ b/kap/private/op_def.f90 @@ -22,14 +22,14 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + MODULE op_def IMPLICIT NONE integer, parameter :: nptot = 10000 integer, parameter :: nrad = 17 - integer, parameter :: ipe = 17 + integer, parameter :: ipe = 17 integer,dimension(140:320),parameter :: JS=(/14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 18, 19, 22, 23,& 26, 27, 30, 31, 34, 34, 34, 34, 36, 36, 36, 36, 36, 36, 38, 38,& @@ -58,7 +58,7 @@ MODULE op_def 112,112,112,112,112,114,114,114,114,114,114,115,116,116,116,116,& 116,116,116,118,118/) -! +! INTEGER,DIMENSION(17),parameter :: kz=(/1,2,6,7,8,10,11,12,13,14,16,18,20,24,25,26,28/) character(len=2), dimension(17),parameter :: name=(/'H ','He','C ','N ','O ','Ne','Na',& 'Mg','Al','Si','S ','Ar','Ca','Cr','Mn',& @@ -66,10 +66,10 @@ MODULE op_def REAL,DIMENSION(17),PARAMETER :: AMASS=(/1.0080,4.0026,12.0111,14.0067,15.9994,20.179,& 22.9898,24.305,26.9815,28.086,32.06,39.948, & 40.08,51.996,54.9380,55.847,58.71/) - + integer,save :: ite1, ite2, ite3, jne3 , ntotp, nc, nf - integer,dimension(91),save :: jn1, jn2 - integer,dimension(17),save :: int + integer,dimension(91),save :: jn1, jn2 + integer,dimension(17),save :: int real,save :: umin, umax real,dimension(17,91,25),save :: epatom, oplnck integer,dimension(17,91,25),save :: ne1p, ne2p,np,kp1,kp2,kp3,npp @@ -78,5 +78,5 @@ MODULE op_def INTEGER,allocatable,DIMENSION(:),save :: nx integer, parameter :: op_cache_version = 1 - + END module op_def diff --git a/kap/public/kap_def.f90 b/kap/public/kap_def.f90 index 56c6fa2bf..d9ccbbca1 100644 --- a/kap/public/kap_def.f90 +++ b/kap/public/kap_def.f90 @@ -81,7 +81,7 @@ end subroutine other_radiative_opacity_interface end interface - + logical, parameter :: show_allocations = .false. ! for debugging memory usage ! for kap output @@ -93,8 +93,8 @@ end subroutine other_radiative_opacity_interface ! info about op_mono elements integer, parameter :: num_op_mono_elements = 17 - integer :: op_mono_element_Z(num_op_mono_elements) - character(len=2) :: op_mono_element_name(num_op_mono_elements) + integer :: op_mono_element_Z(num_op_mono_elements) + character(len=2) :: op_mono_element_name(num_op_mono_elements) real(dp) :: op_mono_element_mass(num_op_mono_elements) @@ -158,7 +158,7 @@ end subroutine other_radiative_opacity_interface integer, parameter :: max_num_CO_tables = 70 ! standard number of CO tables for each X+Z combo - ! X + ! X ! Z 0.0 0.1 0.35 0.7 ! 0.0 58 58 51 32 ! 0.001 58 58 51 30 @@ -195,11 +195,11 @@ end subroutine other_radiative_opacity_interface ! 3) tables with dXC < dXO, ordered by increasing dXC, and by increasing dXO within same dXC. ! the spacing of dXC's is the same as dXO's, so there are as many tables in 3) as in 1). integer :: num_dXC_gt_dXO ! the number of tables with dXC > dXO - integer :: CO_table_numbers(num_kap_CO_dXs,num_kap_CO_dXs) + integer :: CO_table_numbers(num_kap_CO_dXs,num_kap_CO_dXs) ! entry (i,j) is the co_index for table with dXC=Xs(i) and dXO=Xs(j), or -1 if no such table. - integer :: next_dXO_table(max_num_CO_tables) + integer :: next_dXO_table(max_num_CO_tables) ! entry (i) is the co_index for the table with same dXC and next larger dXO, or -1 if none such. - integer :: next_dXC_table(max_num_CO_tables) + integer :: next_dXC_table(max_num_CO_tables) ! entry (i) is the co_index for the table with same dXO and next larger dXC, or -1 if none such. type (Kap_CO_Table), dimension(:), pointer :: co_tables => null() @@ -208,16 +208,16 @@ end subroutine other_radiative_opacity_interface type Kap_General_Info real(dp) :: Zbase - + integer :: kap_option, kap_CO_option, kap_lowT_option - + ! blending in T is done between the following limits real(dp) :: kap_blend_logT_upper_bdy ! = 3.88d0 ! old value was 4.1d0 real(dp) :: kap_blend_logT_lower_bdy ! = 3.80d0 ! old value was 4.0d0 ! last time I looked, the table bottom for the higher T tables was logT = 3.75 ! while max logT for the lower T Freeman tables was 4.5 ! so for those, you need to keep kap_blend_logT_upper_bdy < 4.5 - ! and kap_blend_logT_lower_bdy > 3.75 + ! and kap_blend_logT_lower_bdy > 3.75 ! it is also probably a good idea to keep the blend away from H ionization ! logT upper of about 3.9 or a bit less will do that. @@ -273,15 +273,15 @@ end subroutine other_radiative_opacity_interface logical :: use_other_radiative_opacity procedure (other_radiative_opacity_interface), pointer, nopass :: & other_radiative_opacity => null() - + end type Kap_General_Info ! kap_options integer, parameter :: & - kap_gn93 = 1, & - kap_gs98 = 2, & - kap_a09 = 3, & - kap_OP_gs98 = 4, & + kap_gn93 = 1, & + kap_gs98 = 2, & + kap_a09 = 3, & + kap_OP_gs98 = 4, & kap_OP_a09 = 5, & kap_oplib_gs98 = 6, & kap_oplib_agss09 = 7, & @@ -305,8 +305,8 @@ end subroutine other_radiative_opacity_interface ! kap_CO_options integer, parameter :: & - kap_CO_gn93 = 1, & - kap_CO_gs98 = 2, & + kap_CO_gn93 = 1, & + kap_CO_gs98 = 2, & kap_CO_a09 = 3, & kap_CO_user = 4, & kap_CO_test = 5, & @@ -321,24 +321,24 @@ end subroutine other_radiative_opacity_interface integer, dimension(kap_max_dim, kap_CO_options_max) :: num_kap_CO_Xs_for_this_Z = 0 - + ! kap_lowT_options integer, parameter :: & kap_lowT_fa05_mb22= 1, & kap_lowT_fa05_aag21 = 2, & - kap_lowT_Freedman11 = 3, & - kap_lowT_fa05_gs98 = 4, & - kap_lowT_fa05_gn93 = 5, & - kap_lowT_fa05_a09p = 6, & + kap_lowT_Freedman11 = 3, & + kap_lowT_fa05_gs98 = 4, & + kap_lowT_fa05_gn93 = 5, & + kap_lowT_fa05_a09p = 6, & kap_lowT_af94_gn93 = 7, & kap_lowT_rt14_ag89 = 8, & - kap_lowT_kapCN = 9, & + kap_lowT_kapCN = 9, & kap_lowT_AESOPUS = 10, & kap_lowT_user = 11, & kap_lowT_test = 12, & kap_lowT_options_max = 12 - + integer, dimension(kap_lowT_options_max) :: num_kap_lowT_Xs = 0 real(dp), dimension(kap_max_dim, kap_lowT_options_max) :: kap_lowT_Xs = -1d0 @@ -347,7 +347,7 @@ end subroutine other_radiative_opacity_interface integer, dimension(kap_max_dim, kap_lowT_options_max) :: num_kap_lowT_Xs_for_this_Z = 0 - + character (len=256) :: & kap_option_str(kap_options_max), & kap_CO_option_str(kap_CO_options_max), & @@ -377,7 +377,7 @@ end subroutine other_radiative_opacity_interface ! d(2,i,j) = d2s_dx2(i,j) ! d(3,i,j) = d2s_dy2(i,j) ! d(4,i,j) = d4s_dx2_dy2(i,j) - ! + ! ! given f(i,j), the spline fitting code can compute the other entries ! ! given d(1:4,i,j), spline interpolation code can compute s(x,y) @@ -410,7 +410,7 @@ end subroutine other_radiative_opacity_interface integer, parameter :: kapCN_num_logR = 17 integer, parameter :: kapCN_tbl_size = kapCN_num_logR*kapCN_num_logT ! 306 integer, parameter :: kapCN_num_tbl = num_kapCN_Xs*num_kapCN_fCs*num_kapCN_fNs ! 63 - + real(dp), target :: kapCN_Z(num_kapCN_Zs) real(dp), target :: kapCN_fN(num_kapCN_fNs,num_kapCN_Zs) real(dp), target :: kapCN_fC(num_kapCN_fCs,num_kapCN_Zs) @@ -470,10 +470,10 @@ end subroutine other_radiative_opacity_interface real(dp), dimension(:), allocatable :: Xs, fCOs, fCs, fNs type(AESOPUS_Table), dimension(:,:,:,:), allocatable :: t - + end type AESOPUS_TableSet - + type kapAESOPUS integer :: num_logTs @@ -483,7 +483,7 @@ end subroutine other_radiative_opacity_interface real(dp) :: min_logR, max_logR real(dp) :: min_logT, max_logT - + integer :: num_Zs real(dp), dimension(:), allocatable :: Zs, logZs @@ -508,9 +508,9 @@ subroutine kap_def_init(kap_cache_dir_in) use const_def, only: mesa_data_dir, mesa_caches_dir, mesa_temp_caches_dir, use_mesa_temp_cache character (*), intent(in) :: kap_cache_dir_in integer :: i - + kap_test_partials = .false. - + if (len_trim(kap_cache_dir_in) > 0) then kap_cache_dir = kap_cache_dir_in else if (len_trim(mesa_caches_dir) > 0) then @@ -539,7 +539,7 @@ subroutine kap_def_init(kap_cache_dir_in) kap_temp_cache_dir=trim(mesa_temp_caches_dir)//'/kap_cache' if(use_mesa_temp_cache) call mkdir(kap_temp_cache_dir) - + kap_option_str(kap_gn93) = 'gn93' kap_option_str(kap_gs98) = 'gs98' kap_option_str(kap_a09) = 'a09' @@ -550,12 +550,12 @@ subroutine kap_def_init(kap_cache_dir_in) kap_option_str(kap_oplib_aag21) = 'oplib_aag21' kap_option_str(kap_oplib_mb22) = 'oplib_mb22' kap_option_str(kap_test) = 'test' - + kap_CO_option_str(kap_CO_gn93) = 'gn93_co' kap_CO_option_str(kap_CO_gs98) = 'gs98_co' kap_CO_option_str(kap_CO_a09) = 'a09_co' kap_CO_option_str(kap_CO_test) = 'test_co' - + kap_lowT_option_str(kap_lowT_fa05_mb22) = 'lowT_fa05_mb22' kap_lowT_option_str(kap_lowT_fa05_aag21) = 'lowT_fa05_aag21' kap_lowT_option_str(kap_lowT_Freedman11) = 'lowT_Freedman11' @@ -567,7 +567,7 @@ subroutine kap_def_init(kap_cache_dir_in) kap_lowT_option_str(kap_lowT_kapCN) = 'kapCN' kap_lowT_option_str(kap_lowT_AESOPUS) = 'AESOPUS' kap_lowT_option_str(kap_lowT_test) = 'lowT_test' - + do i=1,kap_options_max nullify(kap_z_tables(i)% ar) end do @@ -651,7 +651,7 @@ subroutine kap_def_init(kap_cache_dir_in) end select end do - + end subroutine kap_def_init @@ -691,7 +691,7 @@ end subroutine do_free_kap subroutine get_kap_ptr(handle,rq,ierr) integer, intent(in) :: handle type (Kap_General_Info), pointer :: rq - integer, intent(out):: ierr + integer, intent(out):: ierr if (handle < 1 .or. handle > max_kap_handles) then ierr = -1 return @@ -712,7 +712,7 @@ subroutine get_output_string(x,xstr,ierr) !works with X and Z if(X < 0d0.or.X>1d0) then xstr='bad' ierr=-1 - return + return endif ierr=0 write(str,'(f8.6)') X @@ -723,11 +723,11 @@ subroutine get_output_string(x,xstr,ierr) !works with X and Z enddo xstr=str(1:max(k,3)) end subroutine get_output_string - + subroutine do_Free_Kap_Tables integer :: i - + do i=1,kap_options_max if (associated(kap_z_tables(i)% ar)) & call free_z_tables(kap_z_tables(i)% ar) @@ -753,21 +753,21 @@ subroutine free_z_tables(z_tables) call free_x_tables(z_tables(iz)% x_tables, z_tables(iz)% num_Xs) end do deallocate(z_tables) - nullify(z_tables) + nullify(z_tables) end subroutine free_z_tables subroutine free_x_tables(x_tables, num_Xs) - type (Kap_X_Table), dimension(:), pointer :: x_tables - integer, intent(in) :: num_Xs + type (Kap_X_Table), dimension(:), pointer :: x_tables + integer, intent(in) :: num_Xs integer :: ix - do ix = 1, num_Xs + do ix = 1, num_Xs if (associated(x_tables(ix)% logRs)) then deallocate(x_tables(ix)% logRs) nullify(x_tables(ix)% logRs) end if if (associated(x_tables(ix)% logTs)) then - deallocate(x_tables(ix)% logTs) - nullify(x_tables(ix)% logTs) + deallocate(x_tables(ix)% logTs) + nullify(x_tables(ix)% logTs) end if if (associated(x_tables(ix)% kap1)) then deallocate(x_tables(ix)% kap1) @@ -791,11 +791,11 @@ subroutine free_co_z_tables(co_z_tables) end if end do deallocate(co_z_tables) - nullify(co_z_tables) + nullify(co_z_tables) end subroutine free_co_z_tables subroutine free_co_x_tables(x_tables) - type (Kap_CO_X_Table), dimension(:), pointer :: x_tables + type (Kap_CO_X_Table), dimension(:), pointer :: x_tables ! stored in order of increasing X integer :: num_Xs integer :: ix @@ -807,28 +807,28 @@ subroutine free_co_x_tables(x_tables) nullify(x_tables(ix)% logRs) end if if (associated(x_tables(ix)% logTs)) then - deallocate(x_tables(ix)% logTs) - nullify(x_tables(ix)% logTs) + deallocate(x_tables(ix)% logTs) + nullify(x_tables(ix)% logTs) end if end do if (associated(x_tables))then - deallocate(x_tables) + deallocate(x_tables) nullify(x_tables) end if end subroutine free_co_x_tables subroutine free_co_table(co_tables, num_COs) - type (Kap_CO_Table), dimension(:), pointer :: co_tables - integer, intent(in) :: num_COs - integer :: ico - do ico = 1, num_COs + type (Kap_CO_Table), dimension(:), pointer :: co_tables + integer, intent(in) :: num_COs + integer :: ico + do ico = 1, num_COs if (associated(co_tables(ico)% kap1)) then - deallocate(co_tables(ico)% kap1) - nullify(co_tables(ico)% kap1) + deallocate(co_tables(ico)% kap1) + nullify(co_tables(ico)% kap1) end if end do if (associated(co_tables)) then - deallocate(co_tables) + deallocate(co_tables) nullify(co_tables) end if end subroutine free_co_table diff --git a/kap/test/src/sample_kap.f90 b/kap/test/src/sample_kap.f90 index 0bdfd73ac..5059f1ca6 100644 --- a/kap/test/src/sample_kap.f90 +++ b/kap/test/src/sample_kap.f90 @@ -9,7 +9,7 @@ ! by the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! -! MESA is distributed in the hope that it will be useful, +! MESA is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU Library General Public License for more details. @@ -28,7 +28,7 @@ program sample_kap use const_lib use math_lib use utils_lib, only: mesa_error - + implicit none !this program demonstrates how to use mesa/kap in a stellar structure code !it reads in a mesa/star model of an AGB star so that it makes full use @@ -41,7 +41,7 @@ program sample_kap type (Kap_General_Info), pointer :: rq1, rq2 integer, parameter :: maxpts = 2000, maxspec = 31 integer :: ierr - + integer, parameter :: h1 = 1 integer, parameter :: h2 = 2 integer, parameter :: he3 = 3 @@ -73,7 +73,7 @@ program sample_kap integer, parameter :: si30 = 29 integer, parameter :: p31 = 30 integer, parameter :: s32 = 31 - + real(dp) :: Mstar, Xc, Xn, Xo, Xne, xc_base, xn_base, xo_base, xne_base, & lnfree_e, d_lnfree_e_dlnRho, d_lnfree_e_dlnT, & eta, d_eta_dlnRho, d_eta_dlnT @@ -96,17 +96,17 @@ program sample_kap ! initialization and setup - my_mesa_dir = '../..' - call const_init(my_mesa_dir,ierr) + my_mesa_dir = '../..' + call const_init(my_mesa_dir,ierr) if (ierr /= 0) then write(*,*) 'const_init failed' call mesa_error(__FILE__,__LINE__) - end if - + end if + call math_init() call chem_init('isotopes.data', ierr) - call kap_init(use_cache, '', ierr) + call kap_init(use_cache, '', ierr) if(ierr/=0) call mesa_error(__FILE__,__LINE__,'problem in kap_init') !next it is necessary to create a 'handle' for the general kap structure @@ -115,7 +115,7 @@ program sample_kap handle1 = alloc_kap_handle_using_inlist('inlist_sample', ierr) call kap_ptr(handle1, rq1, ierr) rq1% use_Type2_opacities = .false. - + handle2 = alloc_kap_handle_using_inlist('inlist_sample', ierr) call kap_ptr(handle2, rq2, ierr) rq2% use_Type2_opacities = .true. @@ -136,10 +136,10 @@ program sample_kap read(iounit,2) Nspec !read number of chemical species in model read(iounit,*) !skip 2 lines read(iounit,*) - + write(*,*) ' Npts', Npts write(*,*) 'Nspec', Nspec - + do i=1,Npts !read model read(iounit,*) ii, lnRho(i), lnT(i), lnR(i), L, dq(i), X(1:Nspec,i) if (ii /= i) then @@ -155,9 +155,9 @@ program sample_kap rq1% Zbase = Z_init rq2% Zbase = Z_init - + logRho(:) = lnRho(:)/ln10 !convert ln's to log10's - logT(:) = lnT(:) /ln10 + logT(:) = lnT(:) /ln10 ! these should come from an eos call lnfree_e = 0d0 ! needed for Compton at high T @@ -178,7 +178,7 @@ program sample_kap end do !$omp parallel do private(i,ierr) schedule(dynamic) - do i=1,Npts + do i=1,Npts call kap_get( & handle1, Nspec, chem_id, net_iso, X(1:Nspec,i), logRho(i), logT(i), & @@ -199,7 +199,7 @@ program sample_kap open(unit=iounit,file=trim(output_file),iostat=ierr) if(ierr/=0) call mesa_error(__FILE__,__LINE__,'problem opening kap_test.data file') - + write(*,*) 'write ' // trim(output_file) write(iounit,3) 'grid', 'log_T', 'log_Rho', 'kappa', 'kappa_CO', & @@ -209,7 +209,7 @@ program sample_kap write(iounit,4) i, logT(i), logRho(i), kappa(i), kappaCO(i), & dlnkap_dlnRho(i), dlnkap_dlnT(i) enddo - + close(iounit) !all finished? then deallocate the handle and unload the opacity tables @@ -222,5 +222,5 @@ program sample_kap 2 format(37x,i6) 3 format(a28,99(a26,1x)) 4 format(i28,99(1pes26.16e3,1x)) - - end program + + end program sample_kap diff --git a/kap/test/src/test_kap.f90 b/kap/test/src/test_kap.f90 index 5d14399c5..2f9b958c0 100644 --- a/kap/test/src/test_kap.f90 +++ b/kap/test/src/test_kap.f90 @@ -2,8 +2,8 @@ program test_kap use test_kap_support use kap_lib implicit none - - call Do_One(.false.) - end + call Do_One(.false.) + + end diff --git a/kap/test/src/test_kap_quietly.f90 b/kap/test/src/test_kap_quietly.f90 index 7e9e0574a..ef00295d8 100644 --- a/kap/test/src/test_kap_quietly.f90 +++ b/kap/test/src/test_kap_quietly.f90 @@ -2,8 +2,8 @@ program test_kap_quietly use test_kap_support use kap_lib implicit none - + call Do_One(.true.) - end + end program test_kap_quietly diff --git a/kap/test/src/test_kap_support.f90 b/kap/test/src/test_kap_support.f90 index 8e6390d05..5fa27ee0d 100644 --- a/kap/test/src/test_kap_support.f90 +++ b/kap/test/src/test_kap_support.f90 @@ -9,7 +9,7 @@ module test_kap_support use const_def, only: dp, ln10, arg_not_provided use math_lib use utils_lib, only: mesa_error - + implicit none logical, parameter :: use_shared_data_dir = .true. ! if false, then test using local version data @@ -19,7 +19,7 @@ module test_kap_support character (len=32) :: my_mesa_dir integer, parameter :: ionmax = 8 - + real(dp) :: abar, zbar, z2bar, z53bar, ye, mass_correction, sumx integer, parameter :: species = 8 integer, parameter :: h1=1, he4=2, c12=3, n14=4, o16=5, ne20=6, mg24=7, fe56=8 @@ -29,8 +29,8 @@ module test_kap_support real(dp) :: X, Y, Z, Zbase contains - - + + subroutine Do_One(quietly) logical, intent(in) :: quietly @@ -76,22 +76,22 @@ subroutine test1_op_mono(quietly, test_str) xmass(ionmax), & frac_Type2, lnfree_e, d_lnfree_e_dlnRho, d_lnfree_e_dlnT, & logT, logRho, kap, log10kap, dlnkap_dlnRho, dlnkap_dlnT - + logical :: CO_enhanced logical, parameter :: dbg = .false. integer :: ierr real(dp) :: chem_factors(ionmax) - + include 'formats' - + ierr = 0 - + call setup_op_mono(ierr) if (ierr /= 0) then write(*,*) 'failed in setup_op_mono' return end if - + lnfree_e=0; d_lnfree_e_dlnRho=0; d_lnfree_e_dlnT=0 xc = 0d0 xn = 0d0 @@ -102,10 +102,10 @@ subroutine test1_op_mono(quietly, test_str) logRho = -5.7d0 z = 0.02d0 xh = 0.65d0 - - + + !call get_composition_info(Z, xh, abar, zbar, chem_id, xmass) - + chem_factors(:) = 1d0 ! scale factors for element opacity frac_Type2 = 0d0 @@ -113,22 +113,22 @@ subroutine test1_op_mono(quietly, test_str) if (ierr /= 0) return log10kap = safe_log10(kap) - + if (.not. quietly) then write(*,*) trim(test_str) write(*,'(A)') call show_args call show_results end if - - ! test element factors with pure Fe56 + + ! test element factors with pure Fe56 write(*,1) 'pure fe56; factors all 1.0' !call get_pure_fe56_composition_info(abar, zbar, chem_id, xmass, fe56) call test_op_mono(fe56,ierr) if (ierr /= 0) return write(*,'(A)') kap1 = kap - + chem_factors(fe56) = 1.75d0 write(*,1) 'pure fe56; fe56 factor increased', chem_factors(fe56) call test_op_mono(fe56,ierr) @@ -137,16 +137,16 @@ subroutine test1_op_mono(quietly, test_str) write(*,1) 'new/old', kap/kap1, kap, kap1 write(*,'(A)') - + contains - - + + subroutine setup_op_mono(ierr) integer, intent(out) :: ierr character (len=256) :: op_mono_data_path, op_mono_data_cache_filename - + ierr = 0 - + call GET_ENVIRONMENT_VARIABLE( & "MESA_OP_MONO_DATA_PATH", op_mono_data_path, status=ierr, trim_name=.true.) if (ierr /= 0) then @@ -171,15 +171,15 @@ subroutine setup_op_mono(ierr) write(*,*) 'op_mono_data_cache_filename ' // trim(op_mono_data_cache_filename) return end if - + end subroutine setup_op_mono - - + + subroutine test_op_mono(fe56,ierr) use const_def, only: Lsun, Rsun, pi integer, intent(in) :: fe56 integer, intent(out) :: ierr - + real, pointer :: & umesh(:), semesh(:), ff(:,:,:,:), ta(:,:,:,:), rs(:,:,:) integer :: kk, nel, nptot, ipe, nrad, iz(ionmax), iZ_rad(ionmax) @@ -188,9 +188,9 @@ subroutine test_op_mono(fe56,ierr) real(dp) :: flux, L, r logical, parameter :: screening = .true. !logical, parameter :: screening = .false. - + include 'formats' - + ierr = 0 !write(*,*) 'call get_op_mono_params' @@ -200,7 +200,7 @@ subroutine test_op_mono(fe56,ierr) ta(nptot,nrad,4,4), & rs(nptot,4,4), stat=ierr) if (ierr /= 0) return - + !write(*,*) 'call get_op_mono_args' call get_op_mono_args( & ionmax, xmass, 0d0, chem_id, chem_factors, & @@ -220,7 +220,7 @@ subroutine test_op_mono(fe56,ierr) kk = ionmax iZ_rad(:) = iZ(:) end if - + call op_mono_get_radacc( & ! input kk, iZ_rad, ionmax, iZ, fap, fac, & @@ -231,21 +231,21 @@ subroutine test_op_mono(fe56,ierr) ! work arrays umesh, semesh, ff, ta, rs, & ierr) - + deallocate(umesh, semesh, ff, rs, ta) if (ierr /= 0) then write(*,*) 'error in op_mono_get_radacc, ierr = ',ierr return end if - + kap = exp10(log10kap) - + if (fe56 > 0) then write(*,'(A)') write(*,1) 'grad', exp10(lgrad(kk)) write(*,1) 'lgrad', lgrad(kk) end if - + write(*,'(A)') write(*,1) 'kap', kap write(*,1) 'log10kap', log10kap @@ -255,8 +255,8 @@ subroutine test_op_mono(fe56,ierr) write(*,'(A)') end subroutine test_op_mono - - + + subroutine show_args 1 format(a40,1pe26.16) write(*,*) 'CO_enhanced', CO_enhanced @@ -273,8 +273,8 @@ subroutine show_args write(*,1) 'lnfree_e', lnfree_e write(*,'(A)') end subroutine show_args - - + + subroutine show_results use utils_lib 1 format(a40,1pe26.16) @@ -292,11 +292,11 @@ subroutine show_results write(*,*) 'bad log10kap' end if end subroutine show_results - - + + end subroutine test1_op_mono - - + + subroutine test1(quietly, which, test_str, ierr) use kap_def, only: Kap_General_Info, num_kap_fracs, i_frac_Type2 logical, intent(in) :: quietly @@ -318,37 +318,37 @@ subroutine test1(quietly, which, test_str, ierr) character(len=64) :: inlist integer :: eos_handle, kap_handle type (Kap_General_Info), pointer :: rq - + logical :: CO_enhanced logical, parameter :: dbg = .false. include 'formats' - + ierr = 0 xa = 0 X = 0; Z = 0; xc = 0; xn = 0; xo = 0; xne = 0 - + select case(which) case (0) ! special test - + case (1) ! fixed inlist = 'inlist_test_fixed' - + CO_enhanced = .false. logT = 6d0 logRho = -6d0 X = 0.7d0 Z = 0.018d0 - + xa(h1) = X xa(he4) = 1d0 - X - Z xa(fe56) = Z - + case (2) ! co inlist = 'inlist_test_co' - + CO_enhanced = .true. logT = 6d0 logRho = -6d0 @@ -376,7 +376,7 @@ subroutine test1(quietly, which, test_str, ierr) case (3) ! OP call mesa_error(__FILE__,__LINE__) - + case (4) ! AESOPUS inlist = 'inlist_aesopus' @@ -396,7 +396,7 @@ subroutine test1(quietly, which, test_str, ierr) xa(c12) = xc xa(n14) = xn xa(o16) = xo - + end select @@ -419,7 +419,7 @@ subroutine test1(quietly, which, test_str, ierr) eta = res(i_eta) d_eta_dlnRho = deos_dlnd(i_eta) d_eta_dlnT = deos_dlnT(i_eta) - + kap_handle = alloc_kap_handle_using_inlist(inlist, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) @@ -432,7 +432,7 @@ subroutine test1(quietly, which, test_str, ierr) kap_fracs, kap, dlnkap_dlnRho, dlnkap_dlnT, dlnkap_dxa, ierr) log10kap = safe_log10(kap) - + if (.not. quietly) then write(*,*) 'test number', which write(*,*) trim(test_str) @@ -442,7 +442,7 @@ subroutine test1(quietly, which, test_str, ierr) end if contains - + subroutine show_args 1 format(a40,1pe26.16) write(*,*) 'CO_enhanced', CO_enhanced @@ -479,24 +479,24 @@ subroutine show_results end subroutine show_results end subroutine test1 - + subroutine setup(quietly) use chem_lib use const_lib logical, intent(in) :: quietly - + integer :: ierr logical, parameter :: use_cache = .true. - + my_mesa_dir = '../..' - + call const_init(my_mesa_dir,ierr) if (ierr /= 0) then write(*,*) 'const_init failed' call mesa_error(__FILE__,__LINE__) end if - + call math_init() call chem_init('isotopes.data', ierr) @@ -507,12 +507,12 @@ subroutine setup(quietly) call eos_init('', use_cache, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - - call kap_init(use_cache, '', ierr) + + call kap_init(use_cache, '', ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + end subroutine setup - - + + end module test_kap_support diff --git a/math/private/math_io.f90 b/math/private/math_io.f90 index f4a362b6c..d07d27b5e 100644 --- a/math/private/math_io.f90 +++ b/math/private/math_io.f90 @@ -91,11 +91,11 @@ subroutine str_to_vector (str, vec, n, ierr) j = k+1 end do - + end subroutine str_to_vector !**** - + subroutine str_to_double (str, x, ierr) character(*), intent(in) :: str @@ -105,7 +105,7 @@ subroutine str_to_double (str, x, ierr) read(str, *, ROUND='COMPATIBLE', IOSTAT=ierr) x end subroutine str_to_double - + !**** subroutine double_to_str (x, str) @@ -119,5 +119,5 @@ subroutine double_to_str (x, str) 100 format(1PD26.16) end subroutine double_to_str - + end module math_io diff --git a/math/public/math_def.f90 b/math/public/math_def.f90 index 4ae9a171e..04a52d335 100644 --- a/math/public/math_def.f90 +++ b/math/public/math_def.f90 @@ -28,9 +28,9 @@ module math_def ! Uses use const_def - + ! No implicit typing - + implicit none integer, parameter :: max_precomp_ints = 1000 diff --git a/math/public/math_lib_crmath.f90 b/math/public/math_lib_crmath.f90 index 0f7404931..7144642bc 100644 --- a/math/public/math_lib_crmath.f90 +++ b/math/public/math_lib_crmath.f90 @@ -145,7 +145,7 @@ elemental function safe_sqrt_ (x) result (sqrt_x) sqrt_x = SQRT(MAX(x, 0._dp)) end function safe_sqrt_ - + !**** elemental function safe_log_ (x) result (log_x) @@ -203,7 +203,7 @@ elemental function exp10_ (x) result (exp10_x) do i = 1, ABS(ix) exp10_x = exp10_x*10._dp end do - + if (ix < 0) exp10_x = 1._dp/exp10_x else @@ -223,7 +223,7 @@ elemental function pow_i_ (x, iy) result (pow_x) real(dp) :: pow_x integer :: i - + if (x == 0._dp) then pow_x = 0._dp @@ -231,13 +231,13 @@ elemental function pow_i_ (x, iy) result (pow_x) else pow_x = 1._dp - + do i = 1, ABS(iy) pow_x = pow_x*x end do if (iy < 0) pow_x = 1._dp/pow_x - + endif end function pow_i_ @@ -252,7 +252,7 @@ elemental function pow_r_ (x, y) result (pow_x) integer :: iy integer :: i - + if (x == 0._dp) then pow_x = 0._dp @@ -264,13 +264,13 @@ elemental function pow_r_ (x, y) result (pow_x) if (y == iy .AND. ABS(iy) < 100) then ! integer power of x pow_x = 1._dp - + do i = 1, ABS(iy) pow_x = pow_x*x end do if (iy < 0) pow_x = 1._dp/pow_x - + else pow_x = exp(log(x)*y) diff --git a/math/public/math_lib_intrinsic.f90 b/math/public/math_lib_intrinsic.f90 index 5859c6dca..76d78d829 100644 --- a/math/public/math_lib_intrinsic.f90 +++ b/math/public/math_lib_intrinsic.f90 @@ -163,7 +163,7 @@ elemental function safe_sqrt_ (x) result (sqrt_x) sqrt_x = SQRT(MAX(x, 0._dp)) end function safe_sqrt_ - + !**** elemental function safe_log_ (x) result (log_x) @@ -243,7 +243,7 @@ elemental function exp10_ (x) result (exp10_x) do i = 1, ABS(ix) exp10_x = exp10_x*10._dp end do - + if (ix < 0) exp10_x = 1._dp/exp10_x else @@ -274,7 +274,7 @@ elemental function pow_i_ (x, iy) result (pow_x) real(dp) :: pow_x pow_x = x**iy - + end function pow_i_ !**** @@ -286,7 +286,7 @@ elemental function pow_r_ (x, y) result (pow_x) real(dp) :: pow_x pow_x = x**y - + end function pow_r_ !**** diff --git a/math/test/src/test_math.f90 b/math/test/src/test_math.f90 index c4b423142..95de0b844 100644 --- a/math/test/src/test_math.f90 +++ b/math/test/src/test_math.f90 @@ -1,5 +1,5 @@ program test_math - + use const_lib use utils_lib use math_lib diff --git a/mtx/private/DGBSVX_wrapper.f90 b/mtx/private/DGBSVX_wrapper.f90 index 0d51bcb2f..d4889ad89 100644 --- a/mtx/private/DGBSVX_wrapper.f90 +++ b/mtx/private/DGBSVX_wrapper.f90 @@ -46,7 +46,7 @@ subroutine DGBSVX_banded_wrapper(matrix_size, n_upper_bands, n_lower_bands, band ! Fixed arguments - FACT = 'N' ! We've already equilibrated the matrix + FACT = 'N' ! We've already equilibrated the matrix TRANS = 'N' ! This argument is irrelevant if FACT == 'N' EQUED = 'N' ! No equilibration NRHS = 1 ! Number of columns in equ for A.x=b. @@ -70,7 +70,7 @@ subroutine DGBSVX_banded_wrapper(matrix_size, n_upper_bands, n_lower_bands, band ! (k,j) -> (n_upper_bands+1+k-j,j) AB = 0d0 - ! In the upper bands, upper band i at index j (bands(i,j)) corresponds to + ! In the upper bands, upper band i at index j (bands(i,j)) corresponds to ! position (j, n_upper_bands - i + j + 1) in the matrix. This is then ! position (i, n_upper_bands - i + j + 1) in AB. do i=1,n_upper_bands @@ -79,7 +79,7 @@ subroutine DGBSVX_banded_wrapper(matrix_size, n_upper_bands, n_lower_bands, band end do end do - ! In the lower bands, lower band i+1+n_upper_bands at index j corresponds to + ! In the lower bands, lower band i+1+n_upper_bands at index j corresponds to ! position (i+j, j) in the matrix. This is then ! position (n_upper_bands+1+i, j) in AB. do i=1,n_lower_bands @@ -106,7 +106,7 @@ subroutine DGBSVX_banded_wrapper(matrix_size, n_upper_bands, n_lower_bands, band write(*,*) 'ierr = ', ierr write(*,*) 'N = ', matrix_size - open(unit=10, file="bands.data") + open(unit=10, file="bands.data") do j=1,LDAB do i=1,matrix_size write(10,*) bands(j,i) @@ -163,15 +163,15 @@ subroutine DGBSVX_tridiagonal_wrapper(ublk, lblk, dblk, pre_conditioner, x, b, n ! Fixed arguments - FACT = 'N' ! We've already equilibrated the matrix + FACT = 'N' ! We've already equilibrated the matrix TRANS = 'N' ! This argument is irrelevant if FACT == 'N' EQUED = 'N' ! No equilibration N = nblocks * nvar ! Number of equations - KL = 2 * nvar ! Number of lower bands. We round up to the max number + KL = 2 * nvar ! Number of lower bands. We round up to the max number ! which could be held by the block triadiagonal matrix. ! If performance is ever an issue this solve can be sped ! up by tightening KL. - KU = 2 * nvar ! Number of upper bands. We round up to the max number + KU = 2 * nvar ! Number of upper bands. We round up to the max number ! which could be held by the block triadiagonal matrix. ! If performance is ever an issue this solve can be sped ! up by tightening KU. diff --git a/mtx/private/bcyclic.f90 b/mtx/private/bcyclic.f90 index f23688db2..0ef3bb2ed 100644 --- a/mtx/private/bcyclic.f90 +++ b/mtx/private/bcyclic.f90 @@ -25,21 +25,21 @@ module bcyclic use const_def, only: dp use my_lapack95 use utils_lib, only: set_nan, mesa_error - + implicit none - + type ulstore integer :: ul_size ! size of umat1 & lmat1 (0 if not allocated) real(dp), pointer :: umat1(:), lmat1(:) end type ulstore type(ulstore), pointer :: odd_storage(:) => null() - + logical, parameter :: dbg = .false. - + logical, parameter :: do_fill_with_NaNs = .false. - - + + contains @@ -58,7 +58,7 @@ subroutine bcyclic_factor ( & real(dp), pointer, intent(inout) :: rpar_decsol(:) ! (lrd) integer, pointer, intent(inout) :: ipar_decsol(:) ! (lid) integer, intent(out) :: ierr - + integer, pointer :: nslevel(:), ipivot(:) integer :: ncycle, nstemp, maxlevels, nlevel logical :: have_odd_storage @@ -66,9 +66,9 @@ subroutine bcyclic_factor ( & real(dp) :: dlamch, sfmin include 'formats' - - ierr = 0 - + + ierr = 0 + if (dbg) write(*,*) 'start bcyclic_factor' ! compute number of cyclic reduction levels @@ -79,7 +79,7 @@ subroutine bcyclic_factor ( & maxlevels = maxlevels+1 end do maxlevels = max(1, maxlevels) - + have_odd_storage = associated(odd_storage) if (have_odd_storage) then if (size(odd_storage) < maxlevels) then @@ -101,12 +101,12 @@ subroutine bcyclic_factor ( & allocate (nslevel(maxlevels), stat=ierr) if (ierr /= 0) return - + if (sparse) then write(*,*) 'no support for sparse matrix in bcyclic' ierr = -1 return - end if + end if ncycle = 1 nstemp = nz @@ -117,7 +117,7 @@ subroutine bcyclic_factor ( & factor_cycle: do ! perform cyclic-reduction factorization nslevel(nlevel) = nstemp - + if (dbg) write(*,2) 'call cycle_onestep', nstemp call cycle_onestep( & @@ -129,41 +129,41 @@ subroutine bcyclic_factor ( & return end if - if (nstemp == 1) exit - + if (nstemp == 1) exit factor_cycle + nstemp = (nstemp+1)/2 nlevel = nlevel+1 ncycle = 2*ncycle - if (nlevel > maxlevels) exit + if (nlevel > maxlevels) exit factor_cycle end do factor_cycle if (dbg) write(*,*) 'done factor_cycle' - + ! factor row 1 dmat(1:nvar,1:nvar) => dblk1(1:nvar*nvar) - sfmin = dlamch('S') + sfmin = dlamch('S') ipivot(1:nvar) => ipivot1(1:nvar) - call my_getf2(nvar, dmat, nvar, ipivot, sfmin, ierr) + call my_getf2(nvar, dmat, nvar, ipivot, sfmin, ierr) if (ierr /= 0) then write(*,*) 'row 1 factor failed in bcyclic_factor' call dealloc return end if - + call dealloc - - + + if (dbg) write(*,*) 'done bcyclic_factor' - - contains - + + contains + subroutine dealloc deallocate (nslevel) end subroutine dealloc - - + + end subroutine bcyclic_factor @@ -182,17 +182,17 @@ subroutine bcyclic_solve ( & real(dp), pointer, intent(inout) :: rpar_decsol(:) ! (lrd) integer, pointer, intent(inout) :: ipar_decsol(:) ! (lid) integer, intent(out) :: ierr - + integer, pointer :: nslevel(:), ipivot(:) integer :: ncycle, nstemp, maxlevels, nlevel, nvar2 real(dp), pointer, dimension(:,:) :: dmat, bptr2 include 'formats' - - + + if (dbg) write(*,*) 'start bcyclic_solve' - ierr = 0 + ierr = 0 nvar2 = nvar*nvar ncycle = 1 maxlevels = 0 @@ -208,7 +208,7 @@ subroutine bcyclic_solve ( & ncycle = 1 nstemp = nz nlevel = 1 - + if (dbg) write(*,*) 'start forward_cycle' forward_cycle: do @@ -222,18 +222,18 @@ subroutine bcyclic_solve ( & return end if - if (nstemp == 1) exit - + if (nstemp == 1) exit forward_cycle + nstemp = (nstemp+1)/2 nlevel = nlevel+1 ncycle = 2*ncycle - if (nlevel > maxlevels) exit + if (nlevel > maxlevels) exit forward_cycle end do forward_cycle - + if (dbg) write(*,*) 'done forward_cycle' - + ipivot(1:nvar) => ipivot1(1:nvar) dmat(1:nvar,1:nvar) => dblk1(1:nvar2) bptr2(1:nvar,1:1) => brhs1(1:nvar) @@ -243,35 +243,35 @@ subroutine bcyclic_solve ( & call dealloc return end if - + ! back solve for even x's - back_cycle: do while (ncycle > 1) + back_cycle: do while (ncycle > 1) ncycle = ncycle/2 nlevel = nlevel-1 if (nlevel < 1) then ierr = -1 - exit + exit back_cycle end if nstemp = nslevel(nlevel) call cycle_solve( & nvar, nz, ncycle, nstemp, nlevel, sparse, lblk1, ublk1, brhs1) end do back_cycle - + call dealloc - + if (dbg) write(*,*) 'done bcyclic_solve' - - - contains - + + + contains + subroutine dealloc deallocate (nslevel) end subroutine dealloc end subroutine bcyclic_solve - - + + subroutine clear_storage integer :: nlevel nlevel = size(odd_storage) @@ -295,7 +295,7 @@ subroutine cycle_onestep( & real(dp), pointer, intent(inout) :: lblk1(:), dblk1(:), ublk1(:) integer, pointer, intent(inout) :: ipivot1(:) integer, intent(out) :: ierr - + integer, pointer :: ipivot(:) real(dp), pointer, dimension(:,:) :: dmat, umat, lmat, umat0, lmat0 real(dp), pointer, dimension(:,:) :: lnext, unext, lprev, uprev @@ -303,18 +303,18 @@ subroutine cycle_onestep( & integer :: i, shift, min_sz, new_sz, shift1, shift2, nvar2, & ns, ierr_loc, nmin, kcount, k real(dp) :: dlamch, sfmin - + include 'formats' ierr = 0 - sfmin = dlamch('S') - nvar2 = nvar*nvar + sfmin = dlamch('S') + nvar2 = nvar*nvar nmin = 1 kcount = 1+(nblk-nmin)/2 min_sz = nvar2*kcount if (odd_storage(nlevel)% ul_size < min_sz) then if (odd_storage(nlevel)% ul_size > 0) & - deallocate(odd_storage(nlevel)% umat1, odd_storage(nlevel)% lmat1) + deallocate(odd_storage(nlevel)% umat1, odd_storage(nlevel)% lmat1) new_sz = FLOOR(min_sz*1.1) + 100 odd_storage(nlevel)% ul_size = new_sz allocate (odd_storage(nlevel)% umat1(new_sz), & @@ -342,10 +342,10 @@ subroutine cycle_onestep( & ierr = -1 return end if - + if (dbg) write(*,*) 'start lu factorization' ! compute lu factorization of even diagonal blocks - nmin = 2 + nmin = 2 !$omp parallel do schedule(static,3) & !$omp private(ipivot,dmat,ns,ierr_loc,shift1,shift2,k) do ns = nmin, nblk, 2 @@ -355,11 +355,11 @@ subroutine cycle_onestep( & dmat(1:nvar,1:nvar) => dblk1(shift2+1:shift2+nvar2) ierr_loc = 0 ipivot(1:nvar) => ipivot1(shift1+1:shift1+nvar) - call my_getf2(nvar, dmat, nvar, ipivot, sfmin, ierr_loc) + call my_getf2(nvar, dmat, nvar, ipivot, sfmin, ierr_loc) if (ierr_loc /= 0) then ierr = ierr_loc end if - end do + end do !$omp end parallel do if (ierr /= 0) then !write(*,*) 'factorization failed in bcyclic' @@ -370,7 +370,7 @@ subroutine cycle_onestep( & !$omp parallel do schedule(static,3) & !$omp private(ns,k,shift1,shift2,ipivot,dmat,umat,lmat,mat1,ierr_loc) - do ns = nmin, nblk, 2 + do ns = nmin, nblk, 2 ! compute new l=-d[-1]l, u=-d[-1]u for even blocks k = ncycle*(ns-1) + 1 shift1 = nvar*(k-1) @@ -385,7 +385,7 @@ subroutine cycle_onestep( & call my_getrs(nvar, nvar, dmat, nvar, ipivot, umat, nvar, ierr_loc) if (ierr_loc /= 0) ierr = ierr_loc umat = -umat - end do + end do !$omp end parallel do if (dbg) write(*,*) 'done solve' @@ -397,7 +397,7 @@ subroutine cycle_onestep( & !$omp parallel do schedule(static,3) & !$omp private(i,ns,shift2,dmat,umat,lmat,lnext,unext,lprev,uprev,kcount,shift,umat0,lmat0,k) do i = 1, 3*(1+(nblk-nmin)/2) - + ns = 2*((i-1)/3) + nmin k = ncycle*(ns-1) + 1 shift2 = nvar2*(k-1) @@ -427,7 +427,7 @@ subroutine cycle_onestep( & if (ns > 1) then ! lmat = matmul(lmat0, lprev) call my_gemm0_p1(nvar,nvar,nvar,lmat0,nvar,lprev,nvar,lmat,nvar) - end if + end if case (1) if (ns < nblk) then ! umat = matmul(umat0, unext) @@ -445,7 +445,7 @@ subroutine cycle_onestep( & else if (ns > 1) then ! dmat = dmat + matmul(lmat0,uprev) call my_gemm_p1(nvar,nvar,nvar,lmat0,nvar,uprev,nvar,dmat,nvar) - end if + end if end select end do @@ -463,14 +463,14 @@ subroutine cycle_rhs( & real(dp), pointer, intent(inout) :: brhs1(:) integer, pointer, intent(in) :: ipivot1(:) integer, intent(out) :: ierr - + integer :: k, ns, ierr_loc, nmin, kcount, shift, shift1, shift2, nvar2 integer, pointer :: ipivot(:) real(dp), pointer, dimension(:,:) :: dmat, umat, lmat, bptr2 real(dp), pointer, dimension(:) :: bprev, bnext, bptr - + include 'formats' - + ierr = 0 nvar2 = nvar*nvar ! compute dblk[-1]*brhs for even indices and store in brhs(even) @@ -500,7 +500,7 @@ subroutine cycle_rhs( & shift1 = nvar*ncycle*(ns-1) bptr(1:nvar) => brhs1(shift1+1:shift1+nvar) kcount = 1+(ns-nmin)/2 - shift = nvar2*(kcount-1) + shift = nvar2*(kcount-1) umat(1:nvar,1:nvar) => odd_storage(nlevel)% umat1(shift+1:shift+nvar2) lmat(1:nvar,1:nvar) => odd_storage(nlevel)% lmat1(shift+1:shift+nvar2) if (ns > 1) then @@ -521,7 +521,7 @@ subroutine cycle_rhs( & ! bptr = bptr - matmul(lmat,bprev) call my_gemv(nvar,nvar,lmat,nvar,bprev,bptr) end if - end do + end do !$omp end parallel do if (nvar2*kcount > odd_storage(nlevel)% ul_size) then @@ -537,7 +537,7 @@ end subroutine cycle_rhs ! odd index solutions at this level. ! note at this point, the odd brhs values have been replaced (at the highest cycle) ! with the solution values (x), at subsequent (lower) cycles, the - ! odd values are replaced by the even solutions at the next highest cycle. the even + ! odd values are replaced by the even solutions at the next highest cycle. the even ! brhs values were multiplied by d[-1] and stored in cycle_rhs ! solve for even index values in terms of (computed at this point) odd index values subroutine cycle_solve( & @@ -582,7 +582,7 @@ subroutine cycle_solve( & !$omp end parallel do end subroutine cycle_solve - + subroutine bcyclic_deallocate ( & lblk1, dblk1, ublk1, ipivot1, brhs1, nvar, nz, sparse, & @@ -598,9 +598,9 @@ subroutine bcyclic_deallocate ( & integer, intent(in) :: lrd, lid real(dp), pointer, intent(inout) :: rpar_decsol(:) ! (lrd) integer, pointer, intent(inout) :: ipar_decsol(:) ! (lid) - integer, intent(out) :: ierr + integer, intent(out) :: ierr ierr = 0 end subroutine bcyclic_deallocate - - + + end module bcyclic diff --git a/mtx/private/mtx_support.f90 b/mtx/private/mtx_support.f90 index 53c4ed4b7..d9d2bb52c 100644 --- a/mtx/private/mtx_support.f90 +++ b/mtx/private/mtx_support.f90 @@ -25,21 +25,21 @@ module mtx_support - + use const_def, only: dp, qp use utils_lib, only: mesa_error - + integer, parameter :: num_chunks = 4 contains - + subroutine do_dense_to_band(n,ndim,a,ml,mu,ab,ldab,ierr) integer, intent(in) :: n,ndim,ml,mu,ldab real(dp), intent(in) :: a(:,:) ! (ndim,n) real(dp), intent(inout) :: ab(:,:) ! (ldab,n) - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: i, j if (ml+mu+1 > n) then ierr = -1 @@ -54,12 +54,12 @@ subroutine do_dense_to_band(n,ndim,a,ml,mu,ab,ldab,ierr) end do end subroutine do_dense_to_band - + subroutine do_band_to_dense(n,ml,mu,ab,ldab,ndim,a,ierr) integer, intent(in) :: n,ndim,ml,mu,ldab real(dp), intent(in) :: ab(:,:) ! (ldab,n) real(dp), intent(inout) :: a(:,:) ! (ndim,n) - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: i, j if (ml+mu+1 > n) then ierr = -1 @@ -74,7 +74,7 @@ subroutine do_band_to_dense(n,ml,mu,ab,ldab,ndim,a,ierr) end do end subroutine do_band_to_dense - + subroutine do_band_to_column_sparse(n,ml,mu,ab,ldab,nzmax,nz,colptr,rowind,values,diags,ierr) integer, intent(in) :: n,ml,mu,nzmax,ldab real(dp), intent(in) :: ab(ldab,n) @@ -85,7 +85,7 @@ subroutine do_band_to_column_sparse(n,ml,mu,ab,ldab,nzmax,nz,colptr,rowind,value ! integer, intent(inout) :: rowind(:) ! (nzmax) ! real(dp), intent(inout) :: values(:) ! (nzmax) logical, intent(in) :: diags - integer, intent(out) :: nz,ierr + integer, intent(out) :: nz,ierr integer :: i, j if (ml+mu+1 > n) then ierr = -1 @@ -110,13 +110,13 @@ subroutine do_band_to_column_sparse(n,ml,mu,ab,ldab,nzmax,nz,colptr,rowind,value rowind(nz) = i end do end do - colptr(n+1) = nz+1 + colptr(n+1) = nz+1 end subroutine do_band_to_column_sparse - - + + subroutine do_column_sparse_to_band(n,ml,mu,ab,ldab,nz,colptr,rowind,values,ierr) integer, intent(in) :: n,ml,mu,nz,ldab - + real(dp), intent(inout) :: ab(ldab,n) integer, intent(in) :: colptr(n+1),rowind(nz) real(dp), intent(in) :: values(nz) @@ -124,13 +124,13 @@ subroutine do_column_sparse_to_band(n,ml,mu,ab,ldab,nz,colptr,rowind,values,ierr ! integer, intent(inout) :: colptr(:) ! (n+1) ! integer, intent(inout) :: rowind(:) ! (nzmax) ! real(dp), intent(in) :: values(:) ! (nz) - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: i,j,k ierr = 0 ab = 0 do j=1,n do k=colptr(j),colptr(j+1)-1 - i = rowind(k) + i = rowind(k) if (i > j+ml .or. i < j-mu) then ierr = j return @@ -140,10 +140,10 @@ subroutine do_column_sparse_to_band(n,ml,mu,ab,ldab,nz,colptr,rowind,values,ierr end do end subroutine do_column_sparse_to_band - + subroutine do_band_to_row_sparse(n,ml,mu,ab,ldab,nzmax,nz,rowptr,colind,values,diags,ierr) integer, intent(in) :: n,ml,mu,nzmax,ldab - + real(dp), intent(in) :: ab(ldab,n) integer, intent(inout) :: rowptr(n+1),colind(nzmax) real(dp), intent(inout) :: values(nzmax) @@ -155,13 +155,13 @@ subroutine do_band_to_row_sparse(n,ml,mu,ab,ldab,nzmax,nz,rowptr,colind,values,d integer, intent(out) :: ierr, nz integer :: idiag, op_err, j1, j2, k, i, nz1 integer, dimension(num_chunks) :: nz_per_chunk, nz_start, nz_max, i_lo, i_hi - + logical, parameter :: dbg = .false. - + include 'formats' - + if (dbg) write(*,*) 'enter do_band_to_row_sparse' - + if (ml+mu+1 > n) then ierr = -1 if (dbg) then @@ -171,11 +171,11 @@ subroutine do_band_to_row_sparse(n,ml,mu,ab,ldab,nzmax,nz,rowptr,colind,values,d end if return end if - + ierr = 0 nz = 0 idiag = ldab - ml - + nz_start(1) = 1 i_lo(1) = 1 do k = 2, num_chunks @@ -186,7 +186,7 @@ subroutine do_band_to_row_sparse(n,ml,mu,ab,ldab,nzmax,nz,rowptr,colind,values,d end do nz_max(num_chunks) = nzmax i_hi(num_chunks) = n - + if (dbg) write(*,*) 'do_band_to_row_sparse - do chunks' op_err = 0 !$OMP PARALLEL DO PRIVATE(k,op_err) @@ -198,15 +198,15 @@ subroutine do_band_to_row_sparse(n,ml,mu,ab,ldab,nzmax,nz,rowptr,colind,values,d end do !$OMP END PARALLEL DO if (dbg) write(*,*) 'do_band_to_row_sparse - done chunks' - + if (ierr /= 0) then - + write(*,*) 'do_band_to_row_sparse: failed to fit in chunks' write(*,*) 'please increase the max fill factor for your sparse matrix' call mesa_error(__FILE__,__LINE__) - - else - + + else + if (dbg) then do k=1,num_chunks write(*,2) 'k', k @@ -218,7 +218,7 @@ subroutine do_band_to_row_sparse(n,ml,mu,ab,ldab,nzmax,nz,rowptr,colind,values,d write(*,'(A)') end do end if - + ! reposition the chunk results if (dbg) write(*,*) 'reposition the chunk results' i = nz_per_chunk(1) @@ -245,11 +245,11 @@ subroutine do_band_to_row_sparse(n,ml,mu,ab,ldab,nzmax,nz,rowptr,colind,values,d end do nz = i end if - + rowptr(n+1) = nz+1 !write(*,*) 'done do_band_to_row_sparse - fill fraction', dble(nz)/dble(nzmax) - + end subroutine do_band_to_row_sparse @@ -268,13 +268,13 @@ subroutine do_chunk_band_to_row_sparse( & ! real(dp), intent(inout) :: values(:) ! (nzmax) integer, dimension(num_chunks) :: nz_per_chunk, nz_start, nz_max, i_lo, i_hi integer, intent(out) :: ierr - + integer :: i, j, nz real(dp) :: val - + logical, parameter :: dbg = .false. include 'formats' - + ierr = 0 nz = nz_start(num) - 1 do i = i_lo(num), i_hi(num) @@ -303,7 +303,7 @@ subroutine do_chunk_band_to_row_sparse( & end subroutine do_chunk_band_to_row_sparse - + subroutine do_row_sparse_to_band(n,ml,mu,ab,ldab,nz,rowptr,colind,values,ierr) integer, intent(in) :: n,ml,mu,nz,ldab real(dp), intent(inout) :: ab(ldab,n) @@ -313,13 +313,13 @@ subroutine do_row_sparse_to_band(n,ml,mu,ab,ldab,nz,rowptr,colind,values,ierr) ! integer, intent(inout) :: rowptr(:) ! (n+1) ! integer, intent(inout) :: colind(:) ! (nz) ! real(dp), intent(in) :: values(:) ! (nz) - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: i,j,k ierr = 0 ab = 0 do i=1,n do k=rowptr(i),rowptr(i+1)-1 - j = colind(k) + j = colind(k) if (i > j+ml .or. i < j-mu) then ierr = j return @@ -331,7 +331,7 @@ end subroutine do_row_sparse_to_band ! sparse conversion based on similar routines from sparskit_src/formats.f - + subroutine do_dense_to_row_sparse(n,ndim,a,nzmax,nz,rowptr,colind,values,diags,ierr) integer, intent(in) :: n,ndim,nzmax !real(dp), intent(in) :: a(ndim,n) @@ -342,8 +342,8 @@ subroutine do_dense_to_row_sparse(n,ndim,a,nzmax,nz,rowptr,colind,values,diags,i integer, intent(inout) :: colind(:) ! (nzmax) real(dp), intent(inout) :: values(:) ! (nzmax) logical, intent(in) :: diags - integer, intent(out) :: nz,ierr - integer :: i,j + integer, intent(out) :: nz,ierr + integer :: i,j ierr = 0 nz = 0 do i=1,n @@ -363,10 +363,10 @@ subroutine do_dense_to_row_sparse(n,ndim,a,nzmax,nz,rowptr,colind,values,diags,i colind(nz) = j end do end do - rowptr(n+1) = nz+1 + rowptr(n+1) = nz+1 end subroutine do_dense_to_row_sparse - - + + subroutine do_dense_to_row_sparse_0_based( & n,ndim,a,nzmax,nz,rowptr,colind,values,diags,ierr) integer, intent(in) :: n,ndim,nzmax @@ -378,8 +378,8 @@ subroutine do_dense_to_row_sparse_0_based( & integer, intent(inout) :: colind(:) ! (nzmax) real(dp), intent(inout) :: values(:) ! (nzmax) logical, intent(in) :: diags - integer, intent(out) :: nz,ierr - integer :: i,j + integer, intent(out) :: nz,ierr + integer :: i,j ierr = 0 nz = 0 do i=1,n @@ -399,11 +399,11 @@ subroutine do_dense_to_row_sparse_0_based( & colind(nz) = j-1 end do end do - rowptr(n+1) = nz + rowptr(n+1) = nz end subroutine do_dense_to_row_sparse_0_based - subroutine do_row_sparse_to_dense(n,ndim,a,nz,rowptr,colind,values,ierr) + subroutine do_row_sparse_to_dense(n,ndim,a,nz,rowptr,colind,values,ierr) integer, intent(in) :: n,ndim,nz real(dp), intent(inout) :: a(ndim,n) integer, intent(in) :: rowptr(n+1),colind(nz) @@ -412,13 +412,13 @@ subroutine do_row_sparse_to_dense(n,ndim,a,nz,rowptr,colind,values,ierr) ! integer, intent(inout) :: rowptr(:) ! (n+1) ! integer, intent(inout) :: colind(:) ! (nz) ! real(dp), intent(inout) :: values(:) ! (nz) - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: i,j,k ierr = 0 a = 0 do i=1,n do k=rowptr(i),rowptr(i+1)-1 - j = colind(k) + j = colind(k) if (j > n) then ierr = i return @@ -429,18 +429,18 @@ subroutine do_row_sparse_to_dense(n,ndim,a,nz,rowptr,colind,values,ierr) end subroutine do_row_sparse_to_dense - subroutine do_row_sparse_0_based_to_dense(n,ndim,a,nz,rowptr,colind,values,ierr) + subroutine do_row_sparse_0_based_to_dense(n,ndim,a,nz,rowptr,colind,values,ierr) integer, intent(in) :: n,ndim,nz real(dp), intent(inout) :: a(ndim,n) integer, intent(in) :: rowptr(0:n),colind(0:nz-1) real(dp), intent(in) :: values(nz) - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: i,j,k ierr = 0 a = 0 do i=1,n do k=rowptr(i),rowptr(i+1)-1 - j = colind(k) + j = colind(k) if (j > n) then ierr = i return @@ -450,7 +450,7 @@ subroutine do_row_sparse_0_based_to_dense(n,ndim,a,nz,rowptr,colind,values,ierr) end do end subroutine do_row_sparse_0_based_to_dense - + subroutine do_dense_to_column_sparse(n,ndim,a,nzmax,nz,colptr,rowind,values,diags,ierr) integer, intent(in) :: n,ndim,nzmax !real(dp), intent(in) :: a(ndim,n) @@ -461,8 +461,8 @@ subroutine do_dense_to_column_sparse(n,ndim,a,nzmax,nz,colptr,rowind,values,diag integer, intent(inout) :: rowind(:) ! (nzmax) real(dp), intent(inout) :: values(:) ! (nzmax) logical, intent(in) :: diags - integer, intent(out) :: nz,ierr - integer :: i,j + integer, intent(out) :: nz,ierr + integer :: i,j ierr = 0 nz = 0 do j=1,n @@ -482,10 +482,10 @@ subroutine do_dense_to_column_sparse(n,ndim,a,nzmax,nz,colptr,rowind,values,diag rowind(nz) = i end do end do - colptr(n+1) = nz+1 + colptr(n+1) = nz+1 end subroutine do_dense_to_column_sparse - + subroutine do_dense_to_col_sparse_0_based( & n,ndim,a,nzmax,nz,colptr,rowind,values,diags,ierr) integer, intent(in) :: n,ndim,nzmax @@ -497,8 +497,8 @@ subroutine do_dense_to_col_sparse_0_based( & integer, intent(inout) :: rowind(:) ! (nzmax) real(dp), intent(inout) :: values(:) ! (nzmax) logical, intent(in) :: diags - integer, intent(out) :: nz,ierr - integer :: i,j + integer, intent(out) :: nz,ierr + integer :: i,j ierr = 0 nz = 0 do j=1,n @@ -518,10 +518,10 @@ subroutine do_dense_to_col_sparse_0_based( & rowind(nz) = i-1 end do end do - colptr(n+1) = nz + colptr(n+1) = nz end subroutine do_dense_to_col_sparse_0_based - + subroutine do_dense_to_col_sparse_0_based_qp( & n,ndim,a,nzmax,nz,colptr,rowind,values,diags,ierr) integer, intent(in) :: n,ndim,nzmax @@ -533,8 +533,8 @@ subroutine do_dense_to_col_sparse_0_based_qp( & integer, intent(inout) :: rowind(:) ! (nzmax) real(qp), intent(out) :: values(:) ! (nzmax) logical, intent(in) :: diags - integer, intent(out) :: nz,ierr - integer :: i,j + integer, intent(out) :: nz,ierr + integer :: i,j ierr = 0 nz = 0 do j=1,n @@ -554,11 +554,11 @@ subroutine do_dense_to_col_sparse_0_based_qp( & rowind(nz) = i-1 end do end do - colptr(n+1) = nz + colptr(n+1) = nz end subroutine do_dense_to_col_sparse_0_based_qp - - subroutine do_column_sparse_to_dense(n,ndim,a,nz,colptr,rowind,values,ierr) + + subroutine do_column_sparse_to_dense(n,ndim,a,nz,colptr,rowind,values,ierr) integer, intent(in) :: n,ndim,nz real(dp), intent(inout) :: a(ndim,n) integer, intent(in) :: colptr(n+1),rowind(nz) @@ -567,13 +567,13 @@ subroutine do_column_sparse_to_dense(n,ndim,a,nz,colptr,rowind,values,ierr) ! integer, intent(in) :: colptr(:) ! (n+1) ! integer, intent(in) :: rowind(:) ! (nz) ! real(dp), intent(in) :: values(:) ! (nz) - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: i,j,k ierr = 0 a = 0 do j=1,n do k=colptr(j),colptr(j+1)-1 - i = rowind(k) + i = rowind(k) if (i > n) then ierr = j return @@ -584,7 +584,7 @@ subroutine do_column_sparse_to_dense(n,ndim,a,nz,colptr,rowind,values,ierr) end subroutine do_column_sparse_to_dense - subroutine do_col_sparse_0_based_to_dense(n,ndim,a,nz,colptr,rowind,values,ierr) + subroutine do_col_sparse_0_based_to_dense(n,ndim,a,nz,colptr,rowind,values,ierr) integer, intent(in) :: n,ndim,nz real(dp), intent(inout) :: a(ndim,n) integer, intent(in) :: colptr(n+1),rowind(nz) @@ -593,7 +593,7 @@ subroutine do_col_sparse_0_based_to_dense(n,ndim,a,nz,colptr,rowind,values,ierr) ! integer, intent(in) :: colptr(:) ! (n+1) ! integer, intent(in) :: rowind(:) ! (nz) ! real(dp), intent(in) :: values(:) ! (nz) - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: i,j,k ierr = 0 a = 0 @@ -612,11 +612,11 @@ end subroutine do_col_sparse_0_based_to_dense subroutine do_block_dble_mv(nvar, nz, lblk, dblk, ublk, b, prod) use my_lapack95, only: my_gemv_p1 - integer, intent(in) :: nvar, nz + integer, intent(in) :: nvar, nz real(dp), pointer, dimension(:,:,:), intent(in) :: lblk, dblk, ublk ! (nvar,nvar,nz) real(dp), pointer, dimension(:,:), intent(in) :: b ! (nvar,nz) - real(dp), pointer, dimension(:,:), intent(inout) :: prod ! (nvar,nz) - integer :: k + real(dp), pointer, dimension(:,:), intent(inout) :: prod ! (nvar,nz) + integer :: k do k = 1, nz prod(1:nvar,k) = 0 call my_gemv_p1(nvar,nvar,dblk(1:nvar,1:nvar,k),nvar,b(1:nvar,k),prod(1:nvar,k)) @@ -626,20 +626,20 @@ subroutine do_block_dble_mv(nvar, nz, lblk, dblk, ublk, b, prod) if (k < nz) then call my_gemv_p1(nvar,nvar,ublk(1:nvar,1:nvar,k),nvar,b(1:nvar,k+1),prod(1:nvar,k)) end if - end do - end subroutine do_block_dble_mv - - + end do + end subroutine do_block_dble_mv + + subroutine do_LU_factored_block_dble_mv(lblk, dblk, ublk, b, ipiv, prod) real(dp), pointer, dimension(:,:,:), intent(in) :: lblk, dblk, ublk ! (nvar,nvar,nz) real(dp), pointer, dimension(:,:), intent(in) :: b ! (nvar,nz) integer, intent(in) :: ipiv(:,:) ! (nvar,nz) - real(dp), pointer, dimension(:,:), intent(inout) :: prod ! (nvar,nz) - integer :: nvar, nz, k, incx, incy + real(dp), pointer, dimension(:,:), intent(inout) :: prod ! (nvar,nz) + integer :: nvar, nz, k, incx, incy nvar = size(b,dim=1) - nz = size(b,dim=2) + nz = size(b,dim=2) incx = 1 - incy = 1 + incy = 1 !$OMP PARALLEL DO PRIVATE(k) do k = 1, nz call do_LU_factored_square_mv(nvar,dblk(:,:,k),b(:,k),ipiv(:,k),prod(:,k)) @@ -649,11 +649,11 @@ subroutine do_LU_factored_block_dble_mv(lblk, dblk, ublk, b, ipiv, prod) if (k < nz) then call dgemv('N',nvar,nvar,1d0,ublk(:,:,k),nvar,b(:,k+1),incx,1d0,prod(:,k),incy) end if - end do + end do !$OMP END PARALLEL DO end subroutine do_LU_factored_block_dble_mv - - + + subroutine do_LU_factored_square_mv(m,a,b,ipiv,x) ! set x = A*b ! A factored in LU manner = P*L*U. integer, intent(in) :: m @@ -681,8 +681,8 @@ subroutine do_LU_factored_square_mv(m,a,b,ipiv,x) ! set x = A*b ! x = P*x call dlaswp(1, x, m, 1, m, ipiv, -1) end subroutine do_LU_factored_square_mv - - + + subroutine do_LU_factored_square_mm(m,A,B,ipiv,C) ! set C = A*B ! A factored in LU manner = P*L*U. integer, intent(in) :: m @@ -813,7 +813,7 @@ subroutine do_band_multiply_xa(n, kl, ku, ab1, ldab, x, b) b(j) = b(j) + x(i)*ab(k+i,j) end do end do - end subroutine do_band_multiply_xa + end subroutine do_band_multiply_xa subroutine do_clip_blocks( & @@ -838,8 +838,8 @@ subroutine do_clip_blocks( & end do end do end subroutine do_clip_blocks - - + + subroutine do_clip_block(mblk, clip_limit, dmat, dmat_nnz) integer, intent(in) :: mblk real(dp), intent(in) :: clip_limit @@ -868,7 +868,7 @@ subroutine read_hbcode1(iounit, nrow, ncol, nnzero, values, rowind, colptr, ierr REAL(dp), pointer :: VALUES (:) integer, intent(out) :: ierr - + integer :: i ierr = 0 READ (iounit, 1000, iostat=ierr ) TITLE , KEY , & @@ -877,7 +877,7 @@ subroutine read_hbcode1(iounit, nrow, ncol, nnzero, values, rowind, colptr, ierr PTRFMT, INDFMT, VALFMT, RHSFMT if (ierr /= 0) return 1000 FORMAT ( A72, A8 / 5I14 / A3, 11X, 4I14 / 2A16, 2A20 ) - + allocate(VALUES(NNZERO), ROWIND(NNZERO), COLPTR(NCOL+1), stat=ierr) if (ierr /= 0) return @@ -913,9 +913,9 @@ subroutine write_hbcode1(iounit, nrow, ncol, nnzero, values, rowind, colptr, ier INTEGER COLPTR (*), ROWIND (*), ierr REAL(dp) VALUES (*) - + integer :: i - + ierr = 0 ! ------------------------ @@ -925,13 +925,13 @@ subroutine write_hbcode1(iounit, nrow, ncol, nnzero, values, rowind, colptr, ier ! Line 1 (A72, A8) ! Col. 1 - 72 Title (TITLE) ! Col. 73 - 80 Matrix name / identifier (MTRXID) -! +! ! Line 2 (I14, 3(1X, I13)) ! Col. 1 - 14 Total number of lines excluding header (TOTCRD) ! Col. 16 - 28 Number of lines for pointers (PTRCRD) ! Col. 30 - 42 Number of lines for row (or variable) indices (INDCRD) ! Col. 44 - 56 Number of lines for numerical values (VALCRD) -! +! ! Line 3 (A3, 11X, 4(1X, I13)) ! Col. 1 - 3 Matrix type (see below) (MXTYPE) ! Col. 15 - 28 Compressed Column: Number of rows (NROW) @@ -942,19 +942,19 @@ subroutine write_hbcode1(iounit, nrow, ncol, nnzero, values, rowind, colptr, ier ! Elemental: Number of variable indeces (NVARIX) ! Col. 58 - 70 Compressed Column: Unused, explicitly zero ! Elemental: Number of elemental matrix entries (NELTVL) -! +! ! Line 4 (2A16, A20) ! Col. 1 - 16 Fortran format for pointers (PTRFMT) ! Col. 17 - 32 Fortran format for row (or variable) indices (INDFMT) ! Col. 33 - 52 Fortran format for numerical values of coefficient matrix ! (VALFMT) ! (blank in the case of matrix patterns) -! +! ! The three character type field on line 3 describes the matrix type. ! The following table lists the permitted values for each of the three ! characters. As an example of the type field, RSA denotes that the matrix ! is real, symmetric, and assembled. -! +! ! First Character: ! R Real matrix ! C Complex matrix @@ -962,24 +962,24 @@ subroutine write_hbcode1(iounit, nrow, ncol, nnzero, values, rowind, colptr, ier ! P Pattern only (no numerical values supplied) ! Q Pattern only (numerical values supplied in associated auxiliary value ! file) -! +! ! Second Character: ! S Symmetric ! U Unsymmetric ! H Hermitian ! Z Skew symmetric ! R Rectangular -! +! ! Third Character: ! A Compressed column form ! E Elemental form -! +! TITLE = '' KEY = '' - + PTRFMT = '(10I8)' INDFMT = '(12I6)' use_VALFMT = '(5(1pE27.16))' @@ -991,10 +991,10 @@ subroutine write_hbcode1(iounit, nrow, ncol, nnzero, values, rowind, colptr, ier VALCRD = NNZERO/5 + 1 ! number of lines for VALUES RHSCRD = 0 TOTCRD = 3 + PTRCRD + INDCRD + VALCRD + RHSCRD - + MXTYPE = 'RUA' NELTVL = 0 - + WRITE (iounit, 1000 ) TITLE , KEY , & TOTCRD, PTRCRD, INDCRD, VALCRD, RHSCRD, & MXTYPE, NROW , NCOL , NNZERO, NELTVL, & @@ -1021,8 +1021,8 @@ subroutine write_hbcode1(iounit, nrow, ncol, nnzero, values, rowind, colptr, ier return end subroutine write_hbcode1 - - + + subroutine read_block_tridiagonal(iounit,nvar,nblk,lblk1,dblk1,ublk1,ierr) integer, intent(in) :: iounit integer, intent(out) :: nvar, nblk @@ -1050,10 +1050,10 @@ subroutine read_block_tridiagonal(iounit,nvar,nblk,lblk1,dblk1,ublk1,ierr) if (ierr /= 0) return end if end do - + end subroutine read_block_tridiagonal - - + + subroutine read1_sparse_block(iounit, nvar, blk, ierr) integer, intent(in) :: iounit, nvar real(dp) :: blk(:,:) ! (nvar,nvar) @@ -1064,11 +1064,11 @@ subroutine read1_sparse_block(iounit, nvar, blk, ierr) ierr = 0 call read_hbcode1(iounit, nrow, ncol, nnz, values, rowind, colptr,ierr) if (ierr /= 0 .or. nrow /= nvar .or. nrow /= ncol) return - call do_column_sparse_to_dense(nrow,ncol,blk,nnz,colptr,rowind,values,ierr) + call do_column_sparse_to_dense(nrow,ncol,blk,nnz,colptr,rowind,values,ierr) deallocate(colptr,rowind,values) end subroutine read1_sparse_block - - + + subroutine write_block_tridiagonal(iounit,nvar,nblk,lblk,dblk,ublk,ierr) integer, intent(in) :: iounit, nvar, nblk real(dp), intent(in), dimension(:,:,:) :: lblk,dblk,ublk @@ -1089,8 +1089,8 @@ subroutine write_block_tridiagonal(iounit,nvar,nblk,lblk,dblk,ublk,ierr) end if end do end subroutine write_block_tridiagonal - - + + subroutine write1_sparse_block(iounit, nvar, blk, ierr) integer, intent(in) :: iounit, nvar real(dp), intent(in) :: blk(:,:) ! (nvar,nvar) diff --git a/mtx/private/my_lapack95.f90 b/mtx/private/my_lapack95.f90 index 7401faa05..608216109 100644 --- a/mtx/private/my_lapack95.f90 +++ b/mtx/private/my_lapack95.f90 @@ -136,8 +136,8 @@ subroutine my_gemv_p_mv(m,n,a,x,b,z,y) ! y = y + a*x + b*z end if end do end subroutine my_gemv_p_mv - - + + subroutine my_gemm(m,n,k,a,lda,b,ldb,c,ldc) ! c := c - a*b integer, intent(in) :: k,lda,ldb,ldc,m,n real(fltp), dimension(:,:) :: a, b, c ! a(lda,*),b(ldb,*),c(ldc,*) @@ -158,10 +158,10 @@ subroutine my_gemm(m,n,k,a,lda,b,ldb,c,ldc) ! c := c - a*b end do end if end do - end do + end do end subroutine my_gemm - - + + subroutine my_gemm_p1(m,n,k,a,lda,b,ldb,c,ldc) ! c := c + a*b integer, intent(in) :: k,lda,ldb,ldc,m,n real(fltp), dimension(:,:) :: a, b, c ! a(lda,*),b(ldb,*),c(ldc,*) @@ -182,10 +182,10 @@ subroutine my_gemm_p1(m,n,k,a,lda,b,ldb,c,ldc) ! c := c + a*b end do end if end do - end do + end do end subroutine my_gemm_p1 - - + + subroutine my_gemm_plus_mm(m,n,k,a,b,d,e,c) ! c := c + a*b + d*e integer, intent(in) :: k,m,n real(fltp), dimension(:,:) :: a, b, c, d, e @@ -212,10 +212,10 @@ subroutine my_gemm_plus_mm(m,n,k,a,b,d,e,c) ! c := c + a*b + d*e end do end if end do - end do + end do end subroutine my_gemm_plus_mm - - + + subroutine my_gemm0(m,n,k,a,lda,b,ldb,c,ldc) ! c := -a*b integer, intent(in) :: k,lda,ldb,ldc,m,n @@ -235,8 +235,8 @@ subroutine my_gemm0(m,n,k,a,lda,b,ldb,c,ldc) end do call my_gemm(m,n,k,a,lda,b,ldb,c,ldc) end subroutine my_gemm0 - - + + subroutine my_gemm0_p1(m,n,k,a,lda,b,ldb,c,ldc) ! c := -a*b integer, intent(in) :: k,lda,ldb,ldc,m,n @@ -257,7 +257,7 @@ subroutine my_gemm0_p1(m,n,k,a,lda,b,ldb,c,ldc) call my_gemm_p1(m,n,k,a,lda,b,ldb,c,ldc) end subroutine my_gemm0_p1 - + subroutine my_getf2(m, a, lda, ipiv, sfmin, info) integer :: info, lda, m integer :: ipiv(:) @@ -285,7 +285,7 @@ subroutine my_getf2(m, a, lda, ipiv, sfmin, info) a(jp,i) = tmp end do end if - if( j.lt.m ) then + if( j.lt.m ) then if( abs(a( j, j )) .ge. sfmin ) then da = one / a( j, j ) n = m-j @@ -305,11 +305,11 @@ subroutine my_getf2(m, a, lda, ipiv, sfmin, info) end do end if else ! no scale - do i = 1, m-j - a( j+i, j ) = a( j+i, j ) / a( j, j ) - end do - end if - end if + do i = 1, m-j + a( j+i, j ) = a( j+i, j ) / a( j, j ) + end do + end if + end if else if( info.eq.0 ) then info = j end if @@ -324,7 +324,7 @@ subroutine my_getf2(m, a, lda, ipiv, sfmin, info) end do end subroutine my_getf2 - + subroutine my_getf2_4_by_4(a, lda, ipiv, sfmin, info) integer :: info, lda ! m=4 integer :: ipiv(:) @@ -334,7 +334,7 @@ subroutine my_getf2_4_by_4(a, lda, ipiv, sfmin, info) integer :: jp real(fltp) :: tmp, da info = 0 - + jp = maxloc(abs(a(1:lda,1)),dim=1) ipiv( 1 ) = jp if( a( jp, 1 ).ne.zero ) then @@ -358,10 +358,10 @@ subroutine my_getf2_4_by_4(a, lda, ipiv, sfmin, info) a(3,1) = da*a(3,1) a(4,1) = da*a(4,1) else ! no scale - a( 2, 1 ) = a( 2, 1 ) / a( 1, 1 ) - a( 3, 1 ) = a( 3, 1 ) / a( 1, 1 ) - a( 4, 1 ) = a( 4, 1 ) / a( 1, 1 ) - end if + a( 2, 1 ) = a( 2, 1 ) / a( 1, 1 ) + a( 3, 1 ) = a( 3, 1 ) / a( 1, 1 ) + a( 4, 1 ) = a( 4, 1 ) / a( 1, 1 ) + end if else if( info.eq.0 ) then info = 1 end if @@ -374,7 +374,7 @@ subroutine my_getf2_4_by_4(a, lda, ipiv, sfmin, info) a(2,4) = a(2,4) - a(2,1)*a(1,4) a(3,4) = a(3,4) - a(3,1)*a(1,4) a(4,4) = a(4,4) - a(4,1)*a(1,4) - + jp = 1 + maxloc(abs(a(2:lda,2)),dim=1) ipiv( 2 ) = jp if( a( jp, 2 ).ne.zero ) then @@ -399,7 +399,7 @@ subroutine my_getf2_4_by_4(a, lda, ipiv, sfmin, info) else ! no scale a( 3, 2 ) = a( 3, 2 ) / a( 2, 2 ) a( 4, 2 ) = a( 4, 2 ) / a( 2, 2 ) - end if + end if else if( info.eq.0 ) then info = 2 end if @@ -407,7 +407,7 @@ subroutine my_getf2_4_by_4(a, lda, ipiv, sfmin, info) a(4,3) = a(4,3) - a(4,2)*a(2,3) a(3,4) = a(3,4) - a(3,2)*a(2,4) a(4,4) = a(4,4) - a(4,2)*a(2,4) - + jp = 2 + maxloc(abs(a(3:lda,3)),dim=1) ipiv( 3 ) = jp if( a( jp, 3 ).ne.zero ) then @@ -429,13 +429,13 @@ subroutine my_getf2_4_by_4(a, lda, ipiv, sfmin, info) da = one / a( 3, 3 ) a(4,3) = da*a(4,3) else ! no scale - a( 4, 3 ) = a( 4, 3 ) / a( 3, 3 ) - end if + a( 4, 3 ) = a( 4, 3 ) / a( 3, 3 ) + end if else if( info.eq.0 ) then info = 3 end if a(4,4) = a(4,4) - a(4,3)*a(3,4) - + jp = 3 + maxloc(abs(a(4:lda,4)),dim=1) ipiv( 4 ) = jp if( a( jp, 4 ).ne.zero ) then @@ -459,7 +459,7 @@ subroutine my_getf2_4_by_4(a, lda, ipiv, sfmin, info) end subroutine my_getf2_4_by_4 - + subroutine my_getf2_5_by_5(a, lda, ipiv, sfmin, info) integer :: info, lda ! m=5 integer :: ipiv(:) @@ -496,11 +496,11 @@ subroutine my_getf2_5_by_5(a, lda, ipiv, sfmin, info) a(4,1) = da*a(4,1) a(5,1) = da*a(5,1) else ! no scale - a( 2, 1 ) = a( 2, 1 ) / a( 1, 1 ) - a( 3, 1 ) = a( 3, 1 ) / a( 1, 1 ) - a( 4, 1 ) = a( 4, 1 ) / a( 1, 1 ) - a( 5, 1 ) = a( 5, 1 ) / a( 1, 1 ) - end if + a( 2, 1 ) = a( 2, 1 ) / a( 1, 1 ) + a( 3, 1 ) = a( 3, 1 ) / a( 1, 1 ) + a( 4, 1 ) = a( 4, 1 ) / a( 1, 1 ) + a( 5, 1 ) = a( 5, 1 ) / a( 1, 1 ) + end if else if( info.eq.0 ) then info = 1 end if @@ -520,7 +520,7 @@ subroutine my_getf2_5_by_5(a, lda, ipiv, sfmin, info) a(3,5) = a(3,5) - a(3,1)*a(1,5) a(4,5) = a(4,5) - a(4,1)*a(1,5) a(5,5) = a(5,5) - a(5,1)*a(1,5) - + jp = 1 + maxloc(abs(a(2:lda,2)),dim=1) ipiv( 2 ) = jp if( a( jp, 2 ).ne.zero ) then @@ -550,7 +550,7 @@ subroutine my_getf2_5_by_5(a, lda, ipiv, sfmin, info) a( 3, 2 ) = a( 3, 2 ) / a( 2, 2 ) a( 4, 2 ) = a( 4, 2 ) / a( 2, 2 ) a( 5, 2 ) = a( 5, 2 ) / a( 2, 2 ) - end if + end if else if( info.eq.0 ) then info = 2 end if @@ -563,7 +563,7 @@ subroutine my_getf2_5_by_5(a, lda, ipiv, sfmin, info) a(3,5) = a(3,5) - a(3,2)*a(2,5) a(4,5) = a(4,5) - a(4,2)*a(2,5) a(5,5) = a(5,5) - a(5,2)*a(2,5) - + jp = 2 + maxloc(abs(a(3:lda,3)),dim=1) ipiv( 3 ) = jp if( a( jp, 3 ).ne.zero ) then @@ -589,9 +589,9 @@ subroutine my_getf2_5_by_5(a, lda, ipiv, sfmin, info) a(4,3) = da*a(4,3) a(5,3) = da*a(5,3) else ! no scale - a( 4, 3 ) = a( 4, 3 ) / a( 3, 3 ) - a( 4, 3 ) = a( 4, 3 ) / a( 3, 3 ) - end if + a( 4, 3 ) = a( 4, 3 ) / a( 3, 3 ) + a( 4, 3 ) = a( 4, 3 ) / a( 3, 3 ) + end if else if( info.eq.0 ) then info = 3 end if @@ -599,7 +599,7 @@ subroutine my_getf2_5_by_5(a, lda, ipiv, sfmin, info) a(5,4) = a(5,4) - a(5,3)*a(3,4) a(4,5) = a(4,5) - a(4,3)*a(3,5) a(5,5) = a(5,5) - a(5,3)*a(3,5) - + jp = 3 + maxloc(abs(a(4:lda,4)),dim=1) ipiv( 4 ) = jp if( a( jp, 4 ).ne.zero ) then @@ -624,13 +624,13 @@ subroutine my_getf2_5_by_5(a, lda, ipiv, sfmin, info) da = one / a( 4, 4 ) a(5,4) = da*a(5,4) else ! no scale - a( 5, 4 ) = a( 5, 4 ) / a( 4, 4 ) - end if + a( 5, 4 ) = a( 5, 4 ) / a( 4, 4 ) + end if else if( info.eq.0 ) then info = 4 end if a(5,5) = a(5,5) - a(5,4)*a(4,5) - + jp = 4 + maxloc(abs(a(5:lda,5)),dim=1) ipiv( 5 ) = jp if( a( jp, 5 ).ne.zero ) then @@ -656,8 +656,8 @@ subroutine my_getf2_5_by_5(a, lda, ipiv, sfmin, info) end if end subroutine my_getf2_5_by_5 - - + + subroutine my_laswp( n, a, lda, k1, k2, ipiv, incx ) integer :: incx, k1, k2, lda, n integer :: ipiv(:) @@ -709,10 +709,10 @@ subroutine my_laswp( n, a, lda, k1, k2, ipiv, incx ) end if ix = ix + incx end do - end if + end if end subroutine my_laswp - - + + subroutine my_laswp_4_by_1( a, lda, ipiv ) ! n == 1, k1 == 1, k2 == 4, incx == 1 integer :: lda @@ -746,8 +746,8 @@ subroutine my_laswp_4_by_1( a, lda, ipiv ) a( ip, 1 ) = temp end if end subroutine my_laswp_4_by_1 - - + + subroutine my_laswp_5_by_1( a, lda, ipiv ) ! n == 1, k1 == 1, k2 == 5, incx == 1 integer :: lda @@ -787,8 +787,8 @@ subroutine my_laswp_5_by_1( a, lda, ipiv ) a( ip, 1 ) = temp end if end subroutine my_laswp_5_by_1 - - + + subroutine my_laswp_4_by_4( a, lda, ipiv ) integer :: lda integer :: ipiv(:) @@ -857,8 +857,8 @@ subroutine my_laswp_4_by_4( a, lda, ipiv ) a( ip, 4 ) = temp end if end subroutine my_laswp_4_by_4 - - + + subroutine my_laswp_5_by_5( a, lda, ipiv ) integer :: lda integer :: ipiv(:) @@ -957,8 +957,8 @@ subroutine my_laswp_5_by_5( a, lda, ipiv ) a( ip, 5 ) = temp end if end subroutine my_laswp_5_by_5 - - + + subroutine my_getrs( n, nrhs, a, lda, ipiv, b, ldb, info ) integer :: info, lda, ldb, n, nrhs integer, pointer :: ipiv(:) @@ -966,7 +966,7 @@ subroutine my_getrs( n, nrhs, a, lda, ipiv, b, ldb, info ) real(fltp), parameter :: one=1, zero=0 integer :: i, j, k info = 0 - + if (nrhs == 1) then if (n == 4) then call my_getrs_4_by_1( a, lda, ipiv, b, ldb, info ) @@ -981,7 +981,7 @@ subroutine my_getrs( n, nrhs, a, lda, ipiv, b, ldb, info ) return else if (nrhs == 5 .and. n == 5) then call my_getrs_5_by_5( a, lda, ipiv, b, ldb, info ) - return + return end if call my_laswp(nrhs, b, ldb, 1, n, ipiv, 1 ) @@ -1006,18 +1006,18 @@ subroutine my_getrs( n, nrhs, a, lda, ipiv, b, ldb, info ) end if end do end do - + end subroutine my_getrs - + subroutine my_getrs_5_by_5( a, lda, ipiv, b, ldb, info ) integer :: info, lda, ldb ! , n=5, nrhs=5 integer, pointer :: ipiv(:) real(fltp), pointer :: a(:,:), b(:,:) ! a( lda, * ), b( ldb, * ) real(fltp), parameter :: zero=0 - + info = 0 - + !call my_laswp(5, b, ldb, 1, 5, ipiv, 1 ) call my_laswp_5_by_5( b, ldb, ipiv ) @@ -1031,7 +1031,7 @@ subroutine my_getrs_5_by_5( a, lda, ipiv, b, ldb, info ) b(4,1) = b(4,1) - b(3,1)*a(4,3) b(5,1) = b(5,1) - b(3,1)*a(5,3) b(5,1) = b(5,1) - b(4,1)*a(5,4) - + b(2,2) = b(2,2) - b(1,2)*a(2,1) b(3,2) = b(3,2) - b(1,2)*a(3,1) b(4,2) = b(4,2) - b(1,2)*a(4,1) @@ -1075,7 +1075,7 @@ subroutine my_getrs_5_by_5( a, lda, ipiv, b, ldb, info ) b(4,5) = b(4,5) - b(3,5)*a(4,3) b(5,5) = b(5,5) - b(3,5)*a(5,3) b(5,5) = b(5,5) - b(4,5)*a(5,4) - + !call dtrsm( 'left', 'upper', 'no transpose', 'non-unit', n, nrhs, one, a, lda, b, ldb ) b(5,1) = b(5,1)/a(5,5) b(1,1) = b(1,1) - b(5,1)*a(1,5) @@ -1092,7 +1092,7 @@ subroutine my_getrs_5_by_5( a, lda, ipiv, b, ldb, info ) b(2,1) = b(2,1)/a(2,2) b(1,1) = b(1,1) - b(2,1)*a(1,2) b(1,1) = b(1,1)/a(1,1) - + b(5,2) = b(5,2)/a(5,5) b(1,2) = b(1,2) - b(5,2)*a(1,5) b(2,2) = b(2,2) - b(5,2)*a(2,5) @@ -1108,7 +1108,7 @@ subroutine my_getrs_5_by_5( a, lda, ipiv, b, ldb, info ) b(2,2) = b(2,2)/a(2,2) b(1,2) = b(1,2) - b(2,2)*a(1,2) b(1,2) = b(1,2)/a(1,1) - + b(5,3) = b(5,3)/a(5,5) b(1,3) = b(1,3) - b(5,3)*a(1,5) b(2,3) = b(2,3) - b(5,3)*a(2,5) @@ -1124,7 +1124,7 @@ subroutine my_getrs_5_by_5( a, lda, ipiv, b, ldb, info ) b(2,3) = b(2,3)/a(2,2) b(1,3) = b(1,3) - b(2,3)*a(1,2) b(1,3) = b(1,3)/a(1,1) - + b(5,4) = b(5,4)/a(5,5) b(1,4) = b(1,4) - b(5,4)*a(1,5) b(2,4) = b(2,4) - b(5,4)*a(2,5) @@ -1140,7 +1140,7 @@ subroutine my_getrs_5_by_5( a, lda, ipiv, b, ldb, info ) b(2,4) = b(2,4)/a(2,2) b(1,4) = b(1,4) - b(2,4)*a(1,2) b(1,4) = b(1,4)/a(1,1) - + b(5,5) = b(5,5)/a(5,5) b(1,5) = b(1,5) - b(5,5)*a(1,5) b(2,5) = b(2,5) - b(5,5)*a(2,5) @@ -1158,7 +1158,7 @@ subroutine my_getrs_5_by_5( a, lda, ipiv, b, ldb, info ) b(1,5) = b(1,5)/a(1,1) end subroutine my_getrs_5_by_5 - + subroutine my_getrs_5_by_1( a, lda, ipiv, b, ldb, info ) integer :: info, lda, ldb ! , n=5, nrhs=1 @@ -1178,7 +1178,7 @@ subroutine my_getrs_5_by_1( a, lda, ipiv, b, ldb, info ) b(4,1) = b(4,1) - b(3,1)*a(4,3) b(5,1) = b(5,1) - b(3,1)*a(5,3) b(5,1) = b(5,1) - b(4,1)*a(5,4) - + !call dtrsm( 'left', 'upper', 'no transpose', 'non-unit', n, nrhs, one, a, lda, b, ldb ) b(5,1) = b(5,1)/a(5,5) b(1,1) = b(1,1) - b(5,1)*a(1,5) @@ -1188,16 +1188,16 @@ subroutine my_getrs_5_by_1( a, lda, ipiv, b, ldb, info ) b(4,1) = b(4,1)/a(4,4) b(1,1) = b(1,1) - b(4,1)*a(1,4) b(2,1) = b(2,1) - b(4,1)*a(2,4) - b(3,1) = b(3,1) - b(4,1)*a(3,4) + b(3,1) = b(3,1) - b(4,1)*a(3,4) b(3,1) = b(3,1)/a(3,3) b(1,1) = b(1,1) - b(3,1)*a(1,3) - b(2,1) = b(2,1) - b(3,1)*a(2,3) + b(2,1) = b(2,1) - b(3,1)*a(2,3) b(2,1) = b(2,1)/a(2,2) b(1,1) = b(1,1) - b(2,1)*a(1,2) b(1,1) = b(1,1)/a(1,1) end subroutine my_getrs_5_by_1 - + subroutine my_getrs_4_by_4( a, lda, ipiv, b, ldb, info ) integer :: info, lda, ldb ! , n=4, nrhs=4 @@ -1205,9 +1205,9 @@ subroutine my_getrs_4_by_4( a, lda, ipiv, b, ldb, info ) real(fltp), pointer :: a(:,:), b(:,:) ! a( lda, * ), b( ldb, * ) real(fltp), parameter :: zero=0 info = 0 - + call my_laswp_4_by_4( b, ldb, ipiv ) - + !call dtrsm( 'left', 'lower', 'no transpose', 'unit', n, nrhs, one, a, lda, b, ldb ) b(2,1) = b(2,1) - b(1,1)*a(2,1) b(3,1) = b(3,1) - b(1,1)*a(3,1) @@ -1215,7 +1215,7 @@ subroutine my_getrs_4_by_4( a, lda, ipiv, b, ldb, info ) b(3,1) = b(3,1) - b(2,1)*a(3,2) b(4,1) = b(4,1) - b(2,1)*a(4,2) b(4,1) = b(4,1) - b(3,1)*a(4,3) - + b(2,2) = b(2,2) - b(1,2)*a(2,1) b(3,2) = b(3,2) - b(1,2)*a(3,1) b(4,2) = b(4,2) - b(1,2)*a(4,1) @@ -1236,7 +1236,7 @@ subroutine my_getrs_4_by_4( a, lda, ipiv, b, ldb, info ) b(3,4) = b(3,4) - b(2,4)*a(3,2) b(4,4) = b(4,4) - b(2,4)*a(4,2) b(4,4) = b(4,4) - b(3,4)*a(4,3) - + !call dtrsm( 'left', 'upper', 'no transpose', 'non-unit', n, nrhs, one, a, lda, b, ldb ) b(4,1) = b(4,1)/a(4,4) b(1,1) = b(1,1) - b(4,1)*a(1,4) @@ -1248,7 +1248,7 @@ subroutine my_getrs_4_by_4( a, lda, ipiv, b, ldb, info ) b(2,1) = b(2,1)/a(2,2) b(1,1) = b(1,1) - b(2,1)*a(1,2) b(1,1) = b(1,1)/a(1,1) - + b(4,2) = b(4,2)/a(4,4) b(1,2) = b(1,2) - b(4,2)*a(1,4) b(2,2) = b(2,2) - b(4,2)*a(2,4) @@ -1259,7 +1259,7 @@ subroutine my_getrs_4_by_4( a, lda, ipiv, b, ldb, info ) b(2,2) = b(2,2)/a(2,2) b(1,2) = b(1,2) - b(2,2)*a(1,2) b(1,2) = b(1,2)/a(1,1) - + b(4,3) = b(4,3)/a(4,4) b(1,3) = b(1,3) - b(4,3)*a(1,4) b(2,3) = b(2,3) - b(4,3)*a(2,4) @@ -1270,7 +1270,7 @@ subroutine my_getrs_4_by_4( a, lda, ipiv, b, ldb, info ) b(2,3) = b(2,3)/a(2,2) b(1,3) = b(1,3) - b(2,3)*a(1,2) b(1,3) = b(1,3)/a(1,1) - + b(4,4) = b(4,4)/a(4,4) b(1,4) = b(1,4) - b(4,4)*a(1,4) b(2,4) = b(2,4) - b(4,4)*a(2,4) @@ -1283,17 +1283,17 @@ subroutine my_getrs_4_by_4( a, lda, ipiv, b, ldb, info ) b(1,4) = b(1,4)/a(1,1) end subroutine my_getrs_4_by_4 - + subroutine my_getrs_4_by_1( a, lda, ipiv, b, ldb, info ) integer :: info, lda, ldb ! , n=4, nrhs=1 integer, pointer :: ipiv(:) real(fltp), pointer :: a(:,:), b(:,:) ! a( lda, * ), b( ldb, * ) real(fltp), parameter :: zero=0 - + info = 0 call my_laswp_4_by_1( b, ldb, ipiv ) - + !call dtrsm( 'left', 'lower', 'no transpose', 'unit', n, nrhs, one, a, lda, b, ldb ) b(2,1) = b(2,1) - b(1,1)*a(2,1) b(3,1) = b(3,1) - b(1,1)*a(3,1) @@ -1301,7 +1301,7 @@ subroutine my_getrs_4_by_1( a, lda, ipiv, b, ldb, info ) b(3,1) = b(3,1) - b(2,1)*a(3,2) b(4,1) = b(4,1) - b(2,1)*a(4,2) b(4,1) = b(4,1) - b(3,1)*a(4,3) - + !call dtrsm( 'left', 'upper', 'no transpose', 'non-unit', n, nrhs, one, a, lda, b, ldb ) b(4,1) = b(4,1)/a(4,4) b(1,1) = b(1,1) - b(4,1)*a(1,4) @@ -1313,10 +1313,10 @@ subroutine my_getrs_4_by_1( a, lda, ipiv, b, ldb, info ) b(2,1) = b(2,1)/a(2,2) b(1,1) = b(1,1) - b(2,1)*a(1,2) b(1,1) = b(1,1)/a(1,1) - + end subroutine my_getrs_4_by_1 - - + + subroutine my_getrs_dbg( n, nrhs, a, lda, ipiv, b, ldb, info ) integer :: info, lda, ldb, n, nrhs integer, pointer :: ipiv(:) @@ -1347,8 +1347,8 @@ subroutine my_getrs_dbg( n, nrhs, a, lda, ipiv, b, ldb, info ) end do end do end subroutine my_getrs_dbg - - + + subroutine my_laswp_dbg( n, a, lda, k1, k2, ipiv, incx ) integer :: incx, k1, k2, lda, n integer :: ipiv(:) @@ -1399,19 +1399,19 @@ subroutine my_laswp_dbg( n, a, lda, k1, k2, ipiv, incx ) ix = ix0 do i = i1, i2, inc ip = ipiv( ix ) - - - + + + if (ip == 0) then - + stop 'my_lapack95 ip == 0' - - + + end if - - - - + + + + if( ip.ne.i ) then do k = n32, n temp = a( i, k ) @@ -1421,7 +1421,7 @@ subroutine my_laswp_dbg( n, a, lda, k1, k2, ipiv, incx ) end if ix = ix + incx end do - end if + end if end subroutine my_laswp_dbg end module my_lapack95 diff --git a/mtx/private/pre_conditioners.f90 b/mtx/private/pre_conditioners.f90 index bafbbec49..871d6dde6 100644 --- a/mtx/private/pre_conditioners.f90 +++ b/mtx/private/pre_conditioners.f90 @@ -34,11 +34,11 @@ subroutine compute_block_preconditioner(ublk, lblk, dblk, nblocks, nvar, pre_con pre_conditioner(k,j) = pre_conditioner(k,j) + sum(abs(dblk(k,:,j))) if (j < nblocks) then - pre_conditioner(k,j) = pre_conditioner(k,j) + sum(abs(ublk(k,:,j))) + pre_conditioner(k,j) = pre_conditioner(k,j) + sum(abs(ublk(k,:,j))) end if if (j > 1) then - pre_conditioner(k,j) = pre_conditioner(k,j) + sum(abs(lblk(k,:,j-1))) + pre_conditioner(k,j) = pre_conditioner(k,j) + sum(abs(lblk(k,:,j-1))) end if end do end do @@ -131,6 +131,6 @@ subroutine compute_band_preconditioner(matrix_size, n_upper_bands, n_lower_bands end do end do - end subroutine compute_band_preconditioner + end subroutine compute_band_preconditioner end module pre_conditioners \ No newline at end of file diff --git a/mtx/public/mtx_lib.f90 b/mtx/public/mtx_lib.f90 index 002314f80..cd223cfe3 100644 --- a/mtx/public/mtx_lib.f90 +++ b/mtx/public/mtx_lib.f90 @@ -25,24 +25,24 @@ module mtx_lib - + use const_def, only: dp - + implicit none - + contains - + ! mesa includes sources for a subset of BLAS and dble. ! you can use those, or, better yet, you can use a package optimized - ! for your machine such as GotoBLAS or Intel's MKL. + ! for your machine such as GotoBLAS or Intel's MKL. ! see utils/makefile_header for details. - ! see mtx/blas_src for the subset of BLAS routines included in mtx_lib - ! see mtx/dble_src for the subset of dble routines included in mtx_lib - + ! see mtx/blas_src for the subset of BLAS routines included in mtx_lib + ! see mtx/dble_src for the subset of dble routines included in mtx_lib + ! subroutines for dense and banded matrix decompositions and solves - + include "mtx_dble_decsol.dek" ! dble versions !> Wraps the lapack DGBSVX routine for banded matrices to be used with block tridiagonal matrices. @@ -65,7 +65,7 @@ subroutine DGBSVX_block_tridiagonal_padded(ublk, lblk, dblk, x, b, nblocks, nvar ! Intermediates real(dp) :: pre_conditioner(nvar, nblocks) - + ! Outputs real(dp), dimension(:,:), intent(out) :: x real(dp), intent(out) :: rcond @@ -130,7 +130,7 @@ subroutine DGBSVX_block_tridiagonal(ublk, lblk, dblk, x, b, nblocks, nvar, ierr) real(dp) :: pre_conditioner(nvar, nblocks) real(dp) :: rcond - + ! Outputs real(dp), dimension(:,:), intent(out) :: x integer, intent(out) :: ierr @@ -199,16 +199,16 @@ end subroutine DGBSVX_banded ! sometimes you just need a null version of a routine include "mtx_null_decsol.dek" - + ! sometimes you need to debug a jacobian by saving it to plotting data files include "mtx_debug_decsol.dek" - ! sparse matrices come in many formats. + ! sparse matrices come in many formats. ! for example, compressed row sparse format is used by SPARSKIT, ! while compressed column sparse format is used by Super_LU. ! here are conversion routines for these two options. include "mtx_formats.dek" - + subroutine mtx_write_hbcode1(iounit, n, nnzero, values, rowind, colptr, ierr) use mtx_support, only: write_hbcode1 integer, intent(in) :: iounit, n, nnzero @@ -218,8 +218,8 @@ subroutine mtx_write_hbcode1(iounit, n, nnzero, values, rowind, colptr, ierr) integer, intent(out) :: ierr call write_hbcode1(iounit, n, n, nnzero, values, rowind, colptr, ierr) end subroutine mtx_write_hbcode1 - - + + subroutine mtx_write_block_tridiagonal(iounit,nvar,nblk,lblk,dblk,ublk,ierr) use mtx_support, only: write_block_tridiagonal integer, intent(in) :: iounit, nvar, nblk @@ -227,7 +227,7 @@ subroutine mtx_write_block_tridiagonal(iounit,nvar,nblk,lblk,dblk,ublk,ierr) integer, intent(out) :: ierr call write_block_tridiagonal(iounit,nvar,nblk,lblk,dblk,ublk,ierr) end subroutine mtx_write_block_tridiagonal - + subroutine mtx_read_block_tridiagonal(iounit,nvar,nblk,lblk1,dblk1,ublk1,ierr) use mtx_support, only: read_block_tridiagonal integer, intent(in) :: iounit @@ -236,9 +236,9 @@ subroutine mtx_read_block_tridiagonal(iounit,nvar,nblk,lblk1,dblk1,ublk1,ierr) integer, intent(out) :: ierr call read_block_tridiagonal(iounit,nvar,nblk,lblk1,dblk1,ublk1,ierr) end subroutine mtx_read_block_tridiagonal - + ! BCYCLIC multi-thread block tridiagonal - include "mtx_bcyclic_dble_decsol.dek" + include "mtx_bcyclic_dble_decsol.dek" ! S.P.Hirshman, K.S.Perumalla, V.E.Lynch, & R.Sanchez, ! BCYCLIC: A parallel block tridiagonal matrix cyclic solver, ! J. Computational Physics, 229 (2010) 6392-6404. @@ -250,10 +250,10 @@ subroutine block_dble_mv(nvar, nz, lblk, dblk, ublk, b, prod) integer, intent(in) :: nvar, nz real(dp), pointer, dimension(:,:,:), intent(in) :: lblk, dblk, ublk ! (nvar,nvar,nz) real(dp), pointer, dimension(:,:), intent(in) :: b ! (nvar,nz) - real(dp), pointer, dimension(:,:), intent(inout) :: prod ! (nvar,nz) + real(dp), pointer, dimension(:,:), intent(inout) :: prod ! (nvar,nz) call do_block_dble_mv(nvar, nz, lblk, dblk, ublk, b, prod) end subroutine block_dble_mv - + subroutine multiply_xa(n, A1, x, b) ! calculates b = x*A @@ -278,7 +278,7 @@ end subroutine block_multiply_xa subroutine band_multiply_xa(n, kl, ku, ab1, ldab, x, b) ! calculates b = x*a = transpose(a)*x - use mtx_support, only: do_band_multiply_xa + use mtx_support, only: do_band_multiply_xa integer, intent(in) :: n ! the number of linear equations, i.e., the order of the ! matrix a. n >= 0. @@ -299,17 +299,17 @@ subroutine band_multiply_xa(n, kl, ku, ab1, ldab, x, b) ! on exit, set to matrix product of x*a = b call do_band_multiply_xa(n, kl, ku, ab1, ldab, x, b) end subroutine band_multiply_xa - - - include "mtx_lapack95.dek" - - + + + include "mtx_lapack95.dek" + + ! utilities for working with jacobians include "mtx_jac.dek" - + ! the following call dble routines to estimate matrix condition numbers. include "mtx_rcond.dek" - + integer function decsol_option(which_decsol_option, ierr) use mtx_def character (len=*), intent(in) :: which_decsol_option @@ -317,40 +317,40 @@ integer function decsol_option(which_decsol_option, ierr) character (len=64) :: option ierr = 0 option = which_decsol_option - + if (option == 'lapack') then decsol_option = lapack else if (option == 'bcyclic_dble') then decsol_option = bcyclic_dble - + else ierr = -1 decsol_option = -1 - end if + end if end function decsol_option - - + + subroutine decsol_option_str(which_decsol_option, decsol_option, ierr) use mtx_def integer, intent(in) :: which_decsol_option character (len=*), intent(out) :: decsol_option integer, intent(out) :: ierr ierr = 0 - + if (which_decsol_option == lapack) then decsol_option = 'lapack' else if (which_decsol_option == bcyclic_dble) then decsol_option = 'bcyclic_dble' - + else ierr = -1 decsol_option = '' - end if - + end if + end subroutine decsol_option_str - - + + logical function is_block_tridiagonal_decsol(which_decsol_option) use mtx_def integer, intent(in) :: which_decsol_option diff --git a/net/private/net_approx21.f90 b/net/private/net_approx21.f90 index ca0842645..ef2fbb239 100644 --- a/net/private/net_approx21.f90 +++ b/net/private/net_approx21.f90 @@ -31,10 +31,10 @@ module net_approx21 implicit none - + !logical :: plus_co56 ! Must now be passed as an argument - + logical, parameter :: reduced_net_for_testing = .true. !logical, parameter :: reduced_net_for_testing = .false. @@ -69,14 +69,14 @@ module net_approx21 ini56, & ineut, & iprot - + integer, parameter :: approx21_num_mesa_reactions_21 = 93, approx21_nrat = 116 integer, parameter :: approx21_num_mesa_reactions_co56 = approx21_num_mesa_reactions_21+1, & approx21_plus_co56_nrat = approx21_nrat+1 - - ! integer :: num_mesa_reactions + + ! integer :: num_mesa_reactions ! integer :: num_reactions - + integer :: rate_id(approx21_num_mesa_reactions_co56) ! rate ids for the mesa reactions ! e.g., rate_id(ir3a) is reaction id for triple alpha as defined in mesa/rates ! Define as largest possible array @@ -176,7 +176,7 @@ module net_approx21 iropg, & irnag, & - ! for reactions to fe56 + ! for reactions to fe56 ir54ng, & ir55gn, & ir55ng, & @@ -232,9 +232,9 @@ subroutine approx21_pa_pg_fractions( & ratraw,dratrawdt,dratrawdd,ierr) real(dp), dimension(:) :: ratraw,dratrawdt,dratrawdd integer, intent(out) :: ierr - + include 'formats' - + ierr = 0 call set1(ifa,irn15pg,irn15pa) @@ -285,7 +285,7 @@ end subroutine set1 end subroutine approx21_pa_pg_fractions - + ! call this before screening subroutine approx21_weak_rates( & y, ratraw, dratrawdt, dratrawdd, & @@ -293,20 +293,20 @@ subroutine approx21_weak_rates( & weak_rate_factor, plus_co56, ierr) use rates_lib, only: eval_ecapnuc_rate use net_derivs, only: eval_ni56_ec_rate, eval_co56_ec_rate - + real(dp), dimension(:) :: y, ratraw, dratrawdt, dratrawdd real(dp), intent(in) :: temp, den, ye, eta, zbar, weak_rate_factor logical, intent(in) :: plus_co56 integer, intent(out) :: ierr - + real(dp) :: rpen, rnep, spen, snep, & rate, d_rate_dlnT, d_rate_dlnRho, Q, Qneu include 'formats' - + ierr = 0 - + call eval_ecapnuc_rate(eta, temp, den, rpen, rnep, spen, snep) - + ratraw(irpen) = rpen dratrawdt(irpen) = 0 dratrawdd(irpen) = 0 @@ -315,7 +315,7 @@ subroutine approx21_weak_rates( & else Qneu = 0 end if - + ratraw(irnep) = rnep dratrawdt(irnep) = 0 dratrawdd(irnep) = 0 @@ -324,7 +324,7 @@ subroutine approx21_weak_rates( & else Qneu = 0 end if - + call eval_ni56_ec_rate( & temp, den, ye, eta, zbar, weak_rate_factor, & rate, d_rate_dlnT, d_rate_dlnRho, Q, Qneu, & @@ -334,10 +334,10 @@ subroutine approx21_weak_rates( & return end if ratraw(irn56ec) = rate - dratrawdt(irn56ec) = 0 + dratrawdt(irn56ec) = 0 dratrawdd(irn56ec) = 0 - - if (plus_co56) then + + if (plus_co56) then call eval_co56_ec_rate( & temp, den, ye, eta, zbar, weak_rate_factor, & rate, d_rate_dlnT, d_rate_dlnRho, Q, Qneu, & @@ -347,8 +347,8 @@ subroutine approx21_weak_rates( & return end if ratraw(irco56ec) = rate - dratrawdt(irco56ec) = 0 - dratrawdd(irco56ec) = 0 + dratrawdt(irco56ec) = 0 + dratrawdd(irco56ec) = 0 end if end subroutine approx21_weak_rates @@ -370,13 +370,13 @@ subroutine approx21_special_reactions( & ratdum,dratdumdt,dratdumdd,dratdumdy1,dratdumdy2 logical, intent(in) :: plus_co56 integer, intent(out) :: ierr - + real(dp) :: denom, denomdt, denomdd, zz, xx, eps, deps_dT, deps_dRho real(dp), parameter :: tiny_denom = 1d-50, tiny_y = 1d-30 integer :: i logical :: okay include 'formats' - + ierr = 0 if (use_3a_FL) then @@ -392,13 +392,13 @@ subroutine approx21_special_reactions( & xx = conv_eps_3a*y(ihe4)*y(ihe4)*y(ihe4)/6d0 ratdum(ir3a) = eps/xx dratdumdt(ir3a) = deps_dT/xx - dratdumdd(ir3a) = deps_dRho/xx + dratdumdd(ir3a) = deps_dRho/xx end if end if - + okay = .true. - do i=1,num_mesa_reactions(plus_co56) + do i=1,num_mesa_reactions(plus_co56) if (ratdum(i) < 0d0) then write(*,2) 'approx21 missing rate for ' // ratnam(i), i, ratdum(i), & btemp, log10(btemp), bden, log10(bden) @@ -408,14 +408,14 @@ subroutine approx21_special_reactions( & if (.not. okay) call mesa_error(__FILE__,__LINE__) ! for debugging: sum(cat)/eps_nuc - - if (reduced_net_for_testing) then - !if (.true.) then - + if (reduced_net_for_testing) then + + !if (.true.) then + !end if - if (.false.) then + if (.false.) then ! turn off PP call turn_off_reaction(irpp) @@ -441,7 +441,7 @@ subroutine approx21_special_reactions( & !Ne/O burn call turn_off_reaction(ir1216) - call turn_off_reaction(ir1616) + call turn_off_reaction(ir1616) call turn_off_reaction(irneag) call turn_off_reaction(irmgga) @@ -496,28 +496,28 @@ subroutine approx21_special_reactions( & call turn_off_reaction(irfeag) !iron group - call turn_off_reaction(irniga) + call turn_off_reaction(irniga) call turn_off_reaction(irfeap) call turn_off_reaction(ircopa) - + call turn_off_reaction(irnigp) call turn_off_reaction(irfepg) call turn_off_reaction(ircogp) - + call turn_off_reaction(irheng) call turn_off_reaction(irhegn) - + call turn_off_reaction(irhng) call turn_off_reaction(irdgn) - + call turn_off_reaction(irdpg) call turn_off_reaction(irhegp) - + call turn_off_reaction(irpen) call turn_off_reaction(irnep) - + call turn_off_reaction(ircopg) - + call turn_off_reaction(ir54ng) call turn_off_reaction(ir55gn) call turn_off_reaction(ir55ng) @@ -533,19 +533,19 @@ subroutine approx21_special_reactions( & call turn_off_reaction(irfe54ap) call turn_off_reaction(irco57pa) - + call turn_off_reaction(irco56ec) call turn_off_reaction(irn56ec) - + end if - !if (.true.) then - + !if (.true.) then - !end if + + !end if end if - + ! fe52(n,g)fe53(n,g)fe54 equilibrium links ratdum(ir1f54) = 0.0d0 dratdumdy1(ir1f54) = 0.0d0 @@ -618,10 +618,10 @@ subroutine approx21_special_reactions( & dratdumdd(irfe56_aux2) = dratdumdd(ir54ng)*ratdum(ir55ng)*zz & + ratdum(ir54ng)*dratdumdd(ir55ng)*zz & - ratdum(irfe56_aux2)*zz*denomdd - + end if - ! fe54(a,p)co57(g,p)fe56 equilibrium links + ! fe54(a,p)co57(g,p)fe56 equilibrium links ratdum(irfe56_aux3) = 0.0d0 dratdumdy1(irfe56_aux3) = 0.0d0 @@ -766,7 +766,7 @@ subroutine approx21_special_reactions( & dratdumdd(ir8f54) = dratdumdd(irnigp) * ratdum(ircopa) * zz & + ratdum(irnigp) * dratdumdd(ircopa) * zz & - ratdum(ir8f54) * zz * denomdd - + end if @@ -837,7 +837,7 @@ subroutine approx21_special_reactions( & denom = ratdum(irhegp)*ratdum(irdgn) + & y(ineut)*ratdum(irheng)*ratdum(irdgn) + & y(ineut)*y(iprot)*ratdum(irheng)*ratdum(irdpg) - + if (is_bad(dratdumdy1(iralf2))) then write(*,1) 'denom', denom write(*,1) 'zz', zz @@ -854,8 +854,8 @@ subroutine approx21_special_reactions( & write(*,1) 'y(iprot)', y(iprot) stop end if - - + + dratdumdy2(iralf2) = -ratdum(iralf2) * zz * y(ineut)* & ratdum(irheng) * ratdum(irdpg) dratdumdt(iralf2) = dratdumdt(irheng)*ratdum(irdpg) * & @@ -912,10 +912,10 @@ subroutine approx21_special_reactions( & end if end if - - + + contains - + subroutine turn_off_reaction(i) integer, intent(in) :: i if (i == 0) return @@ -924,10 +924,10 @@ subroutine turn_off_reaction(i) dratdumdd(i) = 0 dratdumdy1(i) = 0 dratdumdy2(i) = 0 - end subroutine turn_off_reaction + end subroutine turn_off_reaction end subroutine approx21_special_reactions - + subroutine approx21_dydt( & y, rate, ratdum, dydt, deriva, & @@ -949,9 +949,9 @@ subroutine approx21_dydt( & real(qp) :: qray(species(plus_co56)) logical :: okay - + include 'formats' - + ierr = 0 ! Turn on special fe56ec rate above some temperature @@ -965,20 +965,20 @@ subroutine approx21_dydt( & ! hydrogen reactions a1 = -1.5d0 * y(ih1) * y(ih1) * rate(irpp) - a2 = y(ihe3) * y(ihe3) * rate(ir33) - a3 = -y(ihe3) * y(ihe4) * rate(irhe3ag) - a4 = -2.0d0 * y(ic12) * y(ih1) * rate(ircpg) - a5 = -2.0d0 * y(in14) * y(ih1) * rate(irnpg) - a6 = -2.0d0 * y(io16) * y(ih1) * rate(iropg) + a2 = y(ihe3) * y(ihe3) * rate(ir33) + a3 = -y(ihe3) * y(ihe4) * rate(irhe3ag) + a4 = -2.0d0 * y(ic12) * y(ih1) * rate(ircpg) + a5 = -2.0d0 * y(in14) * y(ih1) * rate(irnpg) + a6 = -2.0d0 * y(io16) * y(ih1) * rate(iropg) a7 = -3.0d0 * y(ih1) * rate(irpen) - qray(ih1) = qray(ih1) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + qray(ih1) = qray(ih1) + a1 + a2 + a3 + a4 + a5 + a6 + a7 ! he3 reactions - a1 = 0.5d0 * y(ih1) * y(ih1) * rate(irpp) - a2 = -y(ihe3) * y(ihe3) * rate(ir33) - a3 = -y(ihe3) * y(ihe4) * rate(irhe3ag) + a1 = 0.5d0 * y(ih1) * y(ih1) * rate(irpp) + a2 = -y(ihe3) * y(ihe3) * rate(ir33) + a3 = -y(ihe3) * y(ihe4) * rate(irhe3ag) a4 = y(ih1) * rate(irpen) qray(ihe3) = qray(ihe3) + a1 + a2 + a3 + a4 @@ -986,8 +986,8 @@ subroutine approx21_dydt( & ! he4 reactions ! heavy ion reactions - a1 = 0.5d0 * y(ic12) * y(ic12) * rate(ir1212) - a2 = 0.5d0 * y(ic12) * y(io16) * rate(ir1216) + a1 = 0.5d0 * y(ic12) * y(ic12) * rate(ir1212) + a2 = 0.5d0 * y(ic12) * y(io16) * rate(ir1216) a3 = 0.56d0 * 0.5d0 * y(io16) * y(io16) * rate(ir1616) a4 = -y(ihe4) * y(in14) * rate(irnag) * 1.5d0 ! n14 + 1.5 alpha => ne20 qray(ihe4) = qray(ihe4) + a1 + a2 + a3 + a4 @@ -995,33 +995,33 @@ subroutine approx21_dydt( & ! (a,g) and (g,a) reactions - a1 = -0.5d0 * y(ihe4) * y(ihe4) * y(ihe4) * rate(ir3a) - a2 = 3.0d0 * y(ic12) * rate(irg3a) - a3 = -y(ihe4) * y(ic12) * rate(ircag) - a4 = y(io16) * rate(iroga) - a5 = -y(ihe4) * y(io16) * rate(iroag) - a6 = y(ine20) * rate(irnega) - a7 = -y(ihe4) * y(ine20) * rate(irneag) - a8 = y(img24) * rate(irmgga) - a9 = -y(ihe4) * y(img24)* rate(irmgag) - a10 = y(isi28) * rate(irsiga) - a11 = -y(ihe4) * y(isi28)*rate(irsiag) + a1 = -0.5d0 * y(ihe4) * y(ihe4) * y(ihe4) * rate(ir3a) + a2 = 3.0d0 * y(ic12) * rate(irg3a) + a3 = -y(ihe4) * y(ic12) * rate(ircag) + a4 = y(io16) * rate(iroga) + a5 = -y(ihe4) * y(io16) * rate(iroag) + a6 = y(ine20) * rate(irnega) + a7 = -y(ihe4) * y(ine20) * rate(irneag) + a8 = y(img24) * rate(irmgga) + a9 = -y(ihe4) * y(img24)* rate(irmgag) + a10 = y(isi28) * rate(irsiga) + a11 = -y(ihe4) * y(isi28)*rate(irsiag) a12 = y(is32) * rate(irsga) qray(ihe4) = qray(ihe4) + & a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 - - a1 = -y(ihe4) * y(is32) * rate(irsag) - a2 = y(iar36) * rate(irarga) - a3 = -y(ihe4) * y(iar36)*rate(irarag) - a4 = y(ica40) * rate(ircaga) - a5 = -y(ihe4) * y(ica40)*rate(ircaag) - a6 = y(iti44) * rate(irtiga) - a7 = -y(ihe4) * y(iti44)*rate(irtiag) - a8 = y(icr48) * rate(ircrga) - a9 = -y(ihe4) * y(icr48)*rate(ircrag) - a10 = y(ife52) * rate(irfega) - a11 = -y(ihe4) * y(ife52) * rate(irfeag) + + a1 = -y(ihe4) * y(is32) * rate(irsag) + a2 = y(iar36) * rate(irarga) + a3 = -y(ihe4) * y(iar36)*rate(irarag) + a4 = y(ica40) * rate(ircaga) + a5 = -y(ihe4) * y(ica40)*rate(ircaag) + a6 = y(iti44) * rate(irtiga) + a7 = -y(ihe4) * y(iti44)*rate(irtiag) + a8 = y(icr48) * rate(ircrga) + a9 = -y(ihe4) * y(icr48)*rate(ircrag) + a10 = y(ife52) * rate(irfega) + a11 = -y(ihe4) * y(ife52) * rate(irfeag) a12 = y(ini56) * rate(irniga) qray(ihe4) = qray(ihe4) + & @@ -1031,48 +1031,48 @@ subroutine approx21_dydt( & ! (a,p)(p,g) and (g,p)(p,a) reactions if (.not.deriva) then - a1 = 0.34d0*0.5d0*y(io16)*y(io16)*rate(irs1)*rate(ir1616) + a1 = 0.34d0*0.5d0*y(io16)*y(io16)*rate(irs1)*rate(ir1616) a2 = -y(ihe4) * y(img24) * rate(irmgap)*(1.0d0-rate(irr1)) - a3 = y(isi28) * rate(irsigp) * rate(irr1) - a4 = -y(ihe4) * y(isi28) * rate(irsiap)*(1.0d0-rate(irs1)) - a5 = y(is32) * rate(irsgp) * rate(irs1) - a6 = -y(ihe4) * y(is32) * rate(irsap)*(1.0d0-rate(irt1)) - a7 = y(iar36) * rate(irargp) * rate(irt1) - a8 = -y(ihe4) * y(iar36) * rate(irarap)*(1.0d0-rate(iru1)) - a9 = y(ica40) * rate(ircagp) * rate(iru1) - a10 = -y(ihe4) * y(ica40) * rate(ircaap)*(1.0d0-rate(irv1)) + a3 = y(isi28) * rate(irsigp) * rate(irr1) + a4 = -y(ihe4) * y(isi28) * rate(irsiap)*(1.0d0-rate(irs1)) + a5 = y(is32) * rate(irsgp) * rate(irs1) + a6 = -y(ihe4) * y(is32) * rate(irsap)*(1.0d0-rate(irt1)) + a7 = y(iar36) * rate(irargp) * rate(irt1) + a8 = -y(ihe4) * y(iar36) * rate(irarap)*(1.0d0-rate(iru1)) + a9 = y(ica40) * rate(ircagp) * rate(iru1) + a10 = -y(ihe4) * y(ica40) * rate(ircaap)*(1.0d0-rate(irv1)) a11 = y(iti44) * rate(irtigp) * rate(irv1) - a12 = -y(ihe4) * y(iti44) * rate(irtiap)*(1.0d0-rate(irw1)) - a13 = y(icr48) * rate(ircrgp) * rate(irw1) - a14 = -y(ihe4) * y(icr48) * rate(ircrap)*(1.0d0-rate(irx1)) - a15 = y(ife52) * rate(irfegp) * rate(irx1) + a12 = -y(ihe4) * y(iti44) * rate(irtiap)*(1.0d0-rate(irw1)) + a13 = y(icr48) * rate(ircrgp) * rate(irw1) + a14 = -y(ihe4) * y(icr48) * rate(ircrap)*(1.0d0-rate(irx1)) + a15 = y(ife52) * rate(irfegp) * rate(irx1) qray(ihe4) = qray(ihe4) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + & a8 + a9 + a10 + a11 + a12 + a13 + a14 + a15 else - a1 = 0.34d0*0.5d0*y(io16)*y(io16) * ratdum(irs1)*rate(ir1616) + a1 = 0.34d0*0.5d0*y(io16)*y(io16) * ratdum(irs1)*rate(ir1616) a2 = 0.34d0*0.5d0*y(io16)*y(io16) * rate(irs1) * ratdum(ir1616) - a3 = -y(ihe4)*y(img24) * rate(irmgap)*(1.0d0 - ratdum(irr1)) + a3 = -y(ihe4)*y(img24) * rate(irmgap)*(1.0d0 - ratdum(irr1)) a4 = y(ihe4)*y(img24) * ratdum(irmgap)*rate(irr1) - a5 = y(isi28) * ratdum(irsigp) * rate(irr1) + a5 = y(isi28) * ratdum(irsigp) * rate(irr1) a6 = y(isi28) * rate(irsigp) * ratdum(irr1) - a7 = -y(ihe4)*y(isi28) * rate(irsiap)*(1.0d0 - ratdum(irs1)) + a7 = -y(ihe4)*y(isi28) * rate(irsiap)*(1.0d0 - ratdum(irs1)) a8 = y(ihe4)*y(isi28) * ratdum(irsiap) * rate(irs1) a9 = y(is32) * ratdum(irsgp) * rate(irs1) a10 = y(is32) * rate(irsgp) * ratdum(irs1) qray(ihe4) = qray(ihe4) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 - a1 = -y(ihe4)*y(is32) * rate(irsap)*(1.0d0 - ratdum(irt1)) + a1 = -y(ihe4)*y(is32) * rate(irsap)*(1.0d0 - ratdum(irt1)) a2 = y(ihe4)*y(is32) * ratdum(irsap)*rate(irt1) - a3 = y(iar36) * ratdum(irargp) * rate(irt1) + a3 = y(iar36) * ratdum(irargp) * rate(irt1) a4 = y(iar36) * rate(irargp) * ratdum(irt1) a5 = -y(ihe4)*y(iar36) * rate(irarap)*(1.0d0 - ratdum(iru1)) a6 = y(ihe4)*y(iar36) * ratdum(irarap)*rate(iru1) a7 = y(ica40) * ratdum(ircagp) * rate(iru1) a8 = y(ica40) * rate(ircagp) * ratdum(iru1) - a9 = -y(ihe4)*y(ica40) * rate(ircaap)*(1.0d0-ratdum (irv1)) + a9 = -y(ihe4)*y(ica40) * rate(ircaap)*(1.0d0-ratdum (irv1)) a10 = y(ihe4)*y(ica40) * ratdum(ircaap)*rate(irv1) a11 = y(iti44) * ratdum(irtigp) * rate(irv1) a12 = y(iti44) * rate(irtigp) * ratdum(irv1) @@ -1082,11 +1082,11 @@ subroutine approx21_dydt( & a1 = -y(ihe4)*y(iti44) * rate(irtiap)*(1.0d0 - ratdum(irw1)) a2 = y(ihe4)*y(iti44) * ratdum(irtiap)*rate(irw1) - a3 = y(icr48) * ratdum(ircrgp) * rate(irw1) + a3 = y(icr48) * ratdum(ircrgp) * rate(irw1) a4 = y(icr48) * rate(ircrgp) * ratdum(irw1) a5 = -y(ihe4)*y(icr48) * rate(ircrap)*(1.0d0 - ratdum(irx1)) a6 = y(ihe4)*y(icr48) * ratdum(ircrap)*rate(irx1) - a7 = y(ife52) * ratdum(irfegp) * rate(irx1) + a7 = y(ife52) * ratdum(irfegp) * rate(irx1) a8 = y(ife52) * rate(irfegp) * ratdum(irx1) qray(ihe4) = qray(ihe4) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 @@ -1094,14 +1094,14 @@ subroutine approx21_dydt( & ! photodisintegration reactions - a1 = y(ife54) * y(iprot) * y(iprot) * rate(ir5f54) - a2 = -y(ife52) * y(ihe4) * rate(ir6f54) - a3 = -y(ife52) * y(ihe4) * y(iprot) * rate(ir7f54) - a4 = y(ini56) * y(iprot) * rate(ir8f54) - a5 = -y(ihe4) * rate(iralf1) - a6 = y(ineut)*y(ineut) * y(iprot)*y(iprot) * rate(iralf2) - a7 = y(ife56) * y(iprot) * y(iprot) * rate(irfe56_aux3) - a8 = -y(ife54) * y(ihe4) * rate(irfe56_aux4) + a1 = y(ife54) * y(iprot) * y(iprot) * rate(ir5f54) + a2 = -y(ife52) * y(ihe4) * rate(ir6f54) + a3 = -y(ife52) * y(ihe4) * y(iprot) * rate(ir7f54) + a4 = y(ini56) * y(iprot) * rate(ir8f54) + a5 = -y(ihe4) * rate(iralf1) + a6 = y(ineut)*y(ineut) * y(iprot)*y(iprot) * rate(iralf2) + a7 = y(ife56) * y(iprot) * y(iprot) * rate(irfe56_aux3) + a8 = -y(ife54) * y(ihe4) * rate(irfe56_aux4) qray(ihe4) = qray(ihe4) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 @@ -1110,97 +1110,97 @@ subroutine approx21_dydt( & a1 = 0.5d0 * y(ihe3) * y(ihe3) * rate(ir33) a2 = y(ihe3) * y(ihe4) * rate(irhe3ag) - qray(ihe4) = qray(ihe4) + a1 + a2 + qray(ihe4) = qray(ihe4) + a1 + a2 ! cno cycles - a1 = y(io16) * y(ih1) * rate(iropg) + a1 = y(io16) * y(ih1) * rate(iropg) qray(ihe4) = qray(ihe4) + a1 + a2 - + if (.not. deriva) then - a1 = y(in14) * y(ih1) * rate(ifa) * rate(irnpg) + a1 = y(in14) * y(ih1) * rate(ifa) * rate(irnpg) qray(ihe4) = qray(ihe4) + a1 else - a1 = y(in14) * y(ih1) * rate(ifa) * ratdum(irnpg) - a2 = y(in14) * y(ih1) * ratdum(ifa) * rate(irnpg) + a1 = y(in14) * y(ih1) * rate(ifa) * ratdum(irnpg) + a2 = y(in14) * y(ih1) * ratdum(ifa) * rate(irnpg) qray(ihe4) = qray(ihe4) + a1 + a2 end if ! c12 reactions - a1 = -y(ic12) * y(ic12) * rate(ir1212) - a2 = -y(ic12) * y(io16) * rate(ir1216) - a3 = (1d0/6d0) * y(ihe4) * y(ihe4) * y(ihe4) * rate(ir3a) - a4 = -y(ic12) * rate(irg3a) - a5 = -y(ic12) * y(ihe4) * rate(ircag) - a6 = y(io16) * rate(iroga) - a7 = -y(ic12) * y(ih1) * rate(ircpg) + a1 = -y(ic12) * y(ic12) * rate(ir1212) + a2 = -y(ic12) * y(io16) * rate(ir1216) + a3 = (1d0/6d0) * y(ihe4) * y(ihe4) * y(ihe4) * rate(ir3a) + a4 = -y(ic12) * rate(irg3a) + a5 = -y(ic12) * y(ihe4) * rate(ircag) + a6 = y(io16) * rate(iroga) + a7 = -y(ic12) * y(ih1) * rate(ircpg) qray(ic12) = qray(ic12) + a1 + a2 + a3 + a4 + a5 + a6 + a7 - + if (.not. deriva) then a1 = y(in14) * y(ih1) * rate(ifa) * rate(irnpg) qray(ic12) = qray(ic12) + a1 else a1 = y(in14) * y(ih1) * rate(ifa) * ratdum(irnpg) a2 = y(in14) * y(ih1) * ratdum(ifa) * rate(irnpg) - qray(ic12) = qray(ic12) + a1 + a2 + qray(ic12) = qray(ic12) + a1 + a2 end if ! n14 reactions - a1 = y(ic12) * y(ih1) * rate(ircpg) - a2 = -y(in14) * y(ih1) * rate(irnpg) - a3 = y(io16) * y(ih1) * rate(iropg) + a1 = y(ic12) * y(ih1) * rate(ircpg) + a2 = -y(in14) * y(ih1) * rate(irnpg) + a3 = y(io16) * y(ih1) * rate(iropg) a4 = -y(ihe4) * y(in14) * rate(irnag) ! n14 + 1.5 alpha => ne20 - qray(in14) = qray(in14) + a1 + a2 + a3 + a4 + qray(in14) = qray(in14) + a1 + a2 + a3 + a4 ! o16 reactions - a1 = -y(ic12) * y(io16) * rate(ir1216) - a2 = -y(io16) * y(io16) * rate(ir1616) - a3 = y(ic12) * y(ihe4) * rate(ircag) - a4 = -y(io16) * y(ihe4) * rate(iroag) - a5 = -y(io16) * rate(iroga) - a6 = y(ine20) * rate(irnega) + a1 = -y(ic12) * y(io16) * rate(ir1216) + a2 = -y(io16) * y(io16) * rate(ir1616) + a3 = y(ic12) * y(ihe4) * rate(ircag) + a4 = -y(io16) * y(ihe4) * rate(iroag) + a5 = -y(io16) * rate(iroga) + a6 = y(ine20) * rate(irnega) a7 = -y(io16) * y(ih1) * rate(iropg) qray(io16) = qray(io16) + a1 + a2 + a3 + a4 + a5 + a6 + a7 - + if (.not. deriva) then - a1 = y(in14) * y(ih1) * rate(ifg) * rate(irnpg) + a1 = y(in14) * y(ih1) * rate(ifg) * rate(irnpg) qray(io16) = qray(io16) + a1 else - a1 = y(in14) * y(ih1) * rate(ifg) * ratdum(irnpg) - a2 = y(in14) * y(ih1) * ratdum(ifg) * rate(irnpg) + a1 = y(in14) * y(ih1) * rate(ifg) * ratdum(irnpg) + a2 = y(in14) * y(ih1) * ratdum(ifg) * rate(irnpg) qray(io16) = qray(io16) + a1 + a2 end if ! ne20 reactions - a1 = 0.5d0 * y(ic12) * y(ic12) * rate(ir1212) - a2 = y(io16) * y(ihe4) * rate(iroag) - a3 = -y(ine20) * y(ihe4) * rate(irneag) - a4 = -y(ine20) * rate(irnega) - a5 = y(img24) * rate(irmgga) + a1 = 0.5d0 * y(ic12) * y(ic12) * rate(ir1212) + a2 = y(io16) * y(ihe4) * rate(iroag) + a3 = -y(ine20) * y(ihe4) * rate(irneag) + a4 = -y(ine20) * rate(irnega) + a5 = y(img24) * rate(irmgga) a6 = y(in14) * y(ihe4) * rate(irnag) ! n14 + 1.5 alpha => ne20 qray(ine20) = qray(ine20) + a1 + a2 + a3 + a4 + a5 + a6 ! mg24 reactions - a1 = 0.5d0 * y(ic12) * y(io16) * rate(ir1216) - a2 = y(ine20) * y(ihe4) * rate(irneag) - a3 = -y(img24) * y(ihe4) * rate(irmgag) - a4 = -y(img24) * rate(irmgga) + a1 = 0.5d0 * y(ic12) * y(io16) * rate(ir1216) + a2 = y(ine20) * y(ihe4) * rate(irneag) + a3 = -y(img24) * y(ihe4) * rate(irmgag) + a4 = -y(img24) * rate(irmgga) a5 = y(isi28) * rate(irsiga) - - qray(img24) = qray(img24) + a1 + a2 + a3 + a4 + a5 + + qray(img24) = qray(img24) + a1 + a2 + a3 + a4 + a5 if (.not.deriva) then - a1 = -y(img24) * y(ihe4) * rate(irmgap)*(1.0d0-rate(irr1)) + a1 = -y(img24) * y(ihe4) * rate(irmgap)*(1.0d0-rate(irr1)) a2 = y(isi28) * rate(irr1) * rate(irsigp) qray(img24) = qray(img24) + a1 + a2 @@ -1208,7 +1208,7 @@ subroutine approx21_dydt( & else a1 = -y(img24)*y(ihe4) * rate(irmgap)*(1.0d0 - ratdum(irr1)) a2 = y(img24)*y(ihe4) * ratdum(irmgap)*rate(irr1) - a3 = y(isi28) * ratdum(irr1) * rate(irsigp) + a3 = y(isi28) * ratdum(irr1) * rate(irsigp) a4 = y(isi28) * rate(irr1) * ratdum(irsigp) qray(img24) = qray(img24) + a1 + a2 + a3 + a4 @@ -1216,31 +1216,31 @@ subroutine approx21_dydt( & ! si28 reactions - a1 = 0.5d0 * y(ic12) * y(io16) * rate(ir1216) - a2 = 0.56d0 * 0.5d0*y(io16) * y(io16) * rate(ir1616) - a3 = y(img24) * y(ihe4) * rate(irmgag) - a4 = -y(isi28) * y(ihe4) * rate(irsiag) - a5 = -y(isi28) * rate(irsiga) + a1 = 0.5d0 * y(ic12) * y(io16) * rate(ir1216) + a2 = 0.56d0 * 0.5d0*y(io16) * y(io16) * rate(ir1616) + a3 = y(img24) * y(ihe4) * rate(irmgag) + a4 = -y(isi28) * y(ihe4) * rate(irsiag) + a5 = -y(isi28) * rate(irsiga) a6 = y(is32) * rate(irsga) qray(isi28) = qray(isi28) + a1 + a2 + a3 + a4 + a5 + a6 if (.not.deriva) then - - a1 = 0.34d0*0.5d0*y(io16)*y(io16)*rate(irs1)*rate(ir1616) - a2 = y(img24) * y(ihe4) * rate(irmgap)*(1.0d0-rate(irr1)) - a3 = -y(isi28) * rate(irr1) * rate(irsigp) - a4 = -y(isi28) * y(ihe4) * rate(irsiap)*(1.0d0-rate(irs1)) + + a1 = 0.34d0*0.5d0*y(io16)*y(io16)*rate(irs1)*rate(ir1616) + a2 = y(img24) * y(ihe4) * rate(irmgap)*(1.0d0-rate(irr1)) + a3 = -y(isi28) * rate(irr1) * rate(irsigp) + a4 = -y(isi28) * y(ihe4) * rate(irsiap)*(1.0d0-rate(irs1)) a5 = y(is32) * rate(irs1) * rate(irsgp) qray(isi28) = qray(isi28) + a1 + a2 + a3 + a4 + a5 else - a1 = 0.34d0*0.5d0*y(io16)*y(io16) * ratdum(irs1)*rate(ir1616) + a1 = 0.34d0*0.5d0*y(io16)*y(io16) * ratdum(irs1)*rate(ir1616) a2 = 0.34d0*0.5d0*y(io16)*y(io16) * rate(irs1)*ratdum(ir1616) a3 = y(img24)*y(ihe4) * rate(irmgap)*(1.0d0 - ratdum(irr1)) a4 = -y(img24)*y(ihe4) * ratdum(irmgap)*rate(irr1) - a5 = -y(isi28) * ratdum(irr1) * rate(irsigp) + a5 = -y(isi28) * ratdum(irr1) * rate(irsigp) a6 = -y(isi28) * rate(irr1) * ratdum(irsigp) a7 = -y(isi28)*y(ihe4) * rate(irsiap)*(1.0d0 - ratdum(irs1)) a8 = y(isi28)*y(ihe4) * ratdum(irsiap)*rate(irs1) @@ -1253,20 +1253,20 @@ subroutine approx21_dydt( & ! s32 reactions - a1 = 0.1d0 * 0.5d0*y(io16) * y(io16) * rate(ir1616) - a2 = y(isi28) * y(ihe4) * rate(irsiag) - a3 = -y(is32) * y(ihe4) * rate(irsag) - a4 = -y(is32) * rate(irsga) + a1 = 0.1d0 * 0.5d0*y(io16) * y(io16) * rate(ir1616) + a2 = y(isi28) * y(ihe4) * rate(irsiag) + a3 = -y(is32) * y(ihe4) * rate(irsag) + a4 = -y(is32) * rate(irsga) a5 = y(iar36) * rate(irarga) qray(is32) = qray(is32) + a1 + a2 + a3 + a4 + a5 if (.not.deriva) then - a1 = 0.34d0*0.5d0*y(io16)*y(io16)* rate(ir1616)*(1.0d0-rate(irs1)) - a2 = y(isi28) * y(ihe4) * rate(irsiap)*(1.0d0-rate(irs1)) - a3 = -y(is32) * rate(irs1) * rate(irsgp) - a4 = -y(is32) * y(ihe4) * rate(irsap)*(1.0d0-rate(irt1)) + a1 = 0.34d0*0.5d0*y(io16)*y(io16)* rate(ir1616)*(1.0d0-rate(irs1)) + a2 = y(isi28) * y(ihe4) * rate(irsiap)*(1.0d0-rate(irs1)) + a3 = -y(is32) * rate(irs1) * rate(irsgp) + a4 = -y(is32) * y(ihe4) * rate(irsap)*(1.0d0-rate(irt1)) a5 = y(iar36) * rate(irt1) * rate(irargp) qray(is32) = qray(is32) + a1 + a2 + a3 + a4 + a5 @@ -1275,8 +1275,8 @@ subroutine approx21_dydt( & a1 = 0.34d0*0.5d0*y(io16)*y(io16) * rate(ir1616)*(1.0d0-ratdum(irs1)) a2 = -0.34d0*0.5d0*y(io16)*y(io16) * ratdum(ir1616)*rate(irs1) a3 = y(isi28)*y(ihe4) * rate(irsiap)*(1.0d0-ratdum(irs1)) - a4 = -y(isi28)*y(ihe4) * ratdum(irsiap)*rate(irs1) - a5 = -y(is32) * ratdum(irs1) * rate(irsgp) + a4 = -y(isi28)*y(ihe4) * ratdum(irsiap)*rate(irs1) + a5 = -y(is32) * ratdum(irs1) * rate(irsgp) a6 = -y(is32) * rate(irs1) * ratdum(irsgp) a7 = -y(is32)*y(ihe4) * rate(irsap)*(1.0d0-ratdum(irt1)) a8 = y(is32)*y(ihe4) * ratdum(irsap)*rate(irt1) @@ -1289,32 +1289,32 @@ subroutine approx21_dydt( & ! ar36 reactions - a1 = y(is32) * y(ihe4) * rate(irsag) + a1 = y(is32) * y(ihe4) * rate(irsag) a2 = -y(iar36) * y(ihe4) * rate(irarag) - a3 = -y(iar36) * rate(irarga) + a3 = -y(iar36) * rate(irarga) a4 = y(ica40) * rate(ircaga) qray(iar36) = qray(iar36) + a1 + a2 + a3 + a4 if (.not.deriva) then - a1 = y(is32) * y(ihe4) * rate(irsap)*(1.0d0-rate(irt1)) - a2 = -y(iar36) * rate(irt1) * rate(irargp) - a3 = -y(iar36) * y(ihe4) * rate(irarap)*(1.0d0-rate(iru1)) + a1 = y(is32) * y(ihe4) * rate(irsap)*(1.0d0-rate(irt1)) + a2 = -y(iar36) * rate(irt1) * rate(irargp) + a3 = -y(iar36) * y(ihe4) * rate(irarap)*(1.0d0-rate(iru1)) a4 = y(ica40) * rate(ircagp) * rate(iru1) qray(iar36) = qray(iar36) + a1 + a2 + a3 + a4 else - a1 = y(is32)*y(ihe4) * rate(irsap)*(1.0d0 - ratdum(irt1)) + a1 = y(is32)*y(ihe4) * rate(irsap)*(1.0d0 - ratdum(irt1)) a2 = -y(is32)*y(ihe4) * ratdum(irsap)*rate(irt1) - a3 = -y(iar36) * ratdum(irt1) * rate(irargp) + a3 = -y(iar36) * ratdum(irt1) * rate(irargp) a4 = -y(iar36) * rate(irt1) * ratdum(irargp) a5 = -y(iar36)*y(ihe4) * rate(irarap)*(1.0d0-ratdum(iru1)) a6 = y(iar36)*y(ihe4) * ratdum(irarap)*rate(iru1) - a7 = y(ica40) * ratdum(ircagp) * rate(iru1) + a7 = y(ica40) * ratdum(ircagp) * rate(iru1) a8 = y(ica40) * rate(ircagp) * ratdum(iru1) - qray(iar36) = qray(iar36) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + qray(iar36) = qray(iar36) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 end if @@ -1328,9 +1328,9 @@ subroutine approx21_dydt( & if (.not.deriva) then - a1 = y(iar36) * y(ihe4) * rate(irarap)*(1.0d0-rate(iru1)) - a2 = -y(ica40) * rate(ircagp) * rate(iru1) - a3 = -y(ica40) * y(ihe4) * rate(ircaap)*(1.0d0-rate(irv1)) + a1 = y(iar36) * y(ihe4) * rate(irarap)*(1.0d0-rate(iru1)) + a2 = -y(ica40) * rate(ircagp) * rate(iru1) + a3 = -y(ica40) * y(ihe4) * rate(ircaap)*(1.0d0-rate(irv1)) a4 = y(iti44) * rate(irtigp) * rate(irv1) qray(ica40) = qray(ica40) + a1 + a2 + a3 + a4 @@ -1338,126 +1338,126 @@ subroutine approx21_dydt( & else a1 = y(iar36)*y(ihe4) * rate(irarap)*(1.0d0-ratdum(iru1)) a2 = -y(iar36)*y(ihe4) * ratdum(irarap)*rate(iru1) - a3 = -y(ica40) * ratdum(ircagp) * rate(iru1) + a3 = -y(ica40) * ratdum(ircagp) * rate(iru1) a4 = -y(ica40) * rate(ircagp) * ratdum(iru1) - a5 = -y(ica40)*y(ihe4) * rate(ircaap)*(1.0d0-ratdum(irv1)) + a5 = -y(ica40)*y(ihe4) * rate(ircaap)*(1.0d0-ratdum(irv1)) a6 = y(ica40)*y(ihe4) * ratdum(ircaap)*rate(irv1) - a7 = y(iti44) * ratdum(irtigp) * rate(irv1) + a7 = y(iti44) * ratdum(irtigp) * rate(irv1) a8 = y(iti44) * rate(irtigp) * ratdum(irv1) - qray(ica40) = qray(ica40) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + qray(ica40) = qray(ica40) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 end if ! ti44 reactions - a1 = y(ica40) * y(ihe4) * rate(ircaag) - a2 = -y(iti44) * y(ihe4) * rate(irtiag) - a3 = -y(iti44) * rate(irtiga) + a1 = y(ica40) * y(ihe4) * rate(ircaag) + a2 = -y(iti44) * y(ihe4) * rate(irtiag) + a3 = -y(iti44) * rate(irtiga) a4 = y(icr48) * rate(ircrga) qray(iti44) = qray(iti44) + a1 + a2 + a3 + a4 if (.not.deriva) then - a1 = y(ica40) * y(ihe4) * rate(ircaap)*(1.0d0-rate(irv1)) - a2 = -y(iti44) * rate(irv1) * rate(irtigp) - a3 = -y(iti44) * y(ihe4) * rate(irtiap)*(1.0d0-rate(irw1)) + a1 = y(ica40) * y(ihe4) * rate(ircaap)*(1.0d0-rate(irv1)) + a2 = -y(iti44) * rate(irv1) * rate(irtigp) + a3 = -y(iti44) * y(ihe4) * rate(irtiap)*(1.0d0-rate(irw1)) a4 = y(icr48) * rate(irw1) * rate(ircrgp) qray(iti44) = qray(iti44) + a1 + a2 + a3 + a4 else - a1 = y(ica40)*y(ihe4) * rate(ircaap)*(1.0d0-ratdum(irv1)) + a1 = y(ica40)*y(ihe4) * rate(ircaap)*(1.0d0-ratdum(irv1)) a2 = -y(ica40)*y(ihe4) * ratdum(ircaap)*rate(irv1) - a3 = -y(iti44) * ratdum(irv1) * rate(irtigp) + a3 = -y(iti44) * ratdum(irv1) * rate(irtigp) a4 = -y(iti44) * rate(irv1) * ratdum(irtigp) a5 = -y(iti44)*y(ihe4) * rate(irtiap)*(1.0d0-ratdum(irw1)) a6 = y(iti44)*y(ihe4) * ratdum(irtiap)*rate(irw1) a7 = y(icr48) * ratdum(irw1) * rate(ircrgp) a8 = y(icr48) * rate(irw1) * ratdum(ircrgp) - qray(iti44) = qray(iti44) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + qray(iti44) = qray(iti44) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 end if ! cr48 reactions - a1 = y(iti44) * y(ihe4) * rate(irtiag) - a2 = -y(icr48) * y(ihe4) * rate(ircrag) - a3 = -y(icr48) * rate(ircrga) + a1 = y(iti44) * y(ihe4) * rate(irtiag) + a2 = -y(icr48) * y(ihe4) * rate(ircrag) + a3 = -y(icr48) * rate(ircrga) a4 = y(ife52) * rate(irfega) qray(icr48) = qray(icr48) + a1 + a2 + a3 + a4 if (.not.deriva) then - a1 = y(iti44) * y(ihe4) * rate(irtiap)*(1.0d0-rate(irw1)) - a2 = -y(icr48) * rate(irw1) * rate(ircrgp) - a3 = -y(icr48) * y(ihe4) * rate(ircrap)*(1.0d0-rate(irx1)) + a1 = y(iti44) * y(ihe4) * rate(irtiap)*(1.0d0-rate(irw1)) + a2 = -y(icr48) * rate(irw1) * rate(ircrgp) + a3 = -y(icr48) * y(ihe4) * rate(ircrap)*(1.0d0-rate(irx1)) a4 = y(ife52) * rate(irx1) * rate(irfegp) qray(icr48) = qray(icr48) + a1 + a2 + a3 + a4 else - a1 = y(iti44)*y(ihe4) * rate(irtiap)*(1.0d0-ratdum(irw1)) + a1 = y(iti44)*y(ihe4) * rate(irtiap)*(1.0d0-ratdum(irw1)) a2 = -y(iti44)*y(ihe4) * ratdum(irtiap)*rate(irw1) - a3 = -y(icr48) * ratdum(irw1) * rate(ircrgp) + a3 = -y(icr48) * ratdum(irw1) * rate(ircrgp) a4 = -y(icr48) * rate(irw1) * ratdum(ircrgp) a5 = -y(icr48)*y(ihe4) * rate(ircrap)*(1.0d0-ratdum(irx1)) a6 = y(icr48)*y(ihe4) * ratdum(ircrap)*rate(irx1) - a7 = y(ife52) * ratdum(irx1) * rate(irfegp) + a7 = y(ife52) * ratdum(irx1) * rate(irfegp) a8 = y(ife52) * rate(irx1) * ratdum(irfegp) - qray(icr48) = qray(icr48) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + qray(icr48) = qray(icr48) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 end if ! crx reactions a1 = y(ife56) * fe56ec_fake_factor * rate(irn56ec) - + qray(icrx) = qray(icrx) + a1 ! fe52 reactions - a1 = y(icr48) * y(ihe4) * rate(ircrag) - a2 = -y(ife52) * y(ihe4) * rate(irfeag) - a3 = -y(ife52) * rate(irfega) + a1 = y(icr48) * y(ihe4) * rate(ircrag) + a2 = -y(ife52) * y(ihe4) * rate(irfeag) + a3 = -y(ife52) * rate(irfega) a4 = y(ini56) * rate(irniga) qray(ife52) = qray(ife52) + a1 + a2 + a3 + a4 if (.not.deriva) then - a1 = y(icr48) * y(ihe4) * rate(ircrap)*(1.0d0-rate(irx1)) - a2 = -y(ife52) * rate(irx1) * rate(irfegp) + a1 = y(icr48) * y(ihe4) * rate(ircrap)*(1.0d0-rate(irx1)) + a2 = -y(ife52) * rate(irx1) * rate(irfegp) qray(ife52) = qray(ife52) + a1 + a2 else a1 = y(icr48)*y(ihe4) * rate(ircrap)*(1.0d0-ratdum(irx1)) a2 = -y(icr48)*y(ihe4) * ratdum(ircrap)*rate(irx1) - a3 = -y(ife52) * ratdum(irx1) * rate(irfegp) + a3 = -y(ife52) * ratdum(irx1) * rate(irfegp) a4 = -y(ife52) * rate(irx1) * ratdum(irfegp) qray(ife52) = qray(ife52) + a1 + a2 + a3 + a4 end if - a1 = y(ife54) * rate(ir1f54) - a2 = -y(ife52) * y(ineut) * y(ineut) * rate(ir2f54) - a3 = y(ife54) * y(iprot) * y(iprot) * rate(ir5f54) - a4 = -y(ife52) * y(ihe4) * rate(ir6f54) - a5 = -y(ife52) * y(ihe4) * y(iprot) * rate(ir7f54) - a6 = y(ini56) * y(iprot) * rate(ir8f54) + a1 = y(ife54) * rate(ir1f54) + a2 = -y(ife52) * y(ineut) * y(ineut) * rate(ir2f54) + a3 = y(ife54) * y(iprot) * y(iprot) * rate(ir5f54) + a4 = -y(ife52) * y(ihe4) * rate(ir6f54) + a5 = -y(ife52) * y(ihe4) * y(iprot) * rate(ir7f54) + a6 = y(ini56) * y(iprot) * rate(ir8f54) - qray(ife52) = qray(ife52) + a1 + a2 + a3 + a4 + a5 + a6 + qray(ife52) = qray(ife52) + a1 + a2 + a3 + a4 + a5 + a6 ! fe54 reactions a1 = -y(ife54) * rate(ir1f54) - a2 = y(ife52) * y(ineut) * y(ineut) * rate(ir2f54) - a3 = -y(ife54) * y(iprot) * y(iprot) * rate(ir3f54) - a4 = y(ini56) * rate(ir4f54) - a5 = -y(ife54) * y(iprot) * y(iprot) * rate(ir5f54) - a6 = y(ife52) * y(ihe4) * rate(ir6f54) - a7 = y(ife56) * rate(irfe56_aux1) - a8 = -y(ife54) * y(ineut) * y(ineut) * rate(irfe56_aux2) - a9 = y(ife56) * y(iprot) * y(iprot) * rate(irfe56_aux3) - a10 = -y(ife54) * y(ihe4) * rate(irfe56_aux4) + a2 = y(ife52) * y(ineut) * y(ineut) * rate(ir2f54) + a3 = -y(ife54) * y(iprot) * y(iprot) * rate(ir3f54) + a4 = y(ini56) * rate(ir4f54) + a5 = -y(ife54) * y(iprot) * y(iprot) * rate(ir5f54) + a6 = y(ife52) * y(ihe4) * rate(ir6f54) + a7 = y(ife56) * rate(irfe56_aux1) + a8 = -y(ife54) * y(ineut) * y(ineut) * rate(irfe56_aux2) + a9 = y(ife56) * y(iprot) * y(iprot) * rate(irfe56_aux3) + a10 = -y(ife54) * y(ihe4) * rate(irfe56_aux4) qray(ife54) = qray(ife54) + & a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 @@ -1465,47 +1465,47 @@ subroutine approx21_dydt( & ! fe56 reactions if (plus_co56) then - a1 = y(ico56) * rate(irco56ec) + a1 = y(ico56) * rate(irco56ec) else - a1 = y(ini56) * rate(irn56ec) + a1 = y(ini56) * rate(irn56ec) end if - a2 = -y(ife56) * fe56ec_fake_factor * rate(irn56ec) - a3 = -y(ife56) * rate(irfe56_aux1) - a4 = y(ife54) * y(ineut) * y(ineut) * rate(irfe56_aux2) - a5 = -y(ife56) * y(iprot) * y(iprot) * rate(irfe56_aux3) - a6 = y(ife54) * y(ihe4) * rate(irfe56_aux4) + a2 = -y(ife56) * fe56ec_fake_factor * rate(irn56ec) + a3 = -y(ife56) * rate(irfe56_aux1) + a4 = y(ife54) * y(ineut) * y(ineut) * rate(irfe56_aux2) + a5 = -y(ife56) * y(iprot) * y(iprot) * rate(irfe56_aux3) + a6 = y(ife54) * y(ihe4) * rate(irfe56_aux4) - qray(ife56) = qray(ife56) + a1 + a2 + a3 + a4 + a5 + a6 + qray(ife56) = qray(ife56) + a1 + a2 + a3 + a4 + a5 + a6 if (plus_co56) then ! co56 reactions - a1 = y(ini56) * rate(irn56ec) - a2 = -y(ico56) * rate(irco56ec) - + a1 = y(ini56) * rate(irn56ec) + a2 = -y(ico56) * rate(irco56ec) + qray(ico56) = qray(ico56) + a1 + a2 end if ! ni56 reactions - a1 = y(ife52) * y(ihe4) * rate(irfeag) - a2 = -y(ini56) * rate(irniga) - a3 = -y(ini56) * rate(irn56ec) - + a1 = y(ife52) * y(ihe4) * rate(irfeag) + a2 = -y(ini56) * rate(irniga) + a3 = -y(ini56) * rate(irn56ec) + qray(ini56) = qray(ini56) + a1 + a2 + a3 - a1 = y(ife54) * y(iprot) * y(iprot) * rate(ir3f54) - a2 = -y(ini56) * rate(ir4f54) - a3 = y(ife52) * y(ihe4)* y(iprot) * rate(ir7f54) + a1 = y(ife54) * y(iprot) * y(iprot) * rate(ir3f54) + a2 = -y(ini56) * rate(ir4f54) + a3 = y(ife52) * y(ihe4)* y(iprot) * rate(ir7f54) a4 = -y(ini56) * y(iprot) * rate(ir8f54) qray(ini56) = qray(ini56) + a1 + a2 + a3 + a4 ! neutrons - a1 = 2.0d0 * y(ife54) * rate(ir1f54) - a2 = -2.0d0 * y(ife52) * y(ineut) * y(ineut) * rate(ir2f54) - a3 = 2.0d0 * y(ihe4) * rate(iralf1) - a4 = -2.0d0 * y(ineut)*y(ineut) * y(iprot)*y(iprot) * rate(iralf2) - a5 = y(iprot) * rate(irpen) - a6 = -y(ineut) * rate(irnep) + a1 = 2.0d0 * y(ife54) * rate(ir1f54) + a2 = -2.0d0 * y(ife52) * y(ineut) * y(ineut) * rate(ir2f54) + a3 = 2.0d0 * y(ihe4) * rate(iralf1) + a4 = -2.0d0 * y(ineut)*y(ineut) * y(iprot)*y(iprot) * rate(iralf2) + a5 = y(iprot) * rate(irpen) + a6 = -y(ineut) * rate(irnep) a7 = 2.0d0 * y(ife56) * rate(irfe56_aux1) a8 = -2.0d0 * y(ife54) * y(ineut) * y(ineut) * rate(irfe56_aux2) a9 = -fe56ec_n_neut * y(ife56) * fe56ec_fake_factor * rate(irn56ec) @@ -1513,15 +1513,15 @@ subroutine approx21_dydt( & qray(ineut) = qray(ineut) + a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 ! photodisintegration protons - a1 = -2.0d0 * y(ife54) * y(iprot) * y(iprot) * rate(ir3f54) - a2 = 2.0d0 * y(ini56) * rate(ir4f54) - a3 = -2.0d0 * y(ife54) * y(iprot) * y(iprot) * rate(ir5f54) - a4 = 2.0d0 * y(ife52) * y(ihe4) * rate(ir6f54) - a5 = 2.0d0 * y(ihe4) * rate(iralf1) - a6 = -2.0d0 * y(ineut)*y(ineut) * y(iprot)*y(iprot) * rate(iralf2) - a7 = -y(iprot) * rate(irpen) - a8 = y(ineut) * rate(irnep) - a9 = -2.0d0 * y(ife56) * y(iprot) * y(iprot) * rate(irfe56_aux3) + a1 = -2.0d0 * y(ife54) * y(iprot) * y(iprot) * rate(ir3f54) + a2 = 2.0d0 * y(ini56) * rate(ir4f54) + a3 = -2.0d0 * y(ife54) * y(iprot) * y(iprot) * rate(ir5f54) + a4 = 2.0d0 * y(ife52) * y(ihe4) * rate(ir6f54) + a5 = 2.0d0 * y(ihe4) * rate(iralf1) + a6 = -2.0d0 * y(ineut)*y(ineut) * y(iprot)*y(iprot) * rate(iralf2) + a7 = -y(iprot) * rate(irpen) + a8 = y(ineut) * rate(irnep) + a9 = -2.0d0 * y(ife56) * y(iprot) * y(iprot) * rate(irfe56_aux3) a10 = 2.0d0 * y(ife54) * y(ihe4) * rate(irfe56_aux4) qray(iprot) = qray(iprot) + & @@ -1548,8 +1548,8 @@ subroutine approx21_dydt( & end if end subroutine approx21_dydt - - + + real(dp) function approx21_eval_PPII_fraction(y, rate) result(fII) real(dp), dimension(:), intent(in) :: y, rate real(dp) :: rateII, rateIII, rsum @@ -1561,9 +1561,9 @@ real(dp) function approx21_eval_PPII_fraction(y, rate) result(fII) fII = 0.5d0 else fII = rateII / rsum - end if + end if end function approx21_eval_PPII_fraction - + subroutine approx21_eps_info( & n, y, mion, dydt, rate, fII, & @@ -1595,18 +1595,18 @@ subroutine approx21_eps_info( & Qrti44ag, & Qrcr48ag, & Qrfe52ag, & - Qrfe52ng, & - Qrfe53ng, & - Qrfe54ng, & - Qrfe55ng, & + Qrfe52ng, & + Qrfe53ng, & + Qrfe54ng, & + Qrfe55ng, & Qrfe52neut_to_fe54, & Qrfe52aprot_to_fe54, & Qrfe54ng_to_fe56, & Qrfe54aprot_to_fe56, & Qrfe52aprot_to_ni56, & - Qrfe54prot_to_ni56, & + Qrfe54prot_to_ni56, & Qrhe4_breakup, & - Qrhe4_rebuild, & + Qrhe4_rebuild, & eps_total, eps_neu, & do_eps_nuc_categories, eps_nuc_categories, & dbg, & @@ -1646,17 +1646,17 @@ subroutine approx21_eps_info( & Qrca40ag, & Qrti44ag, & Qrcr48ag, & - Qrfe52ag, & - Qrfe52ng, & - Qrfe53ng, & - Qrfe54ng, & - Qrfe55ng, & + Qrfe52ag, & + Qrfe52ng, & + Qrfe53ng, & + Qrfe54ng, & + Qrfe55ng, & Qrfe52neut_to_fe54, & Qrfe52aprot_to_fe54, & Qrfe54ng_to_fe56, & Qrfe54aprot_to_fe56, & Qrfe52aprot_to_ni56, & - Qrfe54prot_to_ni56, & + Qrfe54prot_to_ni56, & Qrhe4_breakup, & Qrhe4_rebuild logical, intent(in) :: do_eps_nuc_categories @@ -1669,26 +1669,26 @@ subroutine approx21_eps_info( & eps_nuc_q, sum_categories_q real(dp) :: enuc_conv2, sum_categories, eps_nuc, fe56ec_fake_factor logical, intent(in) :: plus_co56 - + include 'formats' - + !write(*,1) 'reaction_Qs(irn14_to_o16) Qrn14_to_o16*Qconv', Qrn14_to_o16*Qconv - + ierr = 0 xx = 0.0_qp do i=1,species(plus_co56) - a1 = dydt(i) + a1 = dydt(i) a2 = mion(i) xx = xx + a1*a2 end do eps_total_q = -m3(avo,clight,clight) * xx eps_total = eps_total_q - + fe56ec_fake_factor = eval_fe56ec_fake_factor( & n% g% fe56ec_fake_factor, n% g% min_T_for_fe56ec_fake_factor, n% temp) fe56ec_n_neut = n% g% fe56ec_n_neut - + eps_neu_q = & m5(Qneu_rpp, 0.5d0, y(ih1), y(ih1), rate(irpp)) + & m5(Qneu_rpp2, y(ihe3), y(ihe4), rate(irhe3ag), fII) + & @@ -1714,7 +1714,7 @@ subroutine approx21_eps_info( & eps_nuc_q = eps_total_q - eps_neu_q eps_nuc = eps_nuc_q - + if (.not. do_eps_nuc_categories) return do i=1,num_categories @@ -1748,7 +1748,7 @@ subroutine approx21_eps_info( & end if n% eps_neu_rate = n% eps_neu_rate * Qconv - + call set_eps_nuc(Qtotal_rpp - Qneu_rpp,(/0.5d0, y(ih1), y(ih1)/),irpp, ipp) call set_eps_nuc(Qr33, (/0.5d0, y(ihe3), y(ihe3)/), ir33, ipp) call set_eps_nuc(( & @@ -1759,7 +1759,7 @@ subroutine approx21_eps_info( & call set_eps_nuc(Qtotal_rcpg - Qneu_rcpg, (/y(ic12), y(ih1)/),ircpg,icno) call set_eps_nuc(Qtotal_rcpg - Qneu_rnpg, (/y(in14), y(ih1)/),irnpg,icno) call set_eps_nuc(Qtotal_ropg - Qneu_ropg, (/y(io16), y(ih1),rate(ifa)/),iropg,icno) - + call set_eps_nuc(Qr3alf, (/1d0/6d0,y(ihe4), y(ihe4), y(ihe4)/),ir3a,i3alf) call set_eps_nuc(Qrc12ag, (/y(ic12), y(ihe4)/),ircag,i_burn_c) @@ -1770,25 +1770,25 @@ subroutine approx21_eps_info( & call set_eps_nuc(Qro16ag, (/y(io16), y(ihe4)/), iroag, i_burn_o) call set_eps_nuc(Qr1212, (/0.5d0,y(ic12), y(ic12)/),ir1212,icc) - + call set_eps_nuc(0.5d0*(Qr1216_to_mg24 + Qr1216_to_si28), (/y(ic12), y(io16)/), ir1216, ico ) ! these make he4 + si28 call set_eps_nuc( Qr1616a * (0.56d0 + 0.34d0*rate(irs1)), (/0.5d0,y(io16), y(io16)/), ir1616, ioo) ! these make s32 call set_eps_nuc( Qr1616g * (0.1d0 + 0.34d0*(1d0 - rate(irs1))) , (/0.5d0,y(io16), y(io16)/), ir1616, ioo ) - + call set_eps_nuc(Qrne20ag, (/y(ihe4), y(ine20)/), irneag, i_burn_ne) - + call set_eps_nuc(Qrmg24ag, (/y(ihe4), y(img24)/),irmgag,i_burn_mg) call set_eps_nuc(Qrmg24ag, (/y(ihe4), y(img24),1.0d0-rate(irr1)/),irmgap,i_burn_mg) - + call set_eps_nuc(Qrsi28ag, (/y(ihe4), y(isi28)/),irsiag,i_burn_si) call set_eps_nuc(Qrsi28ag, (/y(ihe4), y(isi28),(1.0d0-rate(irs1))/),irsiap,i_burn_si) call set_eps_nuc(Qrs32ag, (/y(ihe4), y(is32)/), irsag, i_burn_s) call set_eps_nuc(Qrs32ag, (/y(ihe4), y(is32),(1.0d0-rate(irt1))/), irsap, i_burn_s) - + call set_eps_nuc(Qrar36ag, (/y(ihe4), y(iar36)/), irarag, i_burn_ar) call set_eps_nuc(Qrar36ag, (/y(ihe4), y(iar36),(1.0d0-rate(iru1))/), irarap, i_burn_ar) @@ -1853,14 +1853,14 @@ subroutine approx21_eps_info( & call set_eps_nuc(-Qrfe52aprot_to_ni56,(/ y(ini56), y(iprot)/),ir8f54, iphoto) call set_eps_nuc(-Qrfe52aprot_to_fe54,(/ y(ife54), y(iprot), y(iprot)/),ir5f54, iphoto) - call set_eps_nuc(-Qrfe52ag,(/ y(ini56)/),irniga, iphoto) + call set_eps_nuc(-Qrfe52ag,(/ y(ini56)/),irniga, iphoto) call set_eps_nuc(-Qrfe52neut_to_fe54,(/ y(ife54)/),ir1f54, iphoto) call set_eps_nuc(-Qrfe54ng_to_fe56,(/ y(ife56)/),irfe56_aux1, iphoto) call set_eps_nuc(-Qrfe54aprot_to_fe56,(/ y(ife56), y(iprot), y(iprot)/),irfe56_aux3, iphoto) call set_eps_nuc(-Qrfe54prot_to_ni56,(/ y(ini56)/),ir4f54, iphoto) - + call set_eps_nuc(Qtotal_rni56ec - Qneu_rni56ec, (/y(ini56)/), irn56ec, i_ni56_co56) if (plus_co56) then @@ -1872,16 +1872,16 @@ subroutine approx21_eps_info( & eps_nuc_cat = eps_nuc_cat * Qconv n% eps_nuc_rate = n% eps_nuc_rate * Qconv - + do i=1,num_categories eps_nuc_categories(i) = eps_nuc_cat(i) end do - + ! check eps_nuc vs sum(eps_nuc_cat) - + sum_categories_q = sum(eps_nuc_cat) sum_categories = sum_categories_q - + if (.false. .and. & abs(eps_nuc) > 1d-10*abs(eps_nuc_cat(iphoto)) .and. abs(eps_nuc) > 1d0 .and. & abs(sum_categories - eps_nuc) > 1d-2*min(abs(sum_categories),abs(eps_nuc))) then @@ -1896,7 +1896,7 @@ subroutine approx21_eps_info( & write(*,1) trim(category_name(i)), eps_nuc_categories(i) end if end do - write(*,*) + write(*,*) write(*,1) 'eps_total', eps_total write(*,1) 'eps_neu', eps_neu write(*,1) 'eps_nuc', eps_nuc @@ -1907,7 +1907,7 @@ subroutine approx21_eps_info( & call mesa_error(__FILE__,__LINE__) !$OMP end critical (net21_crit1) end if - + ! for debugging use reduced_net_for_testing if (.false. .and. n% logT >= 9.220336900d0 .and. n% logT <= 9.2203369009d0 .and. & @@ -1921,7 +1921,7 @@ subroutine approx21_eps_info( & do i=1,num_categories write(*,1) trim(category_name(i)), eps_nuc_categories(i) end do - write(*,*) + write(*,*) write(*,1) 'eps_total', eps_total write(*,1) 'eps_neu', eps_neu write(*,1) 'eps_nuc', eps_nuc @@ -1930,28 +1930,28 @@ subroutine approx21_eps_info( & write(*,1) 'sum(cat)/eps_nuc - 1', (sum_categories_q - eps_nuc_q)/eps_nuc_q call mesa_error(__FILE__,__LINE__,'approx21_eps_info') end if - - + + contains - + real(qp) function m2(a1,a2) real(dp), intent(in) :: a1, a2 real(qp) :: q1, q2 q1 = a1; q2 = a2; m2 = q1*q2 end function m2 - + real(qp) function m3(a1,a2,a3) real(dp), intent(in) :: a1, a2, a3 real(qp) :: q1, q2, q3 q1 = a1; q2 = a2; q3 = a3; m3 = q1*q2*q3 end function m3 - + real(qp) function m4(a1,a2,a3,a4) real(dp), intent(in) :: a1, a2, a3, a4 real(qp) :: q1, q2, q3, q4 q1 = a1; q2 = a2; q3 = a3; q4 = a4; m4 = q1*q2*q3*q4 end function m4 - + real(qp) function m5(a1,a2,a3,a4,a5) real(dp), intent(in) :: a1, a2, a3, a4, a5 real(qp) :: q1, q2, q3, q4, q5 @@ -2001,35 +2001,35 @@ subroutine approx21_d_epsneu_dy( & real(dp), intent(inout) :: d_epsneu_dy(:) logical, intent(in) :: plus_co56 integer, intent(out) :: ierr - + real(dp) :: fII - + ierr = 0 - + fII = 0.5d0 ! fix this - + d_epsneu_dy(1:species(plus_co56)) = 0d0 - + d_epsneu_dy(ih1) = Qconv*( & Qneu_rpp * y(ih1) * rate(irpp) + & ! rpp_to_he3 Qneu_rcpg * y(ic12) * rate(ircpg) + & ! C of CNO Qneu_rnpg * y(in14) * rate(irnpg) + & ! N of CNO Qneu_ropg * y(io16) * rate(iropg)) ! O of CNO - + d_epsneu_dy(ihe3) = Qconv*( & Qneu_rpp2 * y(ihe4) * rate(irhe3ag) * fII + & ! r34_pp2 Qneu_rpp3 * y(ihe4) * rate(irhe3ag) * (1d0-fII)) ! r34_pp3 - + d_epsneu_dy(ihe4) = Qconv*( & Qneu_rpp2 * y(ihe3) * rate(irhe3ag) * fII + & ! r34_pp2 Qneu_rpp3 * y(ihe3) * rate(irhe3ag) * (1d0-fII)) ! r34_pp3 - + d_epsneu_dy(ic12) = Qconv* & Qneu_rcpg * y(ih1) * rate(ircpg) ! C of CNO - + d_epsneu_dy(in14) = Qconv* & Qneu_rnpg * y(ih1) * rate(irnpg) ! N of CNO - + d_epsneu_dy(io16) = Qconv* & Qneu_ropg * y(ih1) * rate(iropg) ! O of CNO @@ -2051,12 +2051,12 @@ subroutine approx21_dfdy( & real(dp) abar,zbar,ye,taud,taut, b1, & snuda,snudz,enuc,velx,posx,zz real(dp) :: fe56ec_fake_factor - + ierr = 0 - + ! Turn on special fe56ec rate above some temperature fe56ec_fake_factor=eval_fe56ec_fake_factor(fe56ec_fake_factor_in,min_T,btemp) - + ! NOTE: use of quad precision for dfdy doesn't make a difference. dfdy(1:species(plus_co56),1:species(plus_co56)) = 0.0d0 @@ -2129,8 +2129,8 @@ subroutine approx21_dfdy( & dfdy(ihe4,ihe4) = dfdy(ihe4,ihe4) & - y(ife52) * ratdum(ir6f54) & - y(ife52) * y(iprot) * ratdum(ir7f54) & - - ratdum(iralf1) & - - y(ife54) * ratdum(irfe56_aux4) + - ratdum(iralf1) & + - y(ife54) * ratdum(irfe56_aux4) dfdy(ihe4,ihe4) = dfdy(ihe4,ihe4) & @@ -2200,7 +2200,7 @@ subroutine approx21_dfdy( & - y(ihe4) * y(iprot) * ratdum(ir7f54) dfdy(ihe4,ife54) = y(iprot) * y(iprot) * ratdum(ir5f54) & - - y(ihe4) * ratdum(irfe56_aux4) + - y(ihe4) * ratdum(irfe56_aux4) dfdy(ihe4,ife56) = y(iprot) * y(iprot) * ratdum(irfe56_aux3) @@ -2211,7 +2211,7 @@ subroutine approx21_dfdy( & dfdy(ihe4,ineut) = -y(ihe4) * dratdumdy1(iralf1) & + 2.0d0 * y(ineut) * y(iprot)*y(iprot) * ratdum(iralf2) & + y(ineut)*y(ineut) * y(iprot)*y(iprot) * dratdumdy1(iralf2) - + include 'formats' dfdy(ihe4,iprot) = 2.0d0 * y(ife54) * y(iprot) * ratdum(ir5f54) & @@ -2226,7 +2226,7 @@ subroutine approx21_dfdy( & + y(ineut)*y(ineut) * y(iprot)*y(iprot) * dratdumdy2(iralf2) & + 2.0d0 * y(ife56) * y(iprot) * ratdum(irfe56_aux3) & + y(ife56) * y(iprot) * y(iprot) * dratdumdy1(irfe56_aux3) & - - y(ihe4) * y(ife54) * dratdumdy1(irfe56_aux4) + - y(ihe4) * y(ife54) * dratdumdy1(irfe56_aux4) @@ -2412,7 +2412,7 @@ subroutine approx21_dfdy( & dfdy(ica40,iti44) = ratdum(irtiga) & + ratdum(irtigp) * ratdum(irv1) - + ! ti44 jacobian elements @@ -2491,19 +2491,19 @@ subroutine approx21_dfdy( & - y(ife52) * y(ihe4) * y(iprot) * dratdumdy1(ir7f54) & + y(ini56) * ratdum(ir8f54) & + y(ini56) * y(iprot) * dratdumdy1(ir8f54) - + ! fe54 jacobian elements - dfdy(ife54,ihe4) = y(ife52) * ratdum(ir6f54) & + dfdy(ife54,ihe4) = y(ife52) * ratdum(ir6f54) & - y(ife54) * ratdum(irfe56_aux4) - + dfdy(ife54,ife52) = & y(ineut) * y(ineut) * ratdum(ir2f54) + & y(ihe4) * ratdum(ir6f54) dfdy(ife54,ife54) = & - ratdum(ir1f54) & - - y(ineut) * y(ineut) * ratdum(irfe56_aux2) & + - y(ineut) * y(ineut) * ratdum(irfe56_aux2) & - y(iprot) * y(iprot) * ratdum(ir3f54) & - y(iprot) * y(iprot) * ratdum(ir5f54) & - y(ihe4) * ratdum(irfe56_aux4) @@ -2511,23 +2511,23 @@ subroutine approx21_dfdy( & dfdy(ife54,ife56) = & ratdum(irfe56_aux1) + & y(iprot) * y(iprot) * ratdum(irfe56_aux3) - - dfdy(ife54,ini56) = ratdum(ir4f54) + + dfdy(ife54,ini56) = ratdum(ir4f54) dfdy(ife54,ineut) = & - y(ife54) * dratdumdy1(ir1f54) & + 2.0d0 * y(ife52) * y(ineut) * ratdum(ir2f54) & + y(ife52) * y(ineut) * y(ineut) * dratdumdy1(ir2f54) & - + y(ife56) * dratdumdy1(irfe56_aux1) & + + y(ife56) * dratdumdy1(irfe56_aux1) & - 2.0d0 * y(ife54) * y(ineut) * ratdum(irfe56_aux2) & - - y(ife54) * y(ineut) * y(ineut) * dratdumdy1(irfe56_aux2) + - y(ife54) * y(ineut) * y(ineut) * dratdumdy1(irfe56_aux2) dfdy(ife54,iprot) = -2.0d0 * y(ife54) * y(iprot) * ratdum(ir3f54) & - y(ife54) * y(iprot) * y(iprot) * dratdumdy1(ir3f54) & + y(ini56) * dratdumdy1(ir4f54) & - 2.0d0 * y(ife54) * y(iprot) * ratdum(ir5f54) & - y(ife54) * y(iprot) * y(iprot) * dratdumdy1(ir5f54) & - + y(ihe4) * y(ife52) * dratdumdy1(ir6f54) & + + y(ihe4) * y(ife52) * dratdumdy1(ir6f54) & + 2.0d0 * y(ife56) * y(iprot) * ratdum(irfe56_aux3) & + y(ife56) * y(iprot) * y(iprot) * dratdumdy1(irfe56_aux3) & - y(ihe4) * y(ife54) * dratdumdy1(irfe56_aux4) @@ -2539,11 +2539,11 @@ subroutine approx21_dfdy( & dfdy(ife56,ife54) = & - y(ineut) * y(ineut) * ratdum(irfe56_aux2) + & + y(ineut) * y(ineut) * ratdum(irfe56_aux2) + & y(ihe4) * ratdum(irfe56_aux4) dfdy(ife56,ife56) = - fe56ec_fake_factor * ratdum(irn56ec) & - - ratdum(irfe56_aux1) & + - ratdum(irfe56_aux1) & - y(iprot) * y(iprot) * ratdum(irfe56_aux3) if (plus_co56) then @@ -2557,14 +2557,14 @@ subroutine approx21_dfdy( & -y(ife56) * dratdumdy1(irfe56_aux1) & + 2.0d0 * y(ife54) * y(ineut) * ratdum(irfe56_aux2) & + y(ife54) * y(ineut) * y(ineut) * dratdumdy1(irfe56_aux2) - + dfdy(ife56,iprot) = -2.0d0 * y(ife56) * y(iprot) * ratdum(irfe56_aux3) & - y(ife56) * y(iprot) * y(iprot) * dratdumdy1(irfe56_aux3) & + y(ihe4) * y(ife54) * dratdumdy1(irfe56_aux4) if (plus_co56) then - ! co56 jacobian elements + ! co56 jacobian elements dfdy(ico56,ini56) = ratdum(irn56ec) dfdy(ico56,ico56) = -ratdum(irco56ec) end if @@ -2596,11 +2596,11 @@ subroutine approx21_dfdy( & ! photodisintegration neutrons jacobian elements dfdy(ineut,ihe4) = 2.0d0 * ratdum(iralf1) - dfdy(ineut,ife52) = -2.0d0 * y(ineut) * y(ineut) * ratdum(ir2f54) - + dfdy(ineut,ife52) = -2.0d0 * y(ineut) * y(ineut) * ratdum(ir2f54) + dfdy(ineut,ife54) = 2.0d0 * ratdum(ir1f54) & - 2.0d0 * y(ineut) * y(ineut) * ratdum(irfe56_aux2) - + dfdy(ineut,ife56) = 2.0d0 * ratdum(irfe56_aux1) & - fe56ec_n_neut * fe56ec_fake_factor * ratdum(irn56ec) @@ -2612,7 +2612,7 @@ subroutine approx21_dfdy( & - 4.0d0 * y(ineut) * y(iprot)*y(iprot) * ratdum(iralf2) & - 2.0d0 * y(ineut)*y(ineut) * y(iprot)*y(iprot) * dratdumdy1(iralf2) & - ratdum(irnep) & - + 2.0d0 * y(ife56) * dratdumdy1(irfe56_aux1) & + + 2.0d0 * y(ife56) * dratdumdy1(irfe56_aux1) & - 4.0d0 * y(ife54) * y(ineut) * ratdum(irfe56_aux2) & - 2.0d0 * y(ife54) * y(ineut) * y(ineut) * dratdumdy1(irfe56_aux2) @@ -2623,13 +2623,13 @@ subroutine approx21_dfdy( & ! photodisintegration protons jacobian elements dfdy(iprot,ihe4) = 2.0d0 * y(ife52) * ratdum(ir6f54) & - + 2.0d0 * ratdum(iralf1) & + + 2.0d0 * ratdum(iralf1) & + 2.0d0 * y(ife54) * ratdum(irfe56_aux4) dfdy(iprot,ife52) = 2.0d0 * y(ihe4) * ratdum(ir6f54) dfdy(iprot,ife54) = -2.0d0 * y(iprot) * y(iprot) * ratdum(ir3f54) & - - 2.0d0 * y(iprot) * y(iprot) * ratdum(ir5f54) & + - 2.0d0 * y(iprot) * y(iprot) * ratdum(ir5f54) & + 2.0d0 * y(ihe4) * ratdum(irfe56_aux4) dfdy(iprot,ife56) = -2.0d0 * y(iprot) * y(iprot) * ratdum(irfe56_aux3) @@ -2650,14 +2650,14 @@ subroutine approx21_dfdy( & + 2.0d0 * y(ihe4) * dratdumdy2(iralf1) & - 4.0d0 * y(ineut)*y(ineut) * y(iprot) * ratdum(iralf2) & - 2.0d0 * y(ineut)*y(ineut) * y(iprot)*y(iprot) * dratdumdy2(iralf2) & - - ratdum(irpen) & + - ratdum(irpen) & - 4.0d0 * y(ife56) * y(iprot) * ratdum(irfe56_aux3) & - 2.0d0 * y(ife56) * y(iprot) * y(iprot) * dratdumdy1(irfe56_aux3) & + 2.0d0 * y(ihe4) * y(ife54) * dratdumdy1(irfe56_aux4) end subroutine approx21_dfdy - - + + subroutine approx21_dfdT_dfdRho( & ! epstotal includes neutrinos y, mion, dfdy, ratdum, dratdumdt, dratdumdd, & fe56ec_fake_factor, min_T, fe56ec_n_neut, temp, den, & @@ -2669,12 +2669,12 @@ subroutine approx21_dfdT_dfdRho( & ! epstotal includes neutrinos real(dp), intent(inout), dimension(:) :: d_epstotal_dy, dfdT, dfdRho logical, intent(in) :: plus_co56 integer, intent(out) :: ierr - + integer :: i, j real(dp) :: enuc_conv2 logical, parameter :: deriva = .true. - - ! temperature dependence of the rate equations + + ! temperature dependence of the rate equations dfdT(1:species(plus_co56)) = 0d0 call approx21_dydt( & y,dratdumdt,ratdum,dfdT,deriva,& @@ -2697,10 +2697,10 @@ subroutine approx21_dfdT_dfdRho( & ! epstotal includes neutrinos enddo d_epstotal_dy(j) = d_epstotal_dy(j) * enuc_conv2 enddo - + end subroutine approx21_dfdT_dfdRho - - + + subroutine mark_approx21(handle, ierr) use net_def, only: Net_General_Info, get_net_ptr use chem_def, only: chem_isos @@ -2749,7 +2749,7 @@ subroutine mark_approx21_isos(itab, ye_iso_name,plus_co56, ierr) integer, intent(out) :: ierr integer :: i, cid ierr = 0 - + call do1('h1') call do1('he3') call do1('he4') @@ -2772,9 +2772,9 @@ subroutine mark_approx21_isos(itab, ye_iso_name,plus_co56, ierr) call do1('neut') call do1('prot') call do1(ye_iso_name) - + contains - + subroutine do1(str) use utils_lib, only: mesa_error character (len=*), intent(in) :: str @@ -2788,9 +2788,9 @@ subroutine do1(str) itab(cid) = 1 end subroutine do1 - end subroutine mark_approx21_isos - - + end subroutine mark_approx21_isos + + subroutine set_approx21_isos(itab, ye_iso_name, plus_co56, ierr) use chem_lib, only: chem_get_iso_id use const_def, only: ev2erg, clight @@ -2800,7 +2800,7 @@ subroutine set_approx21_isos(itab, ye_iso_name, plus_co56, ierr) integer, intent(out) :: ierr integer :: i, cid ierr = 0 - + ih1 = do1('h1') ihe3 = do1('he3') ihe4 = do1('he4') @@ -2824,9 +2824,9 @@ subroutine set_approx21_isos(itab, ye_iso_name, plus_co56, ierr) iprot = do1('prot') icrx = do1(ye_iso_name) iso_cid(icrx) = -1 ! different for different approx21 nets - + contains - + integer function do1(str) use chem_def, only: chem_isos use utils_lib, only: mesa_error @@ -2840,10 +2840,10 @@ integer function do1(str) do1 = itab(cid) iso_cid(do1) = cid end function do1 - + end subroutine set_approx21_isos - - + + subroutine mark_approx21_reactions(rtab, plus_co56, ierr) use rates_lib, only: rates_reaction_id integer :: rtab(:) @@ -2852,7 +2852,7 @@ subroutine mark_approx21_reactions(rtab, plus_co56, ierr) integer :: i, ir include 'formats' ierr = 0 - + call do1('r_he4_he4_he4_to_c12') call do1('r_c12_to_he4_he4_he4') call do1('r_c12_ag_o16') @@ -2864,7 +2864,7 @@ subroutine mark_approx21_reactions(rtab, plus_co56, ierr) call do1('r_ne20_ga_o16') call do1('r_ne20_ag_mg24') call do1('r_mg24_ga_ne20') - + call do1('r_mg24_ag_si28') call do1('r_si28_ga_mg24') call do1('r_mg24_ap_al27') @@ -2951,12 +2951,12 @@ subroutine mark_approx21_reactions(rtab, plus_co56, ierr) ! cno cycles call do1('r_c12_pg_n13') call do1('r_n14_pg_o15') - call do1('r_o16_pg_f17') + call do1('r_o16_pg_f17') call do1('r_n15_pg_o16') - call do1('r_n15_pa_c12') + call do1('r_n15_pa_c12') call do1('r_n14_ag_f18') - ! for reactions to fe56 + ! for reactions to fe56 call do1('r_fe54_ng_fe55') call do1('r_fe55_gn_fe54') call do1('r_fe55_ng_fe56') @@ -2965,9 +2965,9 @@ subroutine mark_approx21_reactions(rtab, plus_co56, ierr) call do1('r_co57_pa_fe54') call do1('r_fe56_pg_co57') call do1('r_co57_gp_fe56') - + contains - + subroutine do1(str) use utils_lib, only: mesa_error character (len=*), intent(in) :: str @@ -2980,7 +2980,7 @@ subroutine do1(str) end if rtab(ir) = 1 end subroutine do1 - + end subroutine mark_approx21_reactions @@ -2991,7 +2991,7 @@ subroutine set_approx21_reactions(rtab, plus_co56, ierr) logical, intent(in) :: plus_co56 integer, intent(out) :: ierr ierr = 0 - + ir3a = do1('r_he4_he4_he4_to_c12') irg3a = do1('r_c12_to_he4_he4_he4') ircag = do1('r_c12_ag_o16') @@ -3003,7 +3003,7 @@ subroutine set_approx21_reactions(rtab, plus_co56, ierr) irnega = do1('r_ne20_ga_o16') irneag = do1('r_ne20_ag_mg24') irmgga = do1('r_mg24_ga_ne20') - + irmgag = do1('r_mg24_ag_si28') irsiga = do1('r_si28_ga_mg24') irmgap = do1('r_mg24_ap_al27') @@ -3090,12 +3090,12 @@ subroutine set_approx21_reactions(rtab, plus_co56, ierr) ! cno cycles ircpg = do1('r_c12_pg_n13') irnpg = do1('r_n14_pg_o15') - iropg = do1('r_o16_pg_f17') + iropg = do1('r_o16_pg_f17') irn15pg = do1('r_n15_pg_o16') - irn15pa = do1('r_n15_pa_c12') + irn15pa = do1('r_n15_pa_c12') irnag = do1('r_n14_ag_f18') - ! for reactions to fe56 + ! for reactions to fe56 ir54ng = do1('r_fe54_ng_fe55') ir55gn = do1('r_fe55_gn_fe54') ir55ng = do1('r_fe55_ng_fe56') @@ -3133,18 +3133,18 @@ subroutine set_approx21_reactions(rtab, plus_co56, ierr) irfe56_aux2 = irfe56_aux1+1 irfe56_aux3 = irfe56_aux2+1 irfe56_aux4 = irfe56_aux3+1 - + if( (plus_co56 .and. irfe56_aux4 /= num_reactions(plus_co56)) .or. & (.not.plus_co56 .and. irfe56_aux4 /= num_reactions(plus_co56))) then write(*,*) 'set_approx21_reactions found bad num_reactions' write(*,*) plus_co56,irfe56_aux4,num_reactions(plus_co56) call mesa_error(__FILE__,__LINE__) end if - + call init_approx21(plus_co56) - + contains - + integer function do1(str) use utils_lib, only: mesa_error character (len=*), intent(in) :: str @@ -3161,10 +3161,10 @@ integer function do1(str) end if rate_id(do1) = ir end function do1 - + end subroutine set_approx21_reactions - - + + ! call this after have set rate numbers subroutine init_approx21(plus_co56) integer :: i @@ -3277,7 +3277,7 @@ subroutine init_approx21(plus_co56) ratnam(irn15pa) = 'r_n15_pa_c12' ratnam(irnag) = 'r_n14_ag_f18' - + ratnam(ir54ng) = 'r_fe54_ng_fe55' ratnam(ir55gn) = 'r_fe55_gn_fe54' ratnam(ir55ng) = 'r_fe55_ng_fe56' @@ -3317,9 +3317,9 @@ subroutine init_approx21(plus_co56) ratnam(irfe56_aux2) = 'rfe56aux2' ratnam(irfe56_aux3) = 'rfe56aux3' ratnam(irfe56_aux4) = 'rfe56aux4' - + return - + do i=1,num_mesa_reactions(plus_co56) write(*,2) trim(ratnam(i)), i end do @@ -3330,17 +3330,17 @@ subroutine init_approx21(plus_co56) call mesa_error(__FILE__,__LINE__,'init_approx21') end subroutine init_approx21 - + real(dp) function eval_fe56ec_fake_factor(fe56ec_fake_factor,min_T,temp) real(dp), intent(in) :: fe56ec_fake_factor,min_T,temp - + eval_fe56ec_fake_factor = 0.d0 if(temp >= min_T)then eval_fe56ec_fake_factor = fe56ec_fake_factor end if - + end function eval_fe56ec_fake_factor - + pure integer function num_reactions(plus_co56) logical, intent(in) :: plus_co56 diff --git a/net/private/net_burn.f90 b/net/private/net_burn.f90 index 7b063d278..e7929d40b 100644 --- a/net/private/net_burn.f90 +++ b/net/private/net_burn.f90 @@ -28,29 +28,29 @@ module net_burn use math_lib use chem_def use net_def - + use utils_lib, only: is_bad,fill_with_NaNs,fill_with_NaNs_2D - + use net_burn_support, only: netint use net_approx21, only : num_reactions_func => num_reactions - + implicit none - - + + !logical, parameter :: use_ludcmp = .true. logical, parameter :: use_ludcmp = .false. - + !logical, parameter :: show_mesa_rates = .true. logical, parameter :: show_mesa_rates = .false. - + !logical, parameter :: report_ierr = .true. logical, parameter :: report_ierr = .false. - + contains - + subroutine get_pointers( & g, species, num_reactions, & dratdumdy1, dratdumdy2, dens_dfdy, dmat, i, ierr) @@ -64,13 +64,13 @@ subroutine get_pointers( & integer :: sz include 'formats' ierr = 0 - + sz = num_reactions if (g% doing_approx21) sz = num_reactions_func(g% add_co56_to_approx21) allocate(dratdumdy1(1:sz)) allocate(dratdumdy2(1:sz)) - + allocate(dens_dfdy(1:species,1:species)) allocate(dmat(1:species,1:species)) @@ -80,10 +80,10 @@ subroutine get_pointers( & call fill_with_NaNs_2D(dens_dfdy) call fill_with_NaNs_2D(dmat) end if - + end subroutine get_pointers - + subroutine burn_1_zone( & net_handle, eos_handle, species, num_reactions, t_start, t_end, starting_x, & ntimes, times, log10Ts_f1, log10Rhos_f1, etas_f1, dxdt_source_term, & @@ -95,7 +95,7 @@ subroutine burn_1_zone( & ending_x, eps_nuc_categories, avg_eps_nuc, eps_neu_total, & nfcn, njac, nstep, naccpt, nrejct, ierr) use num_def - use num_lib + use num_lib use mtx_lib use mtx_def use rates_def, only: rates_reaction_id_max, reaction_Name, reaction_categories @@ -103,14 +103,14 @@ subroutine burn_1_zone( & use net_initialize, only: setup_net_info use chem_lib, only: basic_composition_info, get_Q use net_approx21, only: approx21_nrat - + integer, intent(in) :: net_handle, eos_handle integer, intent(in) :: species integer, intent(in) :: num_reactions real(dp), intent(in) :: t_start, t_end, starting_x(:) ! (species) integer, intent(in) :: ntimes ! ending time is times(num_times); starting time is 0 - real(dp), pointer, intent(in) :: times(:) ! (num_times) - real(dp), pointer, intent(in) :: log10Ts_f1(:) + real(dp), pointer, intent(in) :: times(:) ! (num_times) + real(dp), pointer, intent(in) :: log10Ts_f1(:) ! =(4,numtimes) interpolant for log10T(time) real(dp), pointer, intent(in) :: log10Rhos_f1(:) ! =(4,numtimes) interpolant for log10Rho(time) @@ -140,17 +140,17 @@ subroutine burn_1_zone( & integer, intent(out) :: naccpt ! number of accepted steps integer, intent(out) :: nrejct ! number of rejected steps integer, intent(out) :: ierr - + type (Net_General_Info), pointer :: g integer :: ijac, lrd, lid, lout, i, j, ir, idid, sz logical :: okay, have_set_rate_screened real(dp) :: temp, rho, eta, lgT, lgRho, r, prev_lgRho, prev_lgT - + integer :: stpmax, imax_dydx, nstp real(dp) :: & h, start, stptry, stpmin, stopp, max_dydx, abs_max_dydx, & burn_ergs, dx - + real(dp), dimension(species), target :: starting_y_a, ending_y_a, save_x_a real(dp), dimension(:), pointer :: starting_y, ending_y, save_x real(dp), dimension(:), allocatable :: dratdumdy1, dratdumdy2 @@ -159,18 +159,18 @@ subroutine burn_1_zone( & real(dp) :: xh, xhe, z, abar, zbar, z2bar, z53bar, ye, mass_correction, sumx real(dp) :: aion(species) - + logical :: dbg - + type (Net_Info) :: n - + integer :: iwork, cid - + include 'formats' - + !dbg = .true. dbg = burn_dbg - + if (dbg) then do i=1,species write(*,2) 'starting_x', i, starting_x(i) @@ -180,9 +180,9 @@ subroutine burn_1_zone( & starting_y => starting_y_a ending_y => ending_y_a save_x => save_x_a - + have_set_rate_screened = .false. - + lgT = log10Ts_f1(1) temp = exp10(lgT) lgRho = log10Rhos_f1(1) @@ -190,7 +190,7 @@ subroutine burn_1_zone( & eta = etas_f1(1) prev_lgT = -1d99 prev_lgRho = -1d99 - + ierr = 0 call get_net_ptr(net_handle, g, ierr) if (ierr /= 0) then @@ -202,18 +202,18 @@ subroutine burn_1_zone( & write(*,*) 'invalid species', species return end if - + if (g% num_reactions /= num_reactions) then write(*,*) 'invalid num_reactions', num_reactions return end if - + nfcn = 0 njac = 0 nstep = 0 naccpt = 0 nrejct = 0 - + do i=1,species cid = g% chem_id(i) if (cid < 0) cid = g% approx21_ye_iso @@ -223,24 +223,24 @@ subroutine burn_1_zone( & starting_y(i) = starting_x(i)/aion(i) ending_y(i) = starting_y(i) end do - + start = t_start stptry = stptry_in if (stptry == 0d0) stptry = t_end - + !write(*,1) 'stptry', stptry - + stpmin = min(t_end*1d-20,stptry*1d-6) stopp = t_end stpmax = max_steps n% screening_mode = screening_mode n% g => g - + if (dbg) write(*,*) 'call setup_net_info' - call setup_net_info(n) + call setup_net_info(n) if (dbg) write(*,*) 'done setup_net_info' - + if (dbg) write(*,*) 'call get_pointers' call get_pointers( & g, species, num_reactions, & @@ -276,16 +276,16 @@ subroutine burn_1_zone( & ending_x(i) = ending_y(i)*aion(i) dx = ending_x(i) - save_x(i) !write(*,2) 'dx aion end_x', i, dx, aion(i), ending_x(i) - cid = g% chem_id(i) + cid = g% chem_id(i) burn_ergs = burn_ergs + & (get_Q(chem_isos,cid))*dx/chem_isos% Z_plus_N(cid) end do burn_ergs = burn_ergs*Qconv !write(*,1) 'burn_ergs', burn_ergs avg_eps_nuc = burn_ergs/(t_end - t_start) - eps_neu_total - + contains - + subroutine burner_derivs(x,y,f,species,ierr) integer, intent(in) :: species real(dp) :: x, y(:), f(:) @@ -300,15 +300,15 @@ subroutine burner_derivs(x,y,f,species,ierr) real(dp), target :: f21_a(species) real(dp), pointer :: f21(:) - + include 'formats' - + ierr = 0 nfcn = nfcn + 1 dfdx => dfdx_arry call jakob_or_derivs(x,y,f,dfdx,ierr) - if (ierr /= 0) return - + if (ierr /= 0) return + end subroutine burner_derivs subroutine burner_jakob(x,y,dfdy,species,ierr) @@ -318,7 +318,7 @@ subroutine burner_jakob(x,y,dfdy,species,ierr) integer, intent(out) :: ierr real(dp), target :: f_arry(0) real(dp), pointer :: f(:) - + real(dp) :: Z_plus_N, df_t, df_m integer :: i, ci, j, cj logical :: okay @@ -330,7 +330,7 @@ subroutine burner_jakob(x,y,dfdy,species,ierr) call jakob_or_derivs(x,y,f,dfdy,ierr) if (ierr /= 0) return - + end subroutine burner_jakob subroutine jakob_or_derivs(time,y,f,dfdy,ierr) @@ -341,53 +341,53 @@ subroutine jakob_or_derivs(time,y,f,dfdy,ierr) use interp_1d_lib, only: interp_value use eos_def, only: num_eos_basic_results, num_eos_d_dxa_results, i_eta use eos_lib, only: eosDT_get - + real(dp) :: time, y(:), f(:) real(dp) :: dfdy(:,:) integer, intent(out) :: ierr - + real(dp) :: rho, lgRho, T, lgT, rate_limit, rat, dratdt, dratdd real(dp) :: eta, d_eta_dlnT, d_eta_dlnRho real(dp) :: eps_nuc real(dp) :: d_eps_nuc_dT real(dp) :: d_eps_nuc_dRho - real(dp) :: d_eps_nuc_dx(species) + real(dp) :: d_eps_nuc_dx(species) real(dp) :: dxdt(species) real(dp) :: d_dxdt_dRho(species) real(dp) :: d_dxdt_dT(species) real(dp) :: d_dxdt_dx(species, species) - + logical :: rates_only, dxdt_only, okay integer :: i, j, k, ir real(dp), pointer, dimension(:) :: actual_Qs, actual_neuQs real(dp) :: xsum logical, pointer :: from_weaklib(:) - + real(dp), target :: x_a(species), dfdx_a(species,species) real(dp), pointer :: x(:), dfdx(:,:) real(dp), dimension(num_eos_basic_results) :: res, d_dlnd, d_dlnT real(dp) :: d_dxa(num_eos_d_dxa_results,species) - + include 'formats' - + ierr = 0 x => x_a dfdx => dfdx_a - + actual_Qs => null() actual_neuQs => null() from_weaklib => null() - + if (ntimes == 1) then - + lgT = log10Ts_f1(1) lgRho = log10Rhos_f1(1) - + else - + call interp_value(times, ntimes, log10Ts_f1, time, lgT, ierr) if (ierr /= 0) then if (report_ierr) & @@ -403,8 +403,8 @@ subroutine jakob_or_derivs(time,y,f,dfdy,ierr) end if end if - - xsum = 0 + + xsum = 0 do i=1,species if (is_bad(y(i))) then ierr = -1 @@ -412,7 +412,7 @@ subroutine jakob_or_derivs(time,y,f,dfdy,ierr) write(*,2) 'net_burn failed in jakob_or_derivs: bad y(i) lgT lgRho', i, y(i), lgT, lgRho return stop - end if + end if y(i) = min(1.0d0, max(y(i),1.0d-30)) x(i) = y(i)*aion(i) xsum = xsum + x(i) @@ -421,11 +421,11 @@ subroutine jakob_or_derivs(time,y,f,dfdy,ierr) rho = exp10(lgRho) T = exp10(lgT) - + call basic_composition_info( & species, g% chem_id, x, xh, xhe, z, & abar, zbar, z2bar, z53bar, ye, mass_correction, sumx) - + call eosDT_get( & eos_handle, species, g% chem_id, g% net_iso, x, & @@ -439,10 +439,10 @@ subroutine jakob_or_derivs(time,y,f,dfdy,ierr) d_eta_dlnT = d_dlnT(i_eta) d_eta_dlnRho = d_dlnd(i_eta) - + rates_only = .false. dxdt_only = (size(dfdy,dim=1) == 0) - + call eval_net( & n, g, rates_only, dxdt_only, & species, num_reactions, g% num_wk_reactions, & @@ -455,7 +455,7 @@ subroutine jakob_or_derivs(time,y,f,dfdy,ierr) screening_mode, & eps_nuc_categories, eps_neu_total, & actual_Qs, actual_neuQs, from_weaklib, .false., ierr) - + if (size(f,dim=1) > 0) then do j = 1, species f(j) = dxdt(j)/aion(j) @@ -479,15 +479,15 @@ subroutine jakob_or_derivs(time,y,f,dfdy,ierr) end do end do end if - - + + end subroutine jakob_or_derivs - - - + + + end subroutine burn_1_zone - + diff --git a/net/private/net_burn_const_density.f90 b/net/private/net_burn_const_density.f90 index 83082c9d1..5ac12e5e0 100644 --- a/net/private/net_burn_const_density.f90 +++ b/net/private/net_burn_const_density.f90 @@ -28,26 +28,26 @@ module net_burn_const_density use math_lib use chem_def use net_def - + use utils_lib, only: is_bad, fill_with_NaNs,fill_with_NaNs_2D - + use net_burn_support, only: netint use net_approx21, only : num_reactions_func => num_reactions - + implicit none - - + + !logical, parameter :: use_ludcmp = .true. logical, parameter :: use_ludcmp = .false. - + !logical, parameter :: show_mesa_rates = .true. logical, parameter :: show_mesa_rates = .false. - + contains - + subroutine get_pointers( & g, species, nvar, num_reactions, & dratdumdy1, dratdumdy2, dens_dfdy, dmat, i, ierr) @@ -65,7 +65,7 @@ subroutine get_pointers( & if (g% doing_approx21) sz = num_reactions_func(g% add_co56_to_approx21) allocate(dratdumdy1(1:sz)) allocate(dratdumdy2(1:sz)) - + sz = nvar*nvar allocate(dens_dfdy(1:nvar,1:nvar)) allocate(dmat(1:nvar,1:nvar)) @@ -76,10 +76,10 @@ subroutine get_pointers( & call fill_with_NaNs_2D(dens_dfdy) call fill_with_NaNs_2D(dmat) end if - + end subroutine get_pointers - + subroutine burn_const_density_1_zone( & net_handle, eos_handle, species, nvar, num_reactions, t_start, t_end, & starting_x, starting_log10T, log10Rho, & @@ -91,7 +91,7 @@ subroutine burn_const_density_1_zone( & ending_x, eps_nuc_categories, ending_log10T, avg_eps_nuc, eps_neu_total, & nfcn, njac, nstep, naccpt, nrejct, ierr) use num_def - use num_lib + use num_lib use mtx_lib use mtx_def use rates_def, only: rates_reaction_id_max, reaction_Name @@ -99,7 +99,7 @@ subroutine burn_const_density_1_zone( & use net_initialize, only: setup_net_info use chem_lib, only: basic_composition_info, get_Q use net_approx21, only: approx21_nrat - + integer, intent(in) :: net_handle, eos_handle, species, nvar, num_reactions real(dp), intent(in) :: t_start, t_end, starting_x(:) ! (species) real(dp), intent(in) :: starting_log10T, log10Rho @@ -128,17 +128,17 @@ subroutine burn_const_density_1_zone( & integer, intent(out) :: naccpt ! number of accepted steps integer, intent(out) :: nrejct ! number of rejected steps integer, intent(out) :: ierr - + type (Net_General_Info), pointer :: g integer :: ijac, lrd, lid, lout, i, j, ir, idid, sz logical :: okay real(dp) :: temp, rho, lgT, lgRho, r, prev_lgRho, prev_lgT - + integer :: stpmax, imax_dydx, nstp real(dp) :: & h, start, stptry, stpmin, stopp, max_dydx, abs_max_dydx, lnT, & eta, d_eta_dlnT, d_eta_dlnRho, Cv, d_Cv_dlnT, burn_ergs, dx - + real(dp), dimension(nvar), target :: starting_y_a, ending_y_a, save_x_a real(dp), dimension(:), pointer :: starting_y, ending_y, save_x real(dp), dimension(:), allocatable :: dratdumdy1, dratdumdy2 @@ -147,21 +147,21 @@ subroutine burn_const_density_1_zone( & real(dp) :: xh, xhe, z, abar, zbar, z2bar, z53bar, ye, mass_correction, sumx real(dp) :: aion(species) - + logical :: dbg - + type (Net_Info) :: n - + real(dp), dimension(:), pointer :: & rate_raw, rate_raw_dT, rate_raw_dRho, & rate_screened, rate_screened_dT, rate_screened_dRho integer :: iwork, cid - + include 'formats' - + !dbg = .true. dbg = burn_dbg - + if (dbg) then do i=1,species write(*,2) 'starting_x', i, starting_x(i) @@ -182,7 +182,7 @@ subroutine burn_const_density_1_zone( & save_x => save_x_a d_eta_dlnRho = 0d0 - + lgT = starting_log10T lnT = lgT*ln10 temp = exp10(lgT) @@ -190,7 +190,7 @@ subroutine burn_const_density_1_zone( & rho = exp10(lgRho) prev_lgT = -1d99 prev_lgRho = -1d99 - + ierr = 0 call get_net_ptr(net_handle, g, ierr) if (ierr /= 0) then @@ -202,18 +202,18 @@ subroutine burn_const_density_1_zone( & write(*,*) 'invalid species', species return end if - + if (g% num_reactions /= num_reactions) then write(*,*) 'invalid num_reactions', num_reactions return end if - + nfcn = 0 njac = 0 nstep = 0 naccpt = 0 nrejct = 0 - + do i=1,species cid = g% chem_id(i) if (cid < 0) cid = g% approx21_ye_iso @@ -225,24 +225,24 @@ subroutine burn_const_density_1_zone( & end do starting_y(nvar) = lnT ending_y(nvar) = lnT - + start = t_start stptry = stptry_in if (stptry == 0d0) stptry = t_end - + !write(*,1) 'stptry', stptry - + stpmin = min(t_end*1d-20,stptry*1d-6) stopp = t_end stpmax = max_steps n% screening_mode = screening_mode n% g => g - + if (dbg) write(*,2) 'call setup_net_info', iwork - call setup_net_info(n) + call setup_net_info(n) if (dbg) write(*,*) 'done setup_net_info' - + if (dbg) write(*,*) 'call get_pointers' call get_pointers( & g, species, nvar, num_reactions, & @@ -265,7 +265,7 @@ subroutine burn_const_density_1_zone( & !stop stptry = max(start * 1.0d-10,1.0d-16) stpmin = stptry * 1.0d-12 - + if (dbg) write(*,*) 'call netint' call netint( & start,stptry,stpmin,max_steps,stopp,ending_y, & @@ -284,18 +284,18 @@ subroutine burn_const_density_1_zone( & ending_x(i) = ending_y(i)*aion(i) dx = ending_x(i) - save_x(i) !write(*,2) 'dx aion end_x', i, dx, aion(i), ending_x(i) - cid = g% chem_id(i) + cid = g% chem_id(i) burn_ergs = burn_ergs + & (get_Q(chem_isos,cid))*dx/chem_isos% Z_plus_N(cid) end do burn_ergs = burn_ergs*Qconv avg_eps_nuc = burn_ergs/(t_end - t_start) - eps_neu_total ending_log10T = ending_y(nvar)/ln10 - + !write(*,*) 'starting, ending logT', starting_y(nvar)/ln10, ending_log10T - + contains - + subroutine burner_derivs(x,y,f,nvar,ierr) integer, intent(in) :: nvar real(dp) :: x, y(:), f(:) @@ -309,14 +309,14 @@ subroutine burner_derivs(x,y,f,nvar,ierr) real(dp), target :: f21_a(nvar) real(dp), pointer :: f21(:) - + include 'formats' - + ierr = 0 nfcn = nfcn + 1 call jakob_or_derivs(x,y,f,dfdx,ierr) - if (ierr /= 0) return - + if (ierr /= 0) return + end subroutine burner_derivs subroutine burner_jakob(x,y,dfdy,nvar,ierr) @@ -326,7 +326,7 @@ subroutine burner_jakob(x,y,dfdy,nvar,ierr) integer, intent(out) :: ierr real(dp), target :: f_arry(0) real(dp), pointer :: f(:) - + real(dp) :: Z_plus_N, df_t, df_m integer :: i, ci, j, cj logical :: okay @@ -338,7 +338,7 @@ subroutine burner_jakob(x,y,dfdy,nvar,ierr) call jakob_or_derivs(x,y,f,dfdy,ierr) if (ierr /= 0) return - + end subroutine burner_jakob subroutine jakob_or_derivs(time,y,f,dfdy,ierr) @@ -346,64 +346,64 @@ subroutine jakob_or_derivs(time,y,f,dfdy,ierr) use net_eval, only: eval_net use rates_def, only: rates_reaction_id_max, i_rate, i_rate_dT, i_rate_dRho use interp_1d_lib, only: interp_value - + real(dp) :: time, y(:), f(:) real(dp) :: dfdy(:,:) integer, intent(out) :: ierr - + real(dp) :: T, lgT, rate_limit, rat, dratdt, dratdd real(dp) :: eps_nuc real(dp) :: d_eps_nuc_dT real(dp) :: d_eps_nuc_dRho - real(dp) :: d_eps_nuc_dx(nvar) + real(dp) :: d_eps_nuc_dx(nvar) real(dp) :: dxdt(nvar) real(dp) :: d_dxdt_dRho(nvar) real(dp) :: d_dxdt_dT(nvar) real(dp) :: d_dxdt_dx(nvar, nvar) - + logical :: rates_only, dxdt_only, okay integer :: i, j, k, ir real(dp), pointer, dimension(:) :: actual_Qs, actual_neuQs real(dp) :: xsum logical, pointer :: from_weaklib(:) - + real(dp), target :: x_a(nvar), dfdx_a(nvar,nvar) real(dp), pointer :: x(:), dfdx(:,:) real(dp) :: d_eta_dlnRho - + include 'formats' - + ierr = 0 x => x_a dfdx => dfdx_a - + actual_Qs => null() actual_neuQs => null() from_weaklib => null() - - xsum = 0 + + xsum = 0 do i=1,species if (is_bad(y(i))) then ierr = -1 write(*,2) 'net_burn_const_density failed in jakob_or_derivs: bad y(i)', i, y(i) return stop - end if + end if y(i) = min(1.0d0, max(y(i),1.0d-30)) x(i) = y(i)*aion(i) xsum = xsum + x(i) end do if (trace .and. xsum > 2) write(*,*) 'sum_x, time', xsum, time - + lgT = y(nvar)/ln10 T = exp10(lgT) - + call basic_composition_info( & species, g% chem_id, x, xh, xhe, z, & abar, zbar, z2bar, z53bar, ye, mass_correction, sumx) - + call get_eos_info_for_burn_at_const_density( & eos_handle, species, g% chem_id, g% net_iso, x, & Rho, lgRho, T, lgT, & @@ -425,12 +425,12 @@ subroutine jakob_or_derivs(time,y,f,dfdy,ierr) write(*,1) 'zbar', zbar call mesa_error(__FILE__,__LINE__,'net burn const density') end if - + rates_only = .false. dxdt_only = (size(dfdy,dim=1) == 0) - + !write(*,1) 'eval_net lgT', lgT - + d_eta_dlnRho = 0d0 call eval_net( & n, g, rates_only, dxdt_only, & @@ -462,7 +462,7 @@ subroutine jakob_or_derivs(time,y,f,dfdy,ierr) write(*,1) 'd_eta_dlnT', d_eta_dlnT call mesa_error(__FILE__,__LINE__,'net burn const density') end if - + if (size(f,dim=1) > 0) then do j = 1, species f(j) = dxdt(j)/aion(j) @@ -490,7 +490,7 @@ subroutine jakob_or_derivs(time,y,f,dfdy,ierr) do j = 1,species dfdy(nvar,j) = d_eps_nuc_dx(j)/(Cv*T) ! d_lnT_dx(j) !dfdy(nvar,j) = 0d0 ! TESTING - end do + end do dfdy(nvar,nvar) = & d_eps_nuc_dT/Cv - (1d0 + d_Cv_dlnT/Cv)*eps_nuc/(Cv*T) !dfdy(nvar,nvar) = -1d0 ! TESTING @@ -503,12 +503,12 @@ subroutine jakob_or_derivs(time,y,f,dfdy,ierr) call mesa_error(__FILE__,__LINE__,'jakob_or_derivs') end if end if - + end subroutine jakob_or_derivs end subroutine burn_const_density_1_zone - + diff --git a/net/private/net_burn_const_p.f90 b/net/private/net_burn_const_p.f90 index e88efbb06..3f391d631 100644 --- a/net/private/net_burn_const_p.f90 +++ b/net/private/net_burn_const_p.f90 @@ -31,7 +31,7 @@ module net_burn_const_P use rates_def, only: num_rvs use mtx_def use utils_lib, only: fill_with_NaNs,fill_with_NaNs_2D - + implicit none contains @@ -47,20 +47,20 @@ subroutine burn_1_zone_const_P( & ending_x, ending_temp, ending_rho, ending_lnS, initial_rho, initial_lnS, & nfcn, njac, nstep, naccpt, nrejct, time_doing_net, time_doing_eos, ierr) use num_def - use num_lib + use num_lib use mtx_lib use rates_def, only: rates_reaction_id_max - + integer, intent(in) :: net_handle, eos_handle integer, intent(in) :: num_isos integer, intent(in) :: num_reactions real(dp), pointer, intent(in) :: starting_x(:) ! (num_isos) real(dp), intent(in) :: starting_temp logical, intent(in) :: clip ! if true, set negative x's to zero during burn. - + integer, intent(in) :: which_solver ! as defined in num_def.f integer, intent(in) :: ntimes ! ending time is times(num_times); starting time is 0 - real(dp), pointer, intent(in) :: times(:) ! (num_times) + real(dp), pointer, intent(in) :: times(:) ! (num_times) real(dp), pointer, intent(in) :: log10Ps_f1(:) ! =(4,numtimes) interpolant for log10P(time) real(dp), intent(in) :: rate_factors(:) ! (num_reactions) @@ -68,9 +68,9 @@ subroutine burn_1_zone_const_P( & real(dp), pointer, intent(in) :: reaction_Qs(:) ! (rates_reaction_id_max) real(dp), pointer, intent(in) :: reaction_neuQs(:) ! (rates_reaction_id_max) integer, intent(in) :: screening_mode - + ! args to control the solver -- see num/public/num_isolve.dek - real(dp), intent(inout) :: h + real(dp), intent(inout) :: h real(dp), intent(in) :: max_step_size ! maximal step size. integer, intent(in) :: max_steps ! maximal number of allowed steps. ! absolute and relative error tolerances @@ -98,7 +98,7 @@ subroutine burn_1_zone_const_P( & ! if < 0, then ignore ! else on return has input value plus time spent doing eos integer, intent(out) :: ierr - + type (Net_Info) :: n type (Net_General_Info), pointer :: g integer :: ijac, nzmax, isparse, mljac, mujac, imas, mlmas, mumas, lrd, lid, & @@ -106,9 +106,9 @@ subroutine burn_1_zone_const_P( & integer, pointer :: ipar(:), iwork(:), ipar_burn_const_P_decsol(:) real(dp), pointer :: rpar(:), work(:), v(:), rpar_burn_const_P_decsol(:) real(dp) :: t, lgT, lgRho, tend - + include 'formats' - + ending_x = 0 ending_temp = 0 ending_rho = 0 @@ -119,24 +119,24 @@ subroutine burn_1_zone_const_P( & naccpt = 0 nrejct = 0 ierr = 0 - + nvar = num_isos + 1 call get_net_ptr(net_handle, g, ierr) if (ierr /= 0) then return end if - + if (g% num_isos /= num_isos) then write(*,*) 'invalid num_isos', num_isos return end if - + if (g% num_reactions /= num_reactions) then write(*,*) 'invalid num_reactions', num_reactions return end if - + if (which_decsol == lapack) then nzmax = 0 isparse = 0 @@ -145,22 +145,22 @@ subroutine burn_1_zone_const_P( & write(*,1) 'net 1 zone burn const P: unknown value for which_decsol', which_decsol call mesa_error(__FILE__,__LINE__) end if - + ijac = 1 mljac = nvar ! square matrix mujac = nvar imas = 0 mlmas = 0 - mumas = 0 - + mumas = 0 + lout = 0 - + call isolve_work_sizes(nvar, nzmax, imas, mljac, mujac, mlmas, mumas, liwork, lwork) lipar = burn_lipar - lrpar = burn_const_P_lrpar - + lrpar = burn_const_P_lrpar + allocate(v(nvar), iwork(liwork), work(lwork), rpar(lrpar), ipar(lipar), & ipar_burn_const_P_decsol(lid), rpar_burn_const_P_decsol(lrd), stat=ierr) if (ierr /= 0) then @@ -175,9 +175,9 @@ subroutine burn_1_zone_const_P( & call fill_with_NaNs(rpar_burn_const_P_decsol) end if - + i = burn_const_P_lrpar - + ipar(i_burn_caller_id) = caller_id ipar(i_net_handle) = net_handle ipar(i_eos_handle) = eos_handle @@ -191,10 +191,10 @@ subroutine burn_1_zone_const_P( & iwork = 0 work = 0 - + t = 0 tend = times(ntimes) - + rpar(r_burn_const_P_rho) = 1d-99 ! dummy value, will be calculated later rpar(r_burn_const_P_pressure) = exp10(log10Ps_f1(1)) ! no interpolation yet rpar(r_burn_const_P_temperature) = starting_temp @@ -205,7 +205,7 @@ subroutine burn_1_zone_const_P( & v(1:num_isos) = starting_x(1:num_isos) v(nvar) = log(starting_temp) - + if (which_decsol == lapack) then call do_isolve(lapack_decsol, null_decsols, ierr) else @@ -221,7 +221,7 @@ subroutine burn_1_zone_const_P( & njac = iwork(15) nstep = iwork(16) naccpt = iwork(17) - nrejct = iwork(18) + nrejct = iwork(18) time_doing_net = rpar(r_burn_const_P_time_net) time_doing_eos = rpar(r_burn_const_P_time_eos) @@ -231,7 +231,7 @@ subroutine burn_1_zone_const_P( & ending_lnS = rpar(r_burn_const_P_lnS) initial_rho = rpar(r_burn_const_P_init_rho) initial_lnS = rpar(r_burn_const_P_init_lnS) - + if (ierr /= 0) then write(*, '(a30,i10)') 'nfcn', nfcn write(*, '(a30,i10)') 'njac', njac @@ -240,18 +240,18 @@ subroutine burn_1_zone_const_P( & write(*, '(a30,i10)') 'nrejct', nrejct call mesa_error(__FILE__,__LINE__) end if - + call dealloc - - + + contains - - + + subroutine dealloc deallocate(iwork, work, rpar, ipar, ipar_burn_const_P_decsol, rpar_burn_const_P_decsol) end subroutine dealloc - - + + subroutine do_isolve(decsol, decsols, ierr) interface include "mtx_decsol.dek" @@ -261,7 +261,7 @@ subroutine do_isolve(decsol, decsols, ierr) integer :: caller_id, nvar_blk, nz_blk real(dp), dimension(:), pointer :: & lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk - + nullify(lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk) caller_id = 0 nvar_blk = 0 @@ -279,7 +279,7 @@ subroutine do_isolve(decsol, decsols, ierr) decsol, decsols, null_decsolblk, & lrd, rpar_burn_const_P_decsol, lid, ipar_burn_const_P_decsol, & caller_id, nvar_blk, nz_blk, & - lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk, & + lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk, & null_fcn_blk_dble, null_jac_blk_dble, & work, lwork, iwork, liwork, & lrpar, rpar, lipar, ipar, & @@ -318,7 +318,7 @@ subroutine burn_jacob( & integer, intent(inout), pointer :: ipar(:) ! (lipar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(out) :: ierr - + integer :: net_handle, num_reactions, eos_handle real(dp) :: & abar, zbar, z2bar, z53bar, ye, mass_correction, sumx, T, logT, & @@ -328,7 +328,7 @@ subroutine burn_jacob( & real(dp) :: eps_neu_total, eps_nuc real(dp) :: d_eps_nuc_dT real(dp) :: d_eps_nuc_dRho - real(dp) :: d_eps_nuc_dx(nvar-1) + real(dp) :: d_eps_nuc_dx(nvar-1) real(dp) :: dxdt(nvar-1) real(dp) :: d_dxdt_dRho(nvar-1) real(dp) :: d_dxdt_dT(nvar-1) @@ -342,9 +342,9 @@ subroutine burn_jacob( & real(dp) :: dlnRho_dlnPgas_const_T, dlnRho_dlnT_const_Pgas real(dp) :: dlnRho_dlnT_const_P, d_epsnuc_dlnT_const_P, d_Cp_dlnT real(dp) :: res(num_eos_basic_results) - real(dp) :: d_dlnRho_const_T(num_eos_basic_results) - real(dp) :: d_dlnT_const_Rho(num_eos_basic_results) - real(dp) :: d_dxa_const_TRho(num_eos_d_dxa_results, nvar-1) + real(dp) :: d_dlnRho_const_T(num_eos_basic_results) + real(dp) :: d_dlnT_const_Rho(num_eos_basic_results) + real(dp) :: d_dxa_const_TRho(num_eos_d_dxa_results, nvar-1) integer, pointer :: net_iso(:), chem_id(:) type (Net_General_Info), pointer :: g @@ -353,33 +353,33 @@ subroutine burn_jacob( & actual_Qs => null() actual_neuQs => null() from_weaklib => null() - + include 'formats' - + num_isos = nvar-1 - + ierr = 0 f = 0 dfdv = 0 - + eos_handle = ipar(i_eos_handle) - + net_handle = ipar(i_net_handle) call get_net_ptr(net_handle, g, ierr) if (ierr /= 0) then write(*,*) 'invalid handle for eval_net -- did you call alloc_net_handle?' return end if - + v(1:num_isos) = max(1d-30, min(1d0, v(1:num_isos))) ! positive definite mass fractions v(1:num_isos) = v(1:num_isos)/sum(v(1:num_isos)) x(1:num_isos) = v(1:num_isos) - + num_reactions = g% num_reactions i = burn_const_P_lrpar - + if (ipar(i_clip) /= 0) then do i=1,num_isos x(i) = max(0d0, min(1d0, x(i))) @@ -388,11 +388,11 @@ subroutine burn_jacob( & call basic_composition_info( & num_isos, g% chem_id, x, xh, Y, z, abar, zbar, z2bar, z53bar, ye, mass_correction, sumx) - + logT = v(nvar)/ln10 T = exp10(logT) - pressure = rpar(r_burn_const_P_pressure) + pressure = rpar(r_burn_const_P_pressure) Prad = Radiation_Pressure(T) Pgas = pressure - Prad if (Pgas <= 0) then @@ -404,13 +404,13 @@ subroutine burn_jacob( & chem_id => g% chem_id net_iso => g% net_iso - + if (rpar(r_burn_const_P_time_eos) >= 0) then call system_clock(time0,clock_rate) else time0 = 0 endif - + call eosPT_get( & eos_handle, & num_isos, chem_id, net_iso, x, & @@ -486,9 +486,9 @@ subroutine burn_jacob( & if (ierr /= 0) then return - - - + + + write(*,*) 'eval_net failed' write(*,1) 'xh', xh write(*,1) 'Y', Y @@ -505,40 +505,40 @@ subroutine burn_jacob( & write(*,1) 'logRho', logRho write(*,1) 'Cp', Cp ierr = -1 - - + + call mesa_error(__FILE__,__LINE__,'net_burn_const_P') - + return end if - + f(1:num_isos) = dxdt dlnT_dt = eps_nuc/(Cp*T) f(nvar) = dlnT_dt - + if (ld_dfdv > 0) then dlnRho_dlnT_const_P = -res(i_chiT)/res(i_chiRho) d_epsnuc_dlnT_const_P = d_eps_nuc_dT*T + d_eps_nuc_dRho*Rho*dlnRho_dlnT_const_P d_Cp_dlnT = d_dlnT_const_Rho(i_Cp) + d_dlnRho_const_T(i_Cp)*dlnRho_dlnT_const_P - + dfdv(1:num_isos,1:num_isos) = d_dxdt_dx dfdv(nvar,nvar) = d_epsnuc_dlnT_const_P/(Cp*T) - dlnT_dt*(1 + d_Cp_dlnT/Cp) - + ! d_dxdt_dlnT dfdv(1:num_isos,nvar) = & d_dxdt_dT(1:num_isos)*T + d_dxdt_dRho(1:num_isos)*Rho*dlnRho_dlnT_const_P - + ! d_dlnTdt_dx dfdv(nvar,1:num_isos) = d_eps_nuc_dx(1:num_isos)/(Cp*T) end if - + end subroutine burn_jacob - subroutine burn_sjac(n,time,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) + subroutine burn_sjac(n,time,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) use mtx_lib, only: dense_to_sparse_with_diag integer, intent(in) :: n, nzmax, lrpar, lipar real(dp), intent(in) :: time, h @@ -580,10 +580,10 @@ subroutine burn_sjac(n,time,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) ipar(i_sparse_format),n,n,dfdv,nzmax,nz,ia,ja,values,ierr) deallocate(dfdv) end subroutine burn_sjac - - + + end subroutine burn_1_zone_const_P - + end module net_burn_const_P diff --git a/net/private/net_burn_support.f90 b/net/private/net_burn_support.f90 index ba92c4840..d5acde188 100644 --- a/net/private/net_burn_support.f90 +++ b/net/private/net_burn_support.f90 @@ -28,9 +28,9 @@ module net_burn_support use math_lib use utils_lib, only: is_bad, mesa_error use mtx_def, only: lapack - + implicit none - + integer, parameter :: qcol_imax=13, kmaxx = 7, stifbs_imax = kmaxx+1 @@ -40,14 +40,14 @@ module net_burn_support contains - - - + + + subroutine netint( & start,stptry,stpmin,max_steps,stopp,y, & eps,species,nvar,nok,nbad,nstp,odescal,dens_dfdy,dmat, & derivs,jakob,burner_finish_substep,ierr) - + ! input: ! start = beginning integration point ! stptry = suggested first step size @@ -70,13 +70,13 @@ subroutine netint( & real(dp) :: dens_dfdy(:,:),dmat(:,:) integer, intent(out) :: ierr - + interface include 'burner_derivs.inc' - end interface + end interface interface include 'burner_jakob.inc' - end interface + end interface interface include 'burner_finish_substep.inc' end interface @@ -87,7 +87,7 @@ subroutine netint( & real(dp) :: yscal(nvar),dydx(nvar),cons,x,h,hdid,hnext,xx real(dp), parameter :: tiny=1.0d-15 - + real(dp) :: y0(nvar),a(stifbs_imax),alf(kmaxx,kmaxx),epsold,xnew,scale,red integer :: i,kmax,kopt,nseq(stifbs_imax),nvold logical :: first @@ -104,7 +104,7 @@ subroutine netint( & nok = 0 nbad = 0 ierr = 0 - + do i=1,nvar y0(i) = y(i) end do @@ -122,7 +122,7 @@ subroutine netint( & end if y(i) = min(1.0d0, max(y(i),1.0d-30)) end do - + call burner_finish_substep(nstp, x, y, ierr) if (ierr /= 0) return @@ -132,7 +132,7 @@ subroutine netint( & return write(*,*) 'derivs failed in netint' end if - + do i=1,nvar yscal(i) = max(odescal,abs(y(i))) end do @@ -166,7 +166,7 @@ subroutine netint( & ! normal timestep choice h = hnext -! die +! die if (abs(h).lt.stpmin) then write(*,*) 'netint failed: abs(h).lt.stpmin', abs(h), stpmin ierr = -1 @@ -180,7 +180,7 @@ subroutine netint( & write(6,230) (y0(i), i=1,nvar) write(6,220) 'current composition:' write(6,230) (y(i), i=1,nvar) - + !call mesa_error(__FILE__,__LINE__,'h < stpmin in netint') 210 format(1x,a,4i6) @@ -198,7 +198,7 @@ subroutine netint( & end subroutine netint - + subroutine stifbs(y,dydx,nvar,x,htry,eps,yscal,hdid,hnext, & a,alf,epsold,first,kmax,kopt,nseq,nvold,xnew,scale,red, & @@ -224,13 +224,13 @@ subroutine stifbs(y,dydx,nvar,x,htry,eps,yscal,hdid,hnext, & real(dp) :: dens_dfdy(:,:),dmat(:,:) - + interface include 'burner_derivs.inc' - end interface + end interface interface include 'burner_jakob.inc' - end interface + end interface logical reduct integer nvar @@ -246,7 +246,7 @@ subroutine stifbs(y,dydx,nvar,x,htry,eps,yscal,hdid,hnext, & integer nstp, ierr2 ierr = 0 - + ! a new tolerance or a new number, so reinitialize if (eps .ne. epsold .or. nvar .ne. nvold) then hnext = -1.0d29 @@ -336,9 +336,9 @@ subroutine stifbs(y,dydx,nvar,x,htry,eps,yscal,hdid,hnext, & write(*,*) 'simpr failed in stifbs' return - - - + + + end if xest = (h/nseq(k))*(h/nseq(k)) call net_pzextr(k,xest,yseq,y,yerr,nvar,qcol,x_pzextr) @@ -432,13 +432,13 @@ subroutine simpr( & derivs,ierr) ! real(dp) :: dens_dfdy(:,:),dmat(:,:) - + interface include 'burner_derivs.inc' end interface - + integer, intent(out) :: ierr - + integer nvar,nstep integer i,j,nn,ii real(dp) y(:),dydx(:),xs,htot, & @@ -447,7 +447,7 @@ subroutine simpr( & !..for the linear algebra integer, target :: indx_a(nvar) integer, pointer :: indx(:) - + include 'formats' indx => indx_a @@ -456,22 +456,22 @@ subroutine simpr( & h = htot/nstep do j=1,nvar do i=1,nvar - dmat(i,j) = -h * dens_dfdy(i,j) + dmat(i,j) = -h * dens_dfdy(i,j) enddo enddo do i=1,nvar dmat(i,i) = 1.0d0 + dmat(i,i) end do -!..factor the matrix - call my_getf2(nvar, dmat, nvar, indx, ierr) +!..factor the matrix + call my_getf2(nvar, dmat, nvar, indx, ierr) if (ierr /= 0) then if (dbg) write(*,*) 'my_getf2 failed in simpr' return - end if + end if ! use yout as temporary storage; the first step - do i=1,nvar + do i=1,nvar yout(i) = h * dydx(i) if (dbg) then if (is_bad(yout(i))) then @@ -480,44 +480,44 @@ subroutine simpr( & end if end if enddo - - call my_getrs1(nvar, dmat, nvar, indx, yout, nvar, ierr) + + call my_getrs1(nvar, dmat, nvar, indx, yout, nvar, ierr) if (ierr /= 0) then if (dbg) write(*,*) 'my_getrs1 failed in simpr' return - end if + end if do i=1,nvar del(i) = yout(i) ytemp(i) = y(i) + del(i) if (dbg) then if (is_bad(ytemp(i))) then - + do j=1,nvar do ii=1,nvar - if (dens_dfdy(ii,j) /= 0) write(*,3) 'dens_dfdy(ii,j)', ii, j, dens_dfdy(ii,j) + if (dens_dfdy(ii,j) /= 0) write(*,3) 'dens_dfdy(ii,j)', ii, j, dens_dfdy(ii,j) enddo enddo - + do ii=1,nvar if (dydx(ii) /= 0) write(*,2) 'dydx(ii)', ii, dydx(ii) enddo - + do j=1,nvar do ii=1,nvar - if (dmat(ii,j) /= 0) write(*,3) 'dmat(ii,j)', ii, j, dmat(ii,j) + if (dmat(ii,j) /= 0) write(*,3) 'dmat(ii,j)', ii, j, dmat(ii,j) enddo enddo - + do ii=1,nvar if (yout(ii) /= 0) write(*,2) 'yout(ii)', ii, yout(ii) enddo - + write(*,*) 'first step: bad ytemp in simpr nstep i ytemp', nstep, i, ytemp(i), del(i), y(i) call mesa_error(__FILE__,__LINE__,'simpr') - + end if - + end if enddo @@ -531,8 +531,8 @@ subroutine simpr( & ! use yout as temporary storage; general step do nn=2,nstep - do 15 i=1,nvar - yout(i) = h*yout(i) - del(i) + do 15 i=1,nvar + yout(i) = h*yout(i) - del(i) if (dbg) then if (is_bad(yout(i))) then write(*,*) 'bad yout in simpr nn i yout', nn, i, yout(i) @@ -540,11 +540,11 @@ subroutine simpr( & end if end if 15 continue - call my_getrs1(nvar, dmat, nvar, indx, yout, nvar, ierr) + call my_getrs1(nvar, dmat, nvar, indx, yout, nvar, ierr) if (ierr /= 0) then if (dbg) write(*,*) 'my_getrs1 failed in simpr' return - end if + end if do i=1,nvar del(i) = del(i) + 2.0d0 * yout(i) ytemp(i) = ytemp(i) + del(i) @@ -565,21 +565,21 @@ subroutine simpr( & enddo ! take the last step - do 18 i=1,nvar - yout(i) = h * yout(i) - del(i) - if (dbg) then + do 18 i=1,nvar + yout(i) = h * yout(i) - del(i) + if (dbg) then if (is_bad(yout(i))) then write(*,*) 'bad yout in simpr last step: nstep i yout', nstep, i, yout(i) call mesa_error(__FILE__,__LINE__,'simpr') end if end if 18 continue - call my_getrs1(nvar, dmat, nvar, indx, yout, nvar, ierr) + call my_getrs1(nvar, dmat, nvar, indx, yout, nvar, ierr) if (ierr /= 0) then write(*,*) 'my_getrs1 failed in simpr' return - end if - + end if + do i=1,nvar yout(i) = ytemp(i) + yout(i) if (dbg) then @@ -592,8 +592,8 @@ subroutine simpr( & return end subroutine simpr - - + + subroutine net_pzextr(iest,xest,yest,yz,dy,nvar,qcol,x) ! use polynomial extrapolation to evaluate nvar functions at x=0 by fitting ! a polynomial to a sequence of estimates with progressively smaller values @@ -653,11 +653,11 @@ subroutine net_pzextr(iest,xest,yest,yz,dy,nvar,qcol,x) return end subroutine net_pzextr - + include 'mtx_solve_routines.inc' - + end module net_burn_support diff --git a/net/private/net_derivs.f90 b/net/private/net_derivs.f90 index 489f511eb..428df34f7 100644 --- a/net/private/net_derivs.f90 +++ b/net/private/net_derivs.f90 @@ -31,9 +31,9 @@ module net_derivs use rates_def implicit none - + real(dp), parameter :: tiny_rate = 1d-50 - + contains @@ -59,16 +59,16 @@ subroutine get_derivs( & type (Net_General_Info), pointer :: g real(dp) :: T9, T932, eps_nuc_cancel_factor, eps_factor, & old_eps_nuc_categories_val - + include 'formats' - + ierr = 0 T9 = temp*1d-9 T932 = T9*sqrt(T9) - + g => n% g - + if (.true. .or. logtemp <= g% logT_lo_eps_nuc_cancel) then eps_nuc_cancel_factor = 1d0 else if (logtemp >= g% logT_hi_eps_nuc_cancel) then @@ -78,7 +78,7 @@ subroutine get_derivs( & (g% logT_hi_eps_nuc_cancel - logtemp)/& (g% logT_hi_eps_nuc_cancel - g% logT_lo_eps_nuc_cancel) end if - + !write(*,1) 'eps_nuc_cancel_factor', eps_nuc_cancel_factor, logtemp itab => g% net_iso @@ -86,21 +86,21 @@ subroutine get_derivs( & reaction_kind => g% reaction_reaclib_kind reverse_id => g% reverse_id_for_kind_ne_other reaction_id => g% reaction_id - + show_derivs_dydt = .false. if (show_dydt) then i = itab(io16) if (i > 0) & show_derivs_dydt = (abs(n% y(i) - show_dydt_y) < 1d-14) end if - - + + deriv_flgs => deriv_flgs_data if (checking_deriv_flags) deriv_flgs(:) = .false. dydt = 0 if (.not. just_dydt) n% d_dydt_dy = 0 - + ierr = 0 eps_nuc_MeV = 0d0 @@ -109,7 +109,7 @@ subroutine get_derivs( & else jmax = num_rvs end if - + ! Update special rates that depend on the composition do i=1,num_reactions call update_special_rates(n, dydt, eps_nuc_MeV, i, eta, ye, temp, den, abar, zbar, & @@ -117,14 +117,14 @@ subroutine get_derivs( & deriv_flgs, symbolic, just_dydt, & ierr) end do - + old_eps_nuc_categories_val = 0 - + i = 1 do while (i <= num_reactions) - + if (ierr /= 0) exit - + ir = reaction_id(i) icat_f = reaction_categories(ir) @@ -137,31 +137,31 @@ subroutine get_derivs( & r_ir = 0 icat_r = 0 end if - - kind = reaction_kind(i) + + kind = reaction_kind(i) if ( & !kind == ng_kind .or. & !kind == pn_kind .or. & - !kind == pg_kind .or. & - !kind == ap_kind .or. & - !kind == an_kind .or. & - !kind == ag_kind .or. & + !kind == pg_kind .or. & + !kind == ap_kind .or. & + !kind == an_kind .or. & + !kind == ag_kind .or. & !kind == general_one_one_kind .or. & !kind == general_two_one_kind .or. & !kind == general_two_two_kind .or. & kind == -1 & ) kind = other_kind - + !kind = other_kind ! TESTING - + !if (reaction_name(ir) == 'rfe52aprot_to_ni56') then ! write(*,2) 'rfe52aprot_to_ni56 kind', kind ! stop !end if - + eps_factor = 1d0 - !write(*,*) trim(reaction_name(ir)),kind + !write(*,*) trim(reaction_name(ir)),kind select case(kind) case (other_kind) call get1_derivs( & @@ -196,7 +196,7 @@ subroutine get_derivs( & call mesa_error(__FILE__,__LINE__,'confusion in net wrt reaction kind') end select i = i+2 - + ! icat 16 is burn_fe if (.false. .and. icat_f == 16 .and. n% logT >= 9.4864903d0 .and. n% logT <= 9.48649039d0) then write(*,1) trim(category_name(icat_f)) // ' ' // trim(reaction_name(ir)), & @@ -204,8 +204,8 @@ subroutine get_derivs( & Qconv*n% eps_nuc_categories(icat_f) old_eps_nuc_categories_val = n% eps_nuc_categories(icat_f) end if - - + + end do if(associated(net_other_net_derivs)) then @@ -214,28 +214,28 @@ subroutine get_derivs( & symbolic, just_dydt, ierr) end if - + contains subroutine get_general_1_to_1_derivs(i,ierr) ! e.g., 2 c12 -> mg24, 3 he4 -> c12 integer, intent(in) :: i integer, intent(out) :: ierr - + real(qp) :: b, b_f, b_r, rate real(dp) :: d, d_f, d_r, d1, d2, Q, ys_f, ys_r, & d_ysf_dy1, d_ysr_dy2 integer :: c1, c2, i1, i2, o1, o3 - + include 'formats' - - ierr = 0 - + + ierr = 0 + ! forward reaction is c1 i1 -> c2 i2 - c1 = reaction_inputs(1,ir) - i1 = itab(reaction_inputs(2,ir)) + c1 = reaction_inputs(1,ir) + i1 = itab(reaction_inputs(2,ir)) c2 = reaction_outputs(1,ir) i2 = itab(reaction_outputs(2,ir)) - + if (symbolic) then n% d_dydt_dy(i1,i1) = 1 n% d_dydt_dy(i1,i2) = 1 @@ -243,7 +243,7 @@ subroutine get_general_1_to_1_derivs(i,ierr) ! e.g., 2 c12 -> mg24, 3 he4 -> c12 n% d_dydt_dy(i2,i2) = 1 return end if - + select case(c1) case (1) ys_f = n% y(i1) @@ -259,7 +259,7 @@ subroutine get_general_1_to_1_derivs(i,ierr) ! e.g., 2 c12 -> mg24, 3 he4 -> c12 call mesa_error(__FILE__,__LINE__,'get_general_1_to_1_derivs') end select d_f = ys_f - + select case(c2) case (1) ys_r = n% y(i2) @@ -307,7 +307,7 @@ subroutine get_general_1_to_1_derivs(i,ierr) ! e.g., 2 c12 -> mg24, 3 he4 -> c12 n% eps_neu_rate(i) = 0d0 n% eps_neu_rate(r_i) = 0d0 - + rate = n% rate_screened_dT(i) b_f = d_f*rate rate = n% rate_screened_dT(r_i) @@ -319,7 +319,7 @@ subroutine get_general_1_to_1_derivs(i,ierr) ! e.g., 2 c12 -> mg24, 3 he4 -> c12 b_r = -Q*b_r b = b_f + b_r eps_nuc_MeV(i_rate_dT) = eps_nuc_MeV(i_rate_dT) + b - + rate = n% rate_screened_dRho(i) b_f = d_f*rate rate = n% rate_screened_dRho(r_i) @@ -331,7 +331,7 @@ subroutine get_general_1_to_1_derivs(i,ierr) ! e.g., 2 c12 -> mg24, 3 he4 -> c12 b_r = -Q*b_r b = b_f + b_r eps_nuc_MeV(i_rate_dRho) = eps_nuc_MeV(i_rate_dRho) + b - + if (checking_deriv_flags) then deriv_flgs(i) = .true. deriv_flgs(r_i) = .true. @@ -341,34 +341,34 @@ subroutine get_general_1_to_1_derivs(i,ierr) ! e.g., 2 c12 -> mg24, 3 he4 -> c12 d2 = d_ysr_dy2*n% rate_screened(r_i) ! d(rate_r)/d(y2) n% d_eps_nuc_dy(i1) = n% d_eps_nuc_dy(i1) + Q*d1 - n% d_eps_nuc_dy(i2) = n% d_eps_nuc_dy(i2) - Q*d2 - + n% d_eps_nuc_dy(i2) = n% d_eps_nuc_dy(i2) - Q*d2 + n% d_dydt_dy(i1,i1) = n% d_dydt_dy(i1,i1) - c1*d1 n% d_dydt_dy(i2,i1) = n% d_dydt_dy(i2,i1) + c2*d1 n% d_dydt_dy(i1,i2) = n% d_dydt_dy(i1,i2) + c1*d2 n% d_dydt_dy(i2,i2) = n% d_dydt_dy(i2,i2) - c2*d2 - + end subroutine get_general_1_to_1_derivs subroutine get_general_2_to_1_derivs(i,ierr) ! e.g., r_he4_si28_to_o16_o16 integer, intent(in) :: i integer, intent(out) :: ierr - + real(qp) :: b, b_f, b_r, rate real(dp) :: d, d_f, d_r, d1, d2, d3, Q, ys_f, ys_r, & d_ysf_dy1, d_ysf_dy2, d_ysr_dy3, y1, y2, y3 integer :: c1, c2, c3, i1, i2, i3, o1, o3 - + include 'formats' - - ierr = 0 - + + ierr = 0 + ! forward reaction is c1 i1 + c2 i2 -> c3 i3 c1 = reaction_inputs(1,ir) - i1 = itab(reaction_inputs(2,ir)) - c2 = reaction_inputs(3,ir) - i2 = itab(reaction_inputs(4,ir)) + i1 = itab(reaction_inputs(2,ir)) + c2 = reaction_inputs(3,ir) + i2 = itab(reaction_inputs(4,ir)) c3 = reaction_outputs(1,ir) i3 = itab(reaction_outputs(2,ir)) @@ -384,11 +384,11 @@ subroutine get_general_2_to_1_derivs(i,ierr) ! e.g., r_he4_si28_to_o16_o16 n% d_dydt_dy(i3,i3) = 1 return end if - + y1 = n% y(i1) y2 = n% y(i2) y3 = n% y(i3) - + select case(c1) case (1) ys_f = y1 @@ -422,7 +422,7 @@ subroutine get_general_2_to_1_derivs(i,ierr) ! e.g., r_he4_si28_to_o16_o16 write(*,2) 'c1 too big for ' // trim(reaction_name(ir)) call mesa_error(__FILE__,__LINE__,'get_general_2_to_1_derivs') end select - + select case(c3) case (1) ys_r = y3 @@ -452,7 +452,7 @@ subroutine get_general_2_to_1_derivs(i,ierr) ! e.g., r_he4_si28_to_o16_o16 n% raw_rate(i) = d_f * n% rate_raw(i) * avo n% raw_rate(r_i) = d_r * n% rate_raw(r_i) * avo - + n% screened_rate(i) = d_f * n% rate_screened(i) * avo n% screened_rate(r_i) = d_r * n% rate_screened(r_i) * avo @@ -467,7 +467,7 @@ subroutine get_general_2_to_1_derivs(i,ierr) ! e.g., r_he4_si28_to_o16_o16 n% eps_nuc_categories(icat_r) = n% eps_nuc_categories(icat_r) + b_r if (show_eps_nuc .and. abs(b) > 1d2) & write(*,1) trim(reaction_Name(ir)) // ' eps_nuc', b, b_f, b_r - + n% eps_nuc_rate(i) = b_f * Qconv n% eps_nuc_rate(r_i) = b_r * Qconv n% eps_neu_rate(i) = 0d0 @@ -485,7 +485,7 @@ subroutine get_general_2_to_1_derivs(i,ierr) ! e.g., r_he4_si28_to_o16_o16 b_r = -Q*b_r b = b_f + b_r eps_nuc_MeV(i_rate_dT) = eps_nuc_MeV(i_rate_dT) + b - + rate = n% rate_screened_dRho(i) b_f = d_f*rate rate = n% rate_screened_dRho(r_i) @@ -498,7 +498,7 @@ subroutine get_general_2_to_1_derivs(i,ierr) ! e.g., r_he4_si28_to_o16_o16 b_r = -Q*b_r b = b_f + b_r eps_nuc_MeV(i_rate_dRho) = eps_nuc_MeV(i_rate_dRho) + b - + if (checking_deriv_flags) then deriv_flgs(i) = .true. deriv_flgs(r_i) = .true. @@ -509,8 +509,8 @@ subroutine get_general_2_to_1_derivs(i,ierr) ! e.g., r_he4_si28_to_o16_o16 d3 = d_ysr_dy3*n% rate_screened(r_i) ! d(rate_r)/d(y3) n% d_eps_nuc_dy(i1) = n% d_eps_nuc_dy(i1) + Q*d1 - n% d_eps_nuc_dy(i2) = n% d_eps_nuc_dy(i2) + Q*d2 - n% d_eps_nuc_dy(i3) = n% d_eps_nuc_dy(i3) - Q*d3 + n% d_eps_nuc_dy(i2) = n% d_eps_nuc_dy(i2) + Q*d2 + n% d_eps_nuc_dy(i3) = n% d_eps_nuc_dy(i3) - Q*d3 ! dydt(1,i1) = dydt(1,i1) - c1*(ys_f*n% rate_screened(i) - ys_r*n% rate_screened(r_i)) n% d_dydt_dy(i1,i1) = n% d_dydt_dy(i1,i1) - c1*d1 @@ -526,7 +526,7 @@ subroutine get_general_2_to_1_derivs(i,ierr) ! e.g., r_he4_si28_to_o16_o16 n% d_dydt_dy(i3,i1) = n% d_dydt_dy(i3,i1) + c3*d1 n% d_dydt_dy(i3,i2) = n% d_dydt_dy(i3,i2) + c3*d2 n% d_dydt_dy(i3,i3) = n% d_dydt_dy(i3,i3) - c3*d3 - + if (.false. .and. reaction_name(ir) == 'r_he4_si28_to_o16_o16') then ! .and. & !y1 > 1d-20 .and. y2 > 1d-20 .and. y3 > 1d-20) then write(*,'(A)') @@ -564,27 +564,27 @@ subroutine get_general_2_to_1_derivs(i,ierr) ! e.g., r_he4_si28_to_o16_o16 write(*,'(A)') call mesa_error(__FILE__,__LINE__,'get_general_2_to_1_derivs') end if - + end subroutine get_general_2_to_1_derivs subroutine get_general_2_to_2_derivs(i,ierr) integer, intent(in) :: i integer, intent(out) :: ierr - + real(qp) :: b, b_f, b_r, rate real(dp) :: d, d_f, d_r, d1, d2, d3, d4, Q, ys_f, ys_r, & d_ysf_dy1, d_ysf_dy2, d_ysr_dy3, d_ysr_dy4, y1, y2, y3, y4 integer :: c1, c2, c3, c4, i1, i2, i3, i4 - + include 'formats' - - ierr = 0 - + + ierr = 0 + ! forward reaction is c1 i1 + c2 i2 -> c3 i3 + c4 i4 c1 = reaction_inputs(1,ir) - i1 = itab(reaction_inputs(2,ir)) - c2 = reaction_inputs(3,ir) - i2 = itab(reaction_inputs(4,ir)) + i1 = itab(reaction_inputs(2,ir)) + c2 = reaction_inputs(3,ir) + i2 = itab(reaction_inputs(4,ir)) c3 = reaction_outputs(1,ir) i3 = itab(reaction_outputs(2,ir)) c4 = reaction_outputs(3,ir) @@ -595,29 +595,29 @@ subroutine get_general_2_to_2_derivs(i,ierr) n% d_dydt_dy(i1,i2) = 1 n% d_dydt_dy(i1,i3) = 1 n% d_dydt_dy(i1,i4) = 1 - + n% d_dydt_dy(i2,i1) = 1 n% d_dydt_dy(i2,i2) = 1 n% d_dydt_dy(i2,i3) = 1 n% d_dydt_dy(i2,i4) = 1 - + n% d_dydt_dy(i3,i1) = 1 n% d_dydt_dy(i3,i2) = 1 n% d_dydt_dy(i3,i3) = 1 n% d_dydt_dy(i3,i4) = 1 - + n% d_dydt_dy(i4,i1) = 1 n% d_dydt_dy(i4,i2) = 1 n% d_dydt_dy(i4,i3) = 1 n% d_dydt_dy(i4,i4) = 1 return end if - + y1 = n% y(i1) y2 = n% y(i2) y3 = n% y(i3) y4 = n% y(i4) - + select case(c1) case (1) ys_f = y1 @@ -651,7 +651,7 @@ subroutine get_general_2_to_2_derivs(i,ierr) write(*,2) 'c2 too big for ' // trim(reaction_name(ir)), c2 call mesa_error(__FILE__,__LINE__,'get_general_2_to_2_derivs') end select - + select case(c3) case (1) ys_r = y3 @@ -701,7 +701,7 @@ subroutine get_general_2_to_2_derivs(i,ierr) n% raw_rate(i) = d_f * n% rate_raw(i) * avo n% raw_rate(r_i) = d_r * n% rate_raw(r_i) * avo - + n% screened_rate(i) = d_f * n% rate_screened(i) * avo n% screened_rate(r_i) = d_r * n% rate_screened(r_i) * avo @@ -735,7 +735,7 @@ subroutine get_general_2_to_2_derivs(i,ierr) b_r = -Q*b_r b = b_f + b_r eps_nuc_MeV(i_rate_dT) = eps_nuc_MeV(i_rate_dT) + b - + rate = n% rate_screened_dRho(i) b_f = d_f*rate rate = n% rate_screened_dRho(r_i) @@ -749,7 +749,7 @@ subroutine get_general_2_to_2_derivs(i,ierr) b_r = -Q*b_r b = b_f + b_r eps_nuc_MeV(i_rate_dRho) = eps_nuc_MeV(i_rate_dRho) + b - + if (checking_deriv_flags) then deriv_flgs(i) = .true. deriv_flgs(r_i) = .true. @@ -761,9 +761,9 @@ subroutine get_general_2_to_2_derivs(i,ierr) d4 = d_ysr_dy4*n% rate_screened(r_i) ! d(rate_r)/d(y4) n% d_eps_nuc_dy(i1) = n% d_eps_nuc_dy(i1) + Q*d1 - n% d_eps_nuc_dy(i2) = n% d_eps_nuc_dy(i2) + Q*d2 - n% d_eps_nuc_dy(i3) = n% d_eps_nuc_dy(i3) - Q*d3 - n% d_eps_nuc_dy(i4) = n% d_eps_nuc_dy(i4) - Q*d4 + n% d_eps_nuc_dy(i2) = n% d_eps_nuc_dy(i2) + Q*d2 + n% d_eps_nuc_dy(i3) = n% d_eps_nuc_dy(i3) - Q*d3 + n% d_eps_nuc_dy(i4) = n% d_eps_nuc_dy(i4) - Q*d4 n% d_dydt_dy(i1,i1) = n% d_dydt_dy(i1,i1) - c1*d1 n% d_dydt_dy(i1,i2) = n% d_dydt_dy(i1,i2) - c1*d2 @@ -790,19 +790,19 @@ end subroutine get_general_2_to_2_derivs subroutine get_basic_2_to_2_derivs(i,ierr) integer, intent(in) :: i integer, intent(out) :: ierr - + real(qp) :: b, b_f, b_r, rate real(dp) :: d_f, d_r, e_f, e_r, d1, d2, d3, d4, & ys_f, ys_r, Q, y1, y2, y3, y4 integer :: i1, i2, i3, i4, o1, o2, o3, o4 - + include 'formats' - - ierr = 0 - + + ierr = 0 + ! forward reaction is i1 + i2 -> i3 + i4 - i1 = itab(reaction_inputs(2,ir)) - i2 = itab(reaction_inputs(4,ir)) + i1 = itab(reaction_inputs(2,ir)) + i2 = itab(reaction_inputs(4,ir)) i3 = itab(reaction_outputs(2,ir)) i4 = itab(reaction_outputs(4,ir)) @@ -825,15 +825,15 @@ subroutine get_basic_2_to_2_derivs(i,ierr) n% d_dydt_dy(i4,i4) = 1 return end if - + y1 = n% y(i1) y2 = n% y(i2) y3 = n% y(i3) y4 = n% y(i4) - + ys_f = y1*y2 d_f = ys_f - + ys_r = y3*y4 d_r = ys_r @@ -849,7 +849,7 @@ subroutine get_basic_2_to_2_derivs(i,ierr) n% raw_rate(i) = d_f * n% rate_raw(i) * avo n% raw_rate(r_i) = d_r * n% rate_raw(r_i) * avo - + n% screened_rate(i) = d_f * n% rate_screened(i) * avo n% screened_rate(r_i) = d_r * n% rate_screened(r_i) * avo @@ -861,12 +861,12 @@ subroutine get_basic_2_to_2_derivs(i,ierr) n% eps_nuc_categories(icat_r) = n% eps_nuc_categories(icat_r) - b_r*Q if (show_eps_nuc .and. abs(b) > 1d2) & write(*,1) trim(reaction_Name(ir)) // ' eps_nuc', b, b_f, b_r - + n% eps_nuc_rate(i) = b_f * Q * Qconv n% eps_nuc_rate(r_i) = -b_r * Q * Qconv n% eps_neu_rate(i) = 0d0 n% eps_neu_rate(r_i) = 0d0 - + rate = n% rate_screened_dT(i) b_f = d_f*rate @@ -878,7 +878,7 @@ subroutine get_basic_2_to_2_derivs(i,ierr) dydt(i_rate_dT,i3) = dydt(i_rate_dT,i3) + b dydt(i_rate_dT,i4) = dydt(i_rate_dT,i4) + b eps_nuc_MeV(i_rate_dT) = eps_nuc_MeV(i_rate_dT) + b*Q - + rate = n% rate_screened_dRho(i) b_f = d_f*rate rate = n% rate_screened_dRho(r_i) @@ -889,12 +889,12 @@ subroutine get_basic_2_to_2_derivs(i,ierr) dydt(i_rate_dRho,i3) = dydt(i_rate_dRho,i3) + b dydt(i_rate_dRho,i4) = dydt(i_rate_dRho,i4) + b eps_nuc_MeV(i_rate_dRho) = eps_nuc_MeV(i_rate_dRho) + b*Q - + if (checking_deriv_flags) then deriv_flgs(i) = .true. deriv_flgs(r_i) = .true. end if - + e_f = n% rate_screened(i) e_r = n% rate_screened(r_i) @@ -905,14 +905,14 @@ subroutine get_basic_2_to_2_derivs(i,ierr) n% d_eps_nuc_dy(i1) = n% d_eps_nuc_dy(i1) + Q*d1 n% d_eps_nuc_dy(i2) = n% d_eps_nuc_dy(i2) + Q*d2 - n% d_eps_nuc_dy(i3) = n% d_eps_nuc_dy(i3) - Q*d3 - n% d_eps_nuc_dy(i4) = n% d_eps_nuc_dy(i4) - Q*d4 - + n% d_eps_nuc_dy(i3) = n% d_eps_nuc_dy(i3) - Q*d3 + n% d_eps_nuc_dy(i4) = n% d_eps_nuc_dy(i4) - Q*d4 + n% d_dydt_dy(i1,i1) = n% d_dydt_dy(i1,i1) - d1 n% d_dydt_dy(i2,i1) = n% d_dydt_dy(i2,i1) - d1 n% d_dydt_dy(i3,i1) = n% d_dydt_dy(i3,i1) + d1 n% d_dydt_dy(i4,i1) = n% d_dydt_dy(i4,i1) + d1 - + n% d_dydt_dy(i1,i2) = n% d_dydt_dy(i1,i2) - d2 n% d_dydt_dy(i2,i2) = n% d_dydt_dy(i2,i2) - d2 n% d_dydt_dy(i3,i2) = n% d_dydt_dy(i3,i2) + d2 @@ -927,27 +927,27 @@ subroutine get_basic_2_to_2_derivs(i,ierr) n% d_dydt_dy(i2,i4) = n% d_dydt_dy(i2,i4) + d4 n% d_dydt_dy(i3,i4) = n% d_dydt_dy(i3,i4) - d4 n% d_dydt_dy(i4,i4) = n% d_dydt_dy(i4,i4) - d4 - + end subroutine get_basic_2_to_2_derivs subroutine get_basic_2_to_1_derivs(i,ierr) integer, intent(in) :: i integer, intent(out) :: ierr - + real(qp) :: b, b_f, b_r, rate real(dp) :: d_f, d_r, e_f, e_r, d1, d2, d3, & ys_f, ys_r, Q, y1, y2, y3 integer :: i1, i2, i3, o1, o2, o3, k - + include 'formats' - - ierr = 0 - + + ierr = 0 + ! forward reaction is i1 + i2 -> i3 - i1 = itab(reaction_inputs(2,ir)) - i2 = itab(reaction_inputs(4,ir)) + i1 = itab(reaction_inputs(2,ir)) + i2 = itab(reaction_inputs(4,ir)) i3 = itab(reaction_outputs(2,ir)) - + ! if (reaction_inputs(1,ir) /= 1 .or. & ! reaction_inputs(3,ir) /= 1 .or. & ! reaction_outputs(1,ir) /= 1 .or. & @@ -973,10 +973,10 @@ subroutine get_basic_2_to_1_derivs(i,ierr) y1 = n% y(i1) y2 = n% y(i2) y3 = n% y(i3) - + ys_f = y1*y2 d_f = ys_f - + ys_r = y3 d_r = ys_r @@ -991,10 +991,10 @@ subroutine get_basic_2_to_1_derivs(i,ierr) n% raw_rate(i) = d_f * n% rate_raw(i) * avo n% raw_rate(r_i) = d_r * n% rate_raw(r_i) * avo - + n% screened_rate(i) = d_f * n% rate_screened(i) * avo n% screened_rate(r_i) = d_r * n% rate_screened(r_i) * avo - + if (just_dydt) return Q = n% reaction_Qs(ir)*eps_factor @@ -1003,7 +1003,7 @@ subroutine get_basic_2_to_1_derivs(i,ierr) n% eps_nuc_categories(icat_r) = n% eps_nuc_categories(icat_r) - b_r*Q if (show_eps_nuc .and. abs(b) > 1d2) & write(*,1) trim(reaction_Name(ir)) // ' eps_nuc', b, b_f, b_r - + n% eps_nuc_rate(i) = b_f * Q * Qconv n% eps_nuc_rate(r_i) = -b_r * Q * Qconv n% eps_neu_rate(i) = 0d0 @@ -1018,7 +1018,7 @@ subroutine get_basic_2_to_1_derivs(i,ierr) dydt(i_rate_dT,i2) = dydt(i_rate_dT,i2) - b dydt(i_rate_dT,i3) = dydt(i_rate_dT,i3) + b eps_nuc_MeV(i_rate_dT) = eps_nuc_MeV(i_rate_dT) + b*Q - + rate = n% rate_screened_dRho(i) b_f = d_f*rate rate = n% rate_screened_dRho(r_i) @@ -1028,12 +1028,12 @@ subroutine get_basic_2_to_1_derivs(i,ierr) dydt(i_rate_dRho,i2) = dydt(i_rate_dRho,i2) - b dydt(i_rate_dRho,i3) = dydt(i_rate_dRho,i3) + b eps_nuc_MeV(i_rate_dRho) = eps_nuc_MeV(i_rate_dRho) + b*Q - + if (checking_deriv_flags) then deriv_flgs(i) = .true. deriv_flgs(r_i) = .true. end if - + e_f = n% rate_screened(i) e_r = n% rate_screened(r_i) @@ -1043,12 +1043,12 @@ subroutine get_basic_2_to_1_derivs(i,ierr) n% d_eps_nuc_dy(i1) = n% d_eps_nuc_dy(i1) + Q*d1 n% d_eps_nuc_dy(i2) = n% d_eps_nuc_dy(i2) + Q*d2 - n% d_eps_nuc_dy(i3) = n% d_eps_nuc_dy(i3) - Q*d3 - + n% d_eps_nuc_dy(i3) = n% d_eps_nuc_dy(i3) - Q*d3 + n% d_dydt_dy(i1,i1) = n% d_dydt_dy(i1,i1) - d1 n% d_dydt_dy(i2,i1) = n% d_dydt_dy(i2,i1) - d1 n% d_dydt_dy(i3,i1) = n% d_dydt_dy(i3,i1) + d1 - + n% d_dydt_dy(i1,i2) = n% d_dydt_dy(i1,i2) - d2 n% d_dydt_dy(i2,i2) = n% d_dydt_dy(i2,i2) - d2 n% d_dydt_dy(i3,i2) = n% d_dydt_dy(i3,i2) + d2 @@ -1056,13 +1056,13 @@ subroutine get_basic_2_to_1_derivs(i,ierr) n% d_dydt_dy(i1,i3) = n% d_dydt_dy(i1,i3) + d3 n% d_dydt_dy(i2,i3) = n% d_dydt_dy(i2,i3) + d3 n% d_dydt_dy(i3,i3) = n% d_dydt_dy(i3,i3) - d3 - + end subroutine get_basic_2_to_1_derivs subroutine Check integer :: nrates nrates = n% g% num_reactions - + do ir = 1, nrates if (.not. deriv_flgs(ir)) then all_okay = .false. @@ -1070,10 +1070,10 @@ subroutine Check trim(reaction_Name(g% reaction_id(ir))) end if end do - + end subroutine Check - - + + end subroutine get_derivs @@ -1091,7 +1091,7 @@ subroutine get1_derivs( & logical, pointer :: deriv_flgs(:) logical, intent(in) :: symbolic, just_dydt integer, intent(out) :: ierr - + integer :: ir, j, prot, neut, h1, he4, c14, n14, ne20, ne22, & mg21, mg22, mg23, mg24, al23, al24, si24, si25, si26, & s28, s29, s30, cl31, ar32, ar33, ar34, k35, ca36, ca37, ca38, & @@ -1113,15 +1113,15 @@ subroutine get1_derivs( & integer, dimension(3) :: i_in, i_out, idr real(dp), dimension(3) :: c_in, c_out, dr - + logical :: done, has_prot, has_neut, has_h1, switch_to_prot integer :: max_Z, Z_plus_N_for_max_Z integer, parameter :: min_Z_for_switch_to_prot = 12 logical, parameter :: dbg = .false. - + include 'formats' - + g => n% g reaction_id => g% reaction_id @@ -1131,8 +1131,8 @@ subroutine get1_derivs( & h1 = itab(ih1) he4 = itab(ihe4) - ir = reaction_id(i) - + ir = reaction_id(i) + if (reaction_outputs(1,ir) == 0) then n% raw_rate(i) = 0d0 n% screened_rate(i) = 0d0 @@ -1144,7 +1144,7 @@ subroutine get1_derivs( & if (dbg) & write(*,'(/,a,2i6)') ' reaction name <' // trim(reaction_Name(ir)) // '>', i, ir - + max_Z = g% reaction_max_Z(i) Z_plus_N_for_max_Z = g% reaction_max_Z_plus_N_for_max_Z(i) @@ -1158,27 +1158,27 @@ subroutine get1_derivs( & dout3 = 0d0 dout4 = 0d0 dout5 = 0d0 - + ! These rates are setup in update_special_rates select case(ir) case(ir_he4_he4_he4_to_c12) ! triple alpha - if (g% use_3a_fl87) then + if (g% use_3a_fl87) then return end if case(irn14ag_lite) ! n14 + 1.5 alpha => ne20 return - + end select num_reaction_inputs = get_num_reaction_inputs(ir) num_reaction_outputs = get_num_reaction_outputs(ir) - + if (dbg) write(*,*) 'num_reaction_inputs', num_reaction_inputs if (dbg) write(*,*) 'num_reaction_outputs', num_reaction_outputs if (dbg) write(*,*) - + switch_to_prot = .false. cout1 = 0; out1 = 0; o1 = 0 cout2 = 0; out2 = 0; o2 = 0 @@ -1198,7 +1198,7 @@ subroutine get1_derivs( & call mesa_error(__FILE__,__LINE__,'get1_derivs: itab(out1) = 0') end if end if - + if (num_reaction_outputs >= 2) then cout2 = reaction_outputs(3,ir); dout2 = cout2 out2 = reaction_outputs(4,ir) @@ -1208,7 +1208,7 @@ subroutine get1_derivs( & call mesa_error(__FILE__,__LINE__,'get1_derivs: itab(out2) = 0') end if end if - + if (num_reaction_outputs >= 3) then cout3 = reaction_outputs(5,ir); dout3 = cout3 out3 = reaction_outputs(6,ir) @@ -1218,30 +1218,30 @@ subroutine get1_derivs( & call mesa_error(__FILE__,__LINE__,'get1_derivs: itab(out3) = 0') end if end if - + if (num_reaction_outputs >= 4) then write(*,*) trim(reaction_Name(ir)) call mesa_error(__FILE__,__LINE__,'get1_derivs: num_reaction_outputs >= 4') end if - - if (num_reaction_inputs == 1) then + + if (num_reaction_inputs == 1) then cin1 = reaction_inputs(1,ir); din1 = cin1 in1 = reaction_inputs(2,ir) - i1 = itab(in1) - else if (num_reaction_inputs == 2 .or. num_reaction_inputs == 3) then + i1 = itab(in1) + else if (num_reaction_inputs == 2 .or. num_reaction_inputs == 3) then cin1 = reaction_inputs(1,ir); din1 = cin1 in1 = reaction_inputs(2,ir) - i1 = itab(in1) + i1 = itab(in1) cin2 = reaction_inputs(3,ir); din2 = cin2 in2 = reaction_inputs(4,ir) - i2 = itab(in2) + i2 = itab(in2) if (num_reaction_inputs == 3) then cin3 = reaction_inputs(5,ir); din3 = cin3 in3 = reaction_inputs(6,ir) i3 = itab(in3) end if end if - + switch_to_prot = (prot /= 0) .and. (max_Z >= min_Z_for_switch_to_prot) if (switch_to_prot) then if (i1 == h1) then @@ -1267,13 +1267,13 @@ subroutine get1_derivs( & end if if (num_reaction_inputs == 1) then - + if (i1 == 0) then write(*,*) trim(reaction_Name(ir)) write(*,2) 'num_reaction_inputs', num_reaction_inputs call mesa_error(__FILE__,__LINE__,'get1_derivs: itab(in1) = 0') end if - + if (cin1 == 1) then r = n% y(i1) idr1 = i1 @@ -1291,9 +1291,9 @@ subroutine get1_derivs( & dr1 = n% y(i1) !stop end if - + else if (num_reaction_inputs == 2 .or. num_reaction_inputs == 3) then - + if (reaction_ye_rho_exponents(2,ir) == 0) then ! treat as 1 body reaction r = n% y(i1) @@ -1310,20 +1310,20 @@ subroutine get1_derivs( & idr1 = i2 dr2 = n% y(i2) idr2 = i1 - else if (cin1 == 2 .and. cin2 == 1) then + else if (cin1 == 2 .and. cin2 == 1) then r = 0.5d0*n% y(i1)*n% y(i1)*n% y(i2) dr1 = 0.5d0*n% y(i1)*n% y(i1) idr1 = i2 dr2 = n% y(i1)*n% y(i2) idr2 = i1 - else if (cin1 == 1 .and. cin2 == 2) then + else if (cin1 == 1 .and. cin2 == 2) then ! e.g., rhe4p, r_neut_he4_he4_to_be9, r_neut_h1_h1_to_h1_h2 r = n% y(i1)*0.5d0*n% y(i2)*n% y(i2) dr1 = n% y(i1)*n% y(i2) idr1 = i2 dr2 = 0.5d0*n% y(i2)*n% y(i2) idr2 = i1 - else if (cin1 == 2 .and. cin2 == 2) then + else if (cin1 == 2 .and. cin2 == 2) then ! e.g., r_neut_neut_he4_he4_to_h3_li7, r_h1_h1_he4_he4_to_he3_be7 r = 0.5d0*n% y(i1)*n% y(i1)*0.5d0*n% y(i2)*n% y(i2) dr1 = 0.5d0*n% y(i1)*n% y(i1)*n% y(i2) @@ -1333,8 +1333,8 @@ subroutine get1_derivs( & else write(*,*) 'get1_derivs: ' // trim(reaction_Name(ir)) // ' invalid coefficient' call mesa_error(__FILE__,__LINE__,'get1_derivs') - end if - + end if + if (num_reaction_inputs == 3) then ! we assume that the 3rd kind of input is just "along for the ride" ! e.g., some compound reactions such as r34_pp2 are in this category. @@ -1358,7 +1358,7 @@ subroutine get1_derivs( & i_in(1) = i1; i_in(2) = i2; i_in(3) = i3 c_in(1) = din1; c_in(2) = din2; c_in(3) = din3 - + i_out(1) = o1; i_out(2) = o2; i_out(3) = o3 c_out(1) = dout1; c_out(2) = dout2; c_out(3) = dout3 @@ -1369,12 +1369,12 @@ subroutine get1_derivs( & ! for debugging if (num_reaction_inputs == 1) then - - if (num_reaction_outputs == 1) then + + if (num_reaction_outputs == 1) then ! reaction of form din1 in1 -> dout1 out1 if (dbg) write(*,*) ' do_one_one din1', din1, trim(chem_isos% name(g% chem_id(i1))) if (dbg) write(*,*) 'do_one_one dout1', dout1, trim(chem_isos% name(g% chem_id(o1))) - + else if (num_reaction_outputs == 2) then ! reaction of form cin1 in1 -> dout1 out1 + dout2 out2 if (dbg) write(*,*) ' do_one_two din1', din1, trim(chem_isos% name(g% chem_id(i1))) @@ -1404,15 +1404,15 @@ subroutine get1_derivs( & write(*,*) 'too many reaction_outputs for num_reaction_inputs == 1' call mesa_error(__FILE__, __LINE__) end if - + else if (num_reaction_inputs == 2) then - - if (num_reaction_outputs == 1) then + + if (num_reaction_outputs == 1) then ! reaction of form din1 in1 + din2 in2 -> dout1 out1 if (dbg) write(*,*) ' do_two_one din1', din1, trim(chem_isos% name(g% chem_id(i1))) if (dbg) write(*,*) ' do_two_one din2', din2, trim(chem_isos% name(g% chem_id(i2))) if (dbg) write(*,*) 'do_two_one dout1', dout1, trim(chem_isos% name(g% chem_id(o1))) - + if (.false. .and. reaction_Name(ir) == 'r_neut_he4_he4_to_be9' .and. r > 0 .and. & abs(n% y(i1) - 7.7763751756339478D-05) < 1d-20) then write(*,'(i3,3x,a,2x,99e20.10)') i, & @@ -1423,7 +1423,7 @@ subroutine get1_derivs( & r, dr1, dr2, n% y(i1), n% y(i2) !stop end if - + if (.false. .and. reaction_Name(ir) == 'r_he4_si28_to_o16_o16') then write(*,2) 'n% y(i1)', i1, n% y(i1) write(*,2) 'n% y(i2)', i2, n% y(i2) @@ -1448,16 +1448,16 @@ subroutine get1_derivs( & if (dbg) write(*,*) 'do_two_three dout1', dout1, trim(chem_isos% name(g% chem_id(o1))) if (dbg) write(*,*) 'do_two_three dout2', dout2, trim(chem_isos% name(g% chem_id(o2))) if (dbg) write(*,*) 'do_two_three dout3', dout3, trim(chem_isos% name(g% chem_id(o3))) - + else write(*,*) trim(reaction_Name(ir)) write(*,*) 'too many reaction_outputs for num_reaction_inputs == 2' call mesa_error(__FILE__, __LINE__) end if - + else if (num_reaction_inputs == 3) then - if (num_reaction_outputs == 1) then + if (num_reaction_outputs == 1) then ! reaction of form din1 in1 + din2 in2 + din3 in3 -> dout1 out1 if (dbg) write(*,*) ' do_three_one din1', din1, trim(chem_isos% name(g% chem_id(i1))) if (dbg) write(*,*) ' do_three_one din2', din2, trim(chem_isos% name(g% chem_id(i2))) @@ -1477,7 +1477,7 @@ subroutine get1_derivs( & write(*,*) 'too many reaction_outputs for num_reaction_inputs == 3' call mesa_error(__FILE__, __LINE__) end if - + else write(*,*) 'too many reaction_inputs' call mesa_error(__FILE__, __LINE__) @@ -1548,13 +1548,13 @@ subroutine get1_derivs( & deriv_flgs, symbolic, just_dydt) end if - + end subroutine get1_derivs subroutine eval_ni56_ec_rate( & temp, den, ye, eta, zbar, weak_rate_factor, & - rate, d_rate_dlnT, d_rate_dlnRho, Q, Qneu, ierr) + rate, d_rate_dlnT, d_rate_dlnRho, Q, Qneu, ierr) real(dp), intent(in) :: temp, den, ye, eta, zbar, weak_rate_factor real(dp), intent(out) :: rate, d_rate_dlnT, d_rate_dlnRho, Q, Qneu integer, intent(out) :: ierr @@ -1571,7 +1571,7 @@ end subroutine eval_ni56_ec_rate subroutine eval_co56_ec_rate( & temp, den, ye, eta, zbar, weak_rate_factor, & - rate, d_rate_dlnT, d_rate_dlnRho, Q, Qneu, ierr) + rate, d_rate_dlnT, d_rate_dlnRho, Q, Qneu, ierr) real(dp), intent(in) :: temp, den, ye, eta, zbar, weak_rate_factor real(dp), intent(out) :: rate, d_rate_dlnT, d_rate_dlnRho, Q, Qneu integer, intent(out) :: ierr @@ -1590,7 +1590,7 @@ subroutine eval1_weak_rate( & id, ir, temp, ye, rho, eta, zbar, weak_rate_factor, & rate_out, d_rate_dlnT, d_rate_dlnRho, Q_out, & Qneu_out, dQneu_dlnT_out, dQneu_dlnRho_out, & - ierr) + ierr) use rates_def, only: Coulomb_Info use rates_lib, only: eval_weak_reaction_info integer, intent(in) :: id, ir @@ -1599,7 +1599,7 @@ subroutine eval1_weak_rate( & rate_out, d_rate_dlnT, d_rate_dlnRho, Q_out, & Qneu_out, dQneu_dlnT_out, dQneu_dlnRho_out integer, intent(out) :: ierr - + integer :: ids(1), reaction_id_for_weak_reactions(1) type(Coulomb_Info), pointer :: cc type(Coulomb_Info), target :: cc_info @@ -1617,34 +1617,34 @@ subroutine eval1_weak_rate( & lambda, dlambda_dlnT, dlambda_dlnRho, & Q, dQ_dlnT, dQ_dlnRho, & Qneu, dQneu_dlnT, dQneu_dlnRho - + include 'formats' - + ierr = 0 if (id <= 0) then ierr = -1 return end if - + lambda => lambda_a dlambda_dlnT => dlambda_dlnT_a dlambda_dlnRho => dlambda_dlnRho_a - + Q => Q_a dQ_dlnT => dQ_dlnT_a dQ_dlnRho => dQ_dlnRho_a - + Qneu => Qneu_a dQneu_dlnT => dQneu_dlnT_a dQneu_dlnRho => dQneu_dlnRho_a - + ids(1) = id reaction_id_for_weak_reactions(1) = ir T9 = temp*1d-9 YeRho = ye*rho d_eta_dlnT = 0 d_eta_dlnRho = 0 - cc => cc_info + cc => cc_info call eval_weak_reaction_info( & 1, ids, reaction_id_for_weak_reactions, & cc, T9, YeRho, & @@ -1653,24 +1653,24 @@ subroutine eval1_weak_rate( & Q, dQ_dlnT, dQ_dlnRho, & Qneu, dQneu_dlnT, dQneu_dlnRho, & ierr) - + if (ierr /= 0) then return - + write(*,*) 'failed in eval_weak_reaction_info' call mesa_error(__FILE__,__LINE__,'eval1_weak_rate') end if - + rate_out = lambda(1)*weak_rate_factor d_rate_dlnT = dlambda_dlnT(1)*weak_rate_factor d_rate_dlnRho = dlambda_dlnRho(1)*weak_rate_factor - - Q_out = Q(1) + + Q_out = Q(1) Qneu_out = Qneu(1) dQneu_dlnT_out = dQneu_dlnT(1) dQneu_dlnRho_out = dQneu_dlnRho(1) - + end subroutine eval1_weak_rate @@ -1688,7 +1688,7 @@ subroutine update_special_rates( & logical, pointer :: deriv_flgs(:) logical, intent(in) :: symbolic, just_dydt integer, intent(out) :: ierr - + integer :: ir, j, prot, neut, h1, he4, c14, n14, ne20, ne22, & mg21, mg22, mg23, mg24, al23, al24, si24, si25, si26, & s28, s29, s30, cl31, ar32, ar33, ar34, k35, ca36, ca37, ca38, & @@ -1710,15 +1710,15 @@ subroutine update_special_rates( & integer, dimension(3) :: i_in, i_out, idr real(dp), dimension(3) :: c_in, c_out, dr - + logical :: done, has_prot, has_neut, has_h1, switch_to_prot integer :: max_Z, Z_plus_N_for_max_Z integer, parameter :: min_Z_for_switch_to_prot = 12 logical, parameter :: dbg = .false. - + include 'formats' - + g => n% g reaction_id => g% reaction_id @@ -1728,13 +1728,13 @@ subroutine update_special_rates( & h1 = itab(ih1) he4 = itab(ihe4) - ir = reaction_id(i) - + ir = reaction_id(i) + if (reaction_outputs(1,ir) == 0) return ! skip aux reactions - + if (dbg) & write(*,'(/,a,2i6)') ' reaction name <' // trim(reaction_Name(ir)) // '>', i, ir - + max_Z = g% reaction_max_Z(i) Z_plus_N_for_max_Z = g% reaction_max_Z_plus_N_for_max_Z(i) @@ -1751,9 +1751,9 @@ subroutine update_special_rates( & select case(ir) - + case(ir_he4_he4_he4_to_c12) ! triple alpha - if (g% use_3a_fl87) then + if (g% use_3a_fl87) then call do_FL_3alf(i) ! Fushiki and Lamb, Apj, 317, 368-388, 1987 return end if @@ -1783,9 +1783,9 @@ subroutine update_special_rates( & deriv_flgs, symbolic, just_dydt) return - + end select - + contains @@ -1815,7 +1815,7 @@ subroutine do_FL_3alf(i) ! Fushiki and Lamb, Apj, 317, 368-388, 1987 dr1 = 0.5d0*YHe4*YHe4 n% rate_screened(i) = FLeps_nuc/r*rate_factors(i)/conv n% rate_screened_dT(i) = dFLeps_nuc_dT/r*rate_factors(i)/conv - n% rate_screened_dRho(i) = dFLeps_nuc_dRho/r*rate_factors(i)/conv + n% rate_screened_dRho(i) = dFLeps_nuc_dRho/r*rate_factors(i)/conv end if i_in(1) = he4; i_in(2) = 0; i_in(3) = 0 @@ -1835,7 +1835,7 @@ subroutine do_FL_3alf(i) ! Fushiki and Lamb, Apj, 317, 368-388, 1987 end subroutine do_FL_3alf - + end subroutine update_special_rates end module net_derivs diff --git a/net/private/net_derivs_support.f90 b/net/private/net_derivs_support.f90 index 7d053851b..db1bde1a5 100644 --- a/net/private/net_derivs_support.f90 +++ b/net/private/net_derivs_support.f90 @@ -206,7 +206,7 @@ subroutine do_in_out_neu( & if(idr(1)>0) n% d_eps_nuc_dy(idr(1)) = n% d_eps_nuc_dy(idr(1)) + d1*(Q-Qneu) if(idr(2)>0) n% d_eps_nuc_dy(idr(2)) = n% d_eps_nuc_dy(idr(2)) + d2*(Q-Qneu) if(idr(3)>0) n% d_eps_nuc_dy(idr(3)) = n% d_eps_nuc_dy(idr(3)) + d3*(Q-Qneu) - + ! for debugging if(idr(1)>0) then condition = chem_id(idr(1)) == ic12 @@ -215,7 +215,7 @@ subroutine do_in_out_neu( & d, dr(1), d1, Q, d1*Q, n% d_eps_nuc_dy(idr(1)), n% reaction_Qs(reaction_id), & n% reaction_neuQs(reaction_id) end if - + if(idr(2)>0) then condition = chem_id(idr(2)) == ic12 if (show_d_eps_nuc_dy .and. d2 > 0 .and. condition) & @@ -223,7 +223,7 @@ subroutine do_in_out_neu( & d, dr(2), d2, Q, d2*Q, n% d_eps_nuc_dy(idr(2)), n% reaction_Qs(reaction_id), & n% reaction_neuQs(reaction_id) end if - + if(idr(3)>0) then condition = chem_id(idr(3)) == ic12 if (show_d_eps_nuc_dy .and. d3 > 0 .and. condition) & diff --git a/net/private/net_eval.f90 b/net/private/net_eval.f90 index 7bd21bda7..d0c020a66 100644 --- a/net/private/net_eval.f90 +++ b/net/private/net_eval.f90 @@ -24,19 +24,19 @@ ! *********************************************************************** module net_eval - + use const_def use math_lib use chem_def use chem_lib, only: get_mass_excess use net_def, only: Net_General_Info, Net_Info use utils_lib, only: fill_with_NaNs - + implicit none - - + + contains - + subroutine eval_net( & n, g, rates_only, just_dxdt, & @@ -71,16 +71,16 @@ subroutine eval_net( & real(dp), intent(in) :: abar ! mean number of nucleons per nucleus real(dp), intent(in) :: zbar ! mean charge per nucleus real(dp), intent(in) :: z2bar ! mean charge squared per nucleus - real(dp), intent(in) :: ye + real(dp), intent(in) :: ye real(dp), intent(in) :: eta, d_eta_dlnT, d_eta_dlnRho ! eta and derivatives real(dp), intent(in) :: rate_factors(:) real(dp), intent(in) :: weak_rate_factor real(dp), pointer, intent(in) :: reaction_Qs(:) ! (rates_reaction_id_max) real(dp), pointer, intent(in) :: reaction_neuQs(:) ! (rates_reaction_id_max) - real(dp), intent(out) :: eps_nuc ! ergs/gram/second from burning + real(dp), intent(out) :: eps_nuc ! ergs/gram/second from burning real(dp), intent(out) :: d_eps_nuc_dT real(dp), intent(out) :: d_eps_nuc_dRho - real(dp), intent(inout) :: d_eps_nuc_dx(:) + real(dp), intent(inout) :: d_eps_nuc_dx(:) real(dp), intent(inout) :: dxdt(:) real(dp), intent(inout) :: d_dxdt_dRho(:) real(dp), intent(inout) :: d_dxdt_dT(:) @@ -100,14 +100,14 @@ subroutine eval_net( & integer :: ci, i, j, ir, weak_id, h1, iwork integer(8) :: time0, time1 logical :: doing_timing - + logical, parameter :: dbg = .false. !logical, parameter :: dbg = .true. - + include 'formats' if (dbg) write(*,*) 'enter eval_net' - + doing_timing = g% doing_timing if (doing_timing) then call system_clock(time0) @@ -131,7 +131,7 @@ subroutine eval_net( & n% g => g if (dbg) write(*,*) 'call setup_net_info' - call setup_net_info(n) + call setup_net_info(n) n% reaction_Qs => reaction_Qs n% reaction_neuQs => reaction_neuQs @@ -157,18 +157,18 @@ subroutine eval_net( & end if T9 = n% temp*1d-9 - + if (g% doing_approx21) then call set_ptrs_for_approx21(n) end if - + if (dbg) write(*,*) 'call set_molar_abundances' call set_molar_abundances(n, dbg, ierr) if (ierr /= 0) then if (dbg) write(*,*) 'failed in set_molar_abundances' return end if - + if (num_wk_reactions > 0) then if (dbg) write(*,*) 'call get_weaklib_rates' call get_weaklib_rates(n, ierr) @@ -177,7 +177,7 @@ subroutine eval_net( & return end if end if - + if (associated(actual_Qs) .and. associated(actual_neuQs)) then do i = 1, g% num_reactions ir = g% reaction_id(i) @@ -208,13 +208,13 @@ subroutine eval_net( & if (dbg) write(*,*) 'failed in get_rates_with_screening' return end if - + if (rates_only) return ! n% d_eps_nuc_dT = 0 ! n% d_eps_nuc_dRho = 0 ! n% d_eps_nuc_dx(:) = 0 - + ! n% dxdt(:) = 0 ! n% d_dxdt_dRho(:) = 0 ! n% d_dxdt_dT(:) = 0 @@ -225,9 +225,9 @@ subroutine eval_net( & if (g% doing_approx21) then call eval_net_approx21_procs(n, just_dxdt, ierr) - if (ierr /= 0) return + if (ierr /= 0) return - if (net_test_partials) then + if (net_test_partials) then net_test_partials_val = eps_nuc net_test_partials_dval_dx = d_eps_nuc_dx(net_test_partials_i) if (g% add_co56_to_approx21) then @@ -242,9 +242,9 @@ subroutine eval_net( & dxdt, d_dxdt_dT, d_dxdt_dRho, d_dxdt_dx, & eps_nuc_categories) - return - end if ! End of approx21 - + return + end if ! End of approx21 + if (dbg) write(*,*) 'call get_derivs' call get_derivs( & n, n% dydt, eps_nuc_MeV(1:num_rvs), n% eta, n% ye, & @@ -255,7 +255,7 @@ subroutine eval_net( & if (dbg) write(*,*) 'failed in get_derivs' return end if - + if (symbolic) then do j=1, num_isos do i=1, num_isos @@ -264,7 +264,7 @@ subroutine eval_net( & end do return end if - + if (doing_timing) then call system_clock(time1) g% clock_net_derivs = g% clock_net_derivs + (time1 - time0) @@ -281,12 +281,12 @@ subroutine eval_net( & ci = g% chem_id(i) n% dxdt(i) = chem_isos% Z_plus_N(ci) * n% dydt(i_rate, i) end do - + if (.not. just_dxdt) call store_partials(n) - - n% eps_nuc = eps_nuc_MeV(i_rate)*Qconv - n% d_eps_nuc_dT = eps_nuc_MeV(i_rate_dT)*Qconv - n% d_eps_nuc_dRho = eps_nuc_MeV(i_rate_dRho)*Qconv + + n% eps_nuc = eps_nuc_MeV(i_rate)*Qconv + n% d_eps_nuc_dT = eps_nuc_MeV(i_rate_dT)*Qconv + n% d_eps_nuc_dRho = eps_nuc_MeV(i_rate_dRho)*Qconv n% eps_neu_total = n% eps_neu_total * Qconv @@ -295,14 +295,14 @@ subroutine eval_net( & g% clock_net_eval = g% clock_net_eval + (time1 - time0) g% doing_timing = .true. end if - - if (net_test_partials) then + + if (net_test_partials) then !net_test_partials_val = eps_nuc !net_test_partials_dval_dx = d_eps_nuc_dx(net_test_partials_i) net_test_partials_val = & n% rate_screened(g% net_reaction(irn14_to_c12))/ & n% rate_raw(g% net_reaction(irn14_to_c12)) - net_test_partials_dval_dx = 0d0 + net_test_partials_dval_dx = 0d0 write(*,*) 'net_test_partials' end if @@ -310,7 +310,7 @@ subroutine eval_net( & eps_neu_total, & dxdt, d_dxdt_dT, d_dxdt_dRho, d_dxdt_dx,& eps_nuc_categories) - + end subroutine eval_net subroutine unpack_for_export(n, eps_nuc, d_eps_nuc_dT, d_eps_nuc_dRho, d_eps_nuc_dx, & @@ -318,10 +318,10 @@ subroutine unpack_for_export(n, eps_nuc, d_eps_nuc_dT, d_eps_nuc_dRho, d_eps_nuc dxdt, d_dxdt_dT, d_dxdt_dRho, d_dxdt_dx,& eps_nuc_categories) type(net_info) :: n - real(dp), intent(out) :: eps_nuc ! ergs/gram/second from burning + real(dp), intent(out) :: eps_nuc ! ergs/gram/second from burning real(dp), intent(out) :: d_eps_nuc_dT real(dp), intent(out) :: d_eps_nuc_dRho - real(dp), intent(out) :: d_eps_nuc_dx(:) + real(dp), intent(out) :: d_eps_nuc_dx(:) real(dp), intent(out) :: dxdt(:) real(dp), intent(out) :: d_dxdt_dRho(:) real(dp), intent(out) :: d_dxdt_dT(:) @@ -362,29 +362,29 @@ subroutine eval_net_approx21_procs(n,just_dxdt, ierr) g => n% g num_isos = g% num_isos - + call approx21_special_reactions( & n% temp, n% rho, n% abar, n% zbar, n% y, & g% use_3a_fl87, Qconv * n% reaction_Qs(ir_he4_he4_he4_to_c12), & n% rate_screened, n% rate_screened_dT, n% rate_screened_dRho, & n% dratdumdy1, n% dratdumdy2, g% add_co56_to_approx21, ierr) - if (ierr /= 0) return - + if (ierr /= 0) return + call approx21_dydt( & n% y, n% rate_screened, n% rate_screened, & n% dydt1, .false., g% fe56ec_fake_factor, g% min_T_for_fe56ec_fake_factor, & g% fe56ec_n_neut, n% temp, n% rho, g% add_co56_to_approx21, ierr) if (ierr /= 0) return - + n% fII = approx21_eval_PPII_fraction(n% y, n% rate_screened) - + call get_approx21_eps_info( n, & n% dydt1, n% rate_screened, .true., n% eps_total, n% eps_neu_total, & g% add_co56_to_approx21, ierr) - - if (ierr /= 0) return + + if (ierr /= 0) return n% eps_nuc = n% eps_total - n% eps_neu_total - + do i=1, num_isos n% dxdt(i) = chem_isos% Z_plus_N(g% chem_id(i)) * n% dydt1(i) end do @@ -398,10 +398,10 @@ subroutine eval_net_approx21_procs(n,just_dxdt, ierr) n% dratdumdy1, n% dratdumdy2, n% temp, g% add_co56_to_approx21, ierr) if (ierr /= 0) return - call approx21_dfdT_dfdRho( & - + call approx21_dfdT_dfdRho( & + ! NOTE: currently this gives d_eps_total_dy -- should fix to account for neutrinos too - + n% y, g% mion, n% dfdy, n% rate_screened, n% rate_screened_dT, n% rate_screened_dRho, & g% fe56ec_fake_factor, g% min_T_for_fe56ec_fake_factor, & g% fe56ec_n_neut, n% temp, n% rho, n% dfdT, n% dfdRho, n% d_epsnuc_dy, g% add_co56_to_approx21, ierr) @@ -413,22 +413,22 @@ subroutine eval_net_approx21_procs(n,just_dxdt, ierr) if (ierr /= 0) return n% d_eps_nuc_dT = n% deps_total_dT - n% deps_neu_dT - + call get_approx21_eps_info( n, & n% dfdRho, n% rate_screened_dRho, .false., n% deps_total_dRho, n% deps_neu_dRho, & g% add_co56_to_approx21, ierr) - if (ierr /= 0) return + if (ierr /= 0) return n% d_eps_nuc_dRho = n% deps_total_dRho - n% deps_neu_dRho - + call approx21_d_epsneu_dy( & n% y, n% rate_screened, & - n% reaction_neuQs(irpp_to_he3), & - n% reaction_neuQs(ir34_pp2), & - n% reaction_neuQs(ir34_pp3), & - n% reaction_neuQs(irc12_to_n14), & - n% reaction_neuQs(irn14_to_c12), & - n% reaction_neuQs(iro16_to_n14), & + n% reaction_neuQs(irpp_to_he3), & + n% reaction_neuQs(ir34_pp2), & + n% reaction_neuQs(ir34_pp3), & + n% reaction_neuQs(irc12_to_n14), & + n% reaction_neuQs(irn14_to_c12), & + n% reaction_neuQs(iro16_to_n14), & n% d_epsneu_dy, & g% add_co56_to_approx21, ierr) if (ierr /= 0) return @@ -436,7 +436,7 @@ subroutine eval_net_approx21_procs(n,just_dxdt, ierr) do i=1, n% g%num_isos ci = g% chem_id(i) Z_plus_N = dble(chem_isos% Z_plus_N(ci)) - n% d_eps_nuc_dx(i) = (n% d_epsnuc_dy(i) - n% d_epsneu_dy(i))/Z_plus_N + n% d_eps_nuc_dx(i) = (n% d_epsnuc_dy(i) - n% d_epsneu_dy(i))/Z_plus_N n% d_dxdt_dRho(i) = Z_plus_N * n% dfdRho(i) n% d_dxdt_dT(i) = Z_plus_N * n% dfdT(i) do j=1, num_isos @@ -460,31 +460,31 @@ subroutine get_approx21_eps_info(n, & logical, intent(in) :: plus_co56 integer, intent(out) :: ierr real(dp) :: Qtotal_rfe56ec, Qneu_rfe56ec - + g => n% g ! Indexes into reaction_Qs and reaction_neuQs should be in terms of the ! normal rate ids not the approx21 rate ids (in net_approx21.f90) - + call get_Qs_rfe56ec(n, Qtotal_rfe56ec, Qneu_rfe56ec) call approx21_eps_info( & - n, n% y, g% mion, dydt1, rate_screened, n% fII, & - n% reaction_Qs(irpp_to_he3), n% reaction_neuQs(irpp_to_he3), & + n, n% y, g% mion, dydt1, rate_screened, n% fII, & + n% reaction_Qs(irpp_to_he3), n% reaction_neuQs(irpp_to_he3), & n% reaction_Qs(ir_he3_he3_to_h1_h1_he4), & - n% reaction_Qs(ir34_pp2), n% reaction_neuQs(ir34_pp2), & - n% reaction_Qs(ir34_pp3), n% reaction_neuQs(ir34_pp3), & - n% reaction_Qs(irc12_to_n14), n% reaction_neuQs(irc12_to_n14), & - n% reaction_Qs(irn14_to_c12), n% reaction_neuQs(irn14_to_c12), & - n% reaction_Qs(iro16_to_n14), n% reaction_neuQs(iro16_to_n14), & + n% reaction_Qs(ir34_pp2), n% reaction_neuQs(ir34_pp2), & + n% reaction_Qs(ir34_pp3), n% reaction_neuQs(ir34_pp3), & + n% reaction_Qs(irc12_to_n14), n% reaction_neuQs(irc12_to_n14), & + n% reaction_Qs(irn14_to_c12), n% reaction_neuQs(irn14_to_c12), & + n% reaction_Qs(iro16_to_n14), n% reaction_neuQs(iro16_to_n14), & n% reaction_Qs(irn14_to_o16), & - - n% reaction_Qs(irprot_to_neut), n% reaction_neuQs(irprot_to_neut), & - n% reaction_Qs(irneut_to_prot), n% reaction_neuQs(irneut_to_prot), & - n% reaction_Qs(irni56ec_to_co56), n% reaction_neuQs(irni56ec_to_co56), & - n% reaction_Qs(irco56ec_to_fe56), n% reaction_neuQs(irco56ec_to_fe56), & + + n% reaction_Qs(irprot_to_neut), n% reaction_neuQs(irprot_to_neut), & + n% reaction_Qs(irneut_to_prot), n% reaction_neuQs(irneut_to_prot), & + n% reaction_Qs(irni56ec_to_co56), n% reaction_neuQs(irni56ec_to_co56), & + n% reaction_Qs(irco56ec_to_fe56), n% reaction_neuQs(irco56ec_to_fe56), & Qtotal_rfe56ec, Qneu_rfe56ec, & - + n% reaction_Qs(irn14ag_lite), & n% reaction_Qs(ir_he4_he4_he4_to_c12), & n% reaction_Qs(ir_c12_ag_o16), n% reaction_Qs(ir_o16_ag_ne20), & @@ -499,17 +499,17 @@ subroutine get_approx21_eps_info(n, & n% reaction_Qs(ir_ca40_ag_ti44), & n% reaction_Qs(ir_ti44_ag_cr48), & n% reaction_Qs(ir_cr48_ag_fe52), & - n% reaction_Qs(ir_fe52_ag_ni56), & - n% reaction_Qs(ir_fe52_ng_fe53), & - n% reaction_Qs(ir_fe53_ng_fe54), & - n% reaction_Qs(ir_fe54_ng_fe55), & - n% reaction_Qs(ir_fe55_ng_fe56), & - n% reaction_Qs(irfe52neut_to_fe54), & - n% reaction_Qs(irfe52aprot_to_fe54), & - n% reaction_Qs(irfe54ng_to_fe56), & - n% reaction_Qs(irfe54aprot_to_fe56), & - n% reaction_Qs(irfe52aprot_to_ni56), & - n% reaction_Qs(irfe54prot_to_ni56), & + n% reaction_Qs(ir_fe52_ag_ni56), & + n% reaction_Qs(ir_fe52_ng_fe53), & + n% reaction_Qs(ir_fe53_ng_fe54), & + n% reaction_Qs(ir_fe54_ng_fe55), & + n% reaction_Qs(ir_fe55_ng_fe56), & + n% reaction_Qs(irfe52neut_to_fe54), & + n% reaction_Qs(irfe52aprot_to_fe54), & + n% reaction_Qs(irfe54ng_to_fe56), & + n% reaction_Qs(irfe54aprot_to_fe56), & + n% reaction_Qs(irfe52aprot_to_ni56), & + n% reaction_Qs(irfe54prot_to_ni56), & n% reaction_Qs(irhe4_breakup), & n% reaction_Qs(irhe4_rebuild), & eps_total, eps_neu_total, & ! Dont use n% here as we call this for both eps_neu and eps_neu_dt and drho @@ -517,7 +517,7 @@ subroutine get_approx21_eps_info(n, & .false., plus_co56, ierr) end subroutine get_approx21_eps_info - + subroutine get_Qs_rfe56ec(n, Qtotal, Qneu) use chem_def use rates_def @@ -558,7 +558,7 @@ subroutine get_Qs_rfe56ec(n, Qtotal, Qneu) Qtotal = n% reaction_Qs(ir) Qneu = n% reaction_neuQs(ir) end subroutine get_Qs_rfe56ec - + subroutine store_partials(n) use rates_def, only: i_rate, i_rate_dT, i_rate_dRho type(net_info) :: n @@ -579,9 +579,9 @@ subroutine store_partials(n) n% d_dydt_dy(i,j)*Z_plus_N/chem_isos% Z_plus_N(g% chem_id(j)) end do end do - + end subroutine store_partials - + subroutine get_rates_with_screening(n, ierr) use rates_def, only: reaction_inputs, nrattab use rates_lib, only: eval_using_rate_tables @@ -590,16 +590,16 @@ subroutine get_rates_with_screening(n, ierr) type(net_info) :: n type(net_general_info),pointer :: g=> null() - + integer, intent(out) :: ierr logical, parameter :: dbg=.false. integer(8) :: time0, time1 - + integer :: i, num, num_reactions real(dp) :: f logical :: okay - + include 'formats' g => n% g @@ -611,24 +611,24 @@ subroutine get_rates_with_screening(n, ierr) call mesa_error(__FILE__,__LINE__,'get_rates_with_screening') end if end do - + if (dbg) write(*,*) 'call eval_using_rate_tables' call eval_using_rate_tables( & g% num_reactions, g% reaction_id, g% rate_table, g% rattab_f1, nrattab, & n% ye, n% logT, n% temp, n% rho, n% rate_factors, g% logttab, & - n% rate_raw, n% rate_raw_dT, n% rate_raw_dRho, ierr) + n% rate_raw, n% rate_raw_dT, n% rate_raw_dRho, ierr) if (ierr /= 0) then if (dbg) write(*,*) 'ierr from eval_using_rate_tables' return end if - + if (g% doing_timing) then call system_clock(time0) end if if (g% doing_approx21) then call approx21_rates(n, g% add_co56_to_approx21,ierr) - if (ierr /= 0) return + if (ierr /= 0) return end if ! get the reaction rates including screening factors @@ -651,16 +651,16 @@ subroutine get_rates_with_screening(n, ierr) do i=1,num n% dratdumdy1(i) = 0d0 n% dratdumdy2(i) = 0d0 - end do + end do end if - + if (g% doing_timing) then call system_clock(time1) g% clock_net_screen = g% clock_net_screen + (time1 - time0) end if - - end subroutine get_rates_with_screening + + end subroutine get_rates_with_screening subroutine approx21_rates(n, plus_co56, ierr) use net_approx21, only: & @@ -671,12 +671,12 @@ subroutine approx21_rates(n, plus_co56, ierr) ierr = 0 call approx21_pa_pg_fractions( & n% rate_raw, n% rate_raw_dT, n% rate_raw_dRho, ierr) - if (ierr /= 0) return + if (ierr /= 0) return call approx21_weak_rates( & n% y, n% rate_raw, n% rate_raw_dT, n% rate_raw_dRho, & n% temp, n% rho, n% ye, n% eta, n% zbar, & n% weak_rate_factor, plus_co56, ierr) - if (ierr /= 0) return + if (ierr /= 0) return end subroutine approx21_rates @@ -713,7 +713,7 @@ subroutine get_weaklib_rates(n, ierr) end if call coulomb_set_context(cc, n% temp, n% rho, n% logT, n% logRho, n% zbar, n% abar, n% z2bar) - + call eval_weak_reaction_info( & g% num_wk_reactions, & g% weaklib_ids(1:g% num_wk_reactions), & @@ -729,16 +729,16 @@ subroutine get_weaklib_rates(n, ierr) n% dlambda_dlnT(i) = n% weak_rate_factor*n% dlambda_dlnT(i) n% dlambda_dlnRho(i) = n% weak_rate_factor*n% dlambda_dlnRho(i) end do - end if + end if if (g% doing_timing) then call system_clock(time1) g% clock_net_weak_rates = g% clock_net_weak_rates + (time1 - time0) - end if - + end if + end subroutine get_weaklib_rates - - - + + + subroutine get_T_limit_factor( & temp, lnT, T_lo, T_hi, lnT_lo, lnT_hi, & min_ln_factor, min_factor, & @@ -762,13 +762,13 @@ subroutine get_T_limit_factor( & d_factor_dT = d_ln_factor_dlnT*factor/temp end subroutine get_T_limit_factor - + subroutine set_molar_abundances(n, dbg, ierr) type (net_info) :: n type(net_general_info), pointer :: g logical, intent(in) :: dbg integer, intent(out) :: ierr - + real(dp) :: sum integer :: i, ci character (len=256) :: message @@ -783,18 +783,18 @@ subroutine set_molar_abundances(n, dbg, ierr) write(*,*) 'i', i write(*,*) 'g% num_isos', g% num_isos write(*,*) 'g% chem_id(i)', g% chem_id(i) - call mesa_error(__FILE__,__LINE__,'set_molar_abundances') + call mesa_error(__FILE__,__LINE__,'set_molar_abundances') end if n% y(i) = min(1d0, max(n% x(i), 0d0)) / chem_isos% Z_plus_N(ci) enddo - - - + + + return ! let it go even with bad xsum. - - - - + + + + if (abs(sum - 1d0) > 1d-2) then ierr = -1 if (dbg) then @@ -806,7 +806,7 @@ subroutine set_molar_abundances(n, dbg, ierr) end if return end if - + end subroutine set_molar_abundances subroutine do_clean_up_fractions(nzlo, nzhi, species, nz, xa, max_sum_abs, xsum_tol, ierr) @@ -819,7 +819,7 @@ subroutine do_clean_up_fractions(nzlo, nzhi, species, nz, xa, max_sum_abs, xsum_ if (nzlo == nzhi) then call do_clean1(species, xa(1: species, nzlo), nzlo, max_sum_abs, xsum_tol, ierr) return - end if + end if !x$OMP PARALLEL DO PRIVATE(k, op_err) do k = nzlo, nzhi op_err = 0 @@ -828,7 +828,7 @@ subroutine do_clean_up_fractions(nzlo, nzhi, species, nz, xa, max_sum_abs, xsum_ end do !x$OMP END PARALLEL DO end subroutine do_clean_up_fractions - + subroutine do_clean1(species, xa, k, max_sum_abs, xsum_tol, ierr) use utils_lib @@ -851,15 +851,15 @@ subroutine do_clean1(species, xa, k, max_sum_abs, xsum_tol, ierr) do j = 1, species if (xa(j) < tiny_x) xa(j) = tiny_x if (xa(j) > 1) xa(j) = 1 - end do - xsum = sum(xa(1: species)) + end do + xsum = sum(xa(1: species)) if (abs(xsum-1) > xsum_tol) then ierr = -1 return end if xa(1: species) = xa(1: species)/xsum end subroutine do_clean1 - + end module net_eval diff --git a/net/private/net_initialize.f90 b/net/private/net_initialize.f90 index f5e7d8c4a..d495a5bc2 100644 --- a/net/private/net_initialize.f90 +++ b/net/private/net_initialize.f90 @@ -31,7 +31,7 @@ module net_initialize use net_approx21, only : num_reactions_func => num_reactions, & num_mesa_reactions_func => num_mesa_reactions - + implicit none integer, parameter :: max_num_special_case_reactants = 5 @@ -49,7 +49,7 @@ subroutine set_ptrs_for_approx21(n) use utils_lib, only: fill_with_NaNs, fill_with_NaNs_2D type(net_info) :: n - + integer :: num_isos, num_reactions num_reactions = num_reactions_func(n% g% add_co56_to_approx21) @@ -58,7 +58,7 @@ subroutine set_ptrs_for_approx21(n) else num_isos = 21 end if - + if(.not.allocated(n% dfdy)) allocate(n% dfdy(num_isos,num_isos)) if(.not.allocated(n% dratdumdy1)) allocate(n% dratdumdy1(num_reactions)) if(.not.allocated(n% dratdumdy2)) allocate(n% dratdumdy2(num_reactions)) @@ -79,17 +79,17 @@ subroutine set_ptrs_for_approx21(n) call fill_with_NaNs(n% dfdt) call fill_with_NaNs(n% dfdRho) end if - + end subroutine set_ptrs_for_approx21 - + subroutine setup_net_info(n) use chem_def use utils_lib, only: fill_with_NaNs, fill_with_NaNs_2D type (Net_Info) :: n - + integer :: num_reactions, num_isos, num_wk_reactions - + num_isos = n% g% num_isos num_wk_reactions = n% g% num_wk_reactions if (n% g% doing_approx21) then @@ -97,13 +97,13 @@ subroutine setup_net_info(n) else num_reactions = n% g% num_reactions end if - + if(.not.allocated(n% eps_nuc_categories)) allocate(n% eps_nuc_categories(num_categories)) - + if(.not.allocated(n% rate_screened)) allocate(n% rate_screened(num_reactions)) if(.not.allocated(n% rate_screened_dT)) allocate(n% rate_screened_dT(num_reactions)) if(.not.allocated(n% rate_screened_dRho)) allocate(n% rate_screened_dRho(num_reactions)) - + if(.not.allocated(n% rate_raw)) allocate(n% rate_raw(num_reactions)) if(.not.allocated(n% rate_raw_dT)) allocate(n% rate_raw_dT(num_reactions)) if(.not.allocated(n% rate_raw_dRho)) allocate(n% rate_raw_dRho(num_reactions)) @@ -119,7 +119,7 @@ subroutine setup_net_info(n) if(.not.allocated(n% d_dxdt_dT)) allocate(n% d_dxdt_dT(num_isos)) if(.not.allocated(n% dydt)) allocate(n% dydt(num_rvs, num_isos)) if(.not.allocated(n% d_dxdt_dx)) allocate(n% d_dxdt_dx(num_isos, num_isos)) - + if(.not.allocated(n% d_eps_nuc_dy)) allocate(n% d_eps_nuc_dy(num_isos)) if(.not.allocated(n% d_dydt_dy)) allocate(n% d_dydt_dy(num_isos,num_isos)) @@ -175,24 +175,24 @@ subroutine setup_net_info(n) end subroutine setup_net_info - + subroutine alloc_net_general_info(handle, cache_suffix, ierr) use rates_def, only: extended_screening use rates_lib, only: make_rate_tables use chem_def, only: chem_isos - + integer, intent(in) :: handle character (len=*), intent(in) :: cache_suffix integer, intent(out) :: ierr - + type (Net_Info) :: n integer :: ios, status, lwork, num_reactions, & num_isos, num_wk_reactions, i, iwork type (Net_General_Info), pointer :: g - + include 'formats' - + ierr = 0 call get_net_ptr(handle, g, ierr) @@ -202,15 +202,15 @@ subroutine alloc_net_general_info(handle, cache_suffix, ierr) n% reaction_Qs => std_reaction_Qs n% reaction_neuQs => std_reaction_neuQs - + num_reactions = g% num_reactions num_isos = g% num_isos num_wk_reactions = g% num_wk_reactions - call setup_net_info(n) - - g% cache_suffix = trim(cache_suffix) - + call setup_net_info(n) + + g% cache_suffix = trim(cache_suffix) + call make_rate_tables( & g% num_reactions, g% cache_suffix, g% reaction_id, & g% rate_table, g% rattab_f1, nrattab, g% ttab, g% logttab, ierr) @@ -218,17 +218,17 @@ subroutine alloc_net_general_info(handle, cache_suffix, ierr) write(*,*) 'alloc_net_general_info failed in call on make_rate_tables' return end if - + call make_screening_tables(n, ierr) if (ierr /= 0) then write(*,*) 'alloc_net_general_info failed in make_screening_tables' return end if - - + + end subroutine alloc_net_general_info - - + + subroutine set_reaction_max_Z(g) type (Net_General_Info), pointer :: g integer :: i, ir, max_Z, max_Z_plus_N @@ -247,9 +247,9 @@ subroutine set_reaction_max_Z(g) g% reaction_max_Z_plus_N_for_max_Z(i) = max_Z_plus_N !write(*,3) trim(reaction_name(ir)), max_Z, max_Z_plus_N end do - + contains - + subroutine update_max_Z(iso) use chem_def, only: chem_isos integer, intent(in) :: iso @@ -264,11 +264,11 @@ subroutine update_max_Z(iso) else if (Z_plus_N > max_Z_plus_N) then max_Z_plus_N = Z_plus_N end if - end subroutine update_max_Z - - end subroutine set_reaction_max_Z - - + end subroutine update_max_Z + + end subroutine set_reaction_max_Z + + recursive subroutine do_read_net_file(net_filename, handle, ierr) use utils_def use utils_lib @@ -277,18 +277,18 @@ recursive subroutine do_read_net_file(net_filename, handle, ierr) character (len=*), intent(in) :: net_filename integer, intent(in) :: handle integer, intent(out) :: ierr - + integer :: iounit, n, i, j, k, t, id, h1, he4, neut character (len=256) :: buffer, string, filename logical, parameter :: dbg = .false. type (Net_General_Info), pointer :: g - + ierr = 0 call get_net_ptr(handle, g, ierr) if (ierr /= 0) return - + if (len_trim(g% net_filename) == 0) g% net_filename = trim(net_filename) - + ! first look in local directory filename = trim(net_filename) open(newunit=iounit, file=trim(filename), action='read', status='old', iostat=ierr) @@ -296,7 +296,7 @@ recursive subroutine do_read_net_file(net_filename, handle, ierr) filename = 'nets/' // trim(net_filename) ierr = 0 open(newunit=iounit, file=trim(filename), action='read', status='old', iostat=ierr) - if (ierr /= 0) then ! look in global nets directory + if (ierr /= 0) then ! look in global nets directory filename = trim(net_dir) // '/nets/' // trim(net_filename) ierr = 0 open(newunit=iounit, file=trim(filename), action='read', status='old', iostat=ierr) @@ -306,7 +306,7 @@ recursive subroutine do_read_net_file(net_filename, handle, ierr) end if end if end if - + if (dbg) then write(*,'(A)') write(*,*) 'read_net_file <' // trim(filename) // '>' @@ -316,61 +316,61 @@ recursive subroutine do_read_net_file(net_filename, handle, ierr) n = 0 i = 0 - + do t = token(iounit, n, i, buffer, string) select case(t) case(name_token) select case(string) - + case ('add_isos') call do_isos(.true., ierr) if (ierr /= 0) return - + case ('add_iso') call do_isos(.true., ierr) if (ierr /= 0) return - + case ('remove_isos') call do_isos(.false., ierr) if (ierr /= 0) return - + case ('remove_iso') call do_isos(.false., ierr) if (ierr /= 0) return - + case ('add_reaction') call do_reactions(.true., ierr) if (ierr /= 0) return - + case ('add_reactions') call do_reactions(.true., ierr) if (ierr /= 0) return - + case ('remove_reaction') call do_reactions(.false., ierr) if (ierr /= 0) return - + case ('remove_reactions') call do_reactions(.false., ierr) if (ierr /= 0) return - + case ('add_iso_and_reactions') call do_basic_reactions_for_isos(ierr) if (ierr /= 0) return - + case ('add_isos_and_reactions') call do_basic_reactions_for_isos(ierr) if (ierr /= 0) return - + case ('approx21') call do_approx21(1,ierr) if (ierr /= 0) return - + case ('approx21_plus_co56') call do_approx21(2,ierr) if (ierr /= 0) return - + case ('include') t = token(iounit, n, i, buffer, string) if (t /= string_token) then @@ -378,19 +378,19 @@ recursive subroutine do_read_net_file(net_filename, handle, ierr) end if call do_read_net_file(string, handle, ierr) if (ierr /= 0) return - + case default call error; return - + end select case(eof_token) exit case default call error; return end select - + end do - + close(iounit) @@ -404,7 +404,7 @@ recursive subroutine do_read_net_file(net_filename, handle, ierr) k = chem_get_iso_id('al26-2') ! if (dbg) write(6,*) k, trim(chem_isos% name(k)), g% net_iso(k) - if ( (g% net_iso(i) == 1 .and. g% net_iso(j) == 1) .or. & + if ( (g% net_iso(i) == 1 .and. g% net_iso(j) == 1) .or. & (g% net_iso(i) == 1 .and. g% net_iso(k) == 1)) then string = 'cannot specify al26 and al26-1 or al26-2' call error ; return @@ -421,17 +421,17 @@ recursive subroutine do_read_net_file(net_filename, handle, ierr) end if ! done with network veracity checks - + if (dbg) then write(*,'(A)') write(*,*) 'done read_net_file ' // trim(filename) write(*,'(A)') end if - - + + contains - - + + subroutine error character (len=256) :: message ierr = -1 @@ -439,9 +439,9 @@ subroutine error // ' error somewhere around here <' // trim(string) // & '>. please check for missing comma or other typo.' close(iounit) - end subroutine error - - + end subroutine error + + subroutine do_approx21(which_case, ierr) ! e.g. approx21(cr56) use chem_lib, only: chem_get_iso_id use chem_def, only: chem_isos @@ -469,10 +469,10 @@ subroutine do_approx21(which_case, ierr) ! e.g. approx21(cr56) (chem_isos% N(id) - chem_isos% N(ife56)) - & (chem_isos% Z(ife56) - chem_isos% Z(id)) g% doing_approx21 = .true. - g% add_co56_to_approx21 = (which_case == 2) + g% add_co56_to_approx21 = (which_case == 2) end subroutine do_approx21 - - + + subroutine do_isos(add_flag, ierr) use chem_lib, only: chem_get_element_id use chem_lib, only: lookup_ZN @@ -566,8 +566,8 @@ subroutine do_isos(add_flag, ierr) call error; return end if end if - - end if + + end if end do end if t = token(iounit, n, i, buffer, string) @@ -580,7 +580,7 @@ subroutine do_isos(add_flag, ierr) end do iso_loop end subroutine do_isos - + subroutine do_reactions(add_flag, ierr) use rates_lib, only: rates_reaction_id logical, intent(in) :: add_flag @@ -635,8 +635,8 @@ subroutine do_reactions(add_flag, ierr) end do reaction_loop if (cnt > 0) ierr = -1 end subroutine do_reactions - - + + subroutine do_basic_reactions_for_isos(ierr) use chem_lib, only: chem_get_element_id use chem_lib, only: lookup_ZN @@ -717,10 +717,10 @@ subroutine do_basic_reactions_for_isos(ierr) have_next_token = .false. end if end do iso_loop - + end subroutine do_basic_reactions_for_isos - - + + subroutine do1_iso(id,Z,A,A1,A2,ierr) integer, intent(in) :: id,Z,A,A1,A2 integer, intent(out) :: ierr @@ -737,7 +737,7 @@ subroutine do1_iso(id,Z,A,A1,A2,ierr) write(*,*) 'failed in add_net_iso for ' // trim(chem_isos% name(id)) call error; return end if - end if + end if call do_basic_reactions_for_iso(id, ierr) if (ierr /= 0) then write(*,*) 'failed in do_basic_reactions_for_iso for ' // & @@ -745,8 +745,8 @@ subroutine do1_iso(id,Z,A,A1,A2,ierr) call error; return end if end subroutine do1_iso - - + + subroutine do_basic_reactions_for_iso(id, ierr) ! pg X, X gp, ag X, X ag, ap X, X pa, ng X, X gn, ! X wk, X wk_minus, X wk_h1, X wk_he4 @@ -755,7 +755,7 @@ subroutine do_basic_reactions_for_iso(id, ierr) integer :: Z, N, Z2, N2, other_id integer :: i, j, k, ir, r_ir logical :: matches - + include 'formats' ierr = 0 @@ -797,33 +797,33 @@ subroutine do_basic_reactions_for_iso(id, ierr) !write(*,*) 'failed to find reverse for special ' // trim(reaction_name(r_ir)) end if if (r_ir > 0) then - reverse_reaction_id(r_ir) = ir + reverse_reaction_id(r_ir) = ir else if (ir > 0) then !write(*,*) 'failed to find reverse for special ' // trim(reaction_name(ir)) end if end do special_loop - + Z = chem_isos% Z(id) N = chem_isos% N(id) - if (g% net_iso(ih1) > 0) then + if (g% net_iso(ih1) > 0) then other_id = get_iso_id(Z-1, N) call add_basic_reaction(other_id, id, 'pg', 'gp', .true., ir, ierr) - if (ierr /= 0) return + if (ierr /= 0) return call add_basic_reaction(id, other_id, 'gp', 'pg', .true., r_ir, ierr) if (ierr /= 0) return if (ir > 0) reverse_reaction_id(ir) = r_ir - if (r_ir > 0) reverse_reaction_id(r_ir) = ir + if (r_ir > 0) reverse_reaction_id(r_ir) = ir other_id = get_iso_id(Z+1, N) call add_basic_reaction(id, other_id, 'pg', 'gp', .true., ir, ierr) - if (ierr /= 0) return + if (ierr /= 0) return call add_basic_reaction(other_id, id, 'gp', 'pg', .true., r_ir, ierr) - if (ierr /= 0) return + if (ierr /= 0) return if (ir > 0) reverse_reaction_id(ir) = r_ir - if (r_ir > 0) reverse_reaction_id(r_ir) = ir + if (r_ir > 0) reverse_reaction_id(r_ir) = ir end if - + if (g% net_iso(ihe4) > 0) then if (id == ib8) then call add_this_reaction('r_b8_wk_he4_he4', ir, ierr) @@ -833,56 +833,56 @@ subroutine do_basic_reactions_for_iso(id, ierr) call add_basic_reaction(other_id, id, 'ag', 'ga', .true., ir, ierr) if (ierr /= 0) return call add_basic_reaction(id, other_id, 'ga', 'ag', .true., r_ir, ierr) - if (ierr /= 0) return + if (ierr /= 0) return if (ir > 0) reverse_reaction_id(ir) = r_ir - if (r_ir > 0) reverse_reaction_id(r_ir) = ir + if (r_ir > 0) reverse_reaction_id(r_ir) = ir other_id = get_iso_id(Z+2, N+2) call add_basic_reaction(id, other_id, 'ag', 'ga', .true., ir, ierr) - if (ierr /= 0) return + if (ierr /= 0) return call add_basic_reaction(other_id, id, 'ga', 'ag', .true., r_ir, ierr) - if (ierr /= 0) return + if (ierr /= 0) return if (ir > 0) reverse_reaction_id(ir) = r_ir - if (r_ir > 0) reverse_reaction_id(r_ir) = ir + if (r_ir > 0) reverse_reaction_id(r_ir) = ir end if - + if (g% net_iso(ih1) > 0 .and. g% net_iso(ihe4) > 0) then if (id /= ihe4) then other_id = get_iso_id(Z-1, N-2) call add_basic_reaction(other_id, id, 'ap', 'pa', .true., ir, ierr) - if (ierr /= 0) return + if (ierr /= 0) return call add_basic_reaction(id, other_id, 'pa', 'ap', .true., r_ir, ierr) if (ierr /= 0) return if (ir > 0) reverse_reaction_id(ir) = r_ir - if (r_ir > 0) reverse_reaction_id(r_ir) = ir + if (r_ir > 0) reverse_reaction_id(r_ir) = ir other_id = get_iso_id(Z+1, N+2) call add_basic_reaction(id, other_id, 'ap', 'pa', .true., ir, ierr) - if (ierr /= 0) return + if (ierr /= 0) return call add_basic_reaction(other_id, id, 'pa', 'ap', .true., r_ir, ierr) if (ierr /= 0) return if (ir > 0) reverse_reaction_id(ir) = r_ir if (r_ir > 0) reverse_reaction_id(r_ir) = ir - end if + end if end if - + if (id /= ih1 .and. g% net_iso(ih1) > 0 .and. g% net_iso(ineut) > 0) then other_id = get_iso_id(Z-1, N+1) call add_basic_reaction(id, other_id, 'np', 'pn', .true., ir, ierr) if (ierr /= 0) return call add_basic_reaction(other_id, id, 'pn', 'np', .true., r_ir, ierr) - if (ierr /= 0) return + if (ierr /= 0) return if (ir > 0) reverse_reaction_id(ir) = r_ir - if (r_ir > 0) reverse_reaction_id(r_ir) = ir + if (r_ir > 0) reverse_reaction_id(r_ir) = ir if (id /= ineut) then other_id = get_iso_id(Z+1, N-1) call add_basic_reaction(other_id, id, 'np', 'pn', .true., ir, ierr) if (ierr /= 0) return call add_basic_reaction(id, other_id, 'pn', 'np', .true., r_ir, ierr) - if (ierr /= 0) return + if (ierr /= 0) return if (ir > 0) reverse_reaction_id(ir) = r_ir - if (r_ir > 0) reverse_reaction_id(r_ir) = ir + if (r_ir > 0) reverse_reaction_id(r_ir) = ir end if end if - + if (id /= ihe4 .and. g% net_iso(ihe4) > 0 .and. g% net_iso(ineut) > 0) then other_id = get_iso_id(Z-2, N-1) if (other_id /= ihe4) then @@ -891,8 +891,8 @@ subroutine do_basic_reactions_for_iso(id, ierr) call add_basic_reaction(other_id, id, 'an', 'na', .true., r_ir, ierr) if (ierr /= 0) return if (ir > 0) reverse_reaction_id(ir) = r_ir - if (r_ir > 0) reverse_reaction_id(r_ir) = ir - end if + if (r_ir > 0) reverse_reaction_id(r_ir) = ir + end if other_id = get_iso_id(Z+2, N+1) if (other_id /= ihe4) then call add_basic_reaction(other_id, id, 'na', 'an', .true., ir, ierr) @@ -900,20 +900,20 @@ subroutine do_basic_reactions_for_iso(id, ierr) call add_basic_reaction(id, other_id, 'an', 'na', .true., r_ir, ierr) if (ierr /= 0) return if (ir > 0) reverse_reaction_id(ir) = r_ir - if (r_ir > 0) reverse_reaction_id(r_ir) = ir - end if + if (r_ir > 0) reverse_reaction_id(r_ir) = ir + end if end if - - if (g% net_iso(ineut) > 0 .and. id /= ih2) then + + if (g% net_iso(ineut) > 0 .and. id /= ih2) then other_id = get_iso_id(Z, N-1) call add_basic_reaction(other_id, id, 'ng', 'gn', .true., ir, ierr) - if (ierr /= 0) return + if (ierr /= 0) return call add_basic_reaction(id, other_id, 'gn', 'ng', .true., r_ir, ierr) if (ierr /= 0) return if (ir > 0) reverse_reaction_id(ir) = r_ir - if (r_ir > 0) reverse_reaction_id(r_ir) = ir + if (r_ir > 0) reverse_reaction_id(r_ir) = ir end if - + other_id = get_iso_id(Z-1, N+1) call add_basic_reaction(id, other_id, 'wk', '', .true., ir, ierr) if (ierr /= 0) return @@ -924,7 +924,7 @@ subroutine do_basic_reactions_for_iso(id, ierr) end if if (ir > 0) reverse_reaction_id(ir) = r_ir if (r_ir > 0) reverse_reaction_id(r_ir) = ir - + other_id = get_iso_id(Z+1, N-1) call add_basic_reaction(other_id, id, 'wk', '', .true., ir, ierr) if (ierr /= 0) return @@ -935,8 +935,8 @@ subroutine do_basic_reactions_for_iso(id, ierr) end if if (ir > 0) reverse_reaction_id(ir) = r_ir if (r_ir > 0) reverse_reaction_id(r_ir) = ir - - if (g% net_iso(ih1) > 0) then + + if (g% net_iso(ih1) > 0) then other_id = get_iso_id(Z-2, N+1) call add_basic_reaction(id, other_id, 'wk-h1', '', .false., ir, ierr) if (ierr /= 0) return @@ -944,8 +944,8 @@ subroutine do_basic_reactions_for_iso(id, ierr) call add_basic_reaction(other_id, id, 'wk-h1', '', .false., ir, ierr) if (ierr /= 0) return end if - - if (g% net_iso(ihe4) > 0) then + + if (g% net_iso(ihe4) > 0) then other_id = get_iso_id(Z-3, N-1) call add_basic_reaction(id, other_id, 'wk-he4', '', .false., ir, ierr) if (ierr /= 0) return @@ -966,8 +966,8 @@ subroutine do_basic_reactions_for_iso(id, ierr) end if end subroutine do_basic_reactions_for_iso - - + + integer function get_iso_id(Z, N) use chem_lib, only: lookup_ZN integer, intent(in) :: Z, N @@ -975,8 +975,8 @@ integer function get_iso_id(Z, N) if (get_iso_id <= 0) return if (g% net_iso(get_iso_id) <= 0) get_iso_id = 0 end function get_iso_id - - + + subroutine add_this_reaction(string, ir, ierr) use rates_lib, only: rates_reaction_id character (len=*), intent(in) :: string @@ -1017,7 +1017,7 @@ subroutine add_this_reaction(string, ir, ierr) if (dbg) write(*,*) 'add_reaction_for_this_handle ' // trim(string) if (dbg) call mesa_error(__FILE__,__LINE__,'add_this_reaction') end subroutine add_this_reaction - + logical function add_reaction_for_this_handle(string, ir, ierr) use rates_lib, only: rates_reaction_id, add_reaction_for_handle @@ -1029,12 +1029,12 @@ logical function add_reaction_for_this_handle(string, ir, ierr) ir = rates_reaction_id(string) if (ir == 0) then ! check if reaction is defined in reaclib call add_reaction_for_handle(string, ierr) - if (ierr /= 0) then + if (ierr /= 0) then write(*,*) 'failed in add_reaction_for_handle for ' // trim(string) return end if ir = rates_reaction_id(string) - end if + end if if (ir > 0) then call add_net_reaction(handle, ir, ierr) if (ierr /= 0) then @@ -1042,9 +1042,9 @@ logical function add_reaction_for_this_handle(string, ir, ierr) call error end if add_reaction_for_this_handle = .true. - end if + end if end function add_reaction_for_this_handle - + logical function add_this_reaclib_forward_reaction(string, ir, ierr) use rates_lib, only: rates_reaction_id, add_reaction_from_reaclib, reaclib_lookup @@ -1059,13 +1059,13 @@ logical function add_this_reaclib_forward_reaction(string, ir, ierr) indx = reaclib_lookup(string, reaclib_rates% reaction_dict) if (indx > 0) then ! add a definition for it call add_reaction_from_reaclib(string, '', indx, ierr) - if (ierr /= 0) then + if (ierr /= 0) then write(*,*) 'failed in add_this_reaclib_forward_reaction for ' // trim(string) return end if ir = rates_reaction_id(string) end if - end if + end if if (ir > 0) then call add_net_reaction(handle, ir, ierr) if (ierr /= 0) then @@ -1073,10 +1073,10 @@ logical function add_this_reaclib_forward_reaction(string, ir, ierr) call error end if add_this_reaclib_forward_reaction = .true. - end if + end if end function add_this_reaclib_forward_reaction - - + + logical function add_this_reaclib_reverse_reaction(string, ir, ierr) use rates_lib, only: rates_reaction_id, add_reaction_from_reaclib, reaclib_lookup character (len=*), intent(in) :: string @@ -1087,14 +1087,14 @@ logical function add_this_reaclib_reverse_reaction(string, ir, ierr) add_this_reaclib_reverse_reaction = .false. ir = rates_reaction_id(string) if (ir == 0) then ! check if reaction is defined in reaclib - indx = reaclib_lookup(string, reaclib_rates% reverse_dict) + indx = reaclib_lookup(string, reaclib_rates% reverse_dict) if (indx > 0) then ! add a definition for it call add_reaction_from_reaclib( & string, reaclib_rates% reaction_handle(indx), indx, ierr) if (ierr /= 0) return ir = rates_reaction_id(string) end if - end if + end if if (ir > 0) then call add_net_reaction(handle, ir, ierr) if (ierr /= 0) then @@ -1102,10 +1102,10 @@ logical function add_this_reaclib_reverse_reaction(string, ir, ierr) end if add_this_reaclib_reverse_reaction = .true. return - end if + end if end function add_this_reaclib_reverse_reaction - - + + subroutine add_basic_reaction(iso_in, iso_out, op, reverse_op, warn, ir, ierr) use rates_lib, only: rates_reaction_id, add_reaction_from_reaclib, reaclib_lookup use rates_def, only: reaction_inputs @@ -1119,34 +1119,34 @@ subroutine add_basic_reaction(iso_in, iso_out, op, reverse_op, warn, ir, ierr) include 'formats' ierr = 0 ir = 0 - + if (iso_in <= 0 .or. iso_out <= 0) return - + string = 'r_' // trim(chem_isos% name(iso_in)) // '_' // & trim(op) // '_' // trim(chem_isos% name(iso_out)) - + ir = rates_reaction_id(string) - + if (ir < 0 .or. ir > rates_reaction_id_max) then write(*,*) 'failed in rates_reaction_id for ' // trim(string) call mesa_error(__FILE__,__LINE__,'net_init') end if - + if (ir == 0) then ! check if reaction or reverse is defined in reaclib indx = reaclib_lookup(string, reaclib_rates% reaction_dict) if (indx > 0) then ! add a definition for it call add_reaction_from_reaclib(string, '', indx, ierr) - if (ierr /= 0) then + if (ierr /= 0) then write(*,*) 'failed in add_reaction_from_reaclib for ' // trim(string) return end if ir = rates_reaction_id(string) - + if (ir < 0 .or. ir > rates_reaction_id_max) then write(*,*) 'failed in rates_reaction_id for ' // trim(string) call mesa_error(__FILE__,__LINE__,'net_init') end if - + else ierr = 0 if (len_trim(reverse_op) > 0) then ! check for the reverse reaction in reaclib @@ -1155,7 +1155,7 @@ subroutine add_basic_reaction(iso_in, iso_out, op, reverse_op, warn, ir, ierr) indx = reaclib_lookup(reverse, reaclib_rates% reaction_dict) if (indx > 0) then ! add a definition for it call add_reaction_from_reaclib(string, reverse, indx, ierr) - if (ierr /= 0) then + if (ierr /= 0) then write(*,'(a)') 'failed in add_reaction_from_reaclib for ' & // trim(string) // ' reverse ' // trim(reverse) return @@ -1167,7 +1167,7 @@ subroutine add_basic_reaction(iso_in, iso_out, op, reverse_op, warn, ir, ierr) end if end if end if - + if (ir > 0) then call add_net_reaction(handle, ir, ierr) if (ierr /= 0) then @@ -1177,53 +1177,53 @@ subroutine add_basic_reaction(iso_in, iso_out, op, reverse_op, warn, ir, ierr) if (dbg) write(*,*) 'add_basic_reaction ' // trim(string) return end if - + if (warn) then call integer_dict_lookup(skip_warnings_dict, string, i, ierr) if (ierr /= 0 .or. i <= 0) then ierr = 0 end if end if - + end subroutine add_basic_reaction - - + + end subroutine do_read_net_file - + subroutine start_net_def(handle, ierr) use rates_def, only: rates_reaction_id_max integer, intent(in) :: handle integer, intent(out) :: ierr - + type (Net_General_Info), pointer :: g - + ierr = 0 call get_net_ptr(handle, g, ierr) if (ierr /= 0) return - + if (.not. associated(g% net_iso)) then allocate(g% net_iso(num_chem_isos), stat=ierr) if (ierr /= 0) return end if g% net_iso(:) = 0 - + if (.not. associated(g% net_reaction)) then allocate(g% net_reaction(rates_reaction_id_max), stat=ierr) if (ierr /= 0) return end if - g% net_reaction(:) = 0 - - g% net_has_been_defined = .false. - g% net_filename = '' - - + g% net_reaction(:) = 0 + + g% net_has_been_defined = .false. + g% net_filename = '' + + !call show_scr3('start_net_def') - + end subroutine start_net_def - - + + subroutine show_scr3(str) use rates_def use chem_def @@ -1240,8 +1240,8 @@ subroutine show_scr3(str) end do write(*,'(A)') end subroutine show_scr3 - - + + subroutine finish_net_def(handle, ierr) use rates_def, only: reaction_names_dict use utils_lib, only: integer_dict_create_hash, realloc_integer @@ -1249,21 +1249,21 @@ subroutine finish_net_def(handle, ierr) use chem_lib, only: get_mass_excess integer, intent(in) :: handle integer, intent(out) :: ierr - + type (Net_General_Info), pointer :: g integer :: i - + logical, parameter :: dbg = .false. !logical, parameter :: dbg = .true. - + include 'formats' - + ierr = 0 - + if (dbg) write(*,*) 'finish_net_def' - + ! may have defined some new reactions as part of loading the net - ! so recreate the dict hash + ! so recreate the dict hash call integer_dict_create_hash(reaction_names_dict, ierr) if (ierr /= 0) then write(*,*) 'FATAL ERROR: finish_net_def failed in integer_dict_create_hash' @@ -1272,17 +1272,17 @@ subroutine finish_net_def(handle, ierr) call get_net_ptr(handle, g, ierr) if (ierr /= 0) return - + if (.not. associated(g% net_iso)) then ierr = -1 return end if - + if (.not. associated(g% net_reaction)) then ierr = -1 return end if - + if (size(g% net_reaction, dim=1) > rates_reaction_id_max) then if (dbg) write(*,*) 'call realloc_integer' call realloc_integer(g% net_reaction, rates_reaction_id_max, ierr) @@ -1291,27 +1291,27 @@ subroutine finish_net_def(handle, ierr) return end if end if - + if (g% doing_approx21) then if (dbg) write(*,*) 'call mark_approx21' call do_mark_approx21(handle, ierr) if (ierr /= 0) return end if - + if (dbg) write(*,*) 'call setup_iso_info' call setup_iso_info(g, ierr) if (ierr /= 0) return if (dbg) write(*,*) 'call setup_reaction_info' call setup_reaction_info(g, ierr) - if (ierr /= 0) return - + if (ierr /= 0) return + allocate( & g% reaction_max_Z(g% num_reactions), & g% reaction_max_Z_plus_N_for_max_Z(g% num_reactions), & stat=ierr) if (ierr /= 0) return - + allocate( & g% z158(g% num_isos), & g% z52(g% num_isos), & @@ -1327,11 +1327,11 @@ subroutine finish_net_def(handle, ierr) do i=1, g% num_isos g% mion(i) = get_mass_excess(chem_isos, g% chem_id(i)) * mev2gr end do - + call set_reaction_max_Z(g) - g% net_has_been_defined = .true. - + g% net_has_been_defined = .true. + if (g% doing_approx21) then if (dbg) write(*,*) 'call set_approx21' call do_set_approx21(handle, ierr) @@ -1339,37 +1339,37 @@ subroutine finish_net_def(handle, ierr) end if if (dbg) write(*,*) 'done finish_net_def' - + contains - + subroutine do_mark_approx21(handle, ierr) use net_approx21, only: mark_approx21 integer, intent(in) :: handle integer, intent(out) :: ierr call mark_approx21(handle, ierr) end subroutine do_mark_approx21 - - + + subroutine do_set_approx21(handle, ierr) use net_approx21, only: set_approx21 integer, intent(in) :: handle integer, intent(out) :: ierr call set_approx21(handle, ierr) end subroutine do_set_approx21 - - + + end subroutine finish_net_def - - + + subroutine check_for_hardwired_pairs ! especially for approx21 call check_pair('r_he4_he4_he4_to_c12', 'r_c12_to_he4_he4_he4') - call check_pair('rhe4_breakup', 'rhe4_rebuild') + call check_pair('rhe4_breakup', 'rhe4_rebuild') ! << should treat this as he4 + n + p -> 3 n + 3 p ??? call check_pair('rprot_to_neut', 'rneut_to_prot') call check_pair('r_c12_ag_o16', 'r_o16_ga_c12') call check_pair('rc12ap_to_o16', 'ro16gp_to_c12') call check_pair('r_o16_ag_ne20', 'r_ne20_ga_o16') - call check_pair('ro16ap_to_ne20', 'rne20gp_to_o16') + call check_pair('ro16ap_to_ne20', 'rne20gp_to_o16') call check_pair('r_ne20_ag_mg24', 'r_mg24_ga_ne20') call check_pair('rne20ap_to_mg24', 'rmg24gp_to_ne20') call check_pair('r_mg24_ag_si28', 'r_si28_ga_mg24') @@ -1385,17 +1385,17 @@ subroutine check_for_hardwired_pairs ! especially for approx21 call check_pair('r_ti44_ag_cr48', 'r_cr48_ga_ti44') call check_pair('rti44ap_to_cr48', 'rcr48gp_to_ti44') call check_pair('r_cr48_ag_fe52', 'r_fe52_ga_cr48') - call check_pair('rcr48ap_to_fe52', 'rfe52gp_to_cr48') - call check_pair('rfe52aprot_to_fe54', 'rfe54prot_to_fe52') - call check_pair('rfe52neut_to_fe54', 'rfe54g_to_fe52') - call check_pair('rfe54ng_to_fe56', 'rfe56gn_to_fe54') - call check_pair('r_fe52_ag_ni56', 'r_ni56_ga_fe52') - call check_pair('rfe52aprot_to_ni56', 'rni56gprot_to_fe52') - call check_pair('rfe54prot_to_ni56', 'rni56gprot_to_fe54') - call check_pair('rfe54prot_to_ni56', 'rni56gprot_to_fe54') + call check_pair('rcr48ap_to_fe52', 'rfe52gp_to_cr48') + call check_pair('rfe52aprot_to_fe54', 'rfe54prot_to_fe52') + call check_pair('rfe52neut_to_fe54', 'rfe54g_to_fe52') + call check_pair('rfe54ng_to_fe56', 'rfe56gn_to_fe54') + call check_pair('r_fe52_ag_ni56', 'r_ni56_ga_fe52') + call check_pair('rfe52aprot_to_ni56', 'rni56gprot_to_fe52') + call check_pair('rfe54prot_to_ni56', 'rni56gprot_to_fe54') + call check_pair('rfe54prot_to_ni56', 'rni56gprot_to_fe54') end subroutine check_for_hardwired_pairs - - + + subroutine check_pair(s1,s2) use rates_def, only: get_rates_reaction_id, reverse_reaction_id character (len=*), intent(in) :: s1, s2 @@ -1413,15 +1413,15 @@ subroutine check_pair(s1,s2) reverse_reaction_id(ir) = r_ir reverse_reaction_id(r_ir) = ir end subroutine check_pair - - - + + + subroutine set_reaction_kinds(g) use chem_def, only: chem_isos use rates_lib, only: & reaclib_create_handle, reaclib_parse_handle, is_weak_reaction type (Net_General_Info), pointer :: g - + integer :: iso_in1, iso_in2, iso_out1, iso_out2, & num_in1, num_in2, num_out1, num_out2, in_a, in_b, out_c, out_d, & num_basic_ng_kind, num_basic_pn_kind, num_basic_pg_kind, & @@ -1432,12 +1432,12 @@ subroutine set_reaction_kinds(g) character (len=100) :: reverse_handle, op character (len=4) :: rstr integer, pointer :: kind(:), reverse_id(:) - + include 'formats' - + kind => g% reaction_reaclib_kind reverse_id => g% reverse_id_for_kind_ne_other - + num_basic_ng_kind = 0 num_basic_pn_kind = 0 num_basic_pg_kind = 0 @@ -1447,13 +1447,13 @@ subroutine set_reaction_kinds(g) num_general_one_one_kind = 0 num_general_two_one_kind = 0 num_general_two_two_kind = 0 - + do i=1, g% num_reactions - + kind(i) = other_kind reverse_id(i) = 0 - ir = g% reaction_id(i) - + ir = g% reaction_id(i) + if (is_weak_reaction(ir)) cycle ! don't do weak reactions if (reaction_name(ir)(1:2) /= 'r_') cycle ! don't mess with special ones. @@ -1464,9 +1464,9 @@ subroutine set_reaction_kinds(g) reverse_id(i) = r_ir r_i = g% net_reaction(r_ir) if (r_i <= 0) then - cycle ! reverse reaction not in this net + cycle ! reverse reaction not in this net end if - + if (reaction_inputs(6,ir) /= 0) then cycle ! more than 2 input species end if @@ -1476,13 +1476,13 @@ subroutine set_reaction_kinds(g) num_in1 = reaction_inputs(1,ir) iso_in1 = reaction_inputs(2,ir) - + num_in2 = reaction_inputs(3,ir) iso_in2 = reaction_inputs(4,ir) - + num_out1 = reaction_outputs(1,ir) iso_out1 = reaction_outputs(2,ir) - + num_out2 = reaction_outputs(3,ir) iso_out2 = reaction_outputs(4,ir) @@ -1492,7 +1492,7 @@ subroutine set_reaction_kinds(g) if (num_in1 > 3 .or. num_out1 > 3) then cycle ! non-standard reaction end if - + if (iso_in2 == 0) then ! only 1 species on lhs if (iso_out2 > 0) cycle ! 1 to many is treated as reverse of many to 1 ! 1 species to 1 species reaction @@ -1505,9 +1505,9 @@ subroutine set_reaction_kinds(g) end if cycle end if - + if (is_weak_reaction(ir)) cycle - + if (iso_out2 == 0) then ! 2 to 1 if (num_in1 > 1 .or. num_in2 > 1 .or. num_out1 > 1) then kind(i) = general_two_one_kind @@ -1532,7 +1532,7 @@ subroutine set_reaction_kinds(g) ! if get here, have a + b on left with different species a and b ! and only have 1 of each species on left and right - + if (chem_isos% Z(iso_in1) <= chem_isos% Z(iso_in2)) then in_a = iso_in1 in_b = iso_in2 @@ -1543,13 +1543,13 @@ subroutine set_reaction_kinds(g) ! a + b => c; Z(a) <= Z(b) if (iso_out2 == 0) then ! 2-to-1 - + if (in_a == ineut) then kind(i) = ng_kind num_basic_ng_kind = num_basic_ng_kind + 1 else if (in_a == ihe4) then kind(i) = ag_kind - num_basic_ag_kind = num_basic_ag_kind + 1 + num_basic_ag_kind = num_basic_ag_kind + 1 else if (in_a == ih1) then kind(i) = pg_kind num_basic_pg_kind = num_basic_pg_kind + 1 @@ -1564,9 +1564,9 @@ subroutine set_reaction_kinds(g) !write(*,*) 'general 2-1 ' // trim(reaction_name(ir)) end if end if - + else ! 2-to-2. only do ap,an,pn. skip pa,na,np. - + if (chem_isos% Z(iso_out1) <= chem_isos% Z(iso_out2)) then out_c = iso_out1 out_d = iso_out2 @@ -1605,9 +1605,9 @@ subroutine set_reaction_kinds(g) else kind(i) = general_two_two_kind end if - + end if - + if (kind(i) == general_two_two_kind) then if (r_ir > ir) then kind(i) = other_kind @@ -1616,14 +1616,14 @@ subroutine set_reaction_kinds(g) num_general_two_two_kind = num_general_two_two_kind + 1 end if end if - + end do - + return - + if (.true.) then do i=1, g% num_reactions - ir = g% reaction_id(i) + ir = g% reaction_id(i) write(*,3) trim(reaction_name(ir)), i, kind(i) !r_ir = reverse_reaction_id(ir) !if (kind(i) == ag_kind) write(*,'(a60,i5)') trim(reaction_name(ir)) // & @@ -1632,11 +1632,11 @@ subroutine set_reaction_kinds(g) ! ' ' // trim(reaction_name(r_ir)), kind(i) end do end if - + stop - + !return - + write(*,2) 'num_basic_ag_kind', num_basic_ag_kind write(*,2) 'num_basic_pg_kind', num_basic_pg_kind write(*,2) 'num_basic_ng_kind', num_basic_ng_kind @@ -1647,44 +1647,44 @@ subroutine set_reaction_kinds(g) write(*,2) 'num_general_two_one_kind', num_general_two_one_kind write(*,2) 'num_general_two_two_kind', num_general_two_two_kind write(*,'(A)') - + !stop - end subroutine set_reaction_kinds - - + end subroutine set_reaction_kinds + + subroutine add_net_iso(handle, iso_id, ierr) use chem_def, only: chem_isos integer, intent(in) :: handle integer, intent(in) :: iso_id integer, intent(out) :: ierr - + type (Net_General_Info), pointer :: g - + ierr = 0 call get_net_ptr(handle, g, ierr) if (ierr /= 0) return - + if (.not. associated(g% net_iso)) then ierr = -1 return end if - + if (g% net_has_been_defined) then ierr = -1 return end if - + if (iso_id < 0 .or. iso_id > num_chem_isos) then ierr = -1 return end if - + g% net_iso(iso_id) = 1 ! mark as added end subroutine add_net_iso - - + + subroutine add_net_isos(handle, num_isos, iso_ids, ierr) integer, intent(in) :: handle integer, intent(in) :: num_isos, iso_ids(num_isos) @@ -1696,41 +1696,41 @@ subroutine add_net_isos(handle, num_isos, iso_ids, ierr) if (ierr /= 0) return end do end subroutine add_net_isos - - + + subroutine remove_net_iso(handle, iso_id, ierr) integer, intent(in) :: handle integer, intent(in) :: iso_id integer, intent(out) :: ierr - + type (Net_General_Info), pointer :: g - + ierr = 0 call get_net_ptr(handle, g, ierr) if (ierr /= 0) return - + if (.not. associated(g% net_iso)) then ierr = -1 return end if - + if (g% net_has_been_defined) then ierr = -1 return end if - + if (iso_id < 0 .or. iso_id > num_chem_isos) then ierr = -1 return end if - + g% net_iso(iso_id) = 0 ! mark as removed - + call remove_reactions_for_iso(g, iso_id, ierr) - + end subroutine remove_net_iso - - + + subroutine remove_net_isos(handle, num_isos, iso_ids, ierr) integer, intent(in) :: handle integer, intent(in) :: num_isos, iso_ids(:) @@ -1742,39 +1742,39 @@ subroutine remove_net_isos(handle, num_isos, iso_ids, ierr) if (ierr /= 0) return end do end subroutine remove_net_isos - - + + subroutine add_net_reaction(handle, reaction_id, ierr) use utils_lib, only: realloc_integer integer, intent(in) :: handle integer, intent(in) :: reaction_id integer, intent(out) :: ierr - + type (Net_General_Info), pointer :: g integer :: old_sz, new_sz - + ierr = 0 call get_net_ptr(handle, g, ierr) if (ierr /= 0) return - + if (.not. associated(g% net_reaction)) then ierr = -1 write(*,*) 'must call net_start_def before calling net_add_reaction' return end if - + if (g% net_has_been_defined) then ierr = -1 write(*,*) 'must call net_start_def before calling net_add_reaction' return end if - + if (reaction_id < 0 .or. reaction_id > rates_reaction_id_max) then ierr = -1 write(*,*) 'invalid reaction_id for net_add_reaction' return end if - + old_sz = size(g% net_reaction, dim=1) if (reaction_id > old_sz) then new_sz = (reaction_id*11)/10 + 100 @@ -1785,12 +1785,12 @@ subroutine add_net_reaction(handle, reaction_id, ierr) end if g% net_reaction(old_sz+1:new_sz) = 0 end if - + g% net_reaction(reaction_id) = 1 ! mark as added - + end subroutine add_net_reaction - - + + subroutine add_net_reactions(handle, num_reactions, reaction_ids, ierr) integer, intent(in) :: handle integer, intent(in) :: num_reactions, reaction_ids(:) @@ -1802,39 +1802,39 @@ subroutine add_net_reactions(handle, num_reactions, reaction_ids, ierr) if (ierr /= 0) return end do end subroutine add_net_reactions - - + + subroutine remove_net_reaction(handle, reaction_id, ierr) integer, intent(in) :: handle integer, intent(in) :: reaction_id integer, intent(out) :: ierr - + type (Net_General_Info), pointer :: g - + ierr = 0 call get_net_ptr(handle, g, ierr) if (ierr /= 0) return - + if (.not. associated(g% net_reaction)) then ierr = -1 return end if - + if (g% net_has_been_defined) then ierr = -1 return end if - + if (reaction_id <= 0 .or. reaction_id > rates_reaction_id_max) then ierr = -1 return end if - + g% net_reaction(reaction_id) = 0 ! mark as removed - + end subroutine remove_net_reaction - - + + subroutine remove_net_reactions(handle, num_reactions, reaction_ids, ierr) integer, intent(in) :: handle integer, intent(in) :: num_reactions, reaction_ids(:) @@ -1846,18 +1846,18 @@ subroutine remove_net_reactions(handle, num_reactions, reaction_ids, ierr) if (ierr /= 0) return end do end subroutine remove_net_reactions - + subroutine setup_iso_info(g, ierr) type (Net_General_Info), pointer :: g integer, intent(out) :: ierr - + integer :: i, iso_num, num_isos integer, pointer :: itab(:), chem_id(:) - + ierr = 0 itab => g% net_iso - + num_isos = sum(itab(:)) if (num_isos <= 0) then ierr = -1 @@ -1868,7 +1868,7 @@ subroutine setup_iso_info(g, ierr) allocate(g% chem_id(num_isos), stat=ierr) if (ierr /= 0) return chem_id => g% chem_id - + iso_num = 0 do i = 1, num_chem_isos if (itab(i) == 0) cycle @@ -1892,10 +1892,10 @@ subroutine remove_reactions_for_iso(g, target_iso, ierr) ierr = 0 rtab => g% net_reaction itab => g% net_iso - + !if (target_iso /= 0) & ! write(*,*) 'remove_reactions_for_iso ' // trim(chem_isos% name(target_iso)) - + do ir = 1, size(rtab,dim=1) if (rtab(ir) == 0) cycle ! not used num_reaction_inputs = get_num_reaction_inputs(ir) @@ -1917,7 +1917,7 @@ subroutine remove_reactions_for_iso(g, target_iso, ierr) end if end do end do - + end subroutine remove_reactions_for_iso @@ -1927,7 +1927,7 @@ subroutine setup_reaction_info(g, ierr) ! assumes have already called setup_iso_ use num_lib, only: qsort_string_index type (Net_General_Info), pointer :: g integer, intent(out) :: ierr - + integer :: i, j, k, kind, reaction_num, num_reactions, & r1, r2, r3, & num_wk_reactions, ir, cid_lhs, cid_rhs, r_ir, r_i, & @@ -1936,12 +1936,12 @@ subroutine setup_reaction_info(g, ierr) ! assumes have already called setup_iso_ integer, pointer, dimension(:) :: & rtab, index, ids, reaction_kind, & reaction_reaclib_kind, reaction_id, reverse_id_for_kind_ne_other - + include 'formats' - + ierr = 0 rtab => g% net_reaction - + num_reactions = sum(rtab(:)) g% num_reactions = num_reactions allocate( & @@ -1964,9 +1964,9 @@ subroutine setup_reaction_info(g, ierr) ! assumes have already called setup_iso_ reaction_reaclib_kind => g% reaction_reaclib_kind reaction_id => g% reaction_id reverse_id_for_kind_ne_other => g% reverse_id_for_kind_ne_other - + reaction_num = 0 - num_wk_reactions = 0 + num_wk_reactions = 0 do ir = 1, rates_reaction_id_max if (rtab(ir) == 0) cycle ! reaction not in this net reaction_num = reaction_num + 1 @@ -1979,9 +1979,9 @@ subroutine setup_reaction_info(g, ierr) ! assumes have already called setup_iso_ write(*,*) 'reaction_num /= num_reactions', reaction_num, num_reactions call mesa_error(__FILE__,__LINE__,'setup_reaction_info') end if - + call check_for_hardwired_pairs - + ! need to order reactions to ensure bit-for-bit results ! so sort reaction_id by reaction_Name index(1:num_reactions) => g% reaction_kind(1:num_reactions) @@ -1997,7 +1997,7 @@ subroutine setup_reaction_info(g, ierr) ! assumes have already called setup_iso_ end do call set_reaction_kinds(g) - + do i = 1, num_reactions ir = reaction_id(i) if (ir < 1 .or. ir > rates_reaction_id_max) then @@ -2007,8 +2007,8 @@ subroutine setup_reaction_info(g, ierr) ! assumes have already called setup_iso_ end if rtab(ir) = i end do - - i = 1 + + i = 1 kind_loop: do kind = 1, max_kind ! reorder by kind of reaction; other_kind goes last do while (reaction_reaclib_kind(i) == kind) i = i+1 @@ -2018,9 +2018,9 @@ subroutine setup_reaction_info(g, ierr) ! assumes have already called setup_iso_ found_one = .false. do j=i+1,num_reactions ! locate the next instance of current kind of reaction if (reaction_reaclib_kind(j) /= kind) cycle - + ! exchange - + r1 = reaction_reaclib_kind(j) r2 = reverse_id_for_kind_ne_other(j) r3 = reaction_id(j) @@ -2028,24 +2028,24 @@ subroutine setup_reaction_info(g, ierr) ! assumes have already called setup_iso_ reaction_reaclib_kind(j) = reaction_reaclib_kind(i) reverse_id_for_kind_ne_other(j) = reverse_id_for_kind_ne_other(i) reaction_id(j) = reaction_id(i) - + reaction_reaclib_kind(i) = r1 reverse_id_for_kind_ne_other(i) = r2 reaction_id(i) = r3 rtab(reaction_id(i)) = i rtab(reaction_id(j)) = j - + found_one = .true. exit end do - + if (.not. found_one) exit ! look for another kind i = i+1 ! next destination if (i > num_reactions) exit - end do + end do end do kind_loop - + i = 0 !g% have_all_reverses = .true. do ! reorder so that forward + reverse pairs are adjacent. @@ -2074,23 +2074,23 @@ subroutine setup_reaction_info(g, ierr) ! assumes have already called setup_iso_ write(*,*) 'r_i <= i' stop end if - + i = i+1 - + do k=r_i-1,i,-1 reaction_reaclib_kind(k+1) = reaction_reaclib_kind(k) reverse_id_for_kind_ne_other(k+1) = reverse_id_for_kind_ne_other(k) reaction_id(k+1) = reaction_id(k) rtab(reaction_id(k+1)) = k+1 end do - + reaction_reaclib_kind(i) = other_kind reverse_id_for_kind_ne_other(i) = ir reaction_id(i) = r_ir rtab(r_ir) = i - + end do - + g% num_wk_reactions = num_wk_reactions allocate( & g% weak_reaction_num(num_wk_reactions), & @@ -2144,7 +2144,7 @@ subroutine setup_reaction_info(g, ierr) ! assumes have already called setup_iso_ end if end subroutine setup_reaction_info - + ! Fowler, Caughlan, Zimmerman, Annual Review Astro. Astrophys., 1975.12:69-112. eqn (1). real(dp) function neutrino_Q(i1, i2) @@ -2161,127 +2161,127 @@ end function neutrino_Q subroutine init_special_case_reaction_info integer :: i include 'formats' - + i = 0 - + call set(ih1, ih2, 0, 0, 0, 'r_h1_h1_wk_h2', 'r_h1_h1_ec_h2') - + call set(ineut, ih1, ih2, 0, 0, 'r_neut_h1_h1_to_h1_h2', 'r_h1_h2_to_neut_h1_h1') - + call set(ih1, ih2, ih3, 0, 0, 'r_h2_h2_to_h1_h3', 'r_h1_h3_to_h2_h2') - + call set(ih3, ihe3, 0, 0, 0, 'r_he3_ec_h3', '') - + call set(ineut, ih2, ihe3, 0, 0, 'r_h2_h2_to_neut_he3', 'r_neut_he3_to_h2_h2') - + call set(ih1, ihe3, ihe4, 0, 0, 'r_h1_he3_wk_he4', '') - + call set(ih2, ihe4, 0, 0, 0, 'r_h2_h2_to_he4', 'r_he4_to_h2_h2') - + call set(ineut, ih2, ih3, ihe4, 0, 'r_h2_h3_to_neut_he4', 'r_neut_he4_to_h2_h3') - + call set(ih1, ih2, ihe3, ihe4, 0, 'r_h2_he3_to_h1_he4', 'r_h1_he4_to_h2_he3') - + call set(ih2, ih3, ihe3, ihe4, 0, 'r_h3_he3_to_h2_he4', 'r_h2_he4_to_h3_he3') - + call set(ineut, ih3, ihe4, 0, 0, 'r_h3_h3_to_neut_neut_he4', 'r_neut_neut_he4_to_h3_h3') - + call set(ih1, ihe3, ihe4, 0, 0, 'r_he3_he3_to_h1_h1_he4', 'r_h1_h1_he4_to_he3_he3') - + call set(ineut, ih1, ihe4, ili6, 0, 'r_li6_to_neut_h1_he4', 'r_neut_h1_he4_to_li6') - + call set(ineut, ih2, ihe4, ili7, 0, 'r_h2_li7_to_neut_he4_he4', & 'r_neut_he4_he4_to_h2_li7') - + call set(ineut, ih3, ihe4, ili7, 0, & 'r_h3_li7_to_neut_neut_he4_he4', 'r_neut_neut_he4_he4_to_h3_li7') - + call set(ih1, ih2, ili6, ili7, 0, 'r_h1_li7_to_h2_li6', 'r_h2_li6_to_h1_li7') - + call set(ibe7, ili7, 0, 0, 0, 'r_be7_wk_li7', '') - + ! might also need reverse for r_n13_wk_c13, r_o15_wk_n15 - + call set(ih1, ih2, ihe4, ibe7, 0, 'r_h2_be7_to_h1_he4_he4', 'r_h1_he4_he4_to_h2_be7') - + call set(ineut, ihe4, ibe7, 0, 0, 'r_neut_be7_to_he4_he4', 'r_he4_he4_to_neut_be7') - + call set(ih1, ihe3, ihe4, ibe7, 0, 'r_he3_be7_to_h1_h1_he4_he4', & 'r_h1_h1_he4_he4_to_he3_be7') - + call set(ineut, ih2, ili6, ibe7, 0, 'r_neut_be7_to_h2_li6', 'r_h2_li6_to_neut_be7') - + call set(ineut, ih3, ili7, ibe9, 0, 'r_neut_be9_to_h3_li7', 'r_h3_li7_to_neut_be9') - + call set(ineut, ihe4, ibe9, 0, 0, 'r_be9_to_neut_he4_he4', 'r_neut_he4_he4_to_be9') - + call set(ih1, ih2, ihe4, ibe9, 0, 'r_h1_be9_to_h2_he4_he4', 'r_h2_he4_he4_to_h1_be9') - + call set(ineut, ih1, ihe4, ib8, 0, 'r_neut_b8_to_h1_he4_he4', 'r_h1_he4_he4_to_neut_b8') - + call set(ih1, ihe4, ib11, 0, 0, 'r_h1_b11_to_he4_he4_he4', 'r_he4_he4_he4_to_h1_b11') - + call set(ineut, ih3, ibe9, ib11, 0, 'r_neut_b11_to_h3_be9', 'r_h3_be9_to_neut_b11') - + call set(ih1, ihe4, ic9, 0, 0, 'r_c9_wk_h1_he4_he4', '') - + call set(ineut, ihe4, ic11, 0, 0, 'r_neut_c11_to_he4_he4_he4', & 'r_he4_he4_he4_to_neut_c11') - + call set(ihe4, ic12, 0, 0, 0, 'r_he4_he4_he4_to_c12', 'r_c12_to_he4_he4_he4') - + call set(ineut, ih2, ic13, in14, 0, 'r_neut_n14_to_h2_c13', 'r_h2_c13_to_neut_n14') - + call set(ineut, ih2, ic14, in15, 0, 'r_neut_n15_to_h2_c14', 'r_h2_c14_to_neut_n15') - + call set(ih1, ihe4, io13, io15, 0, 'r_he4_o13_to_h1_h1_o15', 'r_h1_h1_o15_to_he4_o13') - + call set(ihe4, ic12, ine20, 0, 0, 'r_c12_c12_to_he4_ne20', 'r_he4_ne20_to_c12_c12') - + call set(ih1, ic12, ina23, 0, 0, 'r_c12_c12_to_h1_na23', 'r_h1_na23_to_c12_c12') - + call set(ineut, ic12, img23, 0, 0, 'r_neut_mg23_to_c12_c12', 'r_c12_c12_to_neut_mg23') - + call set(ihe4, ic12, io16, img24, 0, 'r_c12_o16_to_he4_mg24', 'r_he4_mg24_to_c12_o16') - + call set(ih1, ic12, io16, ial27, 0, 'r_c12_o16_to_h1_al27', 'r_h1_al27_to_c12_o16') - + call set(ineut, ic12, io16, isi27, 0, 'r_neut_si27_to_c12_o16', 'r_c12_o16_to_neut_si27') - + call set(ihe4, io16, isi28, 0, 0, 'r_o16_o16_to_he4_si28', 'r_he4_si28_to_o16_o16') - + call set(ihe4, ic12, ine20, isi28, 0, 'r_c12_ne20_to_he4_si28', 'r_he4_si28_to_c12_ne20') - + call set(ih1, io16, ip31, 0, 0, 'r_o16_o16_to_h1_p31', 'r_h1_p31_to_o16_o16') - + ! call set(ih2, io16, ip30, 0, 0, 'r_o16_o16_to_h2_p30', 'r_h2_p30_to_o16_o16') - + call set(ih1, ic12, ine20, ip31, 0, 'r_c12_ne20_to_h1_p31', 'r_h1_p31_to_c12_ne20') - + call set(ih1, ial25, is27, 0, 0, 'r_s27_wk_h1_h1_al25', '') - + call set(ineut, io16, is31, 0, 0, 'r_o16_o16_to_neut_s31', 'r_neut_s31_to_o16_o16') - + call set(ineut, ic12, ine20, is31, 0, 'r_c12_ne20_to_neut_s31', 'r_neut_s31_to_c12_ne20') - + call set(ih1, ip29, iar31, 0, 0, 'r_ar31_wk_h1_h1_p29', '') - + call set(ih1, ihe4, ica36, ica38, 0, 'r_he4_ca36_to_h1_h1_ca38', & 'r_h1_h1_ca38_to_he4_ca36') - + call set(ineut, ih1, ih3, ihe3, ihe4, 'r_h3_he3_to_neut_h1_he4', '') - + call set(ineut, ih1, ihe3, ihe4, ili7, 'r_he3_li7_to_neut_h1_he4_he4', '') - + call set(ineut, ih1, ih3, ihe4, ibe7, 'r_h3_be7_to_neut_h1_he4_he4', '') - + num_special_case_reactions = i - + !write(*,2) 'num_special_case_reactions', num_special_case_reactions - - + + contains - + subroutine set(i1, i2, i3, i4, i5, s1_in, s2_in) integer, intent(in) :: i1, i2, i3, i4, i5 character (len=*), intent(in) :: s1_in, s2_in @@ -2294,13 +2294,13 @@ subroutine set(i1, i2, i3, i4, i5, s1_in, s2_in) special_case_reactants(5,i) = i5 s1 = s1_in s2 = s2_in - special_case_reactions(1,i) = s1 - special_case_reactions(2,i) = s2 + special_case_reactions(1,i) = s1 + special_case_reactions(2,i) = s2 end subroutine set - + end subroutine init_special_case_reaction_info - + end module net_initialize diff --git a/net/private/net_screen.f90 b/net/private/net_screen.f90 index 17e5b8406..a3427118c 100644 --- a/net/private/net_screen.f90 +++ b/net/private/net_screen.f90 @@ -24,16 +24,16 @@ ! *********************************************************************** module net_screen - + use const_def,only: dp, pi, ln10 use math_lib use chem_def, only: chem_isos, ih1, num_chem_isos use net_def, only: Net_General_Info, Net_Info use rates_def use utils_lib, only: mesa_error - + implicit none - + contains @@ -50,7 +50,7 @@ subroutine make_screening_tables(n, ierr) n% screening_mode, & 0d0, 0d0, 0d0, 1d0, ierr) end subroutine make_screening_tables - + subroutine screen_net( & g, num_isos, y, temp, den, logT, logRho, init, & @@ -61,7 +61,7 @@ subroutine screen_net( & use rates_def, only: Screen_Info, reaction_name use rates_lib, only: screen_set_context - + type (Net_General_Info), pointer :: g integer, intent(in) :: num_isos, screening_mode real(dp), intent(in) :: y(:), temp, den, logT, logRho, & @@ -76,9 +76,9 @@ subroutine screen_net( & integer :: num_reactions, i, ir, j, op_err real(dp) :: Tfactor, dTfactordt logical :: all_okay - + include 'formats' - + ierr = 0 if (.not. init) then @@ -88,7 +88,7 @@ subroutine screen_net( & end if num_reactions = g% num_reactions - + do i = 1, num_reactions ir = g% reaction_id(i) if (ir == 0) then @@ -104,7 +104,7 @@ subroutine screen_net( & i, sc, ir, ierr) if (ierr /= 0) then write(*,*) 'screen_net failed in eval_screen_triple ' // & - trim(reaction_name(ir)) + trim(reaction_name(ir)) return end if else if (reaction_screening_info(2,ir) > 0) then @@ -115,7 +115,7 @@ subroutine screen_net( & i, sc, ir, ierr) if (ierr /= 0) then write(*,*) 'screen_net failed in eval_screen_pair ' // & - trim(reaction_name(ir)) + trim(reaction_name(ir)) return end if else @@ -127,13 +127,13 @@ subroutine screen_net( & if (ierr /= 0) return if(init) return - + call set_combo_screen_rates(num_isos, y, sc, ierr) if (ierr /= 0) then write(*,*) 'screen_net failed in set_combo_screen_rates' return end if - + if (nrattab > 1 .and. (logT < g% logTcut_lim .or. logT <= g% logTcut_lo)) then ! strong rates cutoff smoothly for logT < logTcut_lim if (logT <= g% logTcut_lo) then @@ -156,10 +156,10 @@ subroutine screen_net( & end do end if end if - - + + contains - + subroutine screening_pair( & init, ir, jscr, sc, cid1, a1, z1, cid2, a2, z2, scor, scordt, scordd, ierr) use rates_lib, only: screen_init_AZ_info, screen_pair @@ -183,10 +183,10 @@ subroutine screening_pair( & g% aznut(jscr), g% zs13inv(jscr), & ierr) if (ierr /= 0) write(*,*) 'screen_init_AZ_info failed in screening_pair ' // & - trim(reaction_name(ir)) + trim(reaction_name(ir)) else if (cid1 > 0 .and. cid2 > 0) then - i1 = g% net_iso(cid1) + i1 = g% net_iso(cid1) i2 = g% net_iso(cid2) if (i1 == 0 .or. i2 == 0) then ! not in current net if (g% doing_approx21 .and. & @@ -200,27 +200,27 @@ subroutine screening_pair( & return end if end if - end if + end if call screen_pair( & sc, a1, z1, a2, z2, screening_mode, & g% zs13(jscr), g% zhat(jscr), g% zhat2(jscr), g% lzav(jscr), & g% aznut(jscr), g% zs13inv(jscr), g% logTcut_lo, & - scor, scordt, scordd, ierr) + scor, scordt, scordd, ierr) if (ierr /= 0) write(*,*) 'screen_pair failed in screening_pair ' // & - trim(reaction_name(ir)) - end if + trim(reaction_name(ir)) + end if end subroutine screening_pair - + subroutine set_rate_screening(i, sc1a, sc1adt, sc1add) integer, intent(in) :: i real(dp), intent(in) :: sc1a, sc1adt, sc1add include 'formats' - if (i == 0) return + if (i == 0) return rate_screened(i) = rate_raw(i)*sc1a rate_screened_dT(i) = rate_raw_dT(i)*sc1a + rate_raw(i)*sc1adt rate_screened_dRho(i) = rate_raw_dRho(i)*sc1a + rate_raw(i)*sc1add - end subroutine set_rate_screening - + end subroutine set_rate_screening + subroutine eval_screen_pair(init, jscr, i1, i2, i, sc, ir, ierr) use rates_def, only: Screen_Info logical, intent(in) :: init @@ -246,9 +246,9 @@ subroutine eval_screen_pair(init, jscr, i1, i2, i, sc, ir, ierr) init, ir, jscr, sc, i1, a1, z1, i2, a2, z2, sc1a, sc1adt, sc1add, ierr) if (ierr /= 0) return if (init) return - call set_rate_screening(i, sc1a, sc1adt, sc1add) + call set_rate_screening(i, sc1a, sc1adt, sc1add) end subroutine eval_screen_pair - + subroutine eval_screen_triple(init, jscr, i1_in, i2_in, i3_in, i, sc, ir, ierr) use rates_def, only: Screen_Info logical, intent(in) :: init @@ -308,13 +308,13 @@ subroutine eval_screen_triple(init, jscr, i1_in, i2_in, i3_in, i, sc, ir, ierr) scordt = sc1*sc2dt + sc1dt*sc2 scordd = sc1*sc2dd + sc1dd*sc2 call set_rate_screening(i, scor, scordt, scordd) - + if (.false.) write(*,2) 'scr 3 ' // trim(reaction_Name(ir)) & // ' ' // trim(chem_isos% name(i1)) & // ' ' // trim(chem_isos% name(i2)) & // ' ' // trim(chem_isos% name(i3)), & ir, scor - + end subroutine eval_screen_triple subroutine set_combo_screen_rates(num_isos, y, sc, ierr) @@ -328,10 +328,10 @@ subroutine set_combo_screen_rates(num_isos, y, sc, ierr) real(dp) :: rateII, rateIII, rsum, fII, fIII include 'formats' - + rtab => g% net_reaction ierr = 0 - + if (rtab(ir34_pp2) /= 0 .and. rtab(ir34_pp3) /= 0) then if (rate_screened(rtab(ir34_pp2)) /= & rate_screened(rtab(ir34_pp3))) then @@ -361,7 +361,7 @@ subroutine set_combo_screen_rates(num_isos, y, sc, ierr) fII = rateII / rsum end if fIII = 1d0 - fII - + rate_screened(rtab(ir34_pp2)) = fII*rate_screened(rtab(ir34_pp2)) rate_screened_dT(rtab(ir34_pp2)) = fII*rate_screened_dT(rtab(ir34_pp2)) rate_screened_dRho(rtab(ir34_pp2)) = fII*rate_screened_dRho(rtab(ir34_pp2)) @@ -375,103 +375,103 @@ subroutine set_combo_screen_rates(num_isos, y, sc, ierr) if (rtab(irn14_to_c12) /= 0) & call rate_for_pg_pa_branches( & rtab(irn14pg_aux), rtab(irn15pg_aux), rtab(irn15pa_aux), & - 0, rtab(irn14_to_c12)) + 0, rtab(irn14_to_c12)) if (rtab(irn14_to_o16) /= 0) & call rate_for_pg_pa_branches( & rtab(irn14pg_aux), rtab(irn15pg_aux), rtab(irn15pa_aux), & - rtab(irn14_to_o16), 0) - + rtab(irn14_to_o16), 0) + if (rtab(ir1616ppa) /= 0) & call rate_for_pg_pa_branches( & rtab(ir1616p_aux), rtab(irp31pg_aux), rtab(irp31pa_aux), & - 0, rtab(ir1616ppa)) - + 0, rtab(ir1616ppa)) + if (rtab(ir1616ppg) /= 0) & call rate_for_pg_pa_branches( & rtab(ir1616p_aux), rtab(irp31pg_aux), rtab(irp31pa_aux), & - rtab(ir1616ppg), 0) + rtab(ir1616ppg), 0) call rate_for_alpha_ap( & irc12ap_aux, irn15pg_aux, irn15pa_aux, & - irc12ap_to_o16) + irc12ap_to_o16) call rate_for_alpha_gp( & iro16gp_aux, irn15pg_aux, irn15pa_aux, & - iro16gp_to_c12) + iro16gp_to_c12) call rate_for_alpha_ap( & iro16ap_aux, irf19pg_aux, irf19pa_aux, & - iro16ap_to_ne20) + iro16ap_to_ne20) call rate_for_alpha_gp( & irne20gp_aux, irf19pg_aux, irf19pa_aux, & - irne20gp_to_o16) - + irne20gp_to_o16) + call rate_for_alpha_ap( & irne20ap_aux, irna23pg_aux, irna23pa_aux, & - irne20ap_to_mg24) - + irne20ap_to_mg24) + call rate_for_alpha_gp( & irmg24gp_aux, irna23pg_aux, irna23pa_aux, & - irmg24gp_to_ne20) - + irmg24gp_to_ne20) + call rate_for_alpha_ap( & irmg24ap_aux, iral27pg_aux, iral27pa_aux, & - irmg24ap_to_si28) - + irmg24ap_to_si28) + call rate_for_alpha_gp( & irsi28gp_aux, iral27pg_aux, iral27pa_aux, & - irsi28gp_to_mg24) - + irsi28gp_to_mg24) + call rate_for_alpha_ap( & irsi28ap_aux, irp31pg_aux, irp31pa_aux, & - irsi28ap_to_s32) + irsi28ap_to_s32) call rate_for_alpha_gp( & irs32gp_aux, irp31pg_aux, irp31pa_aux, & - irs32gp_to_si28) - + irs32gp_to_si28) + call rate_for_alpha_ap( & irs32ap_aux, ircl35pg_aux, ircl35pa_aux, & - irs32ap_to_ar36) - + irs32ap_to_ar36) + call rate_for_alpha_gp( & irar36gp_aux, ircl35pg_aux, ircl35pa_aux, & - irar36gp_to_s32) - + irar36gp_to_s32) + call rate_for_alpha_ap( & irar36ap_aux, irk39pg_aux, irk39pa_aux, & - irar36ap_to_ca40) + irar36ap_to_ca40) call rate_for_alpha_gp( & irca40gp_aux, irk39pg_aux, irk39pa_aux, & - irca40gp_to_ar36) + irca40gp_to_ar36) call rate_for_alpha_ap( & irca40ap_aux, irsc43pg_aux, irsc43pa_aux, & - irca40ap_to_ti44) + irca40ap_to_ti44) call rate_for_alpha_gp( & irti44gp_aux, irsc43pg_aux, irsc43pa_aux, & - irti44gp_to_ca40) + irti44gp_to_ca40) call rate_for_alpha_ap( & irti44ap_aux, irv47pg_aux, irv47pa_aux, & - irti44ap_to_cr48) - + irti44ap_to_cr48) + call rate_for_alpha_gp( & ircr48gp_aux, irv47pg_aux, irv47pa_aux, & - ircr48gp_to_ti44) + ircr48gp_to_ti44) call rate_for_alpha_ap( & ircr48ap_aux, irmn51pg_aux, irmn51pa_aux, & - ircr48ap_to_fe52) - + ircr48ap_to_fe52) + call rate_for_alpha_gp( & irfe52gp_aux, irmn51pg_aux, irmn51pa_aux, & - irfe52gp_to_cr48) - + irfe52gp_to_cr48) + end subroutine set_combo_screen_rates @@ -487,7 +487,7 @@ subroutine rate_for_alpha_ap(ir_start, irpg, irpa, ir_with_pg) end subroutine rate_for_alpha_ap subroutine rate_for_alpha_gp(ir_start, irpg, irpa, ir_with_pa) - integer, intent(in) :: ir_start, irpg, irpa, ir_with_pa + integer, intent(in) :: ir_start, irpg, irpa, ir_with_pa integer, pointer :: rtab(:) if (ir_start == 0) return rtab => g% net_reaction @@ -495,14 +495,14 @@ subroutine rate_for_alpha_gp(ir_start, irpg, irpa, ir_with_pa) call rate_for_pg_pa_branches( & rtab(ir_start), rtab(irpg), rtab(irpa), 0, rtab(ir_with_pa)) end subroutine rate_for_alpha_gp - + subroutine rate_for_pg_pa_branches(ir_start, irpg, irpa, ir_with_pg, ir_with_pa) integer, intent(in) :: ir_start, irpg, irpa, ir_with_pg, ir_with_pa - + real(dp) :: pg_raw_rate, pa_raw_rate, pg_frac, pa_frac real(dp) :: d_pg_frac_dT, d_pg_frac_dRho, d_pa_frac_dT, d_pa_frac_dRho real(dp) :: r, drdT, drdd, x - + if (ir_start == 0) then write(*,*) 'ir_start', ir_start if (irpg /= 0) write(*,*) trim(reaction_Name(g% reaction_id(irpg))) // ' irpg' @@ -511,58 +511,58 @@ subroutine rate_for_pg_pa_branches(ir_start, irpg, irpa, ir_with_pg, ir_with_pa) if (ir_with_pa /= 0) write(*,*) trim(reaction_Name(g% reaction_id(ir_with_pa))) // ' ir_with_pa' call mesa_error(__FILE__,__LINE__,'rate_for_pg_pa_branches') end if - + if (irpg == 0) then write(*,*) 'irpg', irpg if (ir_with_pg /= 0) write(*,*) trim(reaction_Name(g% reaction_id(ir_with_pg))) // ' ir_with_pg' if (ir_with_pa /= 0) write(*,*) trim(reaction_Name(g% reaction_id(ir_with_pa))) // ' ir_with_pa' call mesa_error(__FILE__,__LINE__,'rate_for_pg_pa_branches') end if - + if (irpa == 0) then write(*,*) 'irpg', irpg if (ir_with_pg /= 0) write(*,*) trim(reaction_Name(g% reaction_id(ir_with_pg))) // ' ir_with_pg' if (ir_with_pa /= 0) write(*,*) trim(reaction_Name(g% reaction_id(ir_with_pa))) // ' ir_with_pa' call mesa_error(__FILE__,__LINE__,'rate_for_pg_pa_branches') end if - + pg_raw_rate = rate_raw(irpg) pa_raw_rate = rate_raw(irpa) - + if (pg_raw_rate + pa_raw_rate < 1d-99) then ! avoid divide by 0 pg_raw_rate = 1; pa_raw_rate = 1 end if - + pg_frac = pg_raw_rate / (pg_raw_rate + pa_raw_rate) pa_frac = 1 - pg_frac - + x = pg_raw_rate + pa_raw_rate d_pg_frac_dT = & (pa_raw_rate*rate_raw_dT(irpg) - pg_raw_rate*rate_raw_dT(irpa)) / (x*x) d_pa_frac_dT = -d_pg_frac_dT - + d_pg_frac_dRho = & (pa_raw_rate*rate_raw_dRho(irpg) - pg_raw_rate*rate_raw_dRho(irpa)) / (x*x) d_pa_frac_dRho = -d_pg_frac_dRho - + r = rate_screened(ir_start) drdT = rate_screened_dT(ir_start) drdd = rate_screened_dRho(ir_start) - + if (ir_with_pg /= 0) then rate_screened(ir_with_pg) = r*pg_frac rate_screened_dT(ir_with_pg) = r*d_pg_frac_dT + drdT*pg_frac rate_screened_dRho(ir_with_pg) = r*d_pg_frac_dRho + drdd*pg_frac end if - + if (ir_with_pa /= 0) then rate_screened(ir_with_pa) = r*pa_frac rate_screened_dT(ir_with_pa) = r*d_pa_frac_dT + drdT*pa_frac rate_screened_dRho(ir_with_pa) = r*d_pa_frac_dRho + drdd*pa_frac end if - + end subroutine rate_for_pg_pa_branches - + end subroutine screen_net diff --git a/net/public/net_def.f90 b/net/public/net_def.f90 index eee2172d8..df8b90b4a 100644 --- a/net/public/net_def.f90 +++ b/net/public/net_def.f90 @@ -24,9 +24,9 @@ ! *********************************************************************** module net_def - + use const_def, only: dp, qp - + implicit none @@ -38,7 +38,7 @@ module net_def integer, parameter :: num_kinds = weak_kind ! for reaction_reaclib_kind array in Net_General_Info - integer, parameter :: other_kind = 0 + integer, parameter :: other_kind = 0 ! includes weak reactions and reactions that don't have reverse in net ! and one of each pair of 2 to 2 reactions (including np, pa, na) integer, parameter :: ng_kind = other_kind + 1 @@ -51,24 +51,24 @@ module net_def integer, parameter :: general_two_one_kind = general_one_one_kind + 1 ! 2 species in and 1 out integer, parameter :: general_two_two_kind = general_two_one_kind + 1 ! 2 species in and 2 out integer, parameter :: max_kind = general_two_two_kind - - + + type Net_General_Info ! things that are constant for the particular net ! it is okay to have multiple threads using the same instance of this simultaneously. - integer :: num_isos ! total number in current net + integer :: num_isos ! total number in current net integer :: num_reactions ! total number of reactions for current net - + logical :: doing_approx21, add_co56_to_approx21 - + integer :: approx21_ye_iso ! e.g., icr56 for fake fe56ec integer :: fe56ec_n_neut ! number of neutrons consumed per fake fe56ec - + character (len=32) :: cache_suffix ! isotopes @@ -78,43 +78,43 @@ module net_def ! else is value between 1 and num_isos in current net integer, pointer :: chem_id(:) ! maps net iso number to chem id ! index from 1 to num_isos in current net - ! value is between 1 and num_chem_isos + ! value is between 1 and num_chem_isos ! reactions - + integer, pointer :: net_reaction(:) ! maps reaction id to net reaction number - ! index from 1 to rates_reaction_id_max (in rates_def) + ! index from 1 to rates_reaction_id_max (in rates_def) ! value is 0 if the reaction is not in the current net ! else is value between 1 and num_reactions in current net integer, allocatable :: reaction_id(:) ! maps net reaction number to reaction id ! index from 1 to num_reactions in current net - ! value is between 1 and rates_reaction_id_max (in rates_def) + ! value is between 1 and rates_reaction_id_max (in rates_def) integer, allocatable :: reaction_kind(:) integer, pointer :: reaction_reaclib_kind(:) integer, pointer :: reverse_id_for_kind_ne_other(:) - + integer, allocatable :: reaction_max_Z(:) integer, allocatable:: reaction_max_Z_plus_N_for_max_Z(:) - + ! extra info - + ! strong rates cutoff smoothly for logT < logTcut_lim real(dp) :: logTcut_lim ! strong rates are zero logT < logTcut_lo real(dp) :: logTcut_lo - + ! equilibrium eps_nuc cancelation for ng, pg, pn reactions ! at high T, these reactions are assumed in equilibrium with their reverses, ! so no net eps_nuc from the pair real(dp) :: logT_lo_eps_nuc_cancel ! no cancelation for logT <= this real(dp) :: logT_hi_eps_nuc_cancel ! full cancelation for logT >= this - + real(dp) :: fe56ec_fake_factor, min_T_for_fe56ec_fake_factor - + ! the following is private info for the implementation - + ! tables for screen5 real(dp), allocatable :: zs13(:) ! (num_reactions) ! zs13 = (z1+z2)**(1./3.) real(dp), allocatable :: zhat(:) ! (num_reactions) @@ -122,7 +122,7 @@ module net_def real(dp), allocatable :: lzav(:) ! (num_reactions) real(dp), allocatable :: aznut(:) ! (num_reactions) real(dp), allocatable :: zs13inv(:) ! (num_reactions) ! zs13inv = 1 / zs13 - + ! info for evaluation of the raw reaction rates real(dp), pointer :: rate_table(:,:) ! (nrate_table,num_reactions) real(dp), pointer :: rattab_f1(:) ! =(4,nrattab,num_reactions) ! for interpolation @@ -146,13 +146,13 @@ module net_def weak_reaction_index(:), & ! (1:num_reactions) = num in 1:num_wk_reactions weak_reaction_num(:), & ! (1:num_wk_reactions) = num in 1:num_reactions reaction_id_for_weak_reactions(:) ! (1:num_wk_reactions) = rates reaction id - + ! top level file name for net character (len=256) :: net_filename - + ! timing logical :: doing_timing - ! the following are sums of results from system_clock. + ! the following are sums of results from system_clock. ! divide by clock_rate to get seconds. ! must set all of these to 0 before change doing_timing to true. integer(8) :: clock_net_eval @@ -164,7 +164,7 @@ module net_def integer(8) :: clock_derivs_setup integer(8) :: clock_derivs_general integer(8) :: clock_net_get - + ! bookkeeping integer :: handle logical :: net_has_been_defined @@ -178,26 +178,26 @@ module net_def end type Net_General_Info integer, parameter :: num_weak_info_arrays_in_Net_Info = 9 ! weaklib results - - + + type Net_Info ! this is working storage for the nuclear reaction calculations - + ! pointers to caller supplied arrays ---------------------------------- - real(dp), pointer :: reaction_Qs(:) ! if null, use standard values + real(dp), pointer :: reaction_Qs(:) ! if null, use standard values real(dp), pointer :: reaction_neuQs(:) ! if null, use standard values real(dp), allocatable :: eps_nuc_categories(:) ! (num_categories) ! eps_nuc subtotals for each reaction category - + real(dp), allocatable, dimension(:) :: & rate_screened, rate_screened_dT, rate_screened_dRho ! (num_rates) ! the units here depend on the number of reactants. ! in all cases, the rate_screened times as many molar fractions as there are reactants ! gives a number with the same units as dy/dt. ! so for a 2-body reaction, there are 2 Y factors, each with units [moles/gram] - ! and the rate_screened units for such a reaction are [grams/(mole-sec)], + ! and the rate_screened units for such a reaction are [grams/(mole-sec)], ! which when multiplied by [moles/gram]^2 gives the same units as dydt. ! for a 1-body reaction (e.g., a decay), ! there is only 1 Y factor, so the units are [1/second]. @@ -209,7 +209,7 @@ module net_def ! raw rates are unscreened (but include density factors) real(dp), allocatable,dimension(:) :: rate_factors ! (num_rates) - + ! pointers into work array ---------------------------------- ! molar fractions and their rates of change @@ -222,7 +222,7 @@ module net_def real(dp), allocatable,dimension(:,:) :: dfdy real(dp), allocatable,dimension(:) :: dratdumdy1, dratdumdy2, & d_epsnuc_dy, d_epsneu_dy, dydt1, dfdT, dfdRho - + ! weaklib results real(dp), dimension(:), allocatable :: & lambda, dlambda_dlnT, dlambda_dlnRho, & @@ -248,14 +248,14 @@ module net_def real(qp), allocatable,dimension(:,:) :: dydt real(dp), allocatable,dimension(:,:) :: d_dxdt_dx - ! These contain the rates after being mutlplied by th various density and composition factors + ! These contain the rates after being mutlplied by th various density and composition factors ! but would still need to be mulipled by the zone mass for the absolute value - real(dp), allocatable,dimension(:) :: raw_rate, screened_rate, eps_nuc_rate, eps_neu_rate + real(dp), allocatable,dimension(:) :: raw_rate, screened_rate, eps_nuc_rate, eps_neu_rate ! Passed in by star integer :: star_id = -1, zone = -1 - + end type Net_Info @@ -285,11 +285,11 @@ end subroutine other_net_derivs_interface procedure(other_net_derivs_interface), pointer :: & net_other_net_derivs => null() - + ! private to the implementation integer, parameter :: max_net_handles = 10 type (Net_General_Info), target :: net_handles(max_net_handles) - + character (len=256) :: net_dir integer :: weak_rate_id_for_ni56_ec, weak_rate_id_for_co56_ec @@ -304,11 +304,11 @@ end subroutine other_net_derivs_interface integer, parameter :: i_sparse_format = 5 integer, parameter :: i_clip = 6 integer, parameter :: i_ntimes = 7 - + integer, parameter :: burn_lipar = i_ntimes - ! Note: We need burn_lrpar /= burn_const_P_lrpar so that we can determine whether we are doing a normal burn or - ! one at const_P. This is needed in burn_solout in mod_one_zone_burn. + ! Note: We need burn_lrpar /= burn_const_P_lrpar so that we can determine whether we are doing a normal burn or + ! one at const_P. This is needed in burn_solout in mod_one_zone_burn. integer, parameter :: r_burn_temp = 1 integer, parameter :: r_burn_lgT = 2 integer, parameter :: r_burn_rho = 3 @@ -330,7 +330,7 @@ end subroutine other_net_derivs_interface integer, parameter :: r_burn_const_P_temperature = 6 integer, parameter :: r_burn_const_P_init_lnS = 7 integer, parameter :: r_burn_const_P_lnS = 8 - + integer, parameter :: burn_const_P_lrpar = r_burn_const_P_lnS logical :: net_test_partials @@ -340,7 +340,7 @@ end subroutine other_net_derivs_interface contains - + subroutine do_net_def_init use const_def, only: mesa_data_dir use rates_lib, only: get_weak_rate_id @@ -355,22 +355,22 @@ subroutine do_net_def_init net_handles(i)% num_isos = 0 net_handles(i)% num_reactions = 0 end do - + weak_rate_id_for_ni56_ec = get_id('ni56','co56') weak_rate_id_for_co56_ec = get_id('co56','fe56') - + contains - + integer function get_id(iso1, iso2) character(len=*), intent(in) :: iso1, iso2 include 'formats' get_id = get_weak_rate_id(iso1, iso2) if (get_id == 0) then write(*,2) 'failed to find weak reaction for ' // trim(iso1) & - // ' to ' // trim(iso2) + // ' to ' // trim(iso2) end if end function get_id - + end subroutine do_net_def_init @@ -398,8 +398,8 @@ integer function do_alloc_net(ierr) end if call init_net_handle_data(do_alloc_net) end function do_alloc_net - - + + subroutine init_net_handle_data(handle) use rates_def integer, intent(in) :: handle @@ -524,15 +524,15 @@ subroutine do_free_net(handle) g% num_reactions = 0 g% num_wk_reactions = 0 end if - - + + end subroutine do_free_net - + subroutine get_net_ptr(handle, g, ierr) integer, intent(in) :: handle type (Net_General_Info), pointer :: g - integer, intent(out):: ierr + integer, intent(out):: ierr if (handle < 1 .or. handle > max_net_handles) then ierr = -1 return @@ -545,7 +545,7 @@ end subroutine get_net_ptr integer function get_net_timing_total(handle, ierr) integer, intent(in) :: handle type (Net_General_Info), pointer :: g - integer, intent(inout) :: ierr + integer, intent(inout) :: ierr ierr = 0 call get_net_ptr(handle, g, ierr) if (ierr /= 0) then @@ -566,7 +566,7 @@ end function get_net_timing_total subroutine zero_net_timing(handle,ierr) integer, intent(in) :: handle type (Net_General_Info), pointer :: g - integer, intent(inout) :: ierr + integer, intent(inout) :: ierr ierr = 0 call get_net_ptr(handle, g, ierr) if (ierr /= 0) then @@ -576,16 +576,16 @@ subroutine zero_net_timing(handle,ierr) g% clock_net_eval = 0 g% clock_net_weak_rates = 0 - g% clock_net_rate_tables = 0 - g% clock_net_screen = 0 + g% clock_net_rate_tables = 0 + g% clock_net_screen = 0 g% clock_net_derivs = 0 - + g% clock_derivs_setup = 0 g% clock_derivs_select = 0 g% clock_derivs_general = 0 g% clock_net_get = 0 end subroutine zero_net_timing - + subroutine do_net_set_fe56ec_fake_factor( & handle, fe56ec_fake_factor, min_T_for_fe56ec_fake_factor, ierr) integer, intent(in) :: handle @@ -600,12 +600,12 @@ subroutine do_net_set_fe56ec_fake_factor( & g% fe56ec_fake_factor = fe56ec_fake_factor g% min_T_for_fe56ec_fake_factor = min_T_for_fe56ec_fake_factor end subroutine do_net_set_fe56ec_fake_factor - - + + subroutine do_net_set_logTcut(handle, logTcut_lo, logTcut_lim, ierr) integer, intent(in) :: handle - real(dp), intent(in) :: logTcut_lo - real(dp), intent(in) :: logTcut_lim + real(dp), intent(in) :: logTcut_lo + real(dp), intent(in) :: logTcut_lim integer, intent(out) :: ierr type (Net_General_Info), pointer :: g call get_net_ptr(handle, g, ierr) @@ -616,13 +616,13 @@ subroutine do_net_set_logTcut(handle, logTcut_lo, logTcut_lim, ierr) g% logTcut_lo = logTcut_lo g% logTcut_lim = logTcut_lim end subroutine do_net_set_logTcut - - + + subroutine do_net_set_eps_nuc_cancel( & handle, logT_lo_eps_nuc_cancel, logT_hi_eps_nuc_cancel, ierr) integer, intent(in) :: handle - real(dp), intent(in) :: logT_lo_eps_nuc_cancel - real(dp), intent(in) :: logT_hi_eps_nuc_cancel + real(dp), intent(in) :: logT_lo_eps_nuc_cancel + real(dp), intent(in) :: logT_hi_eps_nuc_cancel integer, intent(out) :: ierr type (Net_General_Info), pointer :: g call get_net_ptr(handle, g, ierr) diff --git a/net/public/net_lib.f90 b/net/public/net_lib.f90 index 20178c091..b1c902c90 100644 --- a/net/public/net_lib.f90 +++ b/net/public/net_lib.f90 @@ -22,56 +22,56 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module net_lib ! library for calculating nuclear reaction rates and energy production ! the data interface for the library is defined in net_def - + use chem_def use const_def, only: dp - + implicit none contains ! the procedure interface for the library ! client programs should only call these routines. - - - ! call this routine to initialize the net module. + + + ! call this routine to initialize the net module. ! only needs to be done once at start of run. - - subroutine net_init(ierr) + + subroutine net_init(ierr) use net_def, only : do_net_def_init use net_initialize, only : init_special_case_reaction_info - integer, intent(out) :: ierr ! 0 means AOK. - ierr = 0 + integer, intent(out) :: ierr ! 0 means AOK. + ierr = 0 call do_net_def_init call init_special_case_reaction_info - + end subroutine net_init - - + + subroutine net_shutdown end subroutine net_shutdown - + ! after net_init has finished, you can allocate a "handle". - + integer function alloc_net_handle(ierr) use net_def, only: do_alloc_net, init_net_handle_data integer, intent(out) :: ierr alloc_net_handle = do_alloc_net(ierr) if (ierr /= 0) return - end function alloc_net_handle - + end function alloc_net_handle + subroutine free_net_handle(handle) ! frees the handle and all associated data use net_def, only: do_free_net integer, intent(in) :: handle call do_free_net(handle) - end subroutine free_net_handle - - ! if you want to access the Net_General_Info record directly, + end subroutine free_net_handle + + ! if you want to access the Net_General_Info record directly, ! you'll need a pointer to it. subroutine net_ptr(handle, g, ierr) use net_def, only: Net_General_Info, get_net_ptr @@ -80,11 +80,11 @@ subroutine net_ptr(handle, g, ierr) integer, intent(out):: ierr call get_net_ptr(handle, g, ierr) end subroutine net_ptr - - + + ! routines for defining the net isos and reactions - + ! call this before starting to define ! the set of isotopes and reactions for the net. subroutine net_start_def(handle, ierr) @@ -93,8 +93,8 @@ subroutine net_start_def(handle, ierr) integer, intent(out) :: ierr call start_net_def(handle, ierr) end subroutine net_start_def - - + + ! call this after you've finished defining ! the set of isotopes and reactions for the net. subroutine net_finish_def(handle, ierr) @@ -103,15 +103,15 @@ subroutine net_finish_def(handle, ierr) integer, intent(out) :: ierr call finish_net_def(handle, ierr) end subroutine net_finish_def - + ! note: after net_finish_def returns, ! you have the option of reordering the isotopes ! before you set up the full set of tables for the net. ! use get_chem_id_table_ptr and get_net_iso_table_ptr ! and change both tables to permute the set of isotopes. ! the default isotope ordering is by increasing chem_id number. - - + + ! read_net_file first tries opening the filename in the current directory. ! if doesn't find that file, then tries the data_dir from the call on net_init. ! i.e., looks for /net_data/nets/ @@ -123,8 +123,8 @@ subroutine read_net_file(filename, handle, ierr) integer, intent(out) :: ierr call do_read_net_file(filename, handle, ierr) end subroutine read_net_file - - + + subroutine net_add_iso(handle, iso_id, ierr) use net_initialize, only:add_net_iso integer, intent(in) :: handle @@ -132,8 +132,8 @@ subroutine net_add_iso(handle, iso_id, ierr) integer, intent(out) :: ierr call add_net_iso(handle, iso_id, ierr) end subroutine net_add_iso - - + + subroutine net_add_isos(handle, num_isos, iso_ids, ierr) use net_initialize, only:add_net_isos integer, intent(in) :: handle @@ -141,8 +141,8 @@ subroutine net_add_isos(handle, num_isos, iso_ids, ierr) integer, intent(out) :: ierr call add_net_isos(handle, num_isos, iso_ids, ierr) end subroutine net_add_isos - - + + subroutine net_remove_iso(handle, iso_id, ierr) use net_initialize, only:remove_net_iso integer, intent(in) :: handle @@ -150,8 +150,8 @@ subroutine net_remove_iso(handle, iso_id, ierr) integer, intent(out) :: ierr call remove_net_iso(handle, iso_id, ierr) end subroutine net_remove_iso - - + + subroutine net_remove_isos(handle, num_isos, iso_ids, ierr) use net_initialize, only:remove_net_isos integer, intent(in) :: handle @@ -159,8 +159,8 @@ subroutine net_remove_isos(handle, num_isos, iso_ids, ierr) integer, intent(out) :: ierr call remove_net_isos(handle, num_isos, iso_ids, ierr) end subroutine net_remove_isos - - + + subroutine net_add_reaction(handle, reaction_id, ierr) use net_initialize, only:add_net_reaction integer, intent(in) :: handle @@ -168,8 +168,8 @@ subroutine net_add_reaction(handle, reaction_id, ierr) integer, intent(out) :: ierr call add_net_reaction(handle, reaction_id, ierr) end subroutine net_add_reaction - - + + subroutine net_add_reactions(handle, num_reactions, reaction_ids, ierr) use net_initialize, only:add_net_reactions integer, intent(in) :: handle @@ -177,8 +177,8 @@ subroutine net_add_reactions(handle, num_reactions, reaction_ids, ierr) integer, intent(out) :: ierr call add_net_reactions(handle, num_reactions, reaction_ids, ierr) end subroutine net_add_reactions - - + + subroutine net_remove_reaction(handle, reaction_id, ierr) use net_initialize, only:remove_net_reaction integer, intent(in) :: handle @@ -186,8 +186,8 @@ subroutine net_remove_reaction(handle, reaction_id, ierr) integer, intent(out) :: ierr call remove_net_reaction(handle, reaction_id, ierr) end subroutine net_remove_reaction - - + + subroutine net_remove_reactions(handle, num_reactions, reaction_ids, ierr) use net_initialize, only:remove_net_reactions integer, intent(in) :: handle @@ -195,8 +195,8 @@ subroutine net_remove_reactions(handle, num_reactions, reaction_ids, ierr) integer, intent(out) :: ierr call remove_net_reactions(handle, num_reactions, reaction_ids, ierr) end subroutine net_remove_reactions - - + + subroutine show_net_reactions(handle, iounit, ierr) use net_def use rates_def, only: reaction_Name @@ -214,7 +214,7 @@ subroutine show_net_reactions(handle, iounit, ierr) end do end subroutine show_net_reactions - + subroutine show_net_reactions_and_info(handle, iounit, ierr) use net_def use rates_def, only: & @@ -255,7 +255,7 @@ subroutine show_net_reactions_and_info(handle, iounit, ierr) else if (Q /= 0) then write(iounit,'(i4,a30,f16.6,16x,4x,a10,4x,a66)') i, trim(reaction_Name(id)), & Q, trim(category_name(icat)), info - else + else write(iounit,'(i4,a30,16x,16x,4x,a10,4x,a66)') i, trim(reaction_Name(id)), & trim(category_name(icat)), info end if @@ -263,8 +263,8 @@ subroutine show_net_reactions_and_info(handle, iounit, ierr) end do write(iounit,'(A)') end subroutine show_net_reactions_and_info - - + + subroutine show_net_species(handle, iounit, ierr) use net_def use chem_def @@ -281,8 +281,8 @@ subroutine show_net_species(handle, iounit, ierr) if (id > 0) write(iounit,'(i4,a10)') i, trim(chem_isos% name(id)) end do end subroutine show_net_species - - + + subroutine show_net_params(handle, iounit, ierr) use net_def integer, intent(in) :: handle @@ -293,11 +293,11 @@ subroutine show_net_params(handle, iounit, ierr) include 'formats' ierr = 0 call get_net_ptr(handle, g, ierr) - if (ierr /= 0) return + if (ierr /= 0) return write(iounit,2) 'logTcut_lo =', g% logTcut_lo write(iounit,2) 'logTcut_lim =', g% logTcut_lim end subroutine show_net_params - + subroutine net_set_fe56ec_fake_factor( & handle, fe56ec_fake_factor, min_T_for_fe56ec_fake_factor, ierr) use net_def, only: do_net_set_fe56ec_fake_factor @@ -309,24 +309,24 @@ subroutine net_set_fe56ec_fake_factor( & handle, fe56ec_fake_factor, min_T_for_fe56ec_fake_factor, ierr) if (ierr /= 0) return end subroutine net_set_fe56ec_fake_factor - - + + subroutine net_set_logTcut(handle, logTcut_lo, logTcut_lim, ierr) use net_def, only: do_net_set_logTcut integer, intent(in) :: handle - real(dp), intent(in) :: logTcut_lo - real(dp), intent(in) :: logTcut_lim + real(dp), intent(in) :: logTcut_lo + real(dp), intent(in) :: logTcut_lim integer, intent(out) :: ierr ierr = 0 call do_net_set_logTcut(handle, logTcut_lo, logTcut_lim, ierr) if (ierr /= 0) return end subroutine net_set_logTcut - - + + subroutine net_set_eps_nuc_cancel(handle, logT_lo_eps_nuc_cancel, logT_hi_eps_nuc_cancel, ierr) use net_def, only: do_net_set_eps_nuc_cancel integer, intent(in) :: handle - real(dp), intent(in) :: logT_lo_eps_nuc_cancel, logT_hi_eps_nuc_cancel + real(dp), intent(in) :: logT_lo_eps_nuc_cancel, logT_hi_eps_nuc_cancel integer, intent(out) :: ierr ierr = 0 call do_net_set_eps_nuc_cancel(handle, logT_lo_eps_nuc_cancel, logT_hi_eps_nuc_cancel, ierr) @@ -357,10 +357,10 @@ subroutine net_setup_tables(handle, cache_suffix, ierr) end if end subroutine net_setup_tables - + ! general info about the net - - + + integer function net_num_isos(handle, ierr) ! total number in current net use net_def, only: Net_General_Info, get_net_ptr integer, intent(in) :: handle @@ -374,7 +374,7 @@ integer function net_num_isos(handle, ierr) ! total number in current net end if net_num_isos = g% num_isos end function net_num_isos - + integer function net_num_reactions(handle, ierr) ! total number of rates for net use net_def, only: Net_General_Info, get_net_ptr integer, intent(in) :: handle @@ -388,7 +388,7 @@ integer function net_num_reactions(handle, ierr) ! total number of rates for net end if net_num_reactions = g% num_reactions end function net_num_reactions - + subroutine get_chem_id_table(handle, num_isos, chem_id, ierr) use net_def, only: Net_General_Info, get_net_ptr integer, intent(in) :: handle, num_isos ! num_isos must be number of isos in current net @@ -427,7 +427,7 @@ subroutine get_chem_id_table_ptr(handle, chem_id_ptr, ierr) end if chem_id_ptr => g% chem_id end subroutine get_chem_id_table_ptr - + subroutine get_net_iso_table(handle, net_iso_table, ierr) use net_def, only: Net_General_Info, get_net_ptr integer, intent(in) :: handle @@ -446,7 +446,7 @@ subroutine get_net_iso_table(handle, net_iso_table, ierr) net_iso_table(1:num_chem_isos) = g% net_iso(1:num_chem_isos) ierr = 0 end subroutine get_net_iso_table - + subroutine get_net_iso_table_ptr(handle, net_iso_ptr, ierr) use net_def, only: Net_General_Info, get_net_ptr integer, intent(in) :: handle @@ -468,9 +468,9 @@ end subroutine get_net_iso_table_ptr subroutine get_reaction_id_table(handle, num_reactions, reaction_id, ierr) use net_def, only: Net_General_Info, get_net_ptr - integer, intent(in) :: handle, num_reactions + integer, intent(in) :: handle, num_reactions ! num_reactions must be number of reactions in current net - integer, intent(out) :: reaction_id(num_reactions) + integer, intent(out) :: reaction_id(num_reactions) ! maps net reaction number to reaction id ! index from 1 to num_reactions in current net ! value is between 1 and num_reactions @@ -490,7 +490,7 @@ subroutine get_reaction_id_table(handle, num_reactions, reaction_id, ierr) reaction_id(1:num_reactions) = g% reaction_id(1:num_reactions) ierr = 0 end subroutine get_reaction_id_table - + subroutine get_reaction_id_table_ptr(handle, reaction_id_ptr, ierr) use net_def, only: Net_General_Info, get_net_ptr integer, intent(in) :: handle @@ -507,12 +507,12 @@ subroutine get_reaction_id_table_ptr(handle, reaction_id_ptr, ierr) end if reaction_id_ptr => g% reaction_id end subroutine get_reaction_id_table_ptr - + subroutine get_net_reaction_table(handle, net_reaction_table, ierr) use net_def, only: Net_General_Info, get_net_ptr use rates_def, only: rates_reaction_id_max integer, intent(in) :: handle - integer, intent(out) :: net_reaction_table(rates_reaction_id_max) + integer, intent(out) :: net_reaction_table(rates_reaction_id_max) ! maps reaction id to net reaction number ! index from 1 to rates_reaction_id_max ! value is 0 if the reaction is not in the current net @@ -529,11 +529,11 @@ subroutine get_net_reaction_table(handle, net_reaction_table, ierr) net_reaction_table(1:rates_reaction_id_max) = g% net_reaction(1:rates_reaction_id_max) ierr = 0 end subroutine get_net_reaction_table - + subroutine get_net_reaction_table_ptr(handle, net_reaction_ptr, ierr) use net_def, only: Net_General_Info, get_net_ptr integer, intent(in) :: handle - integer, pointer :: net_reaction_ptr(:) + integer, pointer :: net_reaction_ptr(:) ! maps reaction id to net reaction number ! index from 1 to num_reactions ! value is 0 if the reaction is not in the current net @@ -553,7 +553,7 @@ end subroutine get_net_reaction_table_ptr ! net evaluation routines - + subroutine net_get( & handle, just_dxdt, n, num_isos, num_reactions, & x, temp, log10temp, rho, log10rho, & @@ -568,12 +568,12 @@ subroutine net_get( & use chem_def, only: num_categories use net_eval, only: eval_net use net_def, only: Net_General_Info, Net_Info, get_net_ptr - + use rates_def, only: num_rvs - + ! provide T or logT or both (the code needs both, so pass 'em if you've got 'em!) ! same for Rho and logRho - + integer, intent(in) :: handle logical, intent(in) :: just_dxdt type (Net_Info) :: n @@ -585,9 +585,9 @@ subroutine net_get( & real(dp), intent(in) :: abar ! mean number of nucleons per nucleus real(dp), intent(in) :: zbar ! mean charge per nucleus real(dp), intent(in) :: z2bar ! mean charge squared per nucleus - real(dp), intent(in) :: ye + real(dp), intent(in) :: ye ! mean number free electrons per nucleon, assuming complete ionization - ! d_dxdt_dx(i, j) is d_dxdt(i)_dx(j), + ! d_dxdt_dx(i, j) is d_dxdt(i)_dx(j), ! i.e., partial derivative of rate for i'th isotope wrt j'th isotope abundance real(dp), intent(in) :: eta, d_eta_dlnT, d_eta_dlnRho ! electron degeneracy from eos. ! this arg is only used for prot(e-nu)neut and neut(e+nu)prot. @@ -604,25 +604,25 @@ subroutine net_get( & real(dp), intent(out) :: eps_nuc ! ergs/g/s from burning after including losses from reaction neutrinos real(dp), intent(out) :: d_eps_nuc_dT real(dp), intent(out) :: d_eps_nuc_dRho - real(dp), intent(inout) :: d_eps_nuc_dx(:) ! (num_isos) + real(dp), intent(inout) :: d_eps_nuc_dx(:) ! (num_isos) ! partial derivatives wrt mass fractions - + real(dp), intent(inout) :: dxdt(:) ! (num_isos) ! rate of change of mass fractions caused by nuclear reactions real(dp), intent(inout) :: d_dxdt_dRho(:) ! (num_isos) real(dp), intent(inout) :: d_dxdt_dT(:) ! (num_isos) real(dp), intent(inout) :: d_dxdt_dx(:,:) ! (num_isos, num_isos) ! partial derivatives of rates wrt mass fractions - + real(dp), intent(inout) :: eps_nuc_categories(:) ! (num_categories) ! eps_nuc subtotals for each reaction category real(dp), intent(out) :: eps_neu_total ! ergs/g/s neutrinos from weak reactions - integer, intent(in) :: screening_mode - + integer, intent(in) :: screening_mode + integer, intent(out) :: ierr ! 0 means okay - + integer(8) :: time0, time1 type (Net_General_Info), pointer :: g real(dp), pointer, dimension(:) :: actual_Qs, actual_neuQs @@ -639,13 +639,13 @@ subroutine net_get( & write(*,*) 'invalid handle for net_get -- did you call alloc_net_handle?' return end if - + if (g% doing_timing) then call system_clock(time0) else time0 = 0 endif - + call eval_net( & n, g, rates_only, just_dxdt, num_isos, num_reactions, g% num_wk_reactions, & x, temp, log10temp, rho, log10rho, & @@ -664,7 +664,7 @@ subroutine net_get( & end if end subroutine net_get - + subroutine net_get_rates_only( & handle, n, num_isos, num_reactions, & x, temp, log10temp, rho, log10rho, & @@ -677,10 +677,10 @@ subroutine net_get_rates_only( & use net_eval, only: eval_net use net_def, only: Net_General_Info, Net_Info, get_net_ptr use rates_def, only: num_rvs - + ! provide T or logT or both (the code needs both, so pass 'em if you've got 'em!) ! same for Rho and logRho - + integer, intent(in) :: handle type (Net_Info) :: n integer, intent(in) :: num_isos @@ -691,9 +691,9 @@ subroutine net_get_rates_only( & real(dp), intent(in) :: abar ! mean number of nucleons per nucleus real(dp), intent(in) :: zbar ! mean charge per nucleus real(dp), intent(in) :: z2bar ! mean charge squared per nucleus - real(dp), intent(in) :: ye + real(dp), intent(in) :: ye ! mean number free electrons per nucleon, assuming complete ionization - ! d_dxdt_dx(i, j) is d_dxdt(i)_dx(j), + ! d_dxdt_dx(i, j) is d_dxdt(i)_dx(j), ! i.e., partial derivative of rate for i'th isotope wrt j'th isotope abundance real(dp), intent(in) :: eta, d_eta_dlnT, d_eta_dlnRho ! electron degeneracy from eos. ! this arg is only used for prot(e-nu)neut and neut(e+nu)prot. @@ -706,13 +706,13 @@ subroutine net_get_rates_only( & real(dp), intent(in) :: weak_rate_factor real(dp), pointer, intent(in) :: reaction_Qs(:) ! (rates_reaction_id_max) real(dp), pointer, intent(in) :: reaction_neuQs(:) ! (rates_reaction_id_max) - + ! rate_raw and rate_screened are described in the declaration of the Net_Info derived type integer, intent(in) :: screening_mode - + integer, intent(out) :: ierr ! 0 means okay - + integer(8) :: time0, time1 type (Net_General_Info), pointer :: g real(dp), pointer, dimension(:) :: actual_Qs, actual_neuQs @@ -720,7 +720,7 @@ subroutine net_get_rates_only( & logical, parameter :: symbolic = .false. real(dp) :: eps_nuc, d_eps_nuc_dT, d_eps_nuc_dRho, eps_neu_total - + real(dp), target :: empty_array1(0), empty_array2(0,0) real(dp), pointer, dimension(:) :: & d_eps_nuc_dx, dxdt, d_dxdt_dRho, d_dxdt_dT, eps_nuc_categories @@ -732,7 +732,7 @@ subroutine net_get_rates_only( & dxdt => empty_array1 d_dxdt_dRho => empty_array1 d_dxdt_dT => empty_array1 - + d_dxdt_dx => empty_array2 eps_nuc_categories => empty_array1 @@ -746,13 +746,13 @@ subroutine net_get_rates_only( & write(*,*) 'invalid handle for net_get -- did you call alloc_net_handle?' return end if - + if (g% doing_timing) then call system_clock(time0) else time0 = 0 endif - + call eval_net( & n, g, rates_only, just_dxdt, num_isos, num_reactions, g% num_wk_reactions, & x, temp, log10temp, rho, log10rho, & @@ -769,10 +769,10 @@ subroutine net_get_rates_only( & call system_clock(time1) g% clock_net_get = g% clock_net_get + (time1 - time0) end if - + end subroutine net_get_rates_only - - + + ! this sets d_dxdt_dx to 1 in locations where can have a nonzero partial ! it doesn't set other things such as eps_nuc or rates. ! takes the same set of args as net_get even though doesn't use them all. @@ -791,7 +791,7 @@ subroutine net_get_symbolic_d_dxdt_dx( & use net_eval, only: eval_net use net_def, only: Net_General_Info, Net_Info, get_net_ptr use rates_def, only: num_rvs - + integer, intent(in) :: handle type (Net_Info) :: n integer, intent(in) :: num_isos @@ -802,9 +802,9 @@ subroutine net_get_symbolic_d_dxdt_dx( & real(dp), intent(in) :: abar ! mean number of nucleons per nucleus real(dp), intent(in) :: zbar ! mean charge per nucleus real(dp), intent(in) :: z2bar ! mean charge squared per nucleus - real(dp), intent(in) :: ye + real(dp), intent(in) :: ye ! mean number free electrons per nucleon, assuming complete ionization - ! d_dxdt_dx(i, j) is d_dxdt(i)_dx(j), + ! d_dxdt_dx(i, j) is d_dxdt(i)_dx(j), ! i.e., partial derivative of rate for i'th isotope wrt j'th isotope abundance real(dp), intent(in) :: eta, d_eta_dlnT, d_eta_dlnRho ! electron degeneracy from eos. ! this arg is only used for prot(e-nu)neut and neut(e+nu)prot. @@ -821,31 +821,31 @@ subroutine net_get_symbolic_d_dxdt_dx( & real(dp), intent(out) :: eps_nuc ! ergs/g/s from burning after including reaction neutrinos real(dp), intent(out) :: d_eps_nuc_dT real(dp), intent(out) :: d_eps_nuc_dRho - real(dp), intent(inout) :: d_eps_nuc_dx(:) ! (num_isos) + real(dp), intent(inout) :: d_eps_nuc_dx(:) ! (num_isos) ! partial derivatives wrt mass fractions - + real(dp), intent(inout) :: dxdt(:) ! (num_isos) ! rate of change of mass fractions caused by nuclear reactions real(dp), intent(inout) :: d_dxdt_dRho(:) ! (num_isos) real(dp), intent(inout) :: d_dxdt_dT(:) ! (num_isos) real(dp), intent(inout) :: d_dxdt_dx(:,:) ! (num_isos, num_isos) ! partial derivatives of rates wrt mass fractions - + real(dp), intent(inout) :: eps_nuc_categories(:) ! (num_categories) ! eps_nuc subtotals for each reaction category real(dp), intent(out) :: eps_neu_total ! ergs/g/s neutrinos from weak reactions - + ! rate_raw and rate_screened are described in the declaration of the Net_Info derived type - integer, intent(in) :: screening_mode ! Selects which screening mode to use, see rates_def for definition - + integer, intent(in) :: screening_mode ! Selects which screening mode to use, see rates_def for definition + integer, intent(out) :: ierr ! ierr = 0 means AOK ! ierr = -1 means mass fractions don't add to something very close to 1.0 ! ierr = -2 means neither T nor logT were provided ! ierr = -3 means neither Rho nor logRho were provided - + type (Net_General_Info), pointer :: g real(dp), pointer, dimension(:) :: actual_Qs, actual_neuQs logical, pointer :: from_weaklib(:) ! ignore if null @@ -854,7 +854,7 @@ subroutine net_get_symbolic_d_dxdt_dx( & real(dp) :: max_old_rate_div_new_rate logical, parameter :: rates_only = .false. logical, parameter :: just_dxdt = .false. - + actual_Qs => null() actual_neuQs => null() from_weaklib => null() @@ -866,7 +866,7 @@ subroutine net_get_symbolic_d_dxdt_dx( & 'invalid handle for net_get_symbolic_d_dxdt_dx -- did you call alloc_net_handle?' return end if - + call eval_net( & n, g, rates_only, just_dxdt, num_isos, num_reactions, g% num_wk_reactions, & x, temp, log10temp, rho, log10rho, & @@ -879,9 +879,9 @@ subroutine net_get_symbolic_d_dxdt_dx( & eps_nuc_categories, eps_neu_total, & actual_Qs, actual_neuQs, from_weaklib, symbolic, & ierr) - + end subroutine net_get_symbolic_d_dxdt_dx - + subroutine net_get_with_Qs( & handle, just_dxdt, n, num_isos, num_reactions, & x, temp, log10temp, rho, log10rho, & @@ -909,7 +909,7 @@ subroutine net_get_with_Qs( & real(dp), intent(in) :: abar ! mean number of nucleons per nucleus real(dp), intent(in) :: zbar ! mean charge per nucleus real(dp), intent(in) :: z2bar ! mean charge squared per nucleus - real(dp), intent(in) :: ye + real(dp), intent(in) :: ye real(dp), intent(in) :: eta, d_eta_dlnT, d_eta_dlnRho ! electron degeneracy from eos. real(dp), intent(in), pointer :: rate_factors(:) ! (num_reactions) real(dp), intent(in) :: weak_rate_factor @@ -918,18 +918,18 @@ subroutine net_get_with_Qs( & real(dp), intent(out) :: eps_nuc ! ergs/g/s from burning after including reaction neutrinos real(dp), intent(out) :: d_eps_nuc_dT real(dp), intent(out) :: d_eps_nuc_dRho - real(dp), intent(inout) :: d_eps_nuc_dx(:) ! (num_isos) + real(dp), intent(inout) :: d_eps_nuc_dx(:) ! (num_isos) real(dp), intent(inout) :: dxdt(:) ! (num_isos) real(dp), intent(inout) :: d_dxdt_dRho(:) ! (num_isos) real(dp), intent(inout) :: d_dxdt_dT(:) ! (num_isos) - real(dp), intent(inout) :: d_dxdt_dx(:,:) ! (num_isos, num_isos) + real(dp), intent(inout) :: d_dxdt_dx(:,:) ! (num_isos, num_isos) real(dp), intent(inout) :: eps_nuc_categories(:) ! (num_categories) real(dp), intent(out) :: eps_neu_total ! ergs/g/s neutrinos from weak reactions integer, intent(in) :: screening_mode real(dp), pointer, dimension(:) :: actual_Qs, actual_neuQs ! ignore if null (num_reactions) logical, pointer :: from_weaklib(:) ! ignore if null integer, intent(out) :: ierr - + logical, parameter :: rates_only = .false. logical, parameter :: symbolic = .false. integer(8) :: time0, time1 @@ -947,7 +947,7 @@ subroutine net_get_with_Qs( & else time0 = 0 endif - + call eval_net( & n, g, rates_only, just_dxdt, num_isos, num_reactions, g% num_wk_reactions, & x, temp, log10temp, rho, log10rho, & @@ -964,7 +964,7 @@ subroutine net_get_with_Qs( & call system_clock(time1) g% clock_net_get = g% clock_net_get + (time1 - time0) end if - + end subroutine net_get_with_Qs ! a 1-zone integrator for nets -- for given temperature and density as functions of time @@ -982,15 +982,15 @@ subroutine net_1_zone_burn( & use net_burn, only: burn_1_zone use net_def use chem_def, only: num_categories - + integer, intent(in) :: net_handle, eos_handle integer, intent(in) :: num_isos integer, intent(in) :: num_reactions real(dp), intent(in) :: t_start, t_end, starting_x(:) ! (num_isos) - - integer, intent(in) :: num_times_for_interpolation + + integer, intent(in) :: num_times_for_interpolation ! ending time is times(num_times); starting time is 0 - real(dp), pointer, intent(in) :: times(:) ! (num_times) + real(dp), pointer, intent(in) :: times(:) ! (num_times) real(dp), pointer, intent(in) :: log10Ts_f1(:) ! =(4,numtimes) interpolant for log10T(time) real(dp), pointer, intent(in) :: log10Rhos_f1(:) ! =(4,numtimes) interpolant for log10Rho(time) real(dp), pointer, intent(in) :: etas_f1(:) ! =(4,numtimes) interpolant for eta(time) @@ -1017,7 +1017,7 @@ subroutine net_1_zone_burn( & integer, intent(out) :: naccpt ! number of accepted steps integer, intent(out) :: nrejct ! number of rejected steps integer, intent(out) :: ierr - + call burn_1_zone( & net_handle, eos_handle, num_isos, num_reactions, t_start, t_end, starting_x, & num_times_for_interpolation, times, log10Ts_f1, log10Rhos_f1, etas_f1, & @@ -1027,10 +1027,10 @@ subroutine net_1_zone_burn( & use_pivoting, trace, dbg, burner_finish_substep, & ending_x, eps_nuc_categories, avg_eps_nuc, eps_neu_total, & nfcn, njac, nstep, naccpt, nrejct, ierr) - + end subroutine net_1_zone_burn - + ! a 1-zone integrator for nets -- for given density ! evolve lnT according to dlnT/dt = eps_nuc/(Cv*T) subroutine net_1_zone_burn_const_density( & @@ -1048,7 +1048,7 @@ subroutine net_1_zone_burn_const_density( & use net_burn_const_density, only: burn_const_density_1_zone use net_def use chem_def, only: num_categories - + integer, intent(in) :: net_handle, eos_handle, num_isos, num_reactions real(dp), intent(in) :: t_start, t_end, starting_x(:) ! (num_isos) real(dp), intent(in) :: starting_log10T, log10Rho @@ -1077,7 +1077,7 @@ subroutine net_1_zone_burn_const_density( & integer, intent(out) :: naccpt ! number of accepted steps integer, intent(out) :: nrejct ! number of rejected steps integer, intent(out) :: ierr - + call burn_const_density_1_zone( & net_handle, eos_handle, num_isos, num_isos+1, num_reactions, t_start, t_end, & starting_x, starting_log10T, log10Rho, & @@ -1088,9 +1088,9 @@ subroutine net_1_zone_burn_const_density( & use_pivoting, trace, dbg, burner_finish_substep, & ending_x, eps_nuc_categories, ending_log10T, avg_eps_nuc, ending_eps_neu_total, & nfcn, njac, nstep, naccpt, nrejct, ierr) - + end subroutine net_1_zone_burn_const_density - + ! evolve T according to dT/dt = eps_nuc/Cp while using given P. ! then find new Rho and Cp to match P and new T. subroutine net_1_zone_burn_const_P( & @@ -1110,17 +1110,17 @@ subroutine net_1_zone_burn_const_P( & use net_burn_const_P, only: burn_1_zone_const_P use chem_def, only: num_categories use rates_def, only: num_rvs - + integer, intent(in) :: net_handle, eos_handle integer, intent(in) :: num_isos integer, intent(in) :: num_reactions real(dp), pointer, intent(in) :: starting_x(:) ! (num_isos) real(dp), intent(in) :: starting_temp logical, intent(in) :: clip ! if true, set negative x's to zero during burn. - + integer, intent(in) :: which_solver ! as defined in num_def.f integer, intent(in) :: num_times_for_interpolation ! ending time is times(num_times); starting time is 0 - real(dp), pointer, intent(in) :: times(:) ! (num_times) + real(dp), pointer, intent(in) :: times(:) ! (num_times) real(dp), pointer, intent(in) :: log10Ps_f1(:) ! =(4,numtimes) interpolant for log10P(time) real(dp), intent(in), pointer :: rate_factors(:) ! (num_reactions) @@ -1128,9 +1128,9 @@ subroutine net_1_zone_burn_const_P( & real(dp), pointer, intent(in) :: reaction_Qs(:) ! (rates_reaction_id_max) real(dp), pointer, intent(in) :: reaction_neuQs(:) ! (rates_reaction_id_max) integer, intent(in) :: screening_mode - + ! args to control the solver -- see num/public/num_isolve.dek - real(dp), intent(inout) :: h + real(dp), intent(inout) :: h real(dp), intent(in) :: max_step_size ! maximal step size. integer, intent(in) :: max_steps ! maximal number of allowed steps. ! absolute and relative error tolerances @@ -1158,7 +1158,7 @@ subroutine net_1_zone_burn_const_P( & ! if < 0, then ignore ! else on return has input value plus time spent doing eos integer, intent(out) :: ierr - + call burn_1_zone_const_P( & net_handle, eos_handle, num_isos, num_reactions, & which_solver, starting_temp, starting_x, clip, & @@ -1169,26 +1169,26 @@ subroutine net_1_zone_burn_const_P( & caller_id, solout, iout, & ending_x, ending_temp, ending_rho, ending_lnS, initial_rho, initial_lnS, & nfcn, njac, nstep, naccpt, nrejct, time_doing_net, time_doing_eos, ierr) - + end subroutine net_1_zone_burn_const_P - + ! approximate beta decay neutrino energies (in MeV) ! Fowler, Caughlan, Zimmerman, Annual Review Astro. Astrophys., 1975.12:69-112. eqn (1). real(dp) function eval_neutrino_Q(i1, i2) use net_initialize, only:neutrino_Q integer, intent(in) :: i1, i2 ! i1 decays to i2. e.g., i1=in13 and i2=ic13 eval_neutrino_Q = neutrino_Q(i1, i2) - end function eval_neutrino_Q - - + end function eval_neutrino_Q + + ! for calculating reaction Q real(dp) function isoB(ci) use chem_def, only: del_Mp, del_Mn integer, intent(in) :: ci isoB = chem_isos% binding_energy(ci) - chem_isos% Z(ci)*del_Mp - chem_isos% N(ci)*del_Mn end function isoB - - + + subroutine clean_up_fractions(nzlo, nzhi, species, nz, xa, max_sum_abs, xsum_tol, ierr) ! make sure all fractions are okay and sum to 1.0 use net_eval, only: do_clean_up_fractions @@ -1203,7 +1203,7 @@ subroutine clean_up_fractions(nzlo, nzhi, species, nz, xa, max_sum_abs, xsum_tol integer, intent(out) :: ierr call do_clean_up_fractions(nzlo, nzhi, species, nz, xa, max_sum_abs, xsum_tol, ierr) end subroutine clean_up_fractions - + subroutine clean1(species, xa, max_sum_abs, xsum_tol, ierr) use net_eval, only: do_clean1 @@ -1213,7 +1213,7 @@ subroutine clean1(species, xa, max_sum_abs, xsum_tol, ierr) integer, intent(out) :: ierr call do_clean1(species, xa, 1, max_sum_abs, xsum_tol, ierr) end subroutine clean1 - - + + end module net_lib diff --git a/net/test/src/mod_one_zone_burn.f90 b/net/test/src/mod_one_zone_burn.f90 index 37315bf36..af8bdcbbb 100644 --- a/net/test/src/mod_one_zone_burn.f90 +++ b/net/test/src/mod_one_zone_burn.f90 @@ -32,7 +32,7 @@ module mod_one_zone_support use const_def, only: Qconv, secyer, kerg, avo, ln10 use rates_def use utils_lib, only: mesa_error - + implicit none character(len=256) :: net_name @@ -46,7 +46,7 @@ module mod_one_zone_support character(len=256):: T_Rho_history_filename logical :: read_T_Rho_history - + character(len=256):: burn_filename real(dp) :: burn_tend, burn_rho, burn_temp, & burn_rtol, burn_atol, burn_P, burn_xmin, burn_xmax, & @@ -54,7 +54,7 @@ module mod_one_zone_support logical :: trace, burn_dbg, use_pivoting real(dp) :: min_for_show_peak_abundances integer :: max_num_for_show_peak_abundances - + integer, parameter :: max_num_burn_isos_to_show = 1000 character(len=iso_name_length) :: names_of_isos_to_show(max_num_burn_isos_to_show) integer :: num_names_of_isos_to_show @@ -76,12 +76,12 @@ module mod_one_zone_support character (len=32) :: small_mtx_decsol, large_mtx_decsol logical :: show_net_reactions_info - + real(dp) :: rattab_logT_lower_bound, rattab_logT_upper_bound character(len=256):: data_filename, data_heading_line character (len=64) :: net_file, cache_suffix - + integer :: handle, eos_handle, net_handle type (Net_General_Info), pointer :: g integer :: species, num_reactions @@ -92,8 +92,8 @@ module mod_one_zone_support real(dp) :: eta, d_eta_dlnT, d_eta_dlnRho real(dp), dimension(:), pointer :: & xin, xin_copy, d_eps_nuc_dx, dxdt, d_dxdt_dRho, d_dxdt_dT - real(dp), pointer :: d_dxdt_dx(:, :) - + real(dp), pointer :: d_dxdt_dx(:, :) + real(dp) :: weak_rate_factor integer :: max_steps ! maximal number of allowed steps. @@ -103,7 +103,7 @@ module mod_one_zone_support real(dp) :: burn_lnE, burn_lnS real(dp) :: burn_logT, burn_logRho, & burn_eta, burn_deta_dlnT, burn_Cv, burn_d_Cv_dlnT - + real(dp) :: T_prev, time_prev, eps_nuc_prev, eps_neu_prev, cp_prev real(dp), pointer :: x_previous(:) ! (species) @@ -122,14 +122,14 @@ module mod_one_zone_support real(dp) :: max_step_size ! maximal step size. real(dp), pointer :: rate_factors(:) ! (num_reactions) - integer, pointer :: net_reaction_ptr(:) - + integer, pointer :: net_reaction_ptr(:) + integer, parameter :: max_num_reactions_to_track = 100 integer :: num_reactions_to_track character(len=maxlen_reaction_Name) :: & reaction_to_track(max_num_reactions_to_track) integer :: index_for_reaction_to_track(max_num_reactions_to_track) - + integer, parameter :: max_num_special_rate_factors = 100 integer :: num_special_rate_factors real(dp) :: special_rate_factor(max_num_special_rate_factors) @@ -138,30 +138,30 @@ module mod_one_zone_support character (len=16) :: set_rate_c12ag, set_rate_n14pg, set_rate_3a, & set_rate_1212 - + logical :: show_Qs, quiet, complete_silence_please, & show_ye_stuff - + real(dp) :: starting_logT - + logical, parameter :: dbg = .false. - - + + contains - - + + integer function burn_isos_for_Xinit(i) - integer, intent(in) :: i + integer, intent(in) :: i burn_isos_for_Xinit = chem_get_iso_id(names_of_isos_for_Xinit(i)) end function burn_isos_for_Xinit - - + + integer function burn_isos_to_show(i) - integer, intent(in) :: i + integer, intent(in) :: i burn_isos_to_show = chem_get_iso_id(names_of_isos_to_show(i)) end function burn_isos_to_show - + subroutine Do_One_Zone_Burn(net_file_in) use num_lib, only: solver_option use mtx_lib, only: decsol_option @@ -173,9 +173,9 @@ subroutine Do_One_Zone_Burn(net_file_in) use net_lib, only: get_net_reaction_table_ptr use rates_lib, only: rates_reaction_id use utils_lib, only: set_nan - + character (len=*), intent(in) :: net_file_in - + character (len=256) :: net_file real(dp) :: logRho, logT, Rho, T, xsum, & eps_nuc, d_eps_nuc_dRho, d_eps_nuc_dT @@ -188,14 +188,14 @@ subroutine Do_One_Zone_Burn(net_file_in) log10Ts_f1, log10Rhos_f1, etas_f1, log10Ps_f1 real(dp), dimension(:,:), pointer :: & log10Ts_f, log10Rhos_f, etas_f, log10Ps_f - + ! args to control the solver -- see num/public/num_isolve.dek - real(dp) :: h + real(dp) :: h ! absolute and relative error tolerances real(dp), pointer :: rtol(:) ! relative error tolerance (species) real(dp), pointer :: atol(:) ! absolute error tolerance (species) integer :: itol ! switch for rtol and atol - + real(dp), pointer :: ending_x(:) ! (species) integer :: nfcn ! number of function evaluations integer :: njac ! number of jacobian evaluations @@ -203,7 +203,7 @@ subroutine Do_One_Zone_Burn(net_file_in) integer :: naccpt ! number of accepted steps integer :: nrejct ! number of rejected steps integer :: max_order_used - + integer :: iout, caller_id, cid, ir integer(8) :: time0, time1, clock_rate @@ -214,15 +214,15 @@ subroutine Do_One_Zone_Burn(net_file_in) integer, parameter :: nwork = pm_work_size real(dp), pointer :: pm_work(:) - + type (Net_Info) :: n type (Net_General_Info), pointer :: g - + include 'formats' - + ierr = 0 told = 0 - + net_file = net_file_in call test_net_setup(net_file) @@ -233,12 +233,12 @@ subroutine Do_One_Zone_Burn(net_file_in) call Setup_eos(eos_handle) ! g% max_rate_times_dt = max_rate_times_dt - + logT = burn_logT - T = burn_temp + T = burn_temp logRho = burn_logRho Rho = burn_rho - + if (read_T_Rho_history) then num_times = max_num_times else if (num_times_for_burn <= 0) then @@ -248,7 +248,7 @@ subroutine Do_One_Zone_Burn(net_file_in) end if if (num_names_of_isos_to_show < 0) num_names_of_isos_to_show = species - + allocate( & rate_factors(num_reactions), rtol(species), atol(species), & x_initial(species), x_previous(species), ending_x(species), times(num_times), & @@ -260,7 +260,7 @@ subroutine Do_One_Zone_Burn(net_file_in) write(*,*) 'allocate failed for Do_One_Zone_Burn' call mesa_error(__FILE__,__LINE__) end if - + call get_net_reaction_table_ptr(net_handle, net_reaction_ptr, ierr) if (ierr /= 0) then write(*,*) 'bad net? get_net_reaction_table_ptr failed' @@ -281,7 +281,7 @@ subroutine Do_One_Zone_Burn(net_file_in) trim(reaction_for_special_factor(i)), special_rate_factor(i) end do end if - + if (num_reactions_to_track > 0) then do i=1,num_reactions_to_track index_for_reaction_to_track(i) = 0 @@ -294,23 +294,23 @@ subroutine Do_One_Zone_Burn(net_file_in) write(*,1) 'track rate ' // trim(reaction_to_track(i)) end do end if - + log10Ts_f(1:4,1:num_times) => log10Ts_f1(1:4*num_times) log10Rhos_f(1:4,1:num_times) => log10Rhos_f1(1:4*num_times) etas_f(1:4,1:num_times) => etas_f1(1:4*num_times) log10Ps_f(1:4,1:num_times) => log10Ps_f1(1:4*num_times) - + peak_abundance(:) = 0 xin = 0 eta = 0 - + iout = 1 - itol = 0 - + itol = 0 + rtol(:) = burn_rtol atol(:) = burn_atol - + xin = 0 if (read_initial_abundances) then call read_X(ierr) @@ -332,14 +332,14 @@ subroutine Do_One_Zone_Burn(net_file_in) xin(j) = values_for_Xinit(i) end do end if - + !xin(:) = xin(:)/sum(xin(:)) - + if (read_T_Rho_history) then call do_read_T_Rho_history(ierr) if (ierr /= 0) return end if - + if (num_times_for_burn <= 0) then times(1) = burn_tend log10Ts_f(1,1) = logT @@ -371,16 +371,16 @@ subroutine Do_One_Zone_Burn(net_file_in) end if end if starting_logT = logT - + h = 1d-2*burn_tend ! 1d-14 !write(*,1) 'h', h !stop - + x_initial(1:species) = xin(1:species) x_previous(1:species) = xin(1:species) caller_id = 0 dxdt_source_term => null() - + if (.not. quiet) then write(*,'(A)') write(*,'(A)') @@ -400,11 +400,11 @@ subroutine Do_One_Zone_Burn(net_file_in) write(*,1) 'initial abundances' call show_X(xin,.false.,.false.) end if - -! data_heading_line was not set and writing out nulls. change it - fxt + +! data_heading_line was not set and writing out nulls. change it - fxt ! write(io_out,'(a)') trim(data_heading_line) write(data_heading_line,'(99(a,1pe14.6))') 'temp =',burn_temp,' rho =',burn_rho - write(io_out,'(a)') trim(data_heading_line) + write(io_out,'(a)') trim(data_heading_line) write(io_out,'(a7,99(a26,1x))',advance='no') & 'i', & @@ -429,7 +429,7 @@ subroutine Do_One_Zone_Burn(net_file_in) 'lg_dt', & 'ye', & 'xsum_sub_1' - + do i=1,num_names_of_isos_to_show if (num_names_of_isos_to_show < species) then cid = burn_isos_to_show(i) @@ -459,8 +459,8 @@ subroutine Do_One_Zone_Burn(net_file_in) write(io_out,'(a26,1x)',advance='no') 'raw_' // trim(reaction_to_track(i)) write(io_out,'(a26,1x)',advance='no') 'scrn_' // trim(reaction_to_track(i)) end do - write(io_out,*) - + write(io_out,*) + if (show_net_reactions_info) then write(*,'(a)') ' species' do j=1,species @@ -483,7 +483,7 @@ subroutine Do_One_Zone_Burn(net_file_in) end if write(*,'(A)') end if - + if (.not. quiet) then write(*,1) 'h', h write(*,1) 'max_step_size', max_step_size @@ -491,7 +491,7 @@ subroutine Do_One_Zone_Burn(net_file_in) write(*,2) 'screening_mode', screening_mode write(*,'(A)') end if - + if (species >= decsol_switch) then decsol_choice = decsol_option(large_mtx_decsol, ierr) if (ierr /= 0) then @@ -505,25 +505,25 @@ subroutine Do_One_Zone_Burn(net_file_in) return end if end if - + solver_choice = solver_option(which_solver, ierr) if (ierr /= 0) then write(*,*) 'ERROR: unknown value for which_solver ' // trim(which_solver) return end if - + nullify(pm_work) - + call system_clock(time0,clock_rate) time_doing_net = -1 time_doing_eos = -1 - + if (burn_at_constant_density) then - + starting_log10T = burn_logT logT = burn_logT logRho = burn_logRho - + call net_1_zone_burn_const_density( & net_handle, eos_handle, species, num_reactions, & 0d0, burn_tend, xin, logT, logRho, & @@ -566,7 +566,7 @@ subroutine Do_One_Zone_Burn(net_file_in) call interp_pm(times, num_times, log10Ps_f1, nwork, pm_work, 'net_1_zone_burn', ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in interp for logTs') end if - + call net_1_zone_burn_const_P( & net_handle, eos_handle, species, num_reactions, & solver_choice, starting_temp, xin, clip, & @@ -597,19 +597,19 @@ subroutine Do_One_Zone_Burn(net_file_in) call interp_pm(times, num_times, etas_f1, nwork, pm_work, 'net_1_zone_burn', ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in interp for etas') end if - + call net_1_zone_burn( & net_handle, eos_handle, species, num_reactions, 0d0, burn_tend, xin, & num_times, times, log10Ts_f1, log10Rhos_f1, etas_f1, dxdt_source_term, & rate_factors, weak_rate_factor, & std_reaction_Qs, std_reaction_neuQs, & - screening_mode, & + screening_mode, & stptry, max_steps, eps, odescal, & use_pivoting, trace, burn_dbg, burn_finish_substep, & ending_x, eps_nuc_categories, & avg_eps_nuc, eps_neu_total, & nfcn, njac, nstep, naccpt, nrejct, ierr) - + end if call system_clock(time1,clock_rate) dt = dble(time1 - time0) / clock_rate @@ -618,12 +618,12 @@ subroutine Do_One_Zone_Burn(net_file_in) write(*,*) 'net_1_zone_burn returned ierr', ierr call mesa_error(__FILE__,__LINE__) end if - + if (.not. quiet) then write(*,'(A)') write(*,'(A)') end if - + if (.not. complete_silence_please) then if (nstep >= max_steps) then write(*,2) 'hit max number of steps', nstep @@ -698,7 +698,7 @@ subroutine Do_One_Zone_Burn(net_file_in) write(*,'(/,a30,99f18.3,/)') 'runtime (seconds)', dt write(*,'(A)') end if - + if (save_final_abundances) then if (.not. quiet) write(*,*) 'save final abundances to ' // trim(final_abundances_filename) open(newunit=iounit, file=trim(final_abundances_filename), iostat=ierr) @@ -716,7 +716,7 @@ subroutine Do_One_Zone_Burn(net_file_in) close(iounit) end if end if - + if (associated(pm_work)) deallocate(pm_work) deallocate( & rate_factors, rtol, atol, & @@ -724,11 +724,11 @@ subroutine Do_One_Zone_Burn(net_file_in) log10Ts_f1, log10Rhos_f1, & etas_f1, log10Ps_f1, & peak_abundance, peak_time) - - + + contains - - + + subroutine get_eos_info_for_burn_at_const_density( & eos_handle, species, chem_id, net_iso, xa, & Rho, logRho, T, logT, & @@ -746,15 +746,15 @@ subroutine get_eos_info_for_burn_at_const_density( & real(dp), dimension(num_eos_basic_results) :: res, d_dlnd, d_dlnT real(dp) :: d_dxa(num_eos_d_dxa_results,species) - + include 'formats' ierr = 0 - + Cv = burn_Cv d_Cv_dlnT = burn_d_Cv_dlnT eta = burn_eta d_eta_dlnT = burn_deta_dlnT - + if (burn_Cv <= 0d0 .or. burn_eta <= 0d0) then call eosDT_get( & eos_handle, species, chem_id, net_iso, xa, & @@ -774,7 +774,7 @@ subroutine get_eos_info_for_burn_at_const_density( & d_eta_dlnT = d_dlnT(i_eta) end if end if - + end subroutine get_eos_info_for_burn_at_const_density @@ -782,20 +782,20 @@ subroutine burn_finish_substep(step, time, y, ierr) integer,intent(in) :: step real(dp), intent(in) :: time, y(:) real(dp), dimension(size(y)) :: x - integer, intent(out) :: ierr + integer, intent(out) :: ierr include 'formats' - ierr = 0 + ierr = 0 !if (burn_at_constant_density) then !write(*,2) 'finish_substep time xh logT T', & ! step, time, y(1), y(species+1)/ln10, exp(y(species+1)) !return !end if - + do i=1,species cid = chem_id(i) x(i) = y(i)*dble(chem_isos% Z_plus_N(cid)) end do - + if (burn_at_constant_density) then x(species+1) = y(species+1) logT = x(species+1)/ln10 @@ -804,7 +804,7 @@ subroutine burn_finish_substep(step, time, y, ierr) step, told, time, logT, logRho, species, x, ierr) told = time end subroutine burn_finish_substep - + real(dp) function interp_y(i, s, rwork_y, iwork_y, ierr) use const_def, only: dp @@ -822,9 +822,9 @@ subroutine do_read_T_Rho_history(ierr) integer, intent(out) :: ierr character (len=256) :: buffer, string integer :: i, n, iounit, t, num_isos, id, k - + include 'formats' - + ierr = 0 write(*,*) 'read T Rho history from ' // trim(T_Rho_history_filename) open(newunit=iounit, file=trim(T_Rho_history_filename), & @@ -833,22 +833,22 @@ subroutine do_read_T_Rho_history(ierr) write(*,*) 'failed to open' return end if - + read(iounit,*,iostat=ierr) num_times if (ierr /= 0) then write(*,*) 'first line should have num_times' close(iounit) return end if - + if (num_times > max_num_times) then write(*,3) 'num_times > max_num_times', num_times, max_num_times close(iounit) return end if - + if (.false.) write(*,2) 'num_times', num_times - + do i=1,num_times read(iounit,*,iostat=ierr) times_for_burn(i), log10Ts_for_burn(i), & log10Rhos_for_burn(i), etas_for_burn(i) @@ -860,23 +860,23 @@ subroutine do_read_T_Rho_history(ierr) if (.false.) write(*,2) 'history', i, times_for_burn(i), log10Ts_for_burn(i), & log10Rhos_for_burn(i), etas_for_burn(i) end do - + close(iounit) - + num_times_for_burn = num_times end subroutine do_read_T_Rho_history - - + + subroutine read_X(ierr) use utils_def use utils_lib integer, intent(out) :: ierr character (len=256) :: buffer, string integer :: i, n, iounit, t, num_isos, id, k - + include 'formats' - + write(*,*) 'read initial abundances from ' // trim(initial_abundances_filename) open(newunit=iounit, file=trim(initial_abundances_filename), & action='read', status='old', iostat=ierr) @@ -884,7 +884,7 @@ subroutine read_X(ierr) write(*,*) 'failed to open' return end if - + n = 0 i = 0 t = token(iounit, n, i, buffer, string) @@ -934,16 +934,16 @@ subroutine read_X(ierr) end do close(iounit) end subroutine read_X - - + + subroutine show_X(X,show_peak,do_sort) use num_lib, only: qsort real(dp) :: X(:) - logical, intent(in) :: show_peak, do_sort - real(dp), target :: v_t(species) - integer, target :: index_t(species) - real(dp), pointer :: v(:) - integer, pointer :: index(:) + logical, intent(in) :: show_peak, do_sort + real(dp), target :: v_t(species) + integer, target :: index_t(species) + real(dp), pointer :: v(:) + integer, pointer :: index(:) integer :: j real(dp) :: xsum include 'formats' @@ -951,7 +951,7 @@ subroutine show_X(X,show_peak,do_sort) index => index_t if (do_sort) then - + v(1:species) = abs(x(1:species)) call qsort(index, species, v) do i=1,species @@ -964,7 +964,7 @@ subroutine show_X(X,show_peak,do_sort) call mesa_error(__FILE__,__LINE__) end if end do - + else do j=1, species @@ -1026,7 +1026,7 @@ subroutine burn_solout( & lgrho = log10(rpar(r_burn_const_P_rho)) end if - + call burn_solout1( & step, told, time, lgt, lgrho, n, x, irtrn) end subroutine burn_solout @@ -1050,16 +1050,16 @@ subroutine burn_solout1( & real(dp) :: dlnRho_dlnPgas_const_T, dlnRho_dlnT_const_Pgas real(dp) :: dlnRho_dlnT_const_P, d_epsnuc_dlnT_const_P, d_Cv_dlnT real(dp) :: res(num_eos_basic_results) - real(dp) :: d_dlnRho_const_T(num_eos_basic_results) - real(dp) :: d_dlnT_const_Rho(num_eos_basic_results) - real(dp) :: d_dabar_const_TRho(num_eos_basic_results) + real(dp) :: d_dlnRho_const_T(num_eos_basic_results) + real(dp) :: d_dlnT_const_Rho(num_eos_basic_results) + real(dp) :: d_dabar_const_TRho(num_eos_basic_results) real(dp) :: d_dzbar_const_TRho(num_eos_basic_results) real(dp) :: d_dxa_const_TRho(num_eos_d_dxa_results, species) real(dp) :: Rho, T, xsum, d_eps_nuc_dx(species), dx, enuc, & dt, energy, entropy, burn_ergs, & xh, xhe, Z, mass_correction - + integer :: i, j, adjustment_iso, cid, ierr, max_j real(dp), dimension(species) :: dabar_dx, dzbar_dx, eps_nuc_dx, dmc_dx real(dp), pointer :: actual_Qs(:), actual_neuQs(:) @@ -1069,13 +1069,13 @@ subroutine burn_solout1( & logical :: skip_jacobian include 'formats' - + irtrn = 0 if (time == 0) return logT = logT_in logRho = logRho_in - + if ((.not. quiet) .and. step > 1 .and. mod(step,50) == 0) then max_j = maxloc(x(1:species),dim=1) write(*,2) 'step, time, logT, logRho, ' // trim(chem_isos% name(chem_id(max_j))), & @@ -1090,20 +1090,20 @@ subroutine burn_solout1( & end if ierr = 0 - + allocate( & actual_Qs(num_reactions), actual_neuQs(num_reactions), & from_weaklib(num_reactions), & stat=ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + xin(1:species) = x(1:species) call composition_info( & species, chem_id, xin(1:species), xh, xhe, z, abar, zbar, z2bar, z53bar, ye, & mass_correction, xsum, dabar_dx, dzbar_dx, dmc_dx) Z = max(0d0, min(1d0, 1d0 - (xh + xhe))) - + if (burn_at_constant_P) then logT = x(n)/ln10 @@ -1111,7 +1111,7 @@ subroutine burn_solout1( & Prad = Radiation_Pressure(T) Pgas = pressure - Prad lgPgas = log10(Pgas) - + call eosPT_get( & eos_handle, & species, chem_id, net_iso, x, & @@ -1123,12 +1123,12 @@ subroutine burn_solout1( & if (ierr /= 0) call mesa_error(__FILE__,__LINE__) else ! this is okay for burn_at_constant_density as well as constant T and Rho - + ! logT = rpar(r_burn_prev_lgT) ! logRho = rpar(r_burn_prev_lgRho) T = exp10(logT) Rho = exp10(logRho) - + call eosDT_get( & eos_handle, & species, chem_id, net_iso, x, & @@ -1137,9 +1137,9 @@ subroutine burn_solout1( & d_dxa_const_TRho, ierr) !Pgas, Prad, energy, entropy, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + end if - + lgPgas = res(i_lnPgas)/ln10 Pgas = exp10(lgPgas) Prad = Radiation_Pressure(T) @@ -1151,11 +1151,11 @@ subroutine burn_solout1( & call get_net_ptr(handle, g, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + netinfo% g => g - + call net_get_with_Qs( & handle, skip_jacobian, netinfo, species, num_reactions, & xin(1:species), T, logT, Rho, logRho, & @@ -1183,16 +1183,16 @@ subroutine burn_solout1( & burn_ergs = 0 do i=1,species cid = chem_id(i) - + dx = x(i) - x_initial(i) xsum = xsum + x(i) burn_ergs = burn_ergs + & (get_Q(chem_isos,cid))*dx/chem_isos% Z_plus_N(cid) - + dx = x(i) - x_previous(i) eps_nuc = eps_nuc + & (get_Q(chem_isos,cid))*dx/chem_isos% Z_plus_N(cid) - + end do avg_eps_nuc = burn_ergs*Qconv/time - eps_neu_total eps_nuc = eps_nuc*Qconv/dt - eps_neu_total @@ -1200,11 +1200,11 @@ subroutine burn_solout1( & burn_logRho = logRho burn_lnS = res(i_lnS) burn_lnE = res(i_lnE) - + x_previous(1:species) = x(1:species) - + if (time >= data_output_min_t) then - + write(io_out,'(i7,99(1pe26.16,1x))',advance='no') & step, & sign(1d0,avg_eps_nuc)*log10(max(1d0,abs(avg_eps_nuc))), & @@ -1257,7 +1257,7 @@ subroutine burn_solout1( & write(io_out,'(1pe26.16,1x)',advance='no') netinfo% rate_raw(j) write(io_out,'(1pe26.16,1x)',advance='no') netinfo% rate_screened(j) end do - write(io_out,*) + write(io_out,*) do j=1, species if (x(j) > peak_abundance(j)) then peak_abundance(j) = x(j) @@ -1284,39 +1284,39 @@ subroutine burn_solout1( & write(*,'(A)') call mesa_error(__FILE__,__LINE__,'show_Qs') end if - - + + deallocate(actual_Qs, actual_neuQs, from_weaklib) end subroutine burn_solout1 end subroutine Do_One_Zone_Burn - - + + subroutine test_net_setup(net_file_in) character (len=*), intent(in) :: net_file_in integer :: ierr, i - + include 'formats' - + net_file = net_file_in call net_init(ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + handle = alloc_net_handle(ierr) if (ierr /= 0) then write(*,*) 'alloc_net_handle failed' call mesa_error(__FILE__,__LINE__) end if - + call net_start_def(handle, ierr) if (ierr /= 0) then write(*,*) 'net_start_def failed' call mesa_error(__FILE__,__LINE__) end if - + call read_net_file(net_file, handle, ierr) if (ierr /= 0) then write(*,*) 'read_net_file failed ', trim(net_file) @@ -1328,13 +1328,13 @@ subroutine test_net_setup(net_file_in) write(*,*) 'net_finish_def failed' call mesa_error(__FILE__,__LINE__) end if - + call net_ptr(handle, g, ierr) if (ierr /= 0) then write(*,*) 'net_ptr failed' call mesa_error(__FILE__,__LINE__) end if - + species = g% num_isos num_reactions = g% num_reactions @@ -1345,13 +1345,13 @@ subroutine test_net_setup(net_file_in) write(*,*) 'net_setup_tables failed' call mesa_error(__FILE__,__LINE__) end if - + call get_chem_id_table(handle, species, chem_id, ierr) if (ierr /= 0) then write(*,*) 'get_chem_id_table failed' call mesa_error(__FILE__,__LINE__) end if - + call get_net_iso_table(handle, net_iso, ierr) if (ierr /= 0) then write(*,*) 'get_net_iso_table failed' @@ -1363,13 +1363,13 @@ subroutine test_net_setup(net_file_in) write(*,*) 'get_reaction_id_table failed' call mesa_error(__FILE__,__LINE__) end if - + allocate( & xin(species), xin_copy(species), d_eps_nuc_dx(species), & dxdt(species), d_dxdt_dRho(species), d_dxdt_dT(species), d_dxdt_dx(species, species)) - + end subroutine test_net_setup - + end module mod_one_zone_support @@ -1386,11 +1386,11 @@ module mod_one_zone_burn use mtx_def use mod_one_zone_support - + implicit none - + integer :: ierr, unit - + namelist /one_zone/ & mesa_dir, net_name, quiet, show_ye_stuff, num_names_of_isos_to_show, names_of_isos_to_show, & final_abundances_filename, save_final_abundances, show_peak_x_and_time, & @@ -1415,17 +1415,17 @@ module mod_one_zone_burn num_special_rate_factors, reaction_for_special_factor, special_rate_factor contains - - + + subroutine do_one_burn(filename, qt) character(len=*) :: filename logical, intent(in) :: qt - + include 'formats' - + ! set defaults - - mesa_dir = '../..' + + mesa_dir = '../..' net_name = 'test.net' quiet = .false. show_ye_stuff = .false. @@ -1479,14 +1479,14 @@ subroutine do_one_burn(filename, qt) etas_for_burn = 0 log10Ps_for_burn = 0 max_step_size = 0 - + min_for_show_peak_abundances = 1d-3 ! show if peak is > this max_num_for_show_peak_abundances = 21 show_peak_x_and_time = .true. - + data_filename = 'one_zone_burn.data' data_output_min_t = -99 - + num_names_of_isos_to_show = -1 num_isos_for_Xinit = 4 @@ -1494,40 +1494,40 @@ subroutine do_one_burn(filename, qt) 'he4', 'c12', 'n14', 'o16' /) values_for_Xinit(1:num_isos_for_Xinit) = (/ & 0.95d0, 0.005d0, 0.035d0, 0.010d0 /) - + screening_mode = extended_screening num_special_rate_factors = 0 ! must be <= max_num_special_rate_factors reaction_for_special_factor(:) = '' special_rate_factor(:) = 1 - + num_reactions_to_track = 0 reaction_to_track(:) = '' weak_rate_factor = 1 - + ! read inlist - + open(newunit=unit, file=trim(filename), action='read', delim='quote', iostat=ierr) if (ierr /= 0) then write(*, *) 'Failed to open control namelist file ', trim(filename) call mesa_error(__FILE__,__LINE__) else - read(unit, nml=one_zone, iostat=ierr) + read(unit, nml=one_zone, iostat=ierr) close(unit) if (ierr /= 0) then write(*, *) 'Failed while trying to read control namelist file ', trim(filename) write(*, '(a)') & 'The following runtime error message might help you find the problem' - write(*, *) + write(*, *) open(newunit=unit, file=trim(filename), action='read', delim='quote', status='old', iostat=ierr) read(unit, nml=one_zone) call mesa_error(__FILE__,__LINE__) - end if + end if end if ! do initialization - + if(burn_temp<0.d0 .and. burn_logT<0.d0) then call mesa_error(__FILE__,__LINE__,"Must set either burn_temp or burn_logT") stop @@ -1544,20 +1544,20 @@ subroutine do_one_burn(filename, qt) starting_temp = burn_temp allocate(net_iso(num_chem_isos), chem_id(num_chem_isos)) - + !reaclib_filename = 'jina_reaclib_results_20130213default2' !write(*,*) 'changing reaclib_filename' - + open(unit=io_out, file=trim(data_filename), action='write', iostat=ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + complete_silence_please = qt call Do_One_Zone_Burn(net_name) - + open(unit=io_out, file=trim(data_filename), action='write', iostat=ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + end subroutine do_one_burn - - + + end module mod_one_zone_burn diff --git a/net/test/src/mod_test_net.f90 b/net/test/src/mod_test_net.f90 index 188a11f02..d09cce501 100644 --- a/net/test/src/mod_test_net.f90 +++ b/net/test/src/mod_test_net.f90 @@ -9,7 +9,7 @@ ! by the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! -! MESA is distributed in the hope that it will be useful, +! MESA is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU Library General Public License for more details. @@ -21,32 +21,32 @@ ! *********************************************************************** module mod_test_net - + implicit none - + contains - + subroutine test(quiet) use net_def use net_lib use mod_one_zone_burn, only: do_one_burn use test_net_support use utils_lib, only: mesa_error - + logical, intent(in) :: quiet - + integer :: ierr - + qt = quiet - + call load_libs - + test_logT = 7.833d0 test_logRho = 2d0 screening_mode = extended_screening - + if (.false.) then call Do_One_Test('approx21_cr60_plus_co56.net',.false.) stop @@ -54,50 +54,50 @@ subroutine test(quiet) if (.false.) then write(*,*) 'inlist_one_zone_burn' - call do_one_burn('inlist_one_zone_burn',qt) + call do_one_burn('inlist_one_zone_burn',qt) stop end if if (.false.) then write(*,*) 'test_one_zone_burn_const_density' - call do_one_burn('inlist_one_zone_burn_const_density',qt) + call do_one_burn('inlist_one_zone_burn_const_density',qt) stop end if if (.false.) then write(*,*) 'test_one_zone_burn_const_P' - call do_one_burn('inlist_test_one_zone_burn_const_P',qt) + call do_one_burn('inlist_test_one_zone_burn_const_P',qt) stop end if - + if (.false.) then call Do_One_Test('pp_extras_alternate.net',.false.) stop end if - + if (.false.) then test_logRho = 6d0 test_logT = 9.6d0 call Do_One_Test('approx21.net',.false.) stop end if - + if (.false.) then call Do_One_Test('approx21.net',.false.); stop end if - + if (.false.) then call Do_One_Test_and_show_Qs('pp_and_cno_extras.net',.false.) stop end if - + if (.false.) then call Do_One_Test('wd_o_ne_ignite.net',.false.) stop end if - + if (.not. qt) write(*,*) ' **************** basic **************** ' - + ! 1st one calls test_net_setup -- after than call change_net call test_net_setup('basic.net') call do_test_net(.false.,.false.) @@ -105,69 +105,69 @@ subroutine test(quiet) if (.not. qt) write(*,*) if (.not. qt) write(*,*) if (.not. qt) write(*,*) ' **************** o18_and_ne22 **************** ' - + call change_net('o18_and_ne22.net') - call do_test_net(.false.,.false.) - + call do_test_net(.false.,.false.) + if (.not. qt) write(*,*) if (.not. qt) write(*,*) if (.not. qt) write(*,*) ' **************** pp_extras **************** ' - + call change_net('pp_extras.net') - call do_test_net(.false.,.false.) - + call do_test_net(.false.,.false.) + if (.not. qt) write(*,*) if (.not. qt) write(*,*) if (.not. qt) write(*,*) ' **************** cno_extras **************** ' - + call change_net('cno_extras.net') - call do_test_net(.false.,.false.) + call do_test_net(.false.,.false.) if (.not. qt) write(*,*) if (.not. qt) write(*,*) if (.not. qt) write(*,*) ' **************** approx21 **************** ' - + call change_net('approx21.net') test_logRho = 6d0 test_logT = 9.6d0 - call do_test_net(.false.,.false.) + call do_test_net(.false.,.false.) if (.not. qt) write(*,*) if (.not. qt) write(*,*) if (.not. qt) write(*,*) ' **************** approx21_plus_co56 **************** ' - + call change_net('approx21_plus_co56.net') test_logRho = 6d0 test_logT = 9.6d0 - call do_test_net(.false.,.false.) + call do_test_net(.false.,.false.) if (.not. qt) write(*,*) if (.not. qt) write(*,*) if (.not. qt) write(*,*) ' **************** approx21_cr60_plus_co56 **************** ' - + call change_net('approx21_cr60_plus_co56.net') - call do_test_net(.false.,.false.) - + call do_test_net(.false.,.false.) + if (.not. qt) write(*,*) if (.not. qt) write(*,*) - + if (.not. qt) write(*,*) 'test_one_zone_burn_small_net' call do_one_burn('inlist_test_one_zone_burn_small_net',qt) -! +! ! if (.not. qt) write(*,*) 'test_one_zone_burn_big_net' ! call do_one_burn('inlist_test_one_zone_burn_big_net',qt) -! +! if (.not. qt) write(*,*) 'test_one_zone_burn_const_P' - call do_one_burn('inlist_test_one_zone_burn_const_P',qt) + call do_one_burn('inlist_test_one_zone_burn_const_P',qt) call test_net_cleanup call net_shutdown if (.not. qt) write(*,*) - - + + end subroutine test - + end module mod_test_net diff --git a/net/test/src/sample_net.f90 b/net/test/src/sample_net.f90 index e1cf96521..a48bbe5dd 100644 --- a/net/test/src/sample_net.f90 +++ b/net/test/src/sample_net.f90 @@ -30,16 +30,16 @@ program sample_net ! this program does not do a time integration of a reaction network; ! for that you want to see $MESA_DIR/net/test/one_zone_burn.f90. - + call test - + contains - - - + + + subroutine test use chem_def, only: num_categories - + integer :: ierr, handle, species, & num_reactions integer, pointer :: chem_id(:), net_iso(:) @@ -47,10 +47,10 @@ subroutine test character (len=64) :: mesa_dir -! explicitly set my_mesa_dir to your $MESA_DIR, or use a blank string, in which case your $MESA_DIR is automagically used +! explicitly set my_mesa_dir to your $MESA_DIR, or use a blank string, in which case your $MESA_DIR is automagically used - mesa_dir = '../..' -! mesa_dir = '' + mesa_dir = '../..' +! mesa_dir = '' ! choose the network to use @@ -62,22 +62,22 @@ subroutine test call initialize(mesa_dir, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) -! set up the network +! set up the network call setup_net( & net_file, handle, & species, chem_id, net_iso, num_reactions, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) -! call the burner +! call the burner call do1_net_eval( & handle, species, num_reactions, & chem_id, net_iso, ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + if (ierr /= 0) call mesa_error(__FILE__,__LINE__) + end subroutine test - - + + subroutine initialize(mesa_dir, ierr) use const_lib, only: const_init @@ -90,10 +90,10 @@ subroutine initialize(mesa_dir, ierr) ierr = 0 call math_init() - - call const_init(mesa_dir,ierr) + + call const_init(mesa_dir,ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call chem_init('isotopes.data', ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) @@ -101,71 +101,71 @@ subroutine initialize(mesa_dir, ierr) call rates_init('reactions.list', '', 'rate_tables', .false., .false.,& '', '', '', ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call rates_warning_init(.true., 10d0) - + call net_init(ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + end subroutine initialize - - + + subroutine setup_net( & net_file, handle, & species, chem_id, net_iso, num_reactions, ierr) use net_lib use rates_def, only: rates_reaction_id_max - + character (len=*), intent(in) :: net_file integer, pointer :: chem_id(:), net_iso(:) ! set, but not allocated integer, intent(out) :: handle, species, num_reactions, ierr - + ierr = 0 handle = alloc_net_handle(ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call net_start_def(handle, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + write(*,*) 'load ' // trim(net_file) call read_net_file(net_file, handle, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call net_finish_def(handle, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call net_setup_tables(handle, '', ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + species = net_num_isos(handle, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call get_chem_id_table_ptr(handle, chem_id, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call get_net_iso_table_ptr(handle, net_iso, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + num_reactions = net_num_reactions(handle, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + end subroutine setup_net - - + + subroutine do1_net_eval( & handle, species, num_reactions, chem_id, net_iso, ierr) - + use rates_def use chem_def use net_def use net_lib use chem_lib - -! declare the pass + +! declare the pass integer, intent(in) :: handle, species, num_reactions, & chem_id(:), net_iso(:) integer, intent(out) :: ierr - + ! locals integer :: screening_mode, i @@ -181,7 +181,7 @@ subroutine do1_net_eval( & logical :: skip_jacobian type (Net_Info) :: n character (len=80) :: string - + include "formats" @@ -190,7 +190,7 @@ subroutine do1_net_eval( & 22 format(1x,t2,a,1p7e15.6) 23 format(1x,t2,a7,1pe14.6,t24,a7,1pe14.6,t46,a7,1pe14.6,t68,a7,1pe14.6) 24 format(1x,t2,a12,1pe14.6,t30,a12,1pe14.6,t60,a12,1pe14.6,t90,a12,1pe14.6,t120,a12,1pe14.6) - + ! set some pointers and options ierr = 0 @@ -208,10 +208,10 @@ subroutine do1_net_eval( & ! main loop, keep returning here 100 xa(:) = 0 - write(6,*) + write(6,*) write(6,*) 'give the temperature, density, and mass fractions (h1, he4, c12, n14, o16, ne20, mg24) =>' write(6,*) 'hit return for T = 1e9 K, Rho = 1e4 g/cc, x(c12) = 1 ; enter -1 to stop' - write(6,*) + write(6,*) read(5,'(a)') string ! stop @@ -221,7 +221,7 @@ subroutine do1_net_eval( & ! read the conditions else if (string(1:6) .ne. ' ') then - read(string,*) T,Rho, xa(net_iso(ih1)), xa(net_iso(ihe4)), xa(net_iso(ic12)), & + read(string,*) T,Rho, xa(net_iso(ih1)), xa(net_iso(ihe4)), xa(net_iso(ic12)), & xa(net_iso(in14)), xa(net_iso(io16)), xa(net_iso(ine20)), xa(net_iso(img24)) ! or set some defaults else @@ -239,28 +239,28 @@ subroutine do1_net_eval( & species, chem_id, xa, xh, xhe, z, abar, zbar, z2bar, z53bar, & ye, mass_correction, xsum, dabar_dx, dzbar_dx, dmc_dx) - + ! this is the instantaneous eps_nuc only call net_get( & handle, skip_jacobian, n, species, num_reactions, & - xa, T, logT, Rho, logRho, & + xa, T, logT, Rho, logRho, & abar, zbar, z2bar, ye, eta, d_eta_dlnT, d_eta_dlnRho, & - rate_factors, weak_rate_factor, & + rate_factors, weak_rate_factor, & std_reaction_Qs, std_reaction_neuQs, & - eps_nuc, d_eps_nuc_dRho, d_eps_nuc_dT, d_eps_nuc_dx, & - dxdt, d_dxdt_dRho, d_dxdt_dT, d_dxdt_dx, & - screening_mode, & - eps_nuc_categories, eps_neu_total, & + eps_nuc, d_eps_nuc_dRho, d_eps_nuc_dT, d_eps_nuc_dx, & + dxdt, d_dxdt_dRho, d_dxdt_dT, d_dxdt_dx, & + screening_mode, & + eps_nuc_categories, eps_neu_total, & ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + ! say the initial conditions write(6,23) 'T =',T, 'Rho =',Rho, 'abar =',abar, 'zbar =',zbar write(6,23) 'h1 =',xa(net_iso(ih1)), 'he4 =',xa(net_iso(ihe4)), 'c12 =',xa(net_iso(ic12)), 'n14 =',xa(net_iso(in14)) write(6,23) 'o16 =',xa(net_iso(io16)), 'ne20 =',xa(net_iso(ine20)), 'mg24 =',xa(net_iso(img24)) - + ! write out the mass fraction changes write(6,'(A)') @@ -283,9 +283,9 @@ subroutine do1_net_eval( & end subroutine do1_net_eval - - - + + + end program sample_net diff --git a/net/test/src/test_net.f90 b/net/test/src/test_net.f90 index b489aaab9..2806d82ed 100644 --- a/net/test/src/test_net.f90 +++ b/net/test/src/test_net.f90 @@ -23,11 +23,11 @@ program test_net use mod_test_net, only: test - + implicit none - + call test(.false.) - + end program test_net diff --git a/net/test/src/test_net_do_one.f90 b/net/test/src/test_net_do_one.f90 index c25c63819..6a100e671 100644 --- a/net/test/src/test_net_do_one.f90 +++ b/net/test/src/test_net_do_one.f90 @@ -9,7 +9,7 @@ ! by the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! -! MESA is distributed in the hope that it will be useful, +! MESA is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU Library General Public License for more details. @@ -28,9 +28,9 @@ module test_net_do_one use const_def use rates_def use utils_lib, only: mesa_error - + implicit none - + logical, parameter :: extended_set = .false. logical, parameter :: sorted = .true. @@ -40,16 +40,16 @@ module test_net_do_one real(dp) :: z, abar, zbar, z2bar, z53bar, ye, & eta, d_eta_dlnT, d_eta_dlnRho, eps_neu_total integer :: screening_mode - real(dp) :: test_logT, test_logRho + real(dp) :: test_logT, test_logRho integer, pointer :: reaction_id(:) real(dp), dimension(:), pointer :: & xin, xin_copy, d_eps_nuc_dx, dxdt, d_dxdt_dRho, d_dxdt_dT - real(dp), pointer :: d_dxdt_dx(:,:) - + real(dp), pointer :: d_dxdt_dx(:,:) + contains - - + + subroutine do1_net(handle, symbolic) use chem_lib, only:composition_info integer, intent(in) :: handle @@ -65,24 +65,24 @@ subroutine do1_net(handle, symbolic) type (Net_General_Info), pointer :: g type (Net_Info) :: n logical :: skip_jacobian - + info = 0 call get_net_ptr(handle, g, info) if (info /= 0) call mesa_error(__FILE__,__LINE__) - num_reactions = g% num_reactions + num_reactions = g% num_reactions logRho = test_logRho logT = test_logT if (.not. qt) write(*,*) - + allocate( & rate_factors(num_reactions), & eps_nuc_categories(num_categories), & stat=info) if (info /= 0) call mesa_error(__FILE__,__LINE__) - + call get_chem_id_table(handle, species, chem_id, info) if (info /= 0) call mesa_error(__FILE__,__LINE__) @@ -92,13 +92,13 @@ subroutine do1_net(handle, symbolic) Rho = exp10(logRho) T = exp10(logT) - + if (net_file == '19_to_ni56.net') then logT = 9D+00 logRho = 8D+00 eta = 3D+00 end if - + if (net_file == 'approx21_cr60_plus_co56.net') then logT = 4.6233007922659333D+00 logRho = -1.0746410107891649D+01 @@ -111,7 +111,7 @@ subroutine do1_net(handle, symbolic) skip_jacobian = .false. d_eta_dlnT = 0d0 d_eta_dlnRho = 0d0 - + if (symbolic) then call net_get_symbolic_d_dxdt_dx(handle, n, species, num_reactions, & xin, T, logT, Rho, logRho, & @@ -139,7 +139,7 @@ subroutine do1_net(handle, symbolic) write(*, *) 'bad return from net_get' call mesa_error(__FILE__,__LINE__) end if - + if (symbolic .and..not. qt) then write(*,*) 'nonzero d_dxdt_dx entries' k = 0 @@ -161,11 +161,11 @@ subroutine do1_net(handle, symbolic) g, n, logT, logRho, species, num_reactions, xin, & eps_nuc, d_eps_nuc_dRho, d_eps_nuc_dT, d_eps_nuc_dx, & dxdt, d_dxdt_dRho, d_dxdt_dT, d_dxdt_dx, & - n% eps_nuc_categories, extended_set, sorted) + n% eps_nuc_categories, extended_set, sorted) end if deallocate(rate_factors, eps_nuc_categories) - + return write(*, *) @@ -200,19 +200,19 @@ subroutine show_results( & real(dp), intent(in) :: eps_nuc real(dp), intent(in) :: d_eps_nuc_dT real(dp), intent(in) :: d_eps_nuc_dRho - real(dp), intent(in) :: d_eps_nuc_dx(species) - real(dp), intent(in) :: dxdt(species) - real(dp), intent(in) :: d_dxdt_dRho(species) - real(dp), intent(in) :: d_dxdt_dT(species) - real(dp), intent(in) :: d_dxdt_dx(species, species) - real(dp), intent(in), dimension(num_categories) :: eps_nuc_categories + real(dp), intent(in) :: d_eps_nuc_dx(species) + real(dp), intent(in) :: dxdt(species) + real(dp), intent(in) :: d_dxdt_dRho(species) + real(dp), intent(in) :: d_dxdt_dT(species) + real(dp), intent(in) :: d_dxdt_dx(species, species) + real(dp), intent(in), dimension(num_categories) :: eps_nuc_categories logical, intent(in) :: extended_set logical, intent(in) :: sorted - + integer :: j - + include 'formats' - + if (net_file == 'approx21_cr60_plus_co56.net') then write(*, *) write(*, '(a40, f20.9)') 'log temp', logT @@ -226,29 +226,29 @@ subroutine show_results( & n% rate_raw(g% net_reaction(j)) return end if - + write(*, *) call show_summary_results(logT, logRho, & - eps_nuc, d_eps_nuc_dRho, d_eps_nuc_dT, d_eps_nuc_dx) - + eps_nuc, d_eps_nuc_dRho, d_eps_nuc_dT, d_eps_nuc_dx) + if (extended_set) then write(*, *) call show_all_rates( & g, num_reactions, n, & logT, logRho, sorted) end if - + write(*, *) call show_by_category( & g, num_reactions, eps_nuc_categories, & eps_nuc, d_eps_nuc_dRho, d_eps_nuc_dT, d_eps_nuc_dx, & sorted) - + if (.not. extended_set) return - + write(*, *) call show_dx_dt(g, species, xin, dxdt, sorted) - + write(*, *) call show_d_eps_nuc_dx(g, species, xin, d_eps_nuc_dx, sorted) @@ -256,14 +256,14 @@ subroutine show_results( & end subroutine show_results - + subroutine show_summary_results(logT, logRho, & - eps_nuc, d_eps_nuc_dRho, d_eps_nuc_dT, d_eps_nuc_dx) + eps_nuc, d_eps_nuc_dRho, d_eps_nuc_dT, d_eps_nuc_dx) real(dp), intent(in) :: logT, logRho real(dp), intent(in) :: eps_nuc real(dp), intent(in) :: d_eps_nuc_dT real(dp), intent(in) :: d_eps_nuc_dRho - real(dp), intent(in) :: d_eps_nuc_dx(species) + real(dp), intent(in) :: d_eps_nuc_dx(species) real(dp) :: T, Rho, eps, d_eps_dt, d_eps_dd T = exp10(logT); Rho = exp10(logRho) @@ -281,10 +281,10 @@ subroutine show_summary_results(logT, logRho, & write(*, *) write(*, '(a40, f20.9)') 'd_lneps_dlnT', d_eps_dt * T / eps write(*, '(a40, f20.9)') 'd_lneps_dlnRho', d_eps_dd * Rho / eps - + end subroutine show_summary_results - + subroutine show_all_rates( & g, num_reactions, n, logT, logRho, sorted) type (Net_General_Info), pointer :: g @@ -293,7 +293,7 @@ subroutine show_all_rates( & real(dp), intent(in) :: logT, logRho logical, intent(in) :: sorted real(dp), dimension(num_reactions) :: rfact - + integer :: i real(dp) :: T, Rho T = exp10(logT); Rho = exp10(logRho) @@ -335,7 +335,7 @@ subroutine show_by_category( & real(dp) :: mx integer :: k, j, jmx logical :: flgs(rates_reaction_id_max) - + write(*, *) write(*, *) 'energy generation by category' write(*, *) @@ -358,15 +358,15 @@ subroutine show_by_category( & end if write(*, '(a40, 2x, f15.6, e15.6)') & trim(category_name(jmx)), safe_log10(eps_nuc_categories(jmx)), & - eps_nuc_categories(jmx) + eps_nuc_categories(jmx) end do write(*, *) !write(*, '(a40, 2x, f15.6, e15.6)') & ! 'log10(-photodisintegration)', safe_log10(-eps_nuc_categories(iphoto)), & ! -eps_nuc_categories(iphoto) - + write(*, *) - + end subroutine show_by_category @@ -374,13 +374,13 @@ subroutine show_rates(g, rts, T, Rho, sorted) type (Net_General_Info), pointer :: g real(dp), intent(in) :: rts(rates_reaction_id_max), T, Rho logical, intent(in) :: sorted - + logical :: flgs(rates_reaction_id_max) real(dp) :: mx integer :: k, j, jmx - + flgs = .false. - + do k = 1, g% num_reactions if (.not. sorted) then jmx = k; mx = rts(jmx) @@ -398,7 +398,7 @@ subroutine show_rates(g, rts, T, Rho, sorted) if (mx == 1) cycle write(*, '(a40, e20.9, 2e17.6)') trim(reaction_name(reaction_id(jmx))), mx end do - + end subroutine show_rates @@ -406,13 +406,13 @@ subroutine show_log_rates(g, rts, T, Rho, sorted) type (Net_General_Info), pointer :: g real(dp), intent(in) :: rts(:), T, Rho logical, intent(in) :: sorted - + logical :: flgs(rates_reaction_id_max) real(dp) :: mx integer :: k, j, jmx - + flgs = .false. - + do k = 1, g% num_reactions if (.not. sorted) then jmx = k; mx = rts(jmx) @@ -430,10 +430,10 @@ subroutine show_log_rates(g, rts, T, Rho, sorted) if (mx == 1) cycle write(*, '(a40, f20.9, 2e17.6)') trim(reaction_name(reaction_id(jmx))), safe_log10(mx) end do - + end subroutine show_log_rates - - + + subroutine show_dx_dt(g, species, xin, dxdt, sorted) type (Net_General_Info), pointer :: g integer, intent(in) :: species @@ -446,10 +446,10 @@ subroutine show_dx_dt(g, species, xin, dxdt, sorted) write(*, *) write(*, '(a40, 2(a17))') 'isotope', 'x initial', 'dx_dt ' call show_partials(g, species, xin, dxdt, .true., sorted) - + end subroutine show_dx_dt - - + + subroutine show_d_eps_nuc_dx(g, species, xin, d_eps_nuc_dx, sorted) type (Net_General_Info), pointer :: g integer, intent(in) :: species @@ -462,10 +462,10 @@ subroutine show_d_eps_nuc_dx(g, species, xin, d_eps_nuc_dx, sorted) write(*, *) write(*, '(a40, a17)') 'isotope', 'd_eps_nuc_dx' call show_partials(g, species, xin, d_eps_nuc_dx, .false., sorted) - + end subroutine show_d_eps_nuc_dx - - + + subroutine show_partials(g, species, xin, derivs, initX_flag, sorted) type (Net_General_Info), pointer :: g integer, intent(in) :: species @@ -500,10 +500,10 @@ subroutine show_partials(g, species, xin, derivs, initX_flag, sorted) end if iflgs(jmx) = .true. end do - + end subroutine show_partials - + end module test_net_do_one diff --git a/net/test/src/test_net_quietly.f90 b/net/test/src/test_net_quietly.f90 index f4c3a41b9..25c536cc2 100644 --- a/net/test/src/test_net_quietly.f90 +++ b/net/test/src/test_net_quietly.f90 @@ -23,11 +23,11 @@ program test_net use mod_test_net, only: test - + implicit none - + call test(.true.) - + end program test_net diff --git a/net/test/src/test_net_support.f90 b/net/test/src/test_net_support.f90 index 667c14f04..2869b9fe4 100644 --- a/net/test/src/test_net_support.f90 +++ b/net/test/src/test_net_support.f90 @@ -9,7 +9,7 @@ ! by the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! -! MESA is distributed in the hope that it will be useful, +! MESA is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU Library General Public License for more details. @@ -30,28 +30,28 @@ module test_net_support use rates_def use test_net_do_one use utils_lib, only: mesa_error - + implicit none - - integer, parameter :: max_files = 20, max_cnt = 100000 - - + + integer, parameter :: max_files = 20, max_cnt = 100000 + + character (len=256) :: cache_suffix integer :: num_reactions - + integer, dimension(:), pointer :: net_iso, chem_id, isos_to_show - + integer, pointer :: reaction_table(:) integer, pointer :: rates_to_show(:) real(dp), dimension(:), pointer :: rho_vector, T_vector integer :: nrates_to_show, nisos_to_show, net_handle - + contains - + subroutine do_test_net(do_plots, symbolic) logical, intent(in) :: do_plots, symbolic @@ -62,9 +62,9 @@ subroutine do_test_net(do_plots, symbolic) else call Do_One_Net(symbolic) end if - end subroutine do_test_net - - + end subroutine do_test_net + + subroutine load_libs use const_lib use const_def, only: mesa_dir @@ -72,13 +72,13 @@ subroutine load_libs use rates_lib, only: rates_init, rates_warning_init integer :: ierr character (len=64) :: my_mesa_dir - - my_mesa_dir = '../..' - call const_init(my_mesa_dir,ierr) + + my_mesa_dir = '../..' + call const_init(my_mesa_dir,ierr) if (ierr /= 0) then write(*,*) 'const_init failed' call mesa_error(__FILE__,__LINE__) - end if + end if call math_init() @@ -88,102 +88,102 @@ subroutine load_libs write(*,*) 'chem_init failed' call mesa_error(__FILE__,__LINE__) end if - + call rates_init('reactions.list', '', 'rate_tables', .false., .false., & '', '', '',ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call rates_warning_init(.true., 10d0) - + end subroutine load_libs - - + + subroutine test_net_setup(net_file_in) character (len=*), intent(in) :: net_file_in type(Net_General_Info), pointer :: g integer :: info, ierr - + include 'formats' - + net_file = net_file_in allocate(net_iso(num_chem_isos), isos_to_show(num_chem_isos), chem_id(num_chem_isos)) - + call net_init(ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + net_handle = alloc_net_handle(ierr) if (ierr /= 0) then write(*,*) 'alloc_net_handle failed' call mesa_error(__FILE__,__LINE__) end if - + call net_start_def(net_handle, ierr) if (ierr /= 0) then write(*,*) 'net_start_def failed' call mesa_error(__FILE__,__LINE__) end if - + call read_net_file(net_file, net_handle, ierr) if (ierr /= 0) then write(*,*) 'read_net_file failed ', trim(net_file) call mesa_error(__FILE__,__LINE__) end if - + call net_finish_def(net_handle, ierr) if (ierr /= 0) then write(*,*) 'net_finish_def failed' call mesa_error(__FILE__,__LINE__) end if - + allocate(reaction_id(rates_reaction_id_max), reaction_table(rates_reaction_id_max)) allocate(rates_to_show(rates_reaction_id_max)) - + cache_suffix = '' call net_setup_tables(net_handle, cache_suffix, info) if (ierr /= 0) then write(*,*) 'net_setup_tables failed' call mesa_error(__FILE__,__LINE__) end if - + call net_ptr(net_handle, g, ierr) if (ierr /= 0) then write(*,*) 'net_ptr failed' call mesa_error(__FILE__,__LINE__) end if - + species = g% num_isos num_reactions = g% num_reactions - + call get_chem_id_table(net_handle, species, chem_id, ierr) if (ierr /= 0) then write(*,*) 'get_chem_id_table failed' call mesa_error(__FILE__,__LINE__) end if - + call get_net_iso_table(net_handle, net_iso, ierr) if (ierr /= 0) then write(*,*) 'get_net_iso_table failed' call mesa_error(__FILE__,__LINE__) end if - + call get_reaction_id_table(net_handle, num_reactions, reaction_id, ierr) if (ierr /= 0) then write(*,*) 'get_reaction_id_table failed' call mesa_error(__FILE__,__LINE__) end if - + call get_net_reaction_table(net_handle, reaction_table, ierr) if (ierr /= 0) then write(*,*) 'get_net_reaction_table failed' call mesa_error(__FILE__,__LINE__) end if - + call do_test_net_alloc(species) - end subroutine test_net_setup - + end subroutine test_net_setup + subroutine do_test_net_alloc(species) integer, intent(in) :: species allocate( & @@ -208,20 +208,20 @@ subroutine Setup_eos(handle) if (ierr /= 0) then write(*,*) 'eos_init failed in Setup_eos' call mesa_error(__FILE__,__LINE__) - end if + end if handle = alloc_eos_handle(ierr) if (ierr /= 0) then write(*,*) 'failed trying to allocate eos handle' call mesa_error(__FILE__,__LINE__) - end if + end if end subroutine Setup_eos - - + + subroutine test_net_cleanup call do_test_net_cleanup call free_net_handle(net_handle) end subroutine test_net_cleanup - + subroutine do_test_net_cleanup deallocate(xin) deallocate(d_eps_nuc_dx) @@ -230,8 +230,8 @@ subroutine do_test_net_cleanup deallocate(d_dxdt_dT) deallocate(d_dxdt_dx) end subroutine do_test_net_cleanup - - + + subroutine change_net(new_net_file) character (len=*), intent(in) :: new_net_file call test_net_cleanup @@ -289,15 +289,15 @@ subroutine Create_Plot_Files(species, xin) logT_points = 251 logRho_points = 251 - + dir = 'plot_data' call mkdir(dir) write(*, *) trim(dir) - + 01 format(E30.22) dlogT = (logT_max-logT_min)/(logT_points-1) - dlogRho = (logRho_max-logRho_min)/(logRho_points-1) + dlogRho = (logRho_max-logRho_min)/(logRho_points-1) io_params = 40 io_rho = 41 @@ -323,11 +323,11 @@ subroutine Create_Plot_Files(species, xin) call get_net_ptr(net_handle, g, ierr) if(ierr/=0) return - + num_reactions = g% num_reactions allocate(output_values(logRho_points, logT_points, num_out)) - + !xx$OMP PARALLEL DO PRIVATE(logT, T, j) do j=1, logT_points logT = logT_min + dlogT*(j-1) @@ -335,7 +335,7 @@ subroutine Create_Plot_Files(species, xin) call do_inner_loop(species, num_reactions, logT, T, j, output_values, n, xin, & logRho_points, logRho_min, dlogRho) - + end do !xx$OMP END PARALLEL DO @@ -352,18 +352,18 @@ subroutine Create_Plot_Files(species, xin) write(io_tmp, 01) logT_min + dlogT*(i-1) enddo close(io_tmp) - + !$OMP PARALLEL DO PRIVATE(k) do k = 1, num_out write(*, *) k write(io_first+k-1, '(e14.6)') output_values(:, :, k) end do !$OMP END PARALLEL DO - + do io=io_first, io_last close(io) end do - + end subroutine Create_Plot_Files @@ -385,10 +385,10 @@ subroutine do_inner_loop(species, num_reactions, logT, T, j, output_values, n, x call do_one_net_eval(species, num_reactions, logT, T, logRho, Rho, & i, j, output_values, n, xin) enddo - + end subroutine do_inner_loop - - + + subroutine do_one_net_eval(species, num_reactions, logT, T, logRho, Rho, & i, j, output_values, n, xin) use chem_lib, only:composition_info @@ -399,7 +399,7 @@ subroutine do_one_net_eval(species, num_reactions, logT, T, logRho, Rho, & type(net_info) :: n real(dp), intent(OUT) :: output_values(:, :, :) real(dp), intent(in) :: xin(species) - + real(dp) :: z, abar, zbar, z2bar, z53bar, ye, sum, mx, weak_rate_factor real(dp), target :: rate_factors_a(num_reactions) real(dp), pointer :: rate_factors(:) @@ -407,39 +407,39 @@ subroutine do_one_net_eval(species, num_reactions, logT, T, logRho, Rho, & real(dp) :: eps_nuc real(dp) :: d_eps_nuc_dT real(dp) :: d_eps_nuc_dRho - real(dp) :: d_eps_nuc_dx(species) + real(dp) :: d_eps_nuc_dx(species) ! partial derivatives wrt mass fractions - - real(dp) :: dxdt(species) + + real(dp) :: dxdt(species) ! rate of change of mass fractions caused by nuclear reactions real(dp) :: d_dxdt_dRho(species) real(dp) :: d_dxdt_dT(species) - real(dp) :: d_dxdt_dx(species, species) - real(dp) :: eps_nuc_categories(num_categories) + real(dp) :: d_dxdt_dx(species, species) + real(dp) :: eps_nuc_categories(num_categories) integer :: info, k, h1, he4, chem_id(species) real(dp) :: xh, xhe, mass_correction real(dp), dimension(species) :: dabar_dx, dzbar_dx, dmc_dx logical :: skip_jacobian - + rate_factors => rate_factors_a - + h1 = net_iso(ih1) he4 = net_iso(ihe4) g => n% g - + call get_chem_id_table(net_handle, species, chem_id, info) if (info /= 0) call mesa_error(__FILE__,__LINE__) call composition_info( & species, chem_id, xin, xh, xhe, z, abar, zbar, z2bar, z53bar, ye, & mass_correction, sum, dabar_dx, dzbar_dx, dmc_dx) - + rate_factors(:) = 1 weak_rate_factor = 1 skip_jacobian = .false. - + call net_get(net_handle, skip_jacobian, n, species, num_reactions, & xin, T, logT, Rho, logRho, & abar, zbar, z2bar, ye, eta, d_eta_dlnT, d_eta_dlnRho, & @@ -468,28 +468,28 @@ subroutine do_one_net_eval(species, num_reactions, logT, T, logRho, Rho, & end if k = 1; output_values(i, j, k) = safe_log10(eps_nuc) - + k = k+1; output_values(i, j, k) = sum / max(1d-20, mx) k = k+1; output_values(i, j, k) = d_eps_nuc_dT * T / max(1d-20, eps_nuc) k = k+1; output_values(i, j, k) = d_eps_nuc_dRho * Rho / max(1d-20, eps_nuc) k = k+1; output_values(i, j, k) = safe_log10(abs(d_eps_nuc_dx(h1))) k = k+1; output_values(i, j, k) = safe_log10(abs(d_eps_nuc_dx(he4))) - + if (k > max_files) then write(*, *) 'need to enlarge max_files' call mesa_error(__FILE__,__LINE__) end if end subroutine do_one_net_eval - + integer function Open_Files(io_start, dir) integer, intent(in) :: io_start character (len=256), intent(in) :: dir character (len=256) fname integer :: io io = io_start - + fname = trim(dir) // '/' // 'log_net_eps.data' io = io + 1; open(unit=io, file=trim(fname)) @@ -507,118 +507,118 @@ integer function Open_Files(io_start, dir) fname = trim(dir) // '/' // 'd_eps_nuc_dxhe4.data' io = io + 1; open(unit=io, file=trim(fname)) - + Open_Files = io - + end function Open_Files subroutine set_composition(species, xin) integer, intent(in) :: species real(dp), intent(OUT) :: xin(species) - + real(dp) :: sum integer :: i, adjustment_iso - + eta = 0 - + adjustment_iso = net_iso(img24) - if (net_file == 'basic.net') then - + if (net_file == 'basic.net') then + adjustment_iso = net_iso(img24) - + xin = 0 - xin(net_iso(ih1)) = 0.655186E+00 ! h1 - xin(net_iso(ihe4)) = 0.31002164D+00 ! he4 + xin(net_iso(ih1)) = 0.655186E+00 ! h1 + xin(net_iso(ihe4)) = 0.31002164D+00 ! he4 xin(net_iso(ic12)) = 0.002725D-01 ! c12 - xin(net_iso(in14)) = 0.203101D-01 + 0.612124D-06 + 0.109305D-02 + 0.356004D-04 - xin(net_iso(io16)) = 0.094000D-01 ! o16 - xin(net_iso(ine20)) = 0.162163D-02 ! ne20 + xin(net_iso(in14)) = 0.203101D-01 + 0.612124D-06 + 0.109305D-02 + 0.356004D-04 + xin(net_iso(io16)) = 0.094000D-01 ! o16 + xin(net_iso(ine20)) = 0.162163D-02 ! ne20 xin(net_iso(img24)) = 0.658226D-25 ! mg24 - xin(net_iso(ihe3)) = 0.201852D-02 ! he3 - + xin(net_iso(ihe3)) = 0.201852D-02 ! he3 + else if (net_file == 'o18_and_ne22.net') then - + adjustment_iso = net_iso(img24) - + xin = 0 - xin(net_iso(ih1)) = 0.655186E+00 + xin(net_iso(ih1)) = 0.655186E+00 xin(net_iso(ihe4)) = 0.31002164D+00 - xin(net_iso(ic12)) = 0.002725D-01 + xin(net_iso(ic12)) = 0.002725D-01 xin(net_iso(in14)) = 0.203101D-01 + 0.612124D-06 + 0.109305D-02 xin(net_iso(io16)) = 0.094000D-01 xin(net_iso(io18)) = 1d-20 - xin(net_iso(ine20)) = 0.162163D-02 - xin(net_iso(img24)) = 0.658226D-25 + xin(net_iso(ine20)) = 0.162163D-02 + xin(net_iso(img24)) = 0.658226D-25 xin(net_iso(ine22)) = 0.201852D-02 - + else if (net_file == 'pp_extras.net') then - + adjustment_iso = net_iso(img24) - + xin = 0 - xin(net_iso(ih1)) = 0.655186E+00 ! h1 - xin(net_iso(ihe4)) = 0.31002164D+00 ! he4 + xin(net_iso(ih1)) = 0.655186E+00 ! h1 + xin(net_iso(ihe4)) = 0.31002164D+00 ! he4 xin(net_iso(ic12)) = 0.002725D-01 ! c12 - xin(net_iso(in14)) = 0.203101D-01 + 0.612124D-06 + 0.109305D-02 + 0.356004D-04 - xin(net_iso(io16)) = 0.094000D-01 ! o16 - xin(net_iso(ine20)) = 0.162163D-02 ! ne20 + xin(net_iso(in14)) = 0.203101D-01 + 0.612124D-06 + 0.109305D-02 + 0.356004D-04 + xin(net_iso(io16)) = 0.094000D-01 ! o16 + xin(net_iso(ine20)) = 0.162163D-02 ! ne20 xin(net_iso(img24)) = 0.658226D-25 ! mg24 - - xin(net_iso(ih2)) = 0.632956D-17 ! h2 - xin(net_iso(ihe3)) = 0.201852D-02 ! he3 - xin(net_iso(ili7)) = 0.664160D-15 ! li7 - xin(net_iso(ibe7)) = 0.103866D-15 ! be7 - + + xin(net_iso(ih2)) = 0.632956D-17 ! h2 + xin(net_iso(ihe3)) = 0.201852D-02 ! he3 + xin(net_iso(ili7)) = 0.664160D-15 ! li7 + xin(net_iso(ibe7)) = 0.103866D-15 ! be7 + else if (net_file == 'cno_extras.net') then adjustment_iso = net_iso(img24) xin = 0 - xin(net_iso(ih1)) = 0.173891680788D-01 ! h1 - xin(net_iso(ihe4)) = 0.963245225401D+00 ! he4 - xin(net_iso(ic12)) = 0.238935745993D-03 ! c12 - xin(net_iso(in14)) = 0.134050688300D-01 ! n14 - xin(net_iso(io16)) = 0.268791618452D-03 ! o16 - xin(net_iso(ine20)) = 0.180001692845D-02 ! ne20 - xin(net_iso(img24)) = 0.353667702698D-02 ! mg24 - - xin(net_iso(ic13)) = 0.717642727071D-04 ! c13 - xin(net_iso(in13)) = 0.370732258156D-09 ! n13 - xin(net_iso(in15)) = 0.450484708137D-06 ! n15 - xin(net_iso(io14)) = 0.100000000000D-49 ! o14 - xin(net_iso(io15)) = 0.874815374966D-10 ! o15 - xin(net_iso(if17)) = 0.100000000000D-49 ! f17 - xin(net_iso(if18)) = 0.100000000000D-49 ! f18 - xin(net_iso(ine18)) = 0.100000000000D-49 ! ne18 - xin(net_iso(ine19)) = 0.100000000000D-49 ! ne19 - xin(net_iso(img22)) = 0.439011547696D-04 ! mg22 - + xin(net_iso(ih1)) = 0.173891680788D-01 ! h1 + xin(net_iso(ihe4)) = 0.963245225401D+00 ! he4 + xin(net_iso(ic12)) = 0.238935745993D-03 ! c12 + xin(net_iso(in14)) = 0.134050688300D-01 ! n14 + xin(net_iso(io16)) = 0.268791618452D-03 ! o16 + xin(net_iso(ine20)) = 0.180001692845D-02 ! ne20 + xin(net_iso(img24)) = 0.353667702698D-02 ! mg24 + + xin(net_iso(ic13)) = 0.717642727071D-04 ! c13 + xin(net_iso(in13)) = 0.370732258156D-09 ! n13 + xin(net_iso(in15)) = 0.450484708137D-06 ! n15 + xin(net_iso(io14)) = 0.100000000000D-49 ! o14 + xin(net_iso(io15)) = 0.874815374966D-10 ! o15 + xin(net_iso(if17)) = 0.100000000000D-49 ! f17 + xin(net_iso(if18)) = 0.100000000000D-49 ! f18 + xin(net_iso(ine18)) = 0.100000000000D-49 ! ne18 + xin(net_iso(ine19)) = 0.100000000000D-49 ! ne19 + xin(net_iso(img22)) = 0.439011547696D-04 ! mg22 + else if (net_file == 'pp_cno_extras_o18_ne22.net') then - + adjustment_iso = net_iso(img24) xin = 0 - xin(net_iso(ih1)) = 0.173891680788D-01 ! h1 - xin(net_iso(ihe4)) = 0.963245225401D+00 ! he4 - xin(net_iso(ic12)) = 0.238935745993D-03 ! c12 - xin(net_iso(in14)) = 0.134050688300D-01 ! n14 - xin(net_iso(io16)) = 0.268791618452D-03 ! o16 - xin(net_iso(ine20)) = 0.180001692845D-02 ! ne20 - xin(net_iso(img24)) = 0.353667702698D-02 ! mg24 - - xin(net_iso(ic13)) = 0.717642727071D-04 ! c13 - xin(net_iso(in13)) = 0.370732258156D-09 ! n13 - xin(net_iso(in15)) = 0.450484708137D-06 ! n15 - xin(net_iso(io14)) = 0.100000000000D-49 ! o14 - xin(net_iso(io15)) = 0.874815374966D-10 ! o15 - xin(net_iso(if17)) = 0.100000000000D-49 ! f17 - xin(net_iso(if18)) = 0.100000000000D-49 ! f18 - xin(net_iso(ine18)) = 0.100000000000D-49 ! ne18 - xin(net_iso(ine19)) = 0.100000000000D-49 ! ne19 - xin(net_iso(img22)) = 0.439011547696D-04 ! mg22 - + xin(net_iso(ih1)) = 0.173891680788D-01 ! h1 + xin(net_iso(ihe4)) = 0.963245225401D+00 ! he4 + xin(net_iso(ic12)) = 0.238935745993D-03 ! c12 + xin(net_iso(in14)) = 0.134050688300D-01 ! n14 + xin(net_iso(io16)) = 0.268791618452D-03 ! o16 + xin(net_iso(ine20)) = 0.180001692845D-02 ! ne20 + xin(net_iso(img24)) = 0.353667702698D-02 ! mg24 + + xin(net_iso(ic13)) = 0.717642727071D-04 ! c13 + xin(net_iso(in13)) = 0.370732258156D-09 ! n13 + xin(net_iso(in15)) = 0.450484708137D-06 ! n15 + xin(net_iso(io14)) = 0.100000000000D-49 ! o14 + xin(net_iso(io15)) = 0.874815374966D-10 ! o15 + xin(net_iso(if17)) = 0.100000000000D-49 ! f17 + xin(net_iso(if18)) = 0.100000000000D-49 ! f18 + xin(net_iso(ine18)) = 0.100000000000D-49 ! ne18 + xin(net_iso(ine19)) = 0.100000000000D-49 ! ne19 + xin(net_iso(img22)) = 0.439011547696D-04 ! mg22 + else if (net_file == 'approx21_cr60_plus_co56.net') then - + adjustment_iso = net_iso(img24) xin = 0 xin(net_iso(ihe4))= 3.4555392534813939D-01 @@ -643,9 +643,9 @@ subroutine set_composition(species, xin) xin(net_iso(icr60))= 4.7653353095937982D-08 xin(net_iso(iprot))= 1.2739022407246250D-11 xin(net_iso(ineut))= 0.0000000000000000D+00 - + else if (net_file == 'approx21_cr60_plus_fe53_fe55_co56.net') then - + adjustment_iso = net_iso(img24) xin = 0 xin(net_iso(ihe4))= 3.4555392534813939D-01 @@ -672,12 +672,12 @@ subroutine set_composition(species, xin) xin(net_iso(ife53))= 0.0000000000000000D+00 xin(net_iso(ife55))= 0.0000000000000000D+00 xin(net_iso(ineut))= 0.0000000000000000D+00 - + else if (net_file == 'approx21_new.net' .or. & net_file == 'approx21_old.net' .or. & net_file == 'approx21_plus_co56.net' .or. & net_file == 'approx21.net') then - + adjustment_iso = net_iso(img24) xin = 0 xin(net_iso(ife56))= 8.0387021484318166D-01 @@ -702,10 +702,10 @@ subroutine set_composition(species, xin) xin(net_iso(in14))= 7.5867472225841235D-99 else - + write(*,*) 'net_file ' // trim(net_file) call mesa_error(__FILE__,__LINE__,'set_composition: do not recognize net_file') - + end if sum = 0d0 @@ -718,8 +718,8 @@ subroutine set_composition(species, xin) if (xin(adjustment_iso) < 0d0) call mesa_error(__FILE__,__LINE__,'error in sum of abundances') end subroutine set_composition - - + + subroutine read_test_data(filename, n, rho_vec, T_vec, ierr) ! the data files have columns of mass, radius, density, temp use utils_lib @@ -727,17 +727,17 @@ subroutine read_test_data(filename, n, rho_vec, T_vec, ierr) integer, intent(out) :: n real(dp), dimension(:), pointer :: rho_vec, T_vec ! to be allocated and filled integer, intent(out) :: ierr - + integer :: iounit, i real(dp) :: junk - + ierr = 0 open(newunit=iounit, file=trim(filename), action='read', iostat=ierr) if (ierr /= 0) then write(*, *) 'failed to open ', trim(filename) return end if - + i = 0 do read(unit=iounit, fmt=*, iostat=ierr) junk, junk, junk, junk @@ -749,18 +749,18 @@ subroutine read_test_data(filename, n, rho_vec, T_vec, ierr) exit end do rewind(iounit) - + allocate(rho_vec(n), T_vec(n), stat=ierr); if (ierr /= 0) return - + do i=1, n read(iounit, *) junk, junk, rho_vec(i), T_vec(i) end do - + close(iounit) - + end subroutine read_test_data - + subroutine Do_One_Test(net_file, do_timing) use chem_lib, only:composition_info use rates_lib @@ -769,7 +769,7 @@ subroutine Do_One_Test(net_file, do_timing) call Do_One_Testcase(net_file, do_timing, .false.) end subroutine Do_One_Test - + subroutine Do_One_Test_and_show_Qs(net_file, do_timing) use chem_lib, only:composition_info use rates_lib @@ -777,14 +777,14 @@ subroutine Do_One_Test_and_show_Qs(net_file, do_timing) logical, intent(in) :: do_timing call Do_One_Testcase(net_file, do_timing, .true.) end subroutine Do_One_Test_and_show_Qs - - + + subroutine Do_One_Testcase(net_file, do_timing, show_Qs) use chem_lib, only:composition_info use rates_lib character (len=*), intent(in) :: net_file logical, intent(in) :: do_timing, show_Qs - + real(dp) :: logRho, logT, Rho, T, xsum, Q1, & eps_nuc, d_eps_nuc_dRho, d_eps_nuc_dT, weak_rate_factor, & dvardx, dvardx_0, dx_0, err, var_0, xdum, & @@ -793,31 +793,31 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) integer :: j_dx, j_dx_sink real(dp), dimension(:), pointer :: d_eps_nuc_dx, dabar_dx, dzbar_dx, dmc_dx real(dp), pointer :: rate_factors(:), & - actual_Qs(:), actual_neuQs(:) + actual_Qs(:), actual_neuQs(:) logical, pointer :: from_weaklib(:) logical :: skip_jacobian, doing_d_dlnd, doing_dx real(dp), dimension(:), pointer :: & rate_raw, rate_raw_dT, & rate_screened type(net_info) :: n - + include 'formats' - + write(*,*) 'Do_One_Test ' // trim(net_file) - + if (do_timing) call mesa_error(__FILE__,__LINE__,'no support for do_timing') - + call test_net_setup(net_file) - + ierr = 0 - + write(*,*) 'species', species - + allocate(d_eps_nuc_dx(species), dabar_dx(species), dzbar_dx(species), dmc_dx(species)) - + info = 0 - + allocate(& rate_factors(num_reactions), & actual_Qs(num_reactions), & @@ -825,21 +825,21 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) from_weaklib(num_reactions), & stat=info) if (info /= 0) call mesa_error(__FILE__,__LINE__) - + rate_factors(:) = 1 weak_rate_factor = 1 - + if (.false.) then ! get neutrino Q - + Q1 = eval_neutrino_Q(img22, is30) write(*,1) 'Qneu mg22->s30', Q1 - + Q1 = eval_neutrino_Q(is30, ini56) write(*,1) 'Qneu s30->ni56', Q1 - + Q1 = eval_neutrino_Q(ica38, ini56) write(*,1) 'Qneu ca38->ni56', Q1 - + Q1 = eval_neutrino_Q(ini56, ige64) write(*,1) 'Qneu ni56->ge64', Q1 @@ -857,7 +857,7 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) stop end if - + if (.false.) then ! get reaction Q ! co55 -> fe55 Q1 = isoB(ife55) - isoB(ico55) @@ -869,9 +869,9 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) eta = 0 if (net_file == 'mesa_201.net') then - + nrates_to_show = 2 - + rates_to_show(1:nrates_to_show) = (/ & ir_ar36_ag_ca40, & ir_ca40_ga_ar36 /) @@ -1077,16 +1077,16 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) xin(net_iso(ife65))= 3.7335326045384740D-26 xin(net_iso(ife66))= 8.6772104841406824D-30 xin(net_iso(ib8))= 4.1439050548710376D-31 - + write(*,*) 'sum xin', sum(xin(:)) logT = 9.6532818288064650D+00 logRho = 7.9479966082179185D+00 eta = 2.7403163311838425D+00 - - + + screening_mode = extended_screening - + call net_set_logTcut(net_handle, 0d0, 0d0, info) if (info /= 0) then write(*,*) 'failed in net_set_logTcut' @@ -1094,9 +1094,9 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) end if else if (net_file == 'approx21_cr60_plus_co56.net') then - + nrates_to_show = 2 - + rates_to_show(1:nrates_to_show) = (/ & irco56ec_to_fe56, & irni56ec_to_co56 /) @@ -1124,16 +1124,16 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) xin(net_iso(ico56))= 6.8333792315189530D-03 xin(net_iso(ini56))= 8.7251484519146338D-04 - + write(*,*) 'sum xin', sum(xin(:)) logT = 9.8200000000000003D+00 logRho = 8.2586740078478176D+00 eta = 0d0 - - + + screening_mode = extended_screening - + call net_set_logTcut(net_handle, 0d0, 0d0, info) if (info /= 0) then write(*,*) 'failed in net_set_logTcut' @@ -1141,9 +1141,9 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) end if else if (net_file == 'approx21_cr60_plus_fe53_fe55_co56.net') then - + nrates_to_show = 2 - + rates_to_show(1:nrates_to_show) = (/ & irco56ec_to_fe56, & irni56ec_to_co56 /) @@ -1173,16 +1173,16 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) xin(net_iso(ife55))= 0.0000000000000000D+00 xin(net_iso(ineut))= 0.0000000000000000D+00 - + write(*,*) 'sum xin', sum(xin(:)) logT = 4.6233007922659333D+00 logRho = -1.0746410107891649D+01 eta = -2.2590260158215202D+01 - - + + screening_mode = extended_screening - + call net_set_logTcut(net_handle, 0d0, 0d0, info) if (info /= 0) then write(*,*) 'failed in net_set_logTcut' @@ -1190,26 +1190,26 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) end if else if (net_file == 'basic.net') then - + nrates_to_show = 1 - + if (rates_reaction_id('rc12_to_n14') <= 0) call mesa_error(__FILE__,__LINE__,'bad reaction') write(*,*) 'rc12_to_n14', rates_reaction_id('rc12_to_n14') - + rates_to_show(1:nrates_to_show) = (/ & rates_reaction_id('rc12_to_n14') /) - + xin(net_iso(ihe4))= 9.8119124177708650D-01 xin(net_iso(in14))= 9.8369547495994036D-03 xin(net_iso(io16))= 2.9223115895360822D-03 xin(net_iso(ine20))= 2.0337034688681288D-03 xin(net_iso(ihe3))= 0.0000000000000000D+00 xin(net_iso(ih1))= 0.0000000000000000D+00 - + write(*,*) 'when 1st' xin(net_iso(ic12))= 2.3551202768735954D-04 ! 2.3551179217556737D-04 xin(net_iso(img24))= 3.7802763872225075D-03 ! 3.7802766227342998D-03 - + !write(*,*) 'when 2nd' !xin(net_iso(ic12))= 2.3551179217556737D-04 !xin(net_iso(img24))= 3.7802766227342998D-03 @@ -1219,10 +1219,10 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) eta = 1.2629003275927920D+01 write(*,*) 'sum xin', sum(xin(:)) - - + + screening_mode = extended_screening - + call net_set_logTcut(net_handle, 0d0, 0d0, info) if (info /= 0) then write(*,*) 'failed in net_set_logTcut' @@ -1230,32 +1230,32 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) end if else if (net_file == 'agb.net') then - + nrates_to_show = 4 - + rates_to_show(1:nrates_to_show) = (/ & ir_h1_h1_wk_h2, & ir_c13_an_o16, & ir_f19_ap_ne22, & ir_he3_ag_be7 /) - + xin(net_iso(ih1))= 1 - + write(*,*) 'sum xin', sum(xin(:)) logT = 8.6864273893515023D+00 logRho = 2.0591020210828619D+00 eta = -1.4317150417353590D+01 - - + + screening_mode = extended_screening - + call net_set_logTcut(net_handle, 0d0, 0d0, info) if (info /= 0) then write(*,*) 'failed in net_set_logTcut' call mesa_error(__FILE__,__LINE__) end if - + if (.false.) then if (.false.) then rate_factors(:) = 0 @@ -1272,12 +1272,12 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) end if end if - + else if (net_file == 'pp_and_cno_extras.net') then - + nrates_to_show = 8 - + rates_to_show(1:nrates_to_show) = (/ & rates_reaction_id('r_n13_wk_c13'), & rates_reaction_id('r_o15_wk_n15'), & @@ -1287,7 +1287,7 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) rates_reaction_id('r_ne18_wk_f18'), & rates_reaction_id('r_ne19_wk_f19'), & ir_he4_he4_he4_to_c12 /) - + xin = 0 xin(net_iso(ih1))= 7.2265805432969643D-01 xin(net_iso(ihe3))= 6.7801726921522655D-04 @@ -1304,7 +1304,7 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) xin(net_iso(if19))= 2.1343308067891499D-07 xin(net_iso(ine20))= 1.2563102679570999D-03 xin(net_iso(img24))= 4.7858754879924638D-04 - + logT = 9.6d0 logRho = 6.0d0 rho = 7.8571498592117219D+00 @@ -1313,15 +1313,15 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) zbar = 1.0901664301076275D+00 z2bar = 1.3036906023574921D+00 ye = 8.6144702146826535D-01 - eta = -3.4387570967781595D+00 - + eta = -3.4387570967781595D+00 + screening_mode = extended_screening else if (net_file == 'approx21_plus_co56.net') then - + nrates_to_show = 5 - + rates_to_show(1:nrates_to_show) = (/ & ir_v47_pa_ti44, & ir_mn51_pa_cr48, & @@ -1330,7 +1330,7 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) ir_s32_ap_cl35 & /) xin = 0 - + xin(net_iso(ife54))= 7.8234742556602999D-01 xin(net_iso(isi28))= 7.8210084821085060D-02 xin(net_iso(ini56))= 5.2306555890846963D-02 @@ -1353,7 +1353,7 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) xin(net_iso(ihe3))= 0.0000000000000000D+00 xin(net_iso(ih1))= 0.0000000000000000D+00 write(*,*) 'test case sum xin', sum(xin(1:species)) - + logT = 9.5806070583042597D+00 logRho = 7.1251356937727763D+00 @@ -1368,25 +1368,25 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) screening_mode = extended_screening else - + write(*, *) 'need to define setup for net_file ', trim(net_file) call mesa_error(__FILE__,__LINE__,'Do_One_Test') - + end if - + Rho = exp10(logRho) T = exp10(logT) - + write(*, *) write(*, *) - + info = 0 - + ierr = 0 call composition_info( & species, chem_id, xin, xh, xhe, z, abar, zbar, z2bar, z53bar, ye, & mass_correction, xsum, dabar_dx, dzbar_dx, dmc_dx) - + write(*,'(a40,d26.16)') 'xh', xh write(*,'(a40,d26.16)') 'xhe', xhe write(*,'(a40,d26.16)') 'abar', abar @@ -1400,7 +1400,7 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) write(*,'(a40,d26.16)') 'logT', logT write(*,'(a40,d26.16)') 'logRho', logRho write(*,'(a40,d26.16)') 'eta', eta - + skip_jacobian = .false. n% screening_mode = screening_mode @@ -1435,21 +1435,21 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) write(*, *) 'bad return from net_get' call mesa_error(__FILE__,__LINE__) end if - - - + + + if (.true.) then ! dfridr tests for partials - - + + !doing_d_dlnd = .true. doing_d_dlnd = .false. doing_dx = .false. j_dx = 22 var_0 = dxdt(j_dx) - + if (doing_dx) then - j_dx = 20 ! fe56 + j_dx = 20 ! fe56 j_dx_sink = 17 ! cr56 dx_0 = xin(j_dx)*1d-6 dvardx_0 = d_eps_nuc_dx(j_dx) @@ -1480,17 +1480,17 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) end if write(*,*) 'test net' write(*,'(A)') - + call mesa_error(__FILE__,__LINE__,'test net') - - - - - + + + + + end if - - - + + + if (show_Qs) then write(*,'(A)') @@ -1510,19 +1510,19 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) write(*,'(A)') stop end if - + write(*,2) 'screening_mode', screening_mode - + if (.true.) then write(*,1) 'logT', logT write(*,1) 'logRho', logRho write(*,'(A)') - + write(*,1) 'eps_nuc', eps_nuc write(*,1) 'd_epsnuc_dlnd', d_eps_nuc_dRho*Rho write(*,1) 'd_epsnuc_dlnT', d_eps_nuc_dT*T write(*,'(A)') - + if (eps_nuc > 0) then write(*,1) 'log eps_nuc', log10(eps_nuc) write(*,1) 'd_lnepsnuc_dlnd', d_eps_nuc_dRho*Rho/eps_nuc @@ -1530,7 +1530,7 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) write(*,'(A)') end if - + !stop @@ -1546,12 +1546,12 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) write(*,1) 'd_dxdt_dlnRho ' // trim(chem_isos% name(chem_id(i))), d_dxdt_dRho(i)*rho end do write(*,'(A)') - + do i = 1, species write(*,1) 'd_dxdt_dlnT ' // trim(chem_isos% name(chem_id(i))), d_dxdt_dT(i)*T end do write(*,'(A)') - + if (.false.) then do i = 1, species write(*,1) 'd_dxdt_dx(:,neut) ' // & @@ -1565,7 +1565,7 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) write(*,1) 'dxdt ' // trim(chem_isos% name(chem_id(i))), dxdt(i) end do write(*,1) 'sum(dxdt)', sum(dxdt(1:species)) - + do i=1,nrates_to_show j = rates_to_show(i) if (j == 0) cycle @@ -1573,9 +1573,9 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) rate_raw_dT(reaction_table(j)) end do write(*,'(A)') - + end if - + do i=1,nrates_to_show j = rates_to_show(i) if (j == 0) cycle @@ -1583,7 +1583,7 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) rate_raw(reaction_table(j)) end do write(*,'(A)') - + do i=1,nrates_to_show j = rates_to_show(i) if (j == 0) cycle @@ -1599,7 +1599,7 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) actual_Qs(reaction_table(j)) end do write(*,'(A)') - + do i=1,nrates_to_show j = rates_to_show(i) if (j == 0) cycle @@ -1607,7 +1607,7 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) actual_neuQs(reaction_table(j)) end do write(*,'(A)') - + do i=1,nrates_to_show j = rates_to_show(i) if (j == 0) cycle @@ -1615,28 +1615,28 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) actual_Qs(reaction_table(j)) - actual_neuQs(reaction_table(j)) end do write(*,'(A)') - + if (.false.) then - + do i = 1, species write(*,1) 'x ' // trim(chem_isos% name(chem_id(i))), xin(i) end do write(*,'(A)') - + do i = 1, species if (-dxdt(i) > 1d-90) & write(*,1) 'x/dxdt ' // trim(chem_isos% name(chem_id(i))), xin(i)/dxdt(i) end do write(*,'(A)') - + do i = 1, num_categories if (abs(eps_nuc_categories(i)) < 1d-20) cycle write(*,1) 'eps_nuc_cat ' // trim(category_name(i)), eps_nuc_categories(i) end do write(*,'(A)') - + end if - + stop end if @@ -1703,23 +1703,23 @@ subroutine Do_One_Testcase(net_file, do_timing, show_Qs) deallocate(rate_factors, actual_Qs, actual_neuQs, from_weaklib) - + contains - - + + real(dp) function dfridr_func(delta_x) result(val) real(dp), intent(in) :: delta_x integer :: ierr real(dp) :: var, log_var include 'formats' ierr = 0 - + if (doing_dx) then - + xin_copy = xin xin_copy(j_dx) = xin_copy(j_dx) + delta_x xin_copy(j_dx_sink) = xin_copy(j_dx_sink) - delta_x - + call net_get_with_Qs( & net_handle, skip_jacobian, n, species, num_reactions, & xin_copy, T, logT, Rho, logRho, & @@ -1736,12 +1736,12 @@ real(dp) function dfridr_func(delta_x) result(val) write(*,1) 'xin(j_sink)', xin_copy(j_dx_sink) write(*,1) 'eps_nuc', eps_nuc write(*,'(A)') - + else if (doing_d_dlnd) then - + log_var = logRho + delta_x/ln10 var = exp10(log_var) - + call net_get_with_Qs( & net_handle, skip_jacobian, n, species, num_reactions, & xin, T, logT, var, log_var, & @@ -1755,10 +1755,10 @@ real(dp) function dfridr_func(delta_x) result(val) actual_Qs, actual_neuQs, from_weaklib, ierr) else - + log_var = logT + delta_x/ln10 var = exp10(log_var) - + call net_get_with_Qs( & net_handle, skip_jacobian, n, species, num_reactions, & xin, var, log_var, Rho, logRho, & @@ -1770,13 +1770,13 @@ real(dp) function dfridr_func(delta_x) result(val) screening_mode, & eps_nuc_categories, eps_neu_total, & actual_Qs, actual_neuQs, from_weaklib, ierr) - + end if - + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in call on net_get_with_Qs') !val = eps_nuc ! dxdt(1) val = dxdt(j_dx) - + end function dfridr_func @@ -1831,20 +1831,20 @@ end function dfridr end subroutine Do_One_Testcase - + subroutine test_neutrino_Q real(dp), parameter :: Qnu_n13 = 0.714440d0 !..13n(e+nu)13c real(dp), parameter :: Qnu_o15 = 1.005513d0 !..15o(e+nu)15n real(dp), parameter :: Qnu_f17 = 1.009145d0 !..17f(e+nu)17o - real(dp), parameter :: Qnu_f18 = 0.393075d0 !..18f(e+nu)18o + real(dp), parameter :: Qnu_f18 = 0.393075d0 !..18f(e+nu)18o real(dp), parameter :: Qnu_o14 = 2.22d0 !..14o(e+nu)14n real(dp), parameter :: Qnu_ne18 = 1.87d0 !..18ne(e+nu)18f real(dp), parameter :: Qnu_ne19 = 1.25d0 !..19ne(e+nu)19f !real(dp), parameter :: Qnu_mg21 = 6.2d0 !..mg21(e+nu)na21 real(dp), parameter :: Qnu_mg22 = 2.1d0 !..mg22(e+nu)na22 - + 1 format(a40, 1pd26.16) - + write(*, 1) 'expected Q for 13n(e+nu)13c', Qnu_n13 write(*, 1) 'calculated Q for 13n(e+nu)13c', eval_neutrino_Q(in13, ic13) write(*, *) @@ -1870,11 +1870,11 @@ subroutine test_neutrino_Q write(*, 1) 'calculated Q for mg22(e+nu)na22', eval_neutrino_Q(img22, ina22) write(*, *) stop - + end subroutine test_neutrino_Q - - + + end module test_net_support diff --git a/neu/plotter/src/neu_plotter.f90 b/neu/plotter/src/neu_plotter.f90 index bc5a21c69..310aeb715 100644 --- a/neu/plotter/src/neu_plotter.f90 +++ b/neu/plotter/src/neu_plotter.f90 @@ -83,7 +83,7 @@ program neu_plotter write(*,*) 'invalid value of i_var' stop end if - + ! get info from namelist open(newunit=iounit, file='inlist_plotter') read(iounit, nml=plotter) @@ -327,7 +327,7 @@ real(dp) function dfridr_func(delta_x) result(val) lnT = log10T*ln10 lnd = log10Rho*ln10 - + if (doing_d_dlnd) then log_var = (lnd + delta_x)/ln10 var = exp10(log_var) diff --git a/neu/private/mod_neu.f90 b/neu/private/mod_neu.f90 index 978866796..042f1a81a 100644 --- a/neu/private/mod_neu.f90 +++ b/neu/private/mod_neu.f90 @@ -33,7 +33,7 @@ module mod_neu !..various numerical constants - + real(dp), parameter :: con1 = 1.0d0/5.9302d0 !..cv and ca are the vector and axial currents. @@ -191,18 +191,18 @@ real(dp) function zfermim12(x) end function zfermim12 - + subroutine neutrinos(T, logT, Rho, logRho, abar, zbar, log10_Tlim, & flags, loss, sources, info) use utils_lib, only: is_bad - + !..this routine computes neutrino losses from the analytic fits of - !..itoh et al. apjs 102, 411, 1996, and also returns their derivatives. - + !..itoh et al. apjs 102, 411, 1996, and also returns their derivatives. + ! provide T or logT or both (the code needs both, so pass 'em if you've got 'em!) ! same for Rho and logRho - + real(dp), intent(in) :: T ! temperature real(dp), intent(in) :: logT ! log10 of temperature real(dp), intent(in) :: Rho ! density @@ -232,7 +232,7 @@ subroutine neutrinos(T, logT, Rho, logRho, abar, zbar, log10_Tlim, & info = 0 - + if ((T /= arg_not_provided .and. T .le. Tmin_neu) .or. & (logT /= arg_not_provided .and. logT .le. log10Tmin_neu)) then loss = 0d0 @@ -249,18 +249,18 @@ subroutine neutrinos(T, logT, Rho, logRho, abar, zbar, log10_Tlim, & else temp = T end if - + if (T <= 0) then info = -1 return end if - + if (logT == arg_not_provided) then logtemp = log10(T) else logtemp = logT end if - + if (logtemp > 20) then info = -1 return @@ -275,7 +275,7 @@ subroutine neutrinos(T, logT, Rho, logRho, abar, zbar, log10_Tlim, & else den = Rho end if - + if (Rho <= 0) then info = -1 return @@ -286,13 +286,13 @@ subroutine neutrinos(T, logT, Rho, logRho, abar, zbar, log10_Tlim, & else logden = logRho end if - + if (logden > 20) then info = -1 return end if -!..initialize +!..initialize spair = 0.0d0 spairdt = 0.0d0 spairdd = 0.0d0 @@ -331,7 +331,7 @@ subroutine neutrinos(T, logT, Rho, logRho, abar, zbar, log10_Tlim, & call set_inputs(input,temp,logtemp,den,logden,abar,zbar) - + !..do the requested types if (flags(pair_neu_type)) call pair_neu(spair,spairdt,spairdd,spairda,spairdz, input) @@ -340,38 +340,38 @@ subroutine neutrinos(T, logT, Rho, logRho, abar, zbar, log10_Tlim, & if (flags(brem_neu_type)) call brem_neu(sbrem,sbremdt,sbremdd,sbremda,sbremdz, input) if (flags(reco_neu_type)) call reco_neu(sreco,srecodt,srecodd,srecoda,srecodz, input) -!..convert from erg/cm^3/s to erg/g/s +!..convert from erg/cm^3/s to erg/g/s !..comment these out to duplicate the itoh et al plots spair = spair * input% deni spairdt = spairdt * input% deni spairdd = spairdd * input% deni - spair * input% deni spairda = spairda * input% deni - spairdz = spairdz * input% deni + spairdz = spairdz * input% deni splas = splas * input% deni splasdt = splasdt * input% deni splasdd = splasdd * input% deni - splas * input% deni splasda = splasda * input% deni - splasdz = splasdz * input% deni + splasdz = splasdz * input% deni sphot = sphot * input% deni sphotdt = sphotdt * input% deni sphotdd = sphotdd * input% deni - sphot * input% deni sphotda = sphotda * input% deni - sphotdz = sphotdz * input% deni + sphotdz = sphotdz * input% deni sbrem = sbrem * input% deni sbremdt = sbremdt * input% deni sbremdd = sbremdd * input% deni - sbrem * input% deni sbremda = sbremda * input% deni - sbremdz = sbremdz * input% deni + sbremdz = sbremdz * input% deni sreco = sreco * input% deni srecodt = srecodt * input% deni srecodd = srecodd * input% deni - sreco * input% deni srecoda = srecoda * input% deni - srecodz = srecodz * input% deni + srecodz = srecodz * input% deni !..calculate temperature cutoff factor @@ -379,8 +379,8 @@ subroutine neutrinos(T, logT, Rho, logRho, abar, zbar, log10_Tlim, & dtlim = log10_Tlim - log10Tmin_neu tcutoff_factor = 0.5d0* & (1 - cospi((input% logtemp - log10Tmin_neu)/(log10_Tlim - log10Tmin_neu))) - - + + dtcutoff_factordt = 0.5d0 * pi * sinpi((input% logtemp - log10Tmin_neu)/dtlim) * & 1.d0/(dtlim * temp * ln10) @@ -389,42 +389,42 @@ subroutine neutrinos(T, logT, Rho, logRho, abar, zbar, log10_Tlim, & splasda = tcutoff_factor * splasda splasdz = tcutoff_factor * splasdz splas = tcutoff_factor * splas - + spairdt = tcutoff_factor * spairdt + dtcutoff_factordt * spair spairdd = tcutoff_factor * spairdd spairda = tcutoff_factor * spairda spairdz = tcutoff_factor * spairdz - spair = tcutoff_factor * spair - + spair = tcutoff_factor * spair + sphotdt = tcutoff_factor * sphotdt + dtcutoff_factordt * sphot sphotdd = tcutoff_factor * sphotdd sphotda = tcutoff_factor * sphotda sphotdz = tcutoff_factor * sphotdz sphot = tcutoff_factor * sphot - + sbremdt = tcutoff_factor * sbremdt + dtcutoff_factordt * sbrem sbremdd = tcutoff_factor * sbremdd sbremda = tcutoff_factor * sbremda sbremdz = tcutoff_factor * sbremdz sbrem = tcutoff_factor * sbrem - + srecodt = tcutoff_factor * srecodt + dtcutoff_factordt * sreco srecodd = tcutoff_factor * srecodd srecoda = tcutoff_factor * srecoda srecodz = tcutoff_factor * srecodz sreco = tcutoff_factor * sreco - + end if !..the total neutrino loss rate snu = splas + spair + sphot + sbrem + sreco - dsnudt = splasdt + spairdt + sphotdt + sbremdt + srecodt - dsnudd = splasdd + spairdd + sphotdd + sbremdd + srecodd - dsnuda = splasda + spairda + sphotda + sbremda + srecoda - dsnudz = splasdz + spairdz + sphotdz + sbremdz + srecodz - + dsnudt = splasdt + spairdt + sphotdt + sbremdt + srecodt + dsnudd = splasdd + spairdd + sphotdd + sbremdd + srecodd + dsnuda = splasda + spairda + sphotda + sbremda + srecoda + dsnudz = splasdz + spairdz + sphotdz + sbremdz + srecodz + if (is_bad(snu)) then info = -1 return @@ -437,17 +437,17 @@ subroutine neutrinos(T, logT, Rho, logRho, abar, zbar, log10_Tlim, & loss(3) = dsnudd loss(4) = dsnuda loss(5) = dsnudz - + call store(pair_neu_type, spair, spairdt, spairdd, spairda, spairdz) call store(plas_neu_type, splas, splasdt, splasdd, splasda, splasdz) call store(phot_neu_type, sphot, sphotdt, sphotdd, sphotda, sphotdz) call store(brem_neu_type, sbrem, sbremdt, sbremdd, sbremda, sbremdz) call store(reco_neu_type, sreco, srecodt, srecodd, srecoda, srecodz) - + contains - - + + subroutine store(neu_type, s, sdt, sdd, sda, sdz) integer, intent(in) :: neu_type real(dp), intent(in) :: s, sdt, sdd, sda, sdz @@ -457,7 +457,7 @@ subroutine store(neu_type, s, sdt, sdd, sda, sdz) sources(neu_type,4) = sda sources(neu_type,5) = sdz end subroutine store - + end subroutine neutrinos @@ -480,13 +480,13 @@ subroutine set_inputs(input,temp,logtemp,den,logden,abar,zbar) input% tempi = 1.0d0 / input% temp input% abari = 1.0d0 / input% abar input% zbari = 1.0d0 / input% zbar - - + + !..some composition variables input% ye = input% zbar * input% abari !xmue = abar * zbari - - + + !..some frequent factors input% t9 = input% temp * 1.0d-9 input% xl = input% t9 * con1 @@ -504,9 +504,9 @@ subroutine set_inputs(input,temp,logtemp,den,logden,abar,zbar) input% xlm1 = 1.0d0 / input% xl input% xlm2 = input% xlm1*input% xlm1 input% xlm3 = input% xlm1*input% xlm2 - input% xlm4 = input% xlm1*input% xlm3 - - + input% xlm4 = input% xlm1*input% xlm3 + + input% rm = input% den*input% ye input% rmdd = input% ye input% rmda = -input% rm*input% abari @@ -519,10 +519,10 @@ subroutine set_inputs(input,temp,logtemp,den,logden,abar,zbar) input% zeta = a1 * input% xlm1 input% zetadt = -a1 * input% xlm2 * input% xldt a2 = one_third * a1*input%rmi * input% xlm1 - input% zetadd = a2 * input%rmdd + input% zetadd = a2 * input%rmdd input% zetada = a2 * input%rmda input% zetadz = a2 * input%rmdz - + input% zeta2 = input%zeta * input%zeta input% zeta3 = input%zeta2 * input%zeta @@ -533,7 +533,7 @@ end subroutine set_inputs subroutine phot_neu(sphot,sphotdt,sphotdd,sphotda,sphotdz, input) real(dp), intent(out) :: sphot,sphotdt,sphotdd,sphotda,sphotdz type(inputs), intent(in) :: input - + real(dp) tau,taudt,cos1,cos2,cos3,cos4,cos5,sin1,sin2, & sin3,sin4,sin5,last,xast, & fphot,fphotdt,fphotdd,fphotda,fphotdz, & @@ -550,7 +550,7 @@ subroutine phot_neu(sphot,sphotdt,sphotdd,sphotda,sphotdz, input) real(dp) :: dccdt - !..photoneutrino process section + !..photoneutrino process section !..for reactions like e- + gamma => e- + nu_e + nubar_e !.. e+ + gamma => e+ + nu_e + nubar_e !..equation 3.8 for tau, equation 3.6 for cc, @@ -584,7 +584,7 @@ subroutine phot_neu(sphot,sphotdt,sphotdd,sphotda,sphotdz, input) c15 = -5.249d9 c16 = -5.153d9 c20 = 1.067d11 - c21 = -9.782d9 + c21 = -9.782d9 c22 = -7.193d9 c23 = -6.936d9 c24 = -6.893d9 @@ -610,41 +610,41 @@ subroutine phot_neu(sphot,sphotdt,sphotdd,sphotda,sphotdz, input) tau = input% logtemp - 8d0 cc = 1.5654d0 dccdt = 0d0 - c00 = 9.889d10 + c00 = 9.889d10 c01 = -4.524d8 - c02 = -6.088d6 - c03 = 4.269d7 - c04 = 5.172d7 - c05 = 4.910d7 + c02 = -6.088d6 + c03 = 4.269d7 + c04 = 5.172d7 + c05 = 4.910d7 c06 = 4.388d7 c10 = 1.813d11 - c11 = -7.556d9 - c12 = -3.304d9 + c11 = -7.556d9 + c12 = -3.304d9 c13 = -1.031d9 - c14 = -1.764d9 + c14 = -1.764d9 c15 = -1.851d9 c16 = -1.928d9 c20 = 9.750d10 c21 = 3.484d10 - c22 = 5.199d9 - c23 = -1.695d9 - c24 = -2.865d9 - c25 = -3.395d9 + c22 = 5.199d9 + c23 = -1.695d9 + c24 = -2.865d9 + c25 = -3.395d9 c26 = -3.418d9 - dd01 = -1.135d8 - dd02 = 1.256d8 - dd03 = 5.149d7 - dd04 = 3.436d7 + dd01 = -1.135d8 + dd02 = 1.256d8 + dd03 = 5.149d7 + dd04 = 3.436d7 dd05 = 1.005d7 - dd11 = 1.652d9 - dd12 = -3.119d9 - dd13 = -1.839d9 - dd14 = -1.458d9 + dd11 = 1.652d9 + dd12 = -3.119d9 + dd13 = -1.839d9 + dd14 = -1.458d9 dd15 = -8.956d8 dd21 = -1.548d10 - dd22 = -9.338d9 - dd23 = -5.899d9 - dd24 = -3.035d9 + dd22 = -9.338d9 + dd23 = -5.899d9 + dd24 = -3.035d9 dd25 = -1.598d9 else if (input% temp .ge. 1.0d9) then @@ -653,34 +653,34 @@ subroutine phot_neu(sphot,sphotdt,sphotdd,sphotda,sphotdz, input) dccdt = 0d0 c00 = 9.581d10 c01 = 4.107d8 - c02 = 2.305d8 - c03 = 2.236d8 - c04 = 1.580d8 - c05 = 2.165d8 + c02 = 2.305d8 + c03 = 2.236d8 + c04 = 1.580d8 + c05 = 2.165d8 c06 = 1.721d8 c10 = 1.459d12 c11 = 1.314d11 - c12 = -1.169d11 - c13 = -1.765d11 - c14 = -1.867d11 - c15 = -1.983d11 + c12 = -1.169d11 + c13 = -1.765d11 + c14 = -1.867d11 + c15 = -1.983d11 c16 = -1.896d11 c20 = 2.424d11 c21 = -3.669d9 - c22 = -8.691d9 - c23 = -7.967d9 - c24 = -7.932d9 - c25 = -7.987d9 + c22 = -8.691d9 + c23 = -7.967d9 + c24 = -7.932d9 + c25 = -7.987d9 c26 = -8.333d9 dd01 = 4.724d8 - dd02 = 2.976d8 - dd03 = 2.242d8 - dd04 = 7.937d7 + dd02 = 2.976d8 + dd03 = 2.242d8 + dd04 = 7.937d7 dd05 = 4.859d7 dd11 = -7.094d11 dd12 = -3.697d11 - dd13 = -2.189d11 - dd14 = -1.273d11 + dd13 = -2.189d11 + dd14 = -1.273d11 dd15 = -5.705d10 dd21 = -2.254d10 dd22 = -1.551d10 @@ -777,7 +777,7 @@ subroutine phot_neu(sphot,sphotdt,sphotdd,sphotda,sphotdz, input) fphotdd = (xnumdd - fphot*xdendd)*dum fphotda = (xnumda - fphot*xdenda)*dum fphotdz = (xnumdz - fphot*xdendz)*dum - + !..equation 3.3 a0 = 1.0d0 + 2.045d0 * input% xl @@ -812,10 +812,10 @@ subroutine phot_neu(sphot,sphotdt,sphotdd,sphotda,sphotdz, input) a1 = sphot sphot = input% rm*a1 - sphotdt = input% rm*sphotdt - sphotdd = input% rm*sphotdd + input% rmdd*a1 - sphotda = input% rm*sphotda + input% rmda*a1 - sphotdz = input% rm*sphotdz + input% rmdz*a1 + sphotdt = input% rm*sphotdt + sphotdd = input% rm*sphotdd + input% rmdd*a1 + sphotda = input% rm*sphotda + input% rmda*a1 + sphotdz = input% rm*sphotdz + input% rmdz*a1 a1 = tfac4*(1.0d0 - tfac3 * qphot) a2 = -tfac4*tfac3 @@ -827,12 +827,12 @@ subroutine phot_neu(sphot,sphotdt,sphotdd,sphotda,sphotdz, input) sphotda = a1*sphotda + a2*qphotda*a3 sphotdz = a1*sphotdz + a2*qphotdz*a3 - + if (.false.) then write(*,*) 'logT', input% logtemp write(*,*) 'logRho', input% logden write(*,*) 'sphot', sphot - write(*,*) + write(*,*) end if if (sphot .le. 0.0d0) then @@ -844,8 +844,8 @@ subroutine phot_neu(sphot,sphotdt,sphotdd,sphotda,sphotdz, input) end if end subroutine phot_neu - - + + subroutine brem_neu_weak_degen(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input) type(t8s), intent(in) :: t8 real(dp), intent(out) :: sbrem,sbremdt,sbremdd,sbremda,sbremdz @@ -864,7 +864,7 @@ subroutine brem_neu_weak_degen(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input) real(dp) :: eta,etadt,etadd,etada,etadz,etam1,etam2,etam3, & fbrem,fbremdt,fbremdd,fbremda,fbremdz, & gbrem,gbremdt,gbremdd,gbremda,gbremdz - + real(dp) :: p sbrem=0d0 @@ -872,7 +872,7 @@ subroutine brem_neu_weak_degen(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input) sbremdd=0d0 sbremda=0d0 sbremdz=0d0 - + !..equation 5.3 dum = 7.05d6 * t8% t832 + 5.12d4 * t8% t83 dumdt = (1.5d0*7.05d6*t8% t812 + 3.0d0*5.12d4*t8% t82)*1.0d-8 @@ -907,7 +907,7 @@ subroutine brem_neu_weak_degen(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input) c02 = z*etadd c03 = z*etada c04 = z*etadz - + z = 1.0d0/dum xden = c00*z xdendt = (c01 - xden*dumdt)*z @@ -927,7 +927,7 @@ subroutine brem_neu_weak_degen(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input) a0 = 230.0d0 + 6.7d5*t8% t8m2 + 7.66d9*t8% t8m5 f0 = (-2.0d0*6.7d5*t8% t8m3 - 5.0d0*7.66d9*t8% t8m6)*1.0d-8 - z = 1.0d0 + input% rm*1.0d-9 + z = 1.0d0 + input% rm*1.0d-9 dum = a0*z dumdt = f0*z z = a0*1.0d-9 @@ -941,26 +941,26 @@ subroutine brem_neu_weak_degen(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input) xnumdd = z*dumdd xnumda = z*dumda xnumdz = z*dumdz - + p = pow(t8% t8,3.85d0) c00 = 7.75d5*t8% t832 + 247.0d0*p dd00 = (1.5d0*7.75d5*t8% t812 + 3.85d0*247.0d0*p/t8% T8)*1.0d-8 - + p = pow(t8% t8,1.4d0) c01 = 4.07d0 + 0.0240d0 * p dd01 = 1.4d0*0.0240d0*(p/t8% T8)*1.0d-8 - + p = pow(t8% t8,-0.110d0) c02 = 4.59d-5 * p dd02 = -0.11d0*4.59d-5*(p/t8% T8)*1.0d-8 z = pow(input% den,0.656d0) - dum = c00*input% rmi + c01 + c02*z + dum = c00*input% rmi + c01 + c02*z dumdt = dd00*input% rmi + dd01 + dd02*z z = -c00*input% rmi*input% rmi dumdd = z*input% rmdd + 0.656d0*c02*pow(input% den,-0.344d0) - dumda = z*input% rmda - dumdz = z*input% rmdz + dumda = z*input% rmda + dumdz = z*input% rmdz xden = 1.0d0/dum z = -xden*xden @@ -987,15 +987,15 @@ subroutine brem_neu_weak_degen(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input) z = tfac4*fbrem - tfac5*gbrem sbrem = dum * z - sbremdt = dumdt*z + dum*(tfac4*fbremdt - tfac5*gbremdt) - sbremdd = dumdd*z + dum*(tfac4*fbremdd - tfac5*gbremdd) - sbremda = dumda*z + dum*(tfac4*fbremda - tfac5*gbremda) - sbremdz = dumdz*z + dum*(tfac4*fbremdz - tfac5*gbremdz) + sbremdt = dumdt*z + dum*(tfac4*fbremdt - tfac5*gbremdt) + sbremdd = dumdd*z + dum*(tfac4*fbremdd - tfac5*gbremdd) + sbremda = dumda*z + dum*(tfac4*fbremda - tfac5*gbremda) + sbremdz = dumdz*z + dum*(tfac4*fbremdz - tfac5*gbremdz) + - end subroutine brem_neu_weak_degen - - + + subroutine brem_neu_liquid_metal(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input) type(t8s), intent(in) :: t8 real(dp), intent(out) :: sbrem,sbremdt,sbremdd,sbremda,sbremdz @@ -1009,7 +1009,7 @@ subroutine brem_neu_liquid_metal(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input real(dp) :: u,gm1,gm2,gm13,gm23,gm43,gm53,v,w,fb,gt,gb, & fliq,fliqdt,fliqdd,fliqda,fliqdz, & - gliq,gliqdt,gliqdd,gliqda,gliqdz + gliq,gliqdt,gliqdd,gliqda,gliqdz real(dp) :: cos1,cos2,cos3,cos4,cos5,sin1,sin2, & sin3,sin4,sin5 @@ -1022,7 +1022,7 @@ subroutine brem_neu_liquid_metal(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input sbremda=0d0 sbremdz=0d0 - + !..liquid metal with c12 parameters (not too different for other elements) !..equation 5.18 and 5.16 u = fac3 * (input% logden - 3.0d0) @@ -1056,30 +1056,30 @@ subroutine brem_neu_liquid_metal(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input - 0.01089d0*cos2 - 0.01584d0*sin2 & - 0.01147d0*cos3 - 0.00504d0*sin3 & - 0.00656d0*cos4 - 0.00281d0*sin4 & - - 0.00519d0*cos5 + - 0.00519d0*cos5 c00 = a0*(0.00945d0 & + 0.05821d0*sin1 - 0.04969d0*cos1 & + 0.01089d0*sin2*2.0d0 - 0.01584d0*cos2*2.0d0 & + 0.01147d0*sin3*3.0d0 - 0.00504d0*cos3*3.0d0 & + 0.00656d0*sin4*4.0d0 - 0.00281d0*cos4*4.0d0 & - + 0.00519d0*sin5*5.0d0) + + 0.00519d0*sin5*5.0d0) + - !..equation 5.22 ft = 0.5d0 * 0.06781d0 - 0.02342d0*u + 0.24819d0 & - 0.00944d0*cos1 - 0.02213d0*sin1 & - 0.01289d0*cos2 - 0.01136d0*sin2 & - 0.00589d0*cos3 - 0.00467d0*sin3 & - 0.00404d0*cos4 - 0.00131d0*sin4 & - - 0.00330d0*cos5 + - 0.00330d0*cos5 c01 = a0*(-0.02342d0 & + 0.00944d0*sin1 - 0.02213d0*cos1 & + 0.01289d0*sin2*2.0d0 - 0.01136d0*cos2*2.0d0 & + 0.00589d0*sin3*3.0d0 - 0.00467d0*cos3*3.0d0 & + 0.00404d0*sin4*4.0d0 - 0.00131d0*cos4*4.0d0 & - + 0.00330d0*sin5*5.0d0) + + 0.00330d0*sin5*5.0d0) !..equation 5.23 @@ -1104,14 +1104,14 @@ subroutine brem_neu_liquid_metal(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input - 0.00184d0*cos2 - 0.00354d0*sin2 & + 0.00146d0*cos3 - 0.00014d0*sin3 & + 0.00031d0*cos4 - 0.00018d0*sin4 & - + 0.00069d0*cos5 + + 0.00069d0*cos5 c03 = a0*(-0.00829d0 & - 0.00356d0*sin1 + 0.01052d0*cos1 & + 0.00184d0*sin2*2.0d0 - 0.00354d0*cos2*2.0d0 & - 0.00146d0*sin3*3.0d0 - 0.00014d0*cos3*3.0d0 & - 0.00031d0*sin4*4.0d0 - 0.00018d0*cos4*4.0d0 & - - 0.00069d0*sin5*5.0d0) + - 0.00069d0*sin5*5.0d0) dum = 2.275d-1 * input% zbar * input% zbar*t8% t8m1 * pow(input% den6*input% abari, one_third) @@ -1119,7 +1119,7 @@ subroutine brem_neu_liquid_metal(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input dumdd = one_third*dum * input% deni dumda = -one_third*dum*input% abari dumdz = 2.0d0*dum*input% zbari - + gm1 = 1.0d0/dum gm2 = gm1*gm1 gm13 = pow(gm1,one_third) @@ -1139,7 +1139,7 @@ subroutine brem_neu_liquid_metal(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input !..equation 5.19 and 5.20 fliq = v*fb + (1.0d0 - v)*ft fliqdt = a0*dumdt*(fb - ft) - fliqdd = a0*dumdd*(fb - ft) + v*c00 + (1.0d0 - v)*c01 + fliqdd = a0*dumdd*(fb - ft) + v*c00 + (1.0d0 - v)*c01 fliqda = a0*dumda*(fb - ft) fliqdz = a0*dumdz*(fb - ft) @@ -1159,14 +1159,14 @@ subroutine brem_neu_liquid_metal(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input z = tfac4*fliq - tfac5*gliq sbrem = dum * z - sbremdt = dumdt*z + dum*(tfac4*fliqdt - tfac5*gliqdt) - sbremdd = dumdd*z + dum*(tfac4*fliqdd - tfac5*gliqdd) - sbremda = dumda*z + dum*(tfac4*fliqda - tfac5*gliqda) - sbremdz = dumdz*z + dum*(tfac4*fliqdz - tfac5*gliqdz) - + sbremdt = dumdt*z + dum*(tfac4*fliqdt - tfac5*gliqdt) + sbremdd = dumdd*z + dum*(tfac4*fliqdd - tfac5*gliqdd) + sbremda = dumda*z + dum*(tfac4*fliqda - tfac5*gliqda) + sbremdz = dumdz*z + dum*(tfac4*fliqdz - tfac5*gliqdz) + end subroutine brem_neu_liquid_metal - - + + subroutine brem_neu(sbrem,sbremdt,sbremdd,sbremda,sbremdz, input) real(dp), intent(out) :: sbrem,sbremdt,sbremdd,sbremda,sbremdz type(inputs), intent(in) :: input @@ -1177,8 +1177,8 @@ subroutine brem_neu(sbrem,sbremdt,sbremdd,sbremda,sbremdz, input) type(t8s) :: t8 - - !..bremsstrahlung neutrino section + + !..bremsstrahlung neutrino section !..for reactions like e- + (z,a) => e- + (z,a) + nu + nubar !.. n + n => n + n + nu + nubar !.. n + p => n + p + nu + nubar @@ -1205,7 +1205,7 @@ subroutine brem_neu(sbrem,sbremdt,sbremdd,sbremda,sbremdz, input) t8% t812 = sqrt(t8% t8) t8% t832 = t8% t8 * t8% t812 t8% t82 = t8% t8*t8% t8 - t8% t83 = t8% t82*t8% t8 + t8% t83 = t8% t82*t8% t8 t8% t85 = t8% t82*t8% t83 t8% t86 = t8% t85*t8% t8 t8% t8m1 = 1.0d0/t8% t8 @@ -1219,84 +1219,84 @@ subroutine brem_neu(sbrem,sbremdt,sbremdd,sbremda,sbremdz, input) B = 1.d0 C = 1.018d0 D = 1.0d0 - + U = pow(input% den6*input% ye,two_thirds) tfermi = A * (sqrt(U) - D) - + if (input% temp .ge. tfhi * tfermi) then - + call brem_neu_weak_degen(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input) else if (input% temp .le. tflo * tfermi) then call brem_neu_liquid_metal(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input) - + else ! blend - + call brem_neu_weak_degen(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input) sb = sbrem sbdt = sbremdt sbdd = sbremdd sbda = sbremda sbdz = sbremdz - + call brem_neu_liquid_metal(sbrem,sbremdt,sbremdd,sbremda,sbremdz,t8, input) sb2 = sbrem sbdt2 = sbremdt sbdd2 = sbremdd sbda2 = sbremda sbdz2 = sbremdz - + dtf = tfhi - tflo tfrac = (input% temp / tfermi - tflo) / dtf alfa = 0.5d0 * (1d0 - cospi(tfrac)) beta = 1d0 - alfa - + dtfermidu = (1d0/2d0) * A * pow(U,-1d0/2d0) dtfracdtfermi = -input% temp/(tfermi * tfermi * dtf ) - + ! v = den6* ye = den *10**-6 * ye dudv = two_thirds * pow(input% den6 * input% ye,-1d0/3d0) - + dudd = dudv * 1d-6 * input% ye duda = dudv * input% den6 * input% ye * input% abari * (-1d0) dudz = dudv * input% den6 * input% abari - - + + dtfermidd = dtfermidu * dudd dtfermida = dtfermidu * duda dtfermidz = dtfermidu * dudz - - dtfracdt = 1.0d0/(tfermi * dtf) - + + dtfracdt = 1.0d0/(tfermi * dtf) + dtfracdd = dtfermidd * dtfracdtfermi dtfracda = dtfermida * dtfracdtfermi dtfracdz = dtfermidz * dtfracdtfermi - + dalfadt = dtfracdt * 0.5d0 * pi * sinpi(tfrac) - dalfadd = dtfracdd * 0.5d0 * pi * sinpi(tfrac) - dalfada = dtfracda * 0.5d0 * pi * sinpi(tfrac) - dalfadz = dtfracdz * 0.5d0 * pi * sinpi(tfrac) - + dalfadd = dtfracdd * 0.5d0 * pi * sinpi(tfrac) + dalfada = dtfracda * 0.5d0 * pi * sinpi(tfrac) + dalfadz = dtfracdz * 0.5d0 * pi * sinpi(tfrac) + dbetadt = -dalfadt dbetadd = -dalfadd dbetada = -dalfada dbetadz = -dalfadz - + sbrem = alfa * sb + beta * sb2 sbremdt = alfa * sbdt + beta * sbdt2 + dalfadt * sb + dbetadt * sb2 sbremdd = alfa * sbdd + beta * sbdd2 + dalfadd * sb + dbetadd * sb2 sbremda = alfa * sbda + beta * sbda2 + dalfada * sb + dbetada * sb2 sbremdz = alfa * sbdz + beta * sbdz2 + dalfadz * sb + dbetadz * sb2 - + end if - + end subroutine brem_neu - - + + subroutine reco_neu(sreco,srecodt,srecodd,srecoda,srecodz, input) real(dp), intent(out) :: sreco,srecodt,srecodd,srecoda,srecodz type(inputs), intent(in) :: input @@ -1318,7 +1318,7 @@ subroutine reco_neu(sreco,srecodt,srecodd,srecoda,srecodz, input) srecodd=0d0 srecoda=0d0 srecodz=0d0 - + !..recombination neutrino section !..for reactions like e- (continuum) => e- (bound) + nu_e + nubar_e @@ -1375,29 +1375,29 @@ subroutine reco_neu(sreco,srecodt,srecodd,srecoda,srecodz, input) zetada = 0.0d0 zetadz = 2.0d0*zeta*input% zbari - c00 = 1.0d0/(1.0d0 + f1*nu + f2*nu2 + f3*nu3) + c00 = 1.0d0/(1.0d0 + f1*nu + f2*nu2 + f3*nu3) c01 = f1 + f2*2.0d0*nu + f3*3.0d0*nu2 dum = zeta*c00 dumdt = zetadt*c00 -1d0 * c00 * c00 * zeta*c01*nudt dumdd = -1d0 * c00 * c00 * zeta*c01*nudd dumda = -1d0 * c00 * c00 * zeta*c01*nuda dumdz = zetadz*c00 -1d0 * c00 *c00 * zeta*c01*nudz - + z = 1.0d0/dum - dd00 = pow(dum,-2.25d0) + dd00 = pow(dum,-2.25d0) dd01 = pow(dum,-4.55d0) c00 = a1*z + a2*dd00 + a3*dd01 c01 = -(a1*z + 2.25d0*a2*dd00 + 4.55d0*a3*dd01)*z - - z = exp(c*nu) - dd00 = b*z*(1.0d0 + d*dum) + + z = exp(c*nu) + dd00 = b*z*(1.0d0 + d*dum) gum = 1.0d0 + dd00 - gumdt = dd00*c*nudt + b*z*d*dumdt - gumdd = dd00*c*nudd + b*z*d*dumdd - gumda = dd00*c*nuda + b*z*d*dumda - gumdz = dd00*c*nudz + b*z*d*dumdz + gumdt = dd00*c*nudt + b*z*d*dumdt + gumdd = dd00*c*nudd + b*z*d*dumdd + gumda = dd00*c*nuda + b*z*d*dumda + gumdz = dd00*c*nudz + b*z*d*dumdz - z = exp(nu) + z = exp(nu) a1 = 1.0d0/gum bigj = c00 * z * a1 @@ -1418,11 +1418,11 @@ subroutine reco_neu(sreco,srecodt,srecodd,srecoda,srecodz, input) srecoda = sreco*(-1.0d0*input% abari + bigjda*a2 - z*(zetada+nuda)*a1) srecodz = sreco*(14.0d0*input% zbari + bigjdz*a2 - z*(zetadz+nudz)*a1) - end if + end if + - end subroutine reco_neu - + subroutine plas_neu(splas,splasdt,splasdd,splasda,splasdz, input) real(dp), intent(out) :: splas,splasdt,splasdd,splasda,splasdz type(inputs), intent(in) :: input @@ -1443,8 +1443,8 @@ subroutine plas_neu(splas,splasdt,splasdd,splasda,splasdz, input) splasdd=0d0 splasda=0d0 splasdz=0d0 - - !..plasma neutrino section + + !..plasma neutrino section !..for collective reactions like gamma_plasmon => nu_e + nubar_e !..equation 4.6 @@ -1454,7 +1454,7 @@ subroutine plas_neu(splas,splasdt,splasdd,splasda,splasdz, input) b1 = sqrt(1.0d0 + a2) b2 = 1.0d0/b1 - + c00 = 1.0d0/(input% temp*input% temp*b1) gl2 = 1.1095d11 * input% rm * c00 @@ -1464,7 +1464,7 @@ subroutine plas_neu(splas,splasdt,splasdd,splasda,splasdz, input) gl2dd = 1.1095d11 * (input% rmdd*c00 - d*input% rmdd) gl2da = 1.1095d11 * (input% rmda*c00 - d*input% rmda) gl2dz = 1.1095d11 * (input% rmdz*c00 - d*input% rmdz) - + gl = sqrt(gl2) gl12 = sqrt(gl) @@ -1493,12 +1493,12 @@ subroutine plas_neu(splas,splasdt,splasdd,splasda,splasdz, input) c = 1.0d0/b1 fl = a1*c - d = (a2 - fl*b2)*c + d = (a2 - fl*b2)*c fldt = d*gl2dt fldd = d*gl2dd flda = d*gl2da fldz = d*gl2dz - + !..equation 4.9 and 4.10 cc = log10(2.0d0*input% rm) @@ -1508,14 +1508,14 @@ subroutine plas_neu(splas,splasdt,splasdd,splasda,splasdz, input) xnumdt = -iln10*0.5d0*input% tempi a2 = iln10*one_sixth*input% rmi xnumdd = a2*input% rmdd - xnumda = a2*input% rmda - xnumdz = a2*input% rmdz + xnumda = a2*input% rmda + xnumdz = a2*input% rmdz xden = one_sixth * (-24.5d0 + cc + 3.0d0*xlnt) xdendt = iln10*0.5d0*input% tempi xdendd = a2*input% rmdd - xdenda = a2*input% rmda - xdendz = a2*input% rmdz + xdenda = a2*input% rmda + xdendz = a2*input% rmdz !..equation 4.11 @@ -1526,7 +1526,7 @@ subroutine plas_neu(splas,splasdt,splasdd,splasda,splasdz, input) fxydz = 0.0d0 fxyda = 0.0d0 - else + else a1 = 0.39d0 - 1.25d0*xnum - 0.35d0*sin(4.5d0*xnum) a2 = -1.25d0 - 4.5d0*0.35d0*cos(4.5d0*xnum) @@ -1601,11 +1601,11 @@ subroutine plas_neu(splas,splasdt,splasdd,splasda,splasdz, input) a1 = splas splas = a2*a1 splasdt = a2*splasdt + a3*a1 - splasdd = a2*splasdd - splasda = a2*splasda - splasdz = a2*splasdz + splasdd = a2*splasdd + splasda = a2*splasda + splasdz = a2*splasdz + - end subroutine plas_neu @@ -1615,7 +1615,7 @@ subroutine pair_neu(spair,spairdt,spairdd,spairda,spairdz, input) type(inputs), intent(in) :: input real(dp) :: a1,a2,a3,b1,b2,c,d, gl,gldt - + real(dp) :: xnum,xnumdt,xnumdd,xnumda,xnumdz, & xden,xdendt,xdendd,xdenda,xdendz @@ -1623,9 +1623,9 @@ subroutine pair_neu(spair,spairdt,spairdd,spairda,spairdz, input) qpair,qpairdt,qpairdd,qpairda,qpairdz !..pair neutrino section - !..for reactions like e+ + e- => nu_e + nubar_e + !..for reactions like e+ + e- => nu_e + nubar_e - !..equation 2.8 + !..equation 2.8 gl = 1.0d0 - 13.04d0*input% xl2 +133.5d0*input% xl4 +1534.0d0*input% xl6 +918.6d0*input% xl8 gldt = input% xldt*(-26.08d0*input% xl +534.0d0*input% xl3 +9204.0d0*input% xl5 +7348.8d0*input% xl7) @@ -1641,7 +1641,7 @@ subroutine pair_neu(spair,spairdt,spairdd,spairda,spairdz, input) b1 = exp(-4.9924d0*input% zeta) b2 = -b1*4.9924d0 end if - + xnum = a1 * b1 c = a2*b1 + a1*b2 xnumdt = c*input% zetadt @@ -1653,8 +1653,8 @@ subroutine pair_neu(spair,spairdt,spairdd,spairda,spairdz, input) a1 = 9.383d-1*input% xlm1 - 4.141d-1*input% xlm2 + 5.829d-2*input% xlm3 a2 = -9.383d-1*input% xlm2 + 2.0d0*4.141d-1*input% xlm3 - 3.0d0*5.829d-2*input% xlm4 else - a1 = 1.2383d0*input% xlm1 - 8.141d-1*input% xlm2 - a2 = -1.2383d0*input% xlm2 + 2.0d0*8.141d-1*input% xlm3 + a1 = 1.2383d0*input% xlm1 - 8.141d-1*input% xlm2 + a2 = -1.2383d0*input% xlm2 + 2.0d0*8.141d-1*input% xlm3 end if b1 = 3.0d0*input% zeta2 @@ -1675,7 +1675,7 @@ subroutine pair_neu(spair,spairdt,spairdd,spairda,spairdz, input) !..equation 2.6 a1 = 10.7480d0*input% xl2 + 0.3967d0*input% xlp5 + 1.005d0 - a2 = input% xldt*(2.0d0*10.7480d0*input% xl + 0.5d0*0.3967d0*input% xlmp5) + a2 = input% xldt*(2.0d0*10.7480d0*input% xl + 0.5d0*0.3967d0*input% xlmp5) xnum = 1.0d0/a1 xnumdt = -xnum*xnum*a2 @@ -1689,9 +1689,9 @@ subroutine pair_neu(spair,spairdt,spairdd,spairda,spairdz, input) d = -0.3d0*xden/b1 xdendt = -d*input% rm*c*c*a2 - xdendd = d*input% rmdd*c - xdenda = d*input% rmda*c - xdendz = d*input% rmdz*c + xdendd = d*input% rmdd*c + xdenda = d*input% rmda*c + xdendz = d*input% rmdz*c qpair = xnum*xden qpairdt = xnumdt*xden + xnum*xdendt @@ -1725,11 +1725,11 @@ subroutine pair_neu(spair,spairdt,spairdd,spairda,spairdz, input) spairdd = a1*spairdd + a2*qpairdd*a3 spairda = a1*spairda + a2*qpairda*a3 spairdz = a1*spairdz + a2*qpairdz*a3 - + end subroutine pair_neu end module mod_neu - + diff --git a/neu/public/neu_def.f90 b/neu/public/neu_def.f90 index c0a7accea..2301868db 100644 --- a/neu/public/neu_def.f90 +++ b/neu/public/neu_def.f90 @@ -31,21 +31,21 @@ module neu_def ! for T less than this, neu results are all 0 ! results returned - + integer, parameter :: ineu = 1 ! loss rate (nonnegative) in units of ergs / gram / second integer, parameter :: idneu_dT = 2 ! partial of rate wrt temperature integer, parameter :: idneu_dRho = 3 ! partial of rate wrt density integer, parameter :: idneu_dabar = 4 ! partial of rate wrt mean atomic weight integer, parameter :: idneu_dzbar = 5 ! partial of rate wrt mean charge - + integer, parameter :: num_neu_rvs = 5 ! number of result values per rate - + integer, parameter :: pair_neu_type = 1 ! pair production (for reactions like e+ + e- => nu_e + nubar_e) integer, parameter :: plas_neu_type = 2 ! plasmon neutrinos (for collective reactions like gamma_plasmon => nu_e + nubar_e) integer, parameter :: phot_neu_type = 3 ! photon neutrinos (for reactions like e- + gamma => e- + nu_e + nubar_e) integer, parameter :: brem_neu_type = 4 ! bremsstrahlung (for reactions like e- + (z,a) => e- + (z,a) + nu + nubar) integer, parameter :: reco_neu_type = 5 ! recombination (for reactions like e- (continuum) => e- (bound) + nu_e + nubar_e) - + integer, parameter :: num_neu_types = 5 end module neu_def diff --git a/neu/public/neu_lib.f90 b/neu/public/neu_lib.f90 index 75e5593df..59addb316 100644 --- a/neu/public/neu_lib.f90 +++ b/neu/public/neu_lib.f90 @@ -27,34 +27,34 @@ module neu_lib ! library for calculating neutrino losses from non-nuclear-burning sources ! neutrino losses that occur during nuclear reactions are included in the nuclear library ! the data interface for the library is defined in neu_def - + use const_def, only: dp - + implicit none contains ! the procedure interface for the library ! client programs should only call these routines. - + subroutine neu_get(T, log10_T, Rho, log10_Rho, abar, zbar, log10_Tlim, flags, & loss, sources, info) use neu_def use mod_neu, only : neutrinos ! this routine computes neutrino losses from the analytic fits of - ! itoh et al. apjs 102, 411, 1996, and also returns their derivatives. - + ! itoh et al. apjs 102, 411, 1996, and also returns their derivatives. + ! provide T or log10_T or both (the code needs both, so pass 'em if you've got 'em!) ! same for Rho and log10_Rho - + real(dp), intent(in) :: T ! temperature real(dp), intent(in) :: log10_T ! log10 of temperature real(dp), intent(in) :: Rho ! density real(dp), intent(in) :: log10_Rho ! log10 of density real(dp), intent(in) :: abar ! mean atomic weight real(dp), intent(in) :: zbar ! mean charge - real(dp), intent(in) :: log10_Tlim + real(dp), intent(in) :: log10_Tlim ! log10 of temperature at which begin to cutoff results ! NOTE: the Itoh et al data has a lower temperature limit of 10^7 ! so for T < 10^7, the neutrino losses are simply set to 0 @@ -66,12 +66,12 @@ subroutine neu_get(T, log10_T, Rho, log10_Rho, abar, zbar, log10_Tlim, flags, & real(dp), intent(inout) :: loss(num_neu_rvs) ! total from all sources real(dp), intent(inout) :: sources(num_neu_types, num_neu_rvs) integer, intent(out) :: info ! 0 means AOK. - + call neutrinos(T, log10_T, Rho, log10_Rho, abar, zbar, log10_Tlim, & flags, loss, sources, info) - + end subroutine neu_get - + end module neu_lib diff --git a/neu/test/src/neu_support.f90 b/neu/test/src/neu_support.f90 index 54971eb35..9a8cfc20f 100644 --- a/neu/test/src/neu_support.f90 +++ b/neu/test/src/neu_support.f90 @@ -6,9 +6,9 @@ module neu_support use utils_lib, only: mkdir, mesa_error implicit none - + contains - + subroutine do_test_neutrinos() real(dp),parameter :: logT_start=6.d0,logT_end=10.5d0 real(dp),parameter :: logRho_start=6.d0,logRho_end=10.5d0 diff --git a/neu/test/src/test_neu.f90 b/neu/test/src/test_neu.f90 index b7c9bbf43..c5f89a419 100644 --- a/neu/test/src/test_neu.f90 +++ b/neu/test/src/test_neu.f90 @@ -3,16 +3,16 @@ program test_neu use const_lib use utils_lib, only: mesa_error implicit none - + character (len=32) :: my_mesa_dir integer :: ierr - - my_mesa_dir = '../..' + + my_mesa_dir = '../..' call const_init(my_mesa_dir,ierr) if (ierr /= 0) then write(*,*) 'const_init failed' call mesa_error(__FILE__,__LINE__) - end if + end if call math_init() call do_test_neutrinos() diff --git a/num/private/mod_brent.f90 b/num/private/mod_brent.f90 index 864e629b8..f95075b18 100644 --- a/num/private/mod_brent.f90 +++ b/num/private/mod_brent.f90 @@ -1,6 +1,6 @@ module mod_brent use const_def, only: dp - + implicit none contains @@ -75,7 +75,7 @@ end function f real ( kind = 8 ) z0 real ( kind = 8 ) z1 real ( kind = 8 ) z2 - + ierr = 0 a0 = b x = a0 @@ -115,7 +115,7 @@ end function f end if do iter = 1, max_tries+1 - + if (iter > max_tries) then ierr = -1 exit @@ -358,7 +358,7 @@ end function f integer ( kind = 4 ) iter ierr = 0 - + ! ! C is the square of the inverse of the golden ratio. ! @@ -386,7 +386,7 @@ end function f if ( abs ( x - m ) <= t2 - 0.5D+00 * ( sb - sa ) ) then exit end if - + if (iter > max_tries) then ierr = -1 exit @@ -528,7 +528,7 @@ real(dp) function eval_brent_safe_zero ( a, b, machep, t, epsy, f, fa_in, fb_in, ! ! Licensing: ! - ! This code is distributed under the GNU LGPL license. + ! This code is distributed under the GNU LGPL license. ! ! Modified: ! @@ -549,7 +549,7 @@ real(dp) function eval_brent_safe_zero ( a, b, machep, t, epsy, f, fa_in, fb_in, ! ! Parameters: ! - ! Input, real ( kind = 8 ) A, B, the endpoints of the change of + ! Input, real ( kind = 8 ) A, B, the endpoints of the change of ! sign interval. ! ! Input, real ( kind = 8 ) MACHEP, an estimate for the relative machine @@ -565,9 +565,9 @@ real(dp) function eval_brent_safe_zero ( a, b, machep, t, epsy, f, fa_in, fb_in, ! the function F. ! implicit none - + interface -#include "num_root_fcn.dek" +#include "num_root_fcn.dek" end interface integer, intent(in) :: lipar, lrpar integer, intent(inout), pointer :: ipar(:) ! (lipar) @@ -593,9 +593,9 @@ real(dp) function eval_brent_safe_zero ( a, b, machep, t, epsy, f, fa_in, fb_in, real ( kind = 8 ) t, epsy real ( kind = 8 ) tol real ( kind = 8 ) dfdx - + ierr = 0 - + ! ! Make local copies of A and B. ! diff --git a/num/private/mod_integrate.f90 b/num/private/mod_integrate.f90 index 3018d46a5..6be0759f2 100644 --- a/num/private/mod_integrate.f90 +++ b/num/private/mod_integrate.f90 @@ -75,8 +75,8 @@ recursive function integrator(func, minx, maxx, args, atol, rtol, max_steps, ier if(abs(val1-val2) < atol .or. abs(val1-val2)/val1 < rtol ) then res = val2 else - val1 = integrator(func, xlow, xmid, args, atol, rtol, max_steps-1, ierr) - val2 = integrator(func, xmid, xhigh, args, atol, rtol, max_steps-1, ierr) + val1 = integrator(func, xlow, xmid, args, atol, rtol, max_steps-1, ierr) + val2 = integrator(func, xmid, xhigh, args, atol, rtol, max_steps-1, ierr) res = val1+val2 if(ierr/=0) return diff --git a/num/private/mod_qsort.f90 b/num/private/mod_qsort.f90 index faa9ba77d..101a80e05 100644 --- a/num/private/mod_qsort.f90 +++ b/num/private/mod_qsort.f90 @@ -2,15 +2,15 @@ module mod_qsort use const_def, only: dp - - + + implicit none contains - + ! FILE: sort.f ! PURPOSE: demonstrate the use of "qsort_inline.inc" and ! "qsort_inline_index.inc". These can be used as specific @@ -53,7 +53,7 @@ subroutine rshift(left,right) end do index(left)=hold end subroutine rshift - + logical & function less_than(a,b) integer, intent(in) :: a,b @@ -63,7 +63,7 @@ function less_than(a,b) less_than = ( string(index(a)) < string(index(b)) ) end if end function less_than - + end subroutine sortp_string !--------------------------------------------------------------- ! Sort an array of indices into a string array, with any string length. @@ -104,7 +104,7 @@ subroutine rshift(left,right) end do index(left)=hold end subroutine rshift - + logical & function less_than(a,b) integer, intent(in) :: a,b @@ -114,7 +114,7 @@ function less_than(a,b) less_than = ( string(str_index(index(a))) < string(str_index(index(b))) ) end if end function less_than - + end subroutine sortp_string_index !--------------------------------------------------------------- ! Sort a double-precision array by index @@ -154,17 +154,17 @@ subroutine rshift(left,right) end do index(left)=hold end subroutine rshift - + logical & function less_than(a,b) integer, intent(in) :: a,b less_than = value(index(a)) < value(index(b)) end function less_than - + end subroutine sortp_dp - - + + end module mod_qsort - + diff --git a/num/private/mod_random.f90 b/num/private/mod_random.f90 index ec6b1d226..04c793073 100644 --- a/num/private/mod_random.f90 +++ b/num/private/mod_random.f90 @@ -25,7 +25,7 @@ module mod_random use const_def, only: dp - + contains diff --git a/num/private/mod_simplex.f90 b/num/private/mod_simplex.f90 index eeb9d061f..67e9c92d1 100644 --- a/num/private/mod_simplex.f90 +++ b/num/private/mod_simplex.f90 @@ -24,15 +24,15 @@ ! *********************************************************************** module mod_simplex - + use const_def, only: dp use math_lib use num_def - + contains - + subroutine do_simplex( & n, x_lower, x_upper, x_first, x_final, f_final, & simplex, f, start_from_given_simplex_and_f, & @@ -63,22 +63,22 @@ subroutine do_simplex( & real(dp), intent(out) :: f_final integer, intent(out) :: num_iters, num_fcn_calls, & num_fcn_calls_for_ars, num_accepted_for_ars, ierr - + real(dp), dimension(n) :: c, x_reflect, x_expand, x_contract, x_ars real(dp) :: f_reflect, f_expand, f_contract, f_ars, & term1, weight, sum_weight, term_val_x integer :: h, s, l, i, j - + logical, parameter :: dbg = .false. - + include 'formats' - + ierr = 0 num_fcn_calls = 0 num_fcn_calls_for_ars = 0 num_accepted_for_ars = 0 num_iters = 0 - + if (.not. start_from_given_simplex_and_f) then call set_initial_simplex(ierr) if (ierr /= 0) then @@ -86,14 +86,14 @@ subroutine do_simplex( & return end if end if - - do - + + do + num_iters = num_iters + 1 - + if (dbg) write(*,*) if (dbg) write(*,2) 'iter', num_iters - + ! h = index of max f ! s = index of 2nd max f ! l = index of min f @@ -111,7 +111,7 @@ subroutine do_simplex( & s = j end if end do - + if (dbg) write(*,2) 'worst', h, f(h), simplex(1:n,h) if (dbg) write(*,2) '2nd worst', s, f(s), simplex(1:n,s) if (dbg) write(*,2) 'best', l, f(l), simplex(1:n,l) @@ -128,10 +128,10 @@ subroutine do_simplex( & end do if (dbg) write(*,1) 'term_val_x', term_val_x if (term_val_x <= 1d0) exit - + ! check for failure to converge in allowed iterations or function calls if (num_iters > iter_max .or. num_fcn_calls > fcn_calls_max) exit - + ! c = centroid excluding worst point c(1:n) = 0 sum_weight = 0d0 @@ -153,13 +153,13 @@ subroutine do_simplex( & c(i) = c(i)/sum_weight end do if (dbg) write(*,1) 'c', c(1:n) - + ! transform the simplex - + call reflect(ierr) if (ierr /= 0) return if (dbg) write(*,1) 'reflect', f_reflect, x_reflect(1:n) - + if (f_reflect < f(s)) then ! accept reflect if (dbg) write(*,2) 'accept reflect', num_iters do i=1,n @@ -197,9 +197,9 @@ subroutine do_simplex( & call shrink end if end if - + end do - + f_final = f(l) do i=1,n x_final(i) = simplex(i,l) @@ -208,19 +208,19 @@ subroutine do_simplex( & if (dbg) write(*,*) if (dbg) write(*,1) 'final', f_final, x_final(1:n) if (dbg) write(*,*) - - + + contains - - + + subroutine set_initial_simplex(ierr) integer, intent(out) :: ierr integer :: j, i, k logical :: okay include 'formats' - + ierr = 0 - + do i=1,n simplex(i,n+1) = x_first(i) end do @@ -229,7 +229,7 @@ subroutine set_initial_simplex(ierr) if (dbg) write(*,2) 'failed to get value for first simplex point' return end if - + do j=1,n do i=1,n simplex(i,j) = x_first(i) @@ -261,8 +261,8 @@ subroutine set_initial_simplex(ierr) end do end subroutine set_initial_simplex - - + + real(dp) function get_val(x, op_code, ierr) result(f) real(dp), intent(in) :: x(:) integer, intent(in) :: op_code ! what nelder-mead is doing for this call @@ -283,8 +283,8 @@ real(dp) function get_val(x, op_code, ierr) result(f) num_fcn_calls = num_fcn_calls + 1 f = fcn(n, x, lrpar, rpar, lipar, ipar, op_code, ierr) end function get_val - - + + subroutine reflect(ierr) integer, intent(out) :: ierr integer :: i @@ -295,8 +295,8 @@ subroutine reflect(ierr) end do f_reflect = get_val(x_reflect, simplex_reflect, ierr) end subroutine reflect - - + + subroutine expand(ierr) integer, intent(out) :: ierr integer :: i @@ -307,8 +307,8 @@ subroutine expand(ierr) end do f_expand = get_val(x_expand, simplex_expand, ierr) end subroutine expand - - + + subroutine contract(ierr) integer, intent(out) :: ierr integer :: i, op_code @@ -329,8 +329,8 @@ subroutine contract(ierr) end if f_contract = get_val(x_contract, op_code, ierr) end subroutine contract - - + + subroutine ARS(ierr) integer, intent(out) :: ierr integer :: i, k, k_max @@ -338,7 +338,7 @@ subroutine ARS(ierr) ierr = 0 k_max = 100 do k=1,k_max ! keep trying until find a better random point - if (num_fcn_calls > fcn_calls_max) exit + if (num_fcn_calls > fcn_calls_max) exit call get_point_for_ars(ierr) if (ierr /= 0) return if (dbg) write(*,2) 'adaptive_random_search', num_iters, f_ars, x_ars(1:n) @@ -354,8 +354,8 @@ subroutine ARS(ierr) if (dbg) write(*,2) 'reject adaptive random search', num_iters, f_ars, x_ars(1:n) end do end subroutine ARS - - + + subroutine get_point_for_ars(ierr) use mod_random, only: r8_uniform_01 integer, intent(out) :: ierr @@ -371,8 +371,8 @@ subroutine get_point_for_ars(ierr) num_fcn_calls_for_ars = num_fcn_calls_for_ars + 1 f_ars = get_val(x_ars, simplex_random, ierr) end subroutine get_point_for_ars - - + + subroutine shrink ! shrink the simplex towards the best point integer :: j, i include 'formats' @@ -387,7 +387,7 @@ subroutine shrink ! shrink the simplex towards the best point end do end subroutine shrink - + end subroutine do_simplex diff --git a/num/public/accurate_sum.f90 b/num/public/accurate_sum.f90 index 8059c06bb..be521659e 100644 --- a/num/public/accurate_sum.f90 +++ b/num/public/accurate_sum.f90 @@ -5,7 +5,7 @@ module accurate_sum use const_def - + implicit none private diff --git a/num/public/accurate_sum_auto_diff_star_order1.f90 b/num/public/accurate_sum_auto_diff_star_order1.f90 index 3a1c664ef..c6ce2808c 100644 --- a/num/public/accurate_sum_auto_diff_star_order1.f90 +++ b/num/public/accurate_sum_auto_diff_star_order1.f90 @@ -6,7 +6,7 @@ module accurate_sum_auto_diff_star_order1 use const_def use auto_diff - + implicit none private @@ -139,7 +139,7 @@ end function mult_adr_acc type(accurate_auto_diff_real_star_order1) function mult_acc_rdp(op1, op2) result (ret) type(accurate_auto_diff_real_star_order1), intent(in) :: op1 real(dp), intent(in) :: op2 - + ret%sum = op1%sum * op1 ret%compensator = op1%compensator * op1 @@ -148,7 +148,7 @@ end function mult_acc_rdp type(accurate_auto_diff_real_star_order1) function mult_rdp_acc(op1, op2) result (ret) real(dp), intent(in) :: op1 type(accurate_auto_diff_real_star_order1), intent(in) :: op2 - + ret%sum = op2%sum * op1 ret%compensator = op2%compensator * op1 diff --git a/num/test/src/sample_ode_solver.f90 b/num/test/src/sample_ode_solver.f90 index c0cee48f1..3b64aef2a 100644 --- a/num/test/src/sample_ode_solver.f90 +++ b/num/test/src/sample_ode_solver.f90 @@ -9,7 +9,7 @@ ! by the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! -! MESA is distributed in the hope that it will be useful, +! MESA is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU Library General Public License for more details. @@ -21,7 +21,7 @@ ! *********************************************************************** module vdpol - + ! for information about this problem, ! see http://pitagora.dm.uniba.it/~testset/problems/vdpol.php @@ -30,40 +30,40 @@ module vdpol use mtx_lib use math_lib use utils_lib, only: mesa_error - + implicit none - + ! stiffness parameter real(dp), parameter :: mu = 1d-3 - - - + + + contains - - + + subroutine solve_vdpol - + ! args for isolve -- see num_isolve.dek in num/public - + integer, parameter :: which_solver = ros3p_solver ! as defined in num_def.f - + integer, parameter :: n = 2 ! the number of variables in the "vdpol" system of ODEs - real(dp) :: x + real(dp) :: x ! input: initial x value ! output: x value for which the solution has been computed. - real(dp), pointer :: y(:) + real(dp), pointer :: y(:) ! input: initial values for y ! output: values of y for final value of x. real(dp) :: xend ! desired final x value (positive or negative) - real(dp) :: h + real(dp) :: h ! input: initial step size guess ! output: predicted next step size from the last accepted step real(dp) :: max_step_size integer :: max_steps - + ! absolute and relative error tolerances - real(dp) :: rtol(1), atol(1) + real(dp) :: rtol(1), atol(1) integer :: itol ! information about the jacobian matrix @@ -71,10 +71,10 @@ subroutine solve_vdpol ! information about the "mass" matrix integer :: imas, mlmas, mumas - + ! switch for calling the subroutine solout or nor integer :: iout - + integer :: lrd, lid real(dp), pointer :: rpar_decsol(:) ! (lrd) integer, pointer :: ipar_decsol(:) ! (lid) @@ -82,30 +82,30 @@ subroutine solve_vdpol integer :: caller_id, nvar, nz real(dp), dimension(:), pointer :: lblk, dblk, ublk ! =(nvar,nvar,nz) real(dp), dimension(:), pointer :: uf_lblk, uf_dblk, uf_ublk ! =(nvar,nvar,nz) - - + + ! work arrays. integer :: lwork, liwork real(dp), pointer :: work(:) ! (lwork) integer, pointer :: iwork(:) ! (liwork) - + ! parameter arrays. integer, parameter :: lrpar = 1, lipar = 3 real(dp), target :: rpar_ary(lrpar) integer, target :: ipar_ary(lipar) real(dp), pointer :: rpar(:) integer, pointer :: ipar(:) - + ! io unit for warnings and errors integer :: lout - + ! result code integer :: idid - + integer :: ierr, i real(dp) :: yexact(n), y_min, y_max real(dp), target :: y_ary(n) - + ipar => ipar_ary rpar => rpar_ary y => y_ary @@ -114,9 +114,9 @@ subroutine solve_vdpol caller_id = 0 nvar = 0 nz = 0 - + x = 0 - + y(1) = 2d0 y(2) = 0d0 @@ -124,16 +124,16 @@ subroutine solve_vdpol h = 1d-10 - max_step_size = 0 + max_step_size = 0 max_steps = 500000 rtol(1) = 1d-8 atol(1) = 1d-8 itol = 0 - + y_min = -1d199 y_max = 1d199 - + ijac = 1 nzmax = 0 isparse = 0 @@ -142,64 +142,64 @@ subroutine solve_vdpol imas = 0 mlmas = 0 - mumas = 0 - + mumas = 0 + iout = 1 - + lid = 0 lrd = 0 ipar = 0 - rpar = 0 + rpar = 0 lout = 6 call lapack_work_sizes(n, lrd, lid) call isolve_work_sizes(n, nzmax, imas, mljac, mujac, mlmas, mumas, liwork, lwork) - + allocate(iwork(liwork), work(lwork), ipar_decsol(lid), rpar_decsol(lrd), stat=ierr) if (ierr /= 0) then write(*, *) 'allocate ierr', ierr call mesa_error(__FILE__,__LINE__) end if - + iwork = 0 work = 0 - + write(*,*) write(*,*) 'vdpol' write(*,*) - + call isolve( & - which_solver, n, vdpol_derivs, x, y, xend, & - h, max_step_size, max_steps, & - rtol, atol, itol, y_min, y_max, & - vdpol_jacob, ijac, null_sjac, nzmax, isparse, mljac, mujac, & - null_mas, imas, mlmas, mumas, & - vdpol_solout, iout, & + which_solver, n, vdpol_derivs, x, y, xend, & + h, max_step_size, max_steps, & + rtol, atol, itol, y_min, y_max, & + vdpol_jacob, ijac, null_sjac, nzmax, isparse, mljac, mujac, & + null_mas, imas, mlmas, mumas, & + vdpol_solout, iout, & lapack_decsol, null_decsols, null_decsolblk, & - lrd, rpar_decsol, lid, ipar_decsol, & - caller_id, nvar, nz, lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk, & + lrd, rpar_decsol, lid, ipar_decsol, & + caller_id, nvar, nz, lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk, & null_fcn_blk_dble, null_jac_blk_dble, & - work, lwork, iwork, liwork, & - lrpar, rpar, lipar, ipar, & + work, lwork, iwork, liwork, & + lrpar, rpar, lipar, ipar, & lout, idid) - + if (idid /= 1) ierr = -1 if (ierr /= 0) then call mesa_error(__FILE__,__LINE__) end if - + write(*,*) write(*,*) 'nsteps', iwork(16) - + deallocate(iwork, work, ipar_decsol, rpar_decsol) - + ! expected solution for stiffness param = 1d-3 - yexact(1) = 1.7632345401889102d+00 + yexact(1) = 1.7632345401889102d+00 yexact(2) = -8.3568868191466206d-01 - + write(*,'(/,a5,99a20)') 'i', 'calculated ', 'reference ', 'lg(abs rel diff)' do i=1, n write(*,'(i5,2e20.10,f20.10)') i, y(i), yexact(i), & @@ -261,10 +261,10 @@ real(dp) function interp_y(i, s, rwork, iwork, ierr) end function interp_y end interface integer, intent(out) :: irtrn - + real(dp) :: xout, y1, y2 integer :: ierr - + ierr = 0 irtrn = 0 xout = rpar(1) @@ -291,17 +291,17 @@ end function interp_y end if rpar(1) = xout 99 format(1x, 'x =', f5.2, ' y =', 2e18.10, ' nstep =', i8) - + end subroutine vdpol_solout end module vdpol - + program sample_ode_solver use vdpol implicit none - + call solve_vdpol - + end program sample_ode_solver diff --git a/num/test/src/test_beam.f90 b/num/test/src/test_beam.f90 index 7cef7ee4e..57b393a0d 100644 --- a/num/test/src/test_beam.f90 +++ b/num/test/src/test_beam.f90 @@ -40,7 +40,7 @@ subroutine beam_jacob(n,x,h,y,f,dfdy,ld_dfdy,lrpar,rpar,lipar,ipar,ierr) end subroutine beam_jacob - subroutine beam_sjac(n,x,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) + subroutine beam_sjac(n,x,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) ! sparse jacobian. format either compressed row or compressed column. use mtx_lib,only:dense_to_row_sparse_with_diag,dense_to_col_sparse_with_diag use test_int_support,only:ipar_sparse_format @@ -73,7 +73,7 @@ subroutine beam_solout(nr,xold,x,n,y,rwork,iwork,interp_y,lrpar,rpar,lipar,ipar, ! x is the current x value; xold is the previous x value. ! y is the current y value. ! irtrn negative means terminate integration. - ! rwork and iwork hold info for + ! rwork and iwork hold info for integer, intent(in) :: nr, n, lrpar, lipar real(dp), intent(in) :: xold, x real(dp), intent(inout) :: y(:) ! (n) @@ -96,8 +96,8 @@ end function interp_y integer, intent(out) :: irtrn irtrn = 0 end subroutine beam_solout - - + + subroutine do_test_beam(which_solver,which_decsol,numerical_jacobian,show_all,quiet) use test_support,only:show_results,show_statistics,check_results use test_int_support,only:do_test_stiff_int @@ -113,36 +113,36 @@ subroutine do_test_beam(which_solver,which_decsol,numerical_jacobian,show_all,qu real(dp) :: result(n_soln), soln(n_soln) real(dp) :: h0, t(0:ndisc+1), atol(1), rtol(1) integer :: i, mujac, mljac, matrix_type_spec, ierr, indsol(n_soln), imas, mlmas, mumas, m1, m2, itol, nstep - real(dp), target :: rpar_ary(lrpar) + real(dp), target :: rpar_ary(lrpar) integer, target :: ipar_ary(lipar) real(dp), pointer :: rpar(:) integer, pointer :: ipar(:) integer :: caller_id, nvar, nz real(dp), dimension(:), pointer :: lblk, dblk, ublk ! =(nvar,nvar,nz) real(dp), dimension(:), pointer :: uf_lblk, uf_dblk, uf_ublk ! =(nvar,nvar,nz) - + nullify(lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk) caller_id = 0 nvar = 0 nz = 0 - + rpar => rpar_ary ipar => ipar_ary y => y_ary - + if (.not. quiet) write(*,*) 'beam' - + t(0) = 0 t(1) = 5d0 - + itol = 0 ! scalar tolerances rtol(1) = 1d-3 atol(1) = 1d-3 h0 = 1d-4 ! initial step size - + m1 = n/2 - m2 = 0 - + m2 = 0 + mljac = n mujac = n matrix_type_spec = square_matrix_type @@ -150,14 +150,14 @@ subroutine do_test_beam(which_solver,which_decsol,numerical_jacobian,show_all,qu imas = 0 mlmas = 0 mumas = 0 - + if (.not. numerical_jacobian) then write(*,*) 'beam test only supports numerical jacobian' return end if - + call beam_init(n,y,yprime,consis) - nstep=0 + nstep=0 call do_test_stiff_int(which_solver,which_decsol,numerical_jacobian, & beam_derivs,beam_jacob,beam_sjac,beam_solout,iout, & null_fcn_blk_dble,null_jac_blk_dble, & @@ -168,26 +168,26 @@ subroutine do_test_beam(which_solver,which_decsol,numerical_jacobian,show_all,qu write(*,*) 'test_beam ierr', ierr call mesa_error(__FILE__,__LINE__) end if - + call beam_solut(n,0d0,yexact) indsol(1:n_soln) = (/ 1, 10, 20, 30, 40, 50, 60, 70, 80 /) do i=1,n_soln result(i) = y(indsol(i)) soln(i) = yexact(indsol(i)) end do - + call check_results(n,y,yexact,rtol(1)*1d2,ierr) if (ierr /= 0) then write(*,*) 'check results ierr', ierr call mesa_error(__FILE__,__LINE__) ! do_test_vdpol end if - + if (quiet) return - + call show_results(n_soln,result,soln,show_all) call show_statistics(ipar(i_nfcn),ipar(i_njac),nstep,show_all) end subroutine do_test_beam - - + + end module test_beam diff --git a/num/test/src/test_brent.f90 b/num/test/src/test_brent.f90 index 16f5a80bd..68cab3644 100644 --- a/num/test/src/test_brent.f90 +++ b/num/test/src/test_brent.f90 @@ -1,31 +1,31 @@ module test_brent - + use num_def use num_lib use math_lib use utils_lib, only: mesa_error use const_def, only: dp - + implicit none - + logical, parameter :: dbg = .false. contains - + subroutine do_test_brent write(*,*) 'test brent' - + call test_global_min_all - + call test_local_min_all call test_brent_zero end subroutine do_test_brent - - + + subroutine test_global_min_all !*****************************************************************************80 @@ -34,7 +34,7 @@ subroutine test_global_min_all ! ! Licensing: ! - ! This code is distributed under the GNU LGPL license. + ! This code is distributed under the GNU LGPL license. ! ! Modified: ! @@ -149,7 +149,7 @@ end function f real (dp) x integer :: max_tries, ierr include 'formats' - + max_tries = 10000 ierr = 0 fx = brent_global_min ( max_tries, a, b, c, m, machep, e, t, f, x, ierr ) @@ -173,27 +173,27 @@ real(dp) function h_01 ( x ) real(dp), intent(in) :: x h_01 = 2.0D+00 - x end function h_01 - + real(dp) function h_02 ( x ) real(dp), intent(in) :: x h_02 = x * x end function h_02 - + real(dp) function h_03 ( x ) real(dp), intent(in) :: x h_03 = x * x * ( x + 1.0D+00 ) end function h_03 - + real(dp) function h_04 ( x ) real(dp), intent(in) :: x h_04 = ( x + sin ( x ) ) * exp( - x * x ) end function h_04 - + real(dp) function h_05 ( x ) real(dp), intent(in) :: x h_05 = ( x - sin ( x ) ) * exp( - x * x ) end function h_05 - + subroutine test_local_min_all @@ -203,7 +203,7 @@ subroutine test_local_min_all ! ! Licensing: ! - ! This code is distributed under the GNU LGPL license. + ! This code is distributed under the GNU LGPL license. ! ! Modified: ! @@ -271,7 +271,7 @@ subroutine test_local_min_one ( a, b, eps, t, f, title ) ! ! Licensing: ! - ! This code is distributed under the GNU LGPL license. + ! This code is distributed under the GNU LGPL license. ! ! Modified: ! @@ -311,7 +311,7 @@ end function f real (dp) x integer :: max_tries, ierr include 'formats' - + max_tries = 10000 ierr = 0 fx = brent_local_min(max_tries, a, b, eps, t, f, x, ierr) @@ -334,22 +334,22 @@ real(dp) function g_01 ( x ) real(dp), intent(in) :: x g_01 = ( x - 2.0D+00 ) * ( x - 2.0D+00 ) + 1.0D+00 end function g_01 - + real(dp) function g_02 ( x ) real(dp), intent(in) :: x g_02 = x * x + exp( - x ) end function g_02 - + real(dp) function g_03 ( x ) real(dp), intent(in) :: x g_03 = ( ( x * x + 2.0D+00 ) * x + 1.0D+00 ) * x + 3.0D+00 end function g_03 - + real(dp) function g_04 ( x ) real(dp), intent(in) :: x g_04 = exp( x ) + 0.01D+00 / x end function g_04 - + real(dp) function g_05 ( x ) real(dp), intent(in) :: x g_05 = exp( x ) - 2.0D+00 * x + 0.01D+00 / x - 0.000001D+00 / x / x @@ -367,7 +367,7 @@ real(dp) function f_01 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) ierr = 0 dfdx = 0 end function f_01 - + real(dp) function f_02 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) integer, intent(in) :: lrpar, lipar real(dp), intent(in) :: x @@ -379,7 +379,7 @@ real(dp) function f_02 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) ierr = 0 dfdx = 0 end function f_02 - + real(dp) function f_03 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) integer, intent(in) :: lrpar, lipar real(dp), intent(in) :: x @@ -391,7 +391,7 @@ real(dp) function f_03 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) ierr = 0 dfdx = 0 end function f_03 - + real(dp) function f_04 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) integer, intent(in) :: lrpar, lipar real(dp), intent(in) :: x @@ -403,7 +403,7 @@ real(dp) function f_04 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) ierr = 0 dfdx = 0 end function f_04 - + real(dp) function f_05 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) integer, intent(in) :: lrpar, lipar real(dp), intent(in) :: x @@ -425,7 +425,7 @@ subroutine test_brent_zero ( ) ! ! Licensing: ! - ! This code is distributed under the GNU LGPL license. + ! This code is distributed under the GNU LGPL license. ! ! Modified: ! @@ -488,7 +488,7 @@ subroutine test_zero_one ( a, b, machep, t, f, title ) ! ! Licensing: ! - ! This code is distributed under the GNU LGPL license. + ! This code is distributed under the GNU LGPL license. ! ! Modified: ! @@ -530,20 +530,20 @@ subroutine test_zero_one ( a, b, machep, t, f, title ) character ( len = * ) title real(dp) z real(dp) dfdx - + integer, parameter :: lrpar = 0, lipar = 0 integer :: ierr - real(dp), target :: rpar_ary(lrpar) + real(dp), target :: rpar_ary(lrpar) integer, target :: ipar_ary(lipar) real(dp), pointer :: rpar(:) integer, pointer :: ipar(:) - + include 'formats' - + rpar => rpar_ary ipar => ipar_ary - - + + ierr = 0 fa = f ( a, dfdx, lrpar, rpar, lipar, ipar, ierr ) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) @@ -553,7 +553,7 @@ subroutine test_zero_one ( a, b, machep, t, f, title ) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) fz = f ( z, dfdx, lrpar, rpar, lipar, ipar, ierr ) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + if (abs(fz) < 1d-14) return write ( *, '(a)' ) ' ' @@ -564,6 +564,6 @@ subroutine test_zero_one ( a, b, machep, t, f, title ) return end subroutine test_zero_one - + end module test_brent diff --git a/num/test/src/test_chemakzo.f90 b/num/test/src/test_chemakzo.f90 index c1208c4c0..5d4abd33b 100644 --- a/num/test/src/test_chemakzo.f90 +++ b/num/test/src/test_chemakzo.f90 @@ -40,7 +40,7 @@ subroutine chemakzo_jacob(n,x,h,y,f,dfdy,ld_dfdy,lrpar,rpar,lipar,ipar,ierr) end subroutine chemakzo_jacob - subroutine chemakzo_sjac(n,x,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) + subroutine chemakzo_sjac(n,x,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) ! sparse jacobian. format either compressed row or compressed column. use mtx_lib,only:dense_to_row_sparse_with_diag,dense_to_col_sparse_with_diag use test_int_support,only:ipar_sparse_format @@ -73,7 +73,7 @@ subroutine chemakzo_solout(nr,xold,x,n,y,rwork,iwork,interp_y,lrpar,rpar,lipar,i ! x is the current x value; xold is the previous x value. ! y is the current y value. ! irtrn negative means terminate integration. - ! rwork and iwork hold info for + ! rwork and iwork hold info for integer, intent(in) :: nr, n, lrpar, lipar real(dp), intent(in) :: xold, x real(dp), intent(inout) :: y(:) ! (n) @@ -114,7 +114,7 @@ end function interp_y end do write(*,*) end if - + end subroutine chemakzo_solout @@ -144,8 +144,8 @@ subroutine chemakzo_mas_full(n,am,lmas,lrpar,rpar,lipar,ipar) am(1,i) = 0 end do end subroutine chemakzo_mas_full - - + + subroutine do_test_chemakzo(which_solver,which_decsol,m_band,numerical_jacobian,show_all,quiet) use test_support,only:show_results,show_statistics,check_results use test_int_support,only:do_test_stiff_int @@ -160,47 +160,47 @@ subroutine do_test_chemakzo(which_solver,which_decsol,m_band,numerical_jacobian, integer, parameter :: ndisc = 0 real(dp) :: h0, t(0:ndisc+1), atol(1), rtol(1) integer :: mujac, mljac, matrix_type_spec, ierr, imas, mlmas, mumas, m1, m2, itol, nstep - real(dp), target :: rpar_ary(lrpar) + real(dp), target :: rpar_ary(lrpar) integer, target :: ipar_ary(lipar) real(dp), pointer :: rpar(:) integer, pointer :: ipar(:) integer :: caller_id, nvar, nz real(dp), dimension(:), pointer :: lblk, dblk, ublk ! =(nvar,nvar,nz) real(dp), dimension(:), pointer :: uf_lblk, uf_dblk, uf_ublk ! =(nvar,nvar,nz) - + nullify(lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk) caller_id = 0 nvar = 0 nz = 0 - + rpar => rpar_ary ipar => ipar_ary y => y_ary - + if (.not. quiet) write(*,*) 'chemakzo' - + t(0) = 0 t(1) = 180d0 - + itol = 0 ! scalar tolerances rtol(1) = 1d-8 atol(1) = 1d-8 h0 = 1d-10 ! initial step size - + mljac = n ! square matrix mujac = n matrix_type_spec = square_matrix_type imas = 1 m1 = 0 - m2 = 0 - + m2 = 0 + call chemakzo_init(n,y,yprime,consis) - nstep=0 + nstep=0 if (m_band) then write(*,*) 'M banded' ! mass matrix is diagonal - mlmas = 0 + mlmas = 0 mumas = 0 call do_test_stiff_int(which_solver,which_decsol,numerical_jacobian, & chemakzo_derivs,chemakzo_jacob,chemakzo_sjac,chemakzo_solout,iout, & @@ -210,8 +210,8 @@ subroutine do_test_chemakzo(which_solver,which_decsol,m_band,numerical_jacobian, t,rtol,atol,itol,h0,y,nstep,lrpar,rpar,lipar,ipar,quiet,ierr) else write(*,*) 'M full' - mlmas = n - mumas = n + mlmas = n + mumas = n call do_test_stiff_int(which_solver,which_decsol,numerical_jacobian, & chemakzo_derivs,chemakzo_jacob,chemakzo_sjac,chemakzo_solout,iout, & null_fcn_blk_dble,null_jac_blk_dble, & @@ -223,19 +223,19 @@ subroutine do_test_chemakzo(which_solver,which_decsol,m_band,numerical_jacobian, write(*,*) 'chemakzo ierr', ierr call mesa_error(__FILE__,__LINE__) end if - + call chemakzo_solut(n,0d0,yexact) call check_results(n,y,yexact,rtol(1)*10,ierr) if (ierr /= 0) then write(*,*) 'check results ierr', ierr call mesa_error(__FILE__,__LINE__) ! do_test_vdpol end if - + if (quiet) return call show_results(n,y,yexact,show_all) call show_statistics(ipar(i_nfcn),ipar(i_njac),nstep,show_all) end subroutine do_test_chemakzo - + end module test_chemakzo diff --git a/num/test/src/test_diffusion.f90 b/num/test/src/test_diffusion.f90 index 0518f0310..1ccc72b5d 100644 --- a/num/test/src/test_diffusion.f90 +++ b/num/test/src/test_diffusion.f90 @@ -6,9 +6,9 @@ module test_diffusion use utils_lib, only: mesa_error implicit none - + integer :: mljac, mujac, nstep - + integer, parameter :: nz=48 integer, parameter :: diff_mujac=1, diff_mljac=1, diff_ldjac=diff_mujac+diff_mljac+1 @@ -28,13 +28,13 @@ subroutine diffusion_op(n,x,h,y,f,dfdy,ld_dfdy,lrpar,rpar,lipar,ipar,ierr) integer, intent(inout), pointer :: ipar(:) ! (lipar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(out) :: ierr - + real(dp) :: sig1, sig2 integer :: i ierr = 0 f = 0; dfdy=0 - + sig2 = 0 do i=1,n sig1 = sig2 @@ -62,7 +62,7 @@ subroutine diffusion_op(n,x,h,y,f,dfdy,ld_dfdy,lrpar,rpar,lipar,ipar,ierr) end do end subroutine diffusion_op - + subroutine diffusion_derivs(n, x, h, y, f, lrpar, rpar, lipar, ipar, ierr) integer, intent(in) :: n, lrpar, lipar @@ -72,9 +72,9 @@ subroutine diffusion_derivs(n, x, h, y, f, lrpar, rpar, lipar, ipar, ierr) integer, intent(inout), pointer :: ipar(:) ! (lipar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(out) :: ierr - + real(dp) :: dfdy(0,n) - + ierr = 0 ipar(i_nfcn) = ipar(i_nfcn) + 1 call diffusion_op(n,x,h,y,f,dfdy,0,lrpar,rpar,lipar,ipar,ierr) @@ -94,20 +94,20 @@ subroutine diffusion_jacob(n,x,h,y,f,dfdy,ld_dfdy,lrpar,rpar,lipar,ipar,ierr) ierr = 0 ipar(i_njac) = ipar(i_njac) + 1 call diffusion_op(n,x,h,y,f,dfdy,ld_dfdy,lrpar,rpar,lipar,ipar,ierr) - + return - + dfdy2(2,1:n) = dfdy(1,1:n) dfdy2(3,1:n) = dfdy(2,1:n) - 1 dfdy2(4,1:n) = dfdy(3,1:n) - + call mtx_rcond_banded('N', n, n, 1, 1, dfdy2, 4, ipiv, rcond, work, iwork, info) write(*,2) 'diffusion_jacob rcond', info, x, safe_log10(rcond) - + end subroutine diffusion_jacob - subroutine diffusion_sjac(n,x,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) + subroutine diffusion_sjac(n,x,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) ! sparse jacobian. format either compressed row or compressed column. use mtx_lib,only:band_to_row_sparse_with_diag,band_to_col_sparse_with_diag,mtx_rcond_banded use test_int_support,only:ipar_sparse_format @@ -121,7 +121,7 @@ subroutine diffusion_sjac(n,x,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ier integer, intent(inout), pointer :: ipar(:) ! (lipar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(out) :: ierr ! nonzero means terminate integration - + real(dp) :: dfdy(n,n) integer :: ld_dfdy, nz ld_dfdy = n @@ -141,7 +141,7 @@ subroutine diffusion_solout(nr,xold,x,n,y,rwork,iwork,interp_y,lrpar,rpar,lipar, ! x is the current x value; xold is the previous x value. ! y is the current y value. ! irtrn negative means terminate integration. - ! rwork and iwork hold info for + ! rwork and iwork hold info for integer, intent(in) :: nr, n, lrpar, lipar real(dp), intent(in) :: xold, x real(dp), intent(inout) :: y(:) ! (n) @@ -164,8 +164,8 @@ end function interp_y integer, intent(out) :: irtrn irtrn = 0 end subroutine diffusion_solout - - + + subroutine do_test_diffusion(which_solver,which_decsol,numerical_jacobian,show_all,quiet) use test_support,only:show_results,show_statistics,check_results use test_int_support,only:do_test_stiff_int @@ -182,50 +182,50 @@ subroutine do_test_diffusion(which_solver,which_decsol,numerical_jacobian,show_a real(dp), pointer :: y(:) real(dp) :: result(n_soln), soln(n_soln), h0, atol(1), rtol(1), t(0:ndisc+1) integer :: i, k, matrix_type_spec, ierr, imas, mlmas, mumas, m1, m2, itol - real(dp), target :: rpar_ary(lrpar) + real(dp), target :: rpar_ary(lrpar) integer, target :: ipar_ary(lipar) real(dp), pointer :: rpar(:) integer, pointer :: ipar(:) integer :: caller_id, nvar_blk_dble, nz_blk_dble real(dp), dimension(:), pointer :: lblk, dblk, ublk ! =(nvar,nvar,nz) real(dp), dimension(:), pointer :: uf_lblk, uf_dblk, uf_ublk ! =(nvar,nvar,nz) - + nullify(lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk) caller_id = 0 nvar_blk_dble = 0 nz_blk_dble = 0 - + rpar => rpar_ary ipar => ipar_ary y => y_ary - + if (.not. quiet) write(*,*) 'diffusion' t(0) = 0d0 t(1) = tend - + itol = 0 ! scalar tolerances rtol = 1d-6 atol = 1d-6 h0 = atol(1)*1d-1 ! initial step size - + matrix_type_spec = banded_matrix_type mljac = diff_mljac mujac = diff_mujac imas = 0 mlmas = 0 - mumas = 0 - + mumas = 0 + m1 = 0 - m2 = 0 - + m2 = 0 + k=nz/2 y(1:k) = 0 y(k+1:nz) = ystart - + y0 = y - + do k=1,nz if (k == 1) then sig_dm(k) = 0; @@ -237,8 +237,8 @@ subroutine do_test_diffusion(which_solver,which_decsol,numerical_jacobian,show_a sig_dm(k) = sig; end if end do - - nstep=0 + + nstep=0 call do_test_stiff_int(which_solver,which_decsol,numerical_jacobian, & diffusion_derivs,diffusion_jacob,diffusion_sjac,diffusion_solout,iout, & @@ -250,9 +250,9 @@ subroutine do_test_diffusion(which_solver,which_decsol,numerical_jacobian,show_a write(*,*) 'test_diffusion ierr', ierr call mesa_error(__FILE__,__LINE__) end if - + !call write_diffusion_results - + call set_yexact i=0 do k=10,nz-10,(nz-10)/12 @@ -261,12 +261,12 @@ subroutine do_test_diffusion(which_solver,which_decsol,numerical_jacobian,show_a soln(i) = yexact(k) result(i) = y(k) end do - + call show_results(n_soln,result,soln,show_all) call show_statistics(ipar(i_nfcn),ipar(i_njac),nstep,show_all) - + contains - + subroutine set_yexact ! for nz=48, sig = 1d-2, ystart = 1d0, tend = 1d4 yexact( 1)= 0.0000000000000000D+00 @@ -318,7 +318,7 @@ subroutine set_yexact yexact(47)= 1.0000000000000000D+00 yexact(48)= 1.0000000000000000D+00 end subroutine set_yexact - + subroutine write_diffusion_results use utils_lib, only: mkdir use const_def @@ -343,8 +343,8 @@ subroutine write_diffusion_results end subroutine write_diffusion_results end subroutine do_test_diffusion - - - - + + + + end module test_diffusion diff --git a/num/test/src/test_int_support.f90 b/num/test/src/test_int_support.f90 index d63f73dc0..92f012864 100644 --- a/num/test/src/test_int_support.f90 +++ b/num/test/src/test_int_support.f90 @@ -4,15 +4,15 @@ module test_int_support use utils_lib, only: mesa_error implicit none - + integer, parameter :: ipar_sparse_format = 1 ! =0 means compressed row format; else, compressed column format. integer, parameter :: i_nfcn=2 integer, parameter :: i_njac=3 contains - - + + subroutine do_test_stiff_int( & which_solver, which_decsol, numerical_jacobian, & fcn, jac, sjac, solout, iout_input, & @@ -54,17 +54,17 @@ subroutine do_test_stiff_int( & real(dp), pointer :: work(:) !(lwork) integer, pointer :: ipar_decsol(:) !(lid) real(dp), pointer :: rpar_decsol(:) !(lrd) - + iout = iout_input if (quiet) iout = 0 max_steps = 500000 - max_step_size = 0 + max_step_size = 0 isparse = 0 lout = 6 - + y_min = -1d199 y_max = 1d199 - + if (numerical_jacobian) then ijac = 0 else @@ -72,7 +72,7 @@ subroutine do_test_stiff_int( & end if ipar = 0 - rpar = 0 + rpar = 0 nrdens = n max_cols_exptrap = 0 ! use default @@ -92,23 +92,23 @@ subroutine do_test_stiff_int( & end if call isolve_work_sizes(n,nzmax,imas,mljac,mujac,mlmas,mumas,liwork,lwork) - + allocate(iwork(liwork),work(lwork),ipar_decsol(lid),rpar_decsol(lrd),stat=ierr) if (ierr /= 0) then write(*,*) 'allocate ierr', ierr call mesa_error(__FILE__,__LINE__) ! test_int_support end if - + iwork = 0 work = 0 - + iwork(9) = m1 iwork(10) = m2 nstep = 0 eps = rtol(1) do i=0,ndisc - ierr = 0 + ierr = 0 h = h0 select case(which_solver) case (ros2_solver) @@ -147,10 +147,10 @@ subroutine do_test_stiff_int( & end do deallocate(iwork,work,ipar_decsol,rpar_decsol) - + contains - - + + subroutine do_isolve(decsol, decsols, decsolblk) interface include "mtx_decsol.dek" @@ -160,26 +160,26 @@ subroutine do_isolve(decsol, decsols, decsolblk) integer :: j include 'formats' call isolve( & - which_solver, n, fcn, t(i), y, t(i+1), & - h, max_step_size, max_steps, & - rtol, atol, itol, y_min, y_max, & - jac, ijac, sjac, nzmax, isparse, mljac, mujac, & - mas, imas, mlmas, mumas, & - solout, iout, & + which_solver, n, fcn, t(i), y, t(i+1), & + h, max_step_size, max_steps, & + rtol, atol, itol, y_min, y_max, & + jac, ijac, sjac, nzmax, isparse, mljac, mujac, & + mas, imas, mlmas, mumas, & + solout, iout, & decsol, decsols, decsolblk, & - lrd, rpar_decsol, lid, ipar_decsol, & + lrd, rpar_decsol, lid, ipar_decsol, & caller_id, nvar_blk_dble, nz_blk_dble, & - lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk, & + lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk, & fcn_blk_dble, jac_blk_dble, & - work, lwork, iwork, liwork, & - lrpar, rpar, lipar, ipar, & + work, lwork, iwork, liwork, & + lrpar, rpar, lipar, ipar, & lout, idid) return do j=1,n write(*,2) 'y(j)', j, y(j) end do end subroutine do_isolve - + end subroutine do_test_stiff_int diff --git a/num/test/src/test_integrate.f90 b/num/test/src/test_integrate.f90 index e64d0c477..ac0836cc8 100644 --- a/num/test/src/test_integrate.f90 +++ b/num/test/src/test_integrate.f90 @@ -38,11 +38,11 @@ real(dp) function linear(x, args, ierr) real(dp), intent(in) :: x real(dp), intent(in) :: args(:) integer, intent(inout) :: ierr - + ierr = 0 linear = x - end function linear + end function linear end subroutine test_basic @@ -65,7 +65,7 @@ real(dp) function sine(x, args, ierr) real(dp), intent(in) :: x real(dp), intent(in) :: args(:) integer, intent(inout) :: ierr - + ierr = 0 sine = sin(x) @@ -93,7 +93,7 @@ real(dp) function iexp(x, args, ierr) real(dp), intent(in) :: x real(dp), intent(in) :: args(:) integer, intent(inout) :: ierr - + ierr = 0 iexp = exp(x) @@ -121,9 +121,9 @@ real(dp) function box(x, args, ierr) real(dp), intent(in) :: x real(dp), intent(in) :: args(:) integer, intent(inout) :: ierr - + ierr = 0 - + if(x<1) then box = 0d0 else if(x.ge.1d0 .and. x.le.2d0) then diff --git a/num/test/src/test_newton.f90 b/num/test/src/test_newton.f90 index 09cd4a954..38c36d989 100644 --- a/num/test/src/test_newton.f90 +++ b/num/test/src/test_newton.f90 @@ -1,34 +1,34 @@ module test_newton - use const_def, only: dp + use const_def, only: dp use num_def use num_lib use mtx_def use mtx_lib use math_lib use utils_lib, only: mesa_error - + implicit none real(dp), parameter :: one=1 - + integer, parameter :: nz = 1001, nvar = 2 !use odd number of zones for problem symmetry integer, parameter :: nsec = 0 ! number of secondaries per zone - integer, parameter :: ldy = nz + integer, parameter :: ldy = nz integer, parameter :: i_conc=1, i_flux=2, equ_conc=1, equ_flux=2 - + integer :: matrix_type real(dp), pointer, dimension(:) :: equ1, x1, xold1, dx1, xscale1, y1 real(dp), pointer, dimension(:,:) :: equ, x, xold, dx, xscale, y real(dp), pointer, dimension(:,:,:) :: ublk, dblk, lblk logical, parameter :: dbg = .false. - + contains - + subroutine do_test_newton( & do_numerical_jacobian, which_decsol_in) logical, intent(in) :: do_numerical_jacobian @@ -39,9 +39,9 @@ subroutine do_test_newton( & real(dp) :: xmin, xmax, delx integer :: ierr, which_decsol, numsteps, midpt, maxsteps, neq character (len=64) :: decsol_option_name - + real(dp), parameter :: expected = 2.9347118120566711D-02 ! using lapack - + include 'formats' which_decsol = which_decsol_in @@ -58,27 +58,27 @@ subroutine do_test_newton( & xmax = 1.0 delx = (xmax - xmin)/float(nz) !use uniform spatial mesh tmax = pow2(10.0*delx)/kappa !maximum evolution time in units of stability time step - + allocate(concentration(nz), fluxes(nz), stat=ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + neq = nvar*nz allocate( & equ1(neq), x1(neq), xold1(neq), dx1(neq), & xscale1(neq), y1(ldy*nsec), stat=ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + x(1:nvar,1:nz) => x1(1:neq) xold(1:nvar,1:nz) => xold1(1:neq) dx(1:nvar,1:nz) => dx1(1:neq) equ(1:nvar,1:nz) => equ1(1:neq) xscale(1:nvar,1:nz) => xscale1(1:neq) y(1:ldy,1:nsec) => y1(1:ldy*nsec) - + concentration = 0.0 fluxes = 0.0 midpt = ceiling(float(nz)/2) - concentration(midpt) = 1.0 !delta function spike + concentration(midpt) = 1.0 !delta function spike numsteps = 0 maxsteps = 500 dt = alphat*(delx*delx)/kappa ! explicit stability time step multiplied by alphat @@ -91,26 +91,26 @@ subroutine do_test_newton( & time = time + dt !write(*,2) 'diffusion step', numsteps, concentration(midpt), time/tmax end do - + actual = concentration(midpt) write(*,1) 'expected', expected write(*,1) 'actual', actual !write(*,1) '(actual - expected)/expected', (actual - expected)/expected write(*,*) - + deallocate(concentration, fluxes) deallocate(equ1, x1, xold1, dx1, xscale1, y1) - + end subroutine do_test_newton - - + + subroutine do_1step_diffuse( & do_numerical_jacobian, which_decsol, & dt, kappa, nz, nvar, concentration, fluxes, delx, ierr) logical, intent(in) :: do_numerical_jacobian integer, intent(in) :: which_decsol integer, intent(in) :: nz, nvar - real(dp), intent(inout) :: dt, kappa + real(dp), intent(inout) :: dt, kappa real(dp), pointer, dimension(:), intent(inout) :: concentration, fluxes real(dp), intent(in) :: delx integer, intent(out) :: ierr @@ -118,44 +118,44 @@ subroutine do_1step_diffuse( & integer :: liwork, lwork integer, dimension(:), pointer :: iwork real(dp), dimension(:), pointer :: work - + integer, parameter :: lrpar = 3, lipar = 1 integer, target :: ipar_target(lipar) real(dp), target :: rpar_target(lrpar) integer, pointer :: ipar(:) real(dp), pointer :: rpar(:) - + integer :: lrd, lid integer, pointer :: ipar_decsol(:) ! (lid) real(dp), pointer :: rpar_decsol(:) ! (lrd) - + integer :: mljac, mujac real(dp) :: tol_correction_norm, tol_max_correction, tol_residual_norm logical :: nonconv - + include 'formats' - + ierr = 0 ipar => ipar_target - rpar => rpar_target + rpar => rpar_target rpar(1) = dt rpar(2) = kappa rpar(3) = delx - + if (do_numerical_jacobian) then ipar(1) = 1 else ipar(1) = 0 end if - + call set_fluxes(concentration, fluxes, kappa, delx) xold(i_conc,:) = concentration ! starting model xold(i_flux,:) = fluxes dx = 0d0 x = xold - + tol_correction_norm = 1d-9 ! upper limit on magnitude of average scaled correction tol_max_correction = 1d99 tol_residual_norm = 1d99 @@ -182,22 +182,22 @@ subroutine do_1step_diffuse( & allocate(rpar_decsol(lrd), ipar_decsol(lid), stat=ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call newton_work_sizes( & mljac, mujac, nvar, nz, nsec, matrix_type, lwork, liwork, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + allocate(work(lwork), iwork(liwork), stat=ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + work = 0 iwork = 0 - + iwork(i_try_really_hard) = 1 ! try really hard for first model iwork(i_model_number) = 1 - + !iwork(i_debug) = 1 - + if (which_decsol == lapack) then call do_newt( & lapack_decsol, null_decsolblk, & @@ -205,21 +205,21 @@ subroutine do_1step_diffuse( & else stop 'bad which_decsol' end if - + if (nonconv) then write(*,*) 'failed to converge' call mesa_error(__FILE__,__LINE__) end if - + concentration = x(i_conc,:) fluxes = x(i_flux,:) deallocate(iwork, work, rpar_decsol, ipar_decsol) - - - contains - - + + + contains + + subroutine do_newt(decsol, decsolblk, nonconv, ierr) interface include "mtx_decsol.dek" @@ -227,7 +227,7 @@ subroutine do_newt(decsol, decsolblk, nonconv, ierr) end interface logical, intent(out) :: nonconv integer, intent(out) :: ierr - + real(dp), pointer :: AF1(:) AF1 => null() call newton( & @@ -244,18 +244,18 @@ subroutine do_newt(decsol, decsolblk, nonconv, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) if (associated(AF1)) deallocate(AF1) end subroutine do_newt - - + + end subroutine do_1step_diffuse - - + + subroutine set_fluxes(concentration, fluxes, kappa, delx) real(dp), intent(in) :: delx, kappa real(dp), pointer, dimension(:), intent(inout) :: concentration, fluxes integer :: i do i=2,nz fluxes(i) = -kappa*(concentration(i)-concentration(i-1))/delx - end do + end do fluxes(1) = 0 end subroutine set_fluxes @@ -300,17 +300,17 @@ subroutine eval_jacobian(ldA, A1, idiag, lrpar, rpar, lipar, ipar, ierr) integer, intent(in) :: ldA ! leading dimension of A real(dp), pointer :: A1(:) ! (ldA, nvar*nz) ! the jacobian matrix ! A(idiag+q-v, v) = partial of equation(q) wrt variable(v) - integer, intent(inout) :: idiag + integer, intent(inout) :: idiag integer, intent(in) :: lrpar, lipar real(dp), intent(inout) :: rpar(:) ! (lrpar) integer, intent(inout) :: ipar(:) ! (lipar) - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: k real(dp) :: dt, kappa, delx real(dp), pointer :: blk3(:, :, :, :) ierr = 0 - + blk3(1:nvar,1:nvar,1:nz,1:3) => A1(1:nvar*nvar*nz*3) ublk => blk3(:,:,:,1) dblk => blk3(:,:,:,2) @@ -325,19 +325,19 @@ subroutine eval_jacobian(ldA, A1, idiag, lrpar, rpar, lipar, ipar, ierr) call e00(A1, equ_conc, i_conc, k, idiag, ldA, one) call e00(A1, equ_conc, i_flux, k, idiag, ldA, -dt/delx) call ep1(A1, equ_conc, i_flux, k, idiag, ldA, dt/delx) - end do + end do call e00(A1, equ_conc, i_conc, nz, idiag, ldA, one + kappa*dt/delx**2) - + do k=2,nz ! flux equ call e00(A1, equ_flux, i_flux, k, idiag, ldA, one) call e00(A1, equ_flux, i_conc, k, idiag, ldA, kappa/delx) - call em1(A1, equ_flux, i_conc, k, idiag, ldA, -kappa/delx) - end do + call em1(A1, equ_flux, i_conc, k, idiag, ldA, -kappa/delx) + end do call e00(A1, equ_flux, i_flux, 1, idiag, ldA, one) end subroutine eval_jacobian - - + + subroutine e00(A1,i,j,k,idiag,ldA,v) ! partial of equ(i,k) wrt var(j,k) real(dp), pointer :: A1(:) real(dp) :: v @@ -361,8 +361,8 @@ subroutine e00(A1,i,j,k,idiag,ldA,v) ! partial of equ(i,k) wrt var(j,k) stop 'bad matrix_type' end if end subroutine e00 - - + + subroutine em1(A1,i,j,k,idiag,ldA,v) ! partial of equ(i,k) wrt var(j,k-1) real(dp), pointer :: A1(:) real(dp) :: v @@ -387,8 +387,8 @@ subroutine em1(A1,i,j,k,idiag,ldA,v) ! partial of equ(i,k) wrt var(j,k-1) stop 'bad matrix_type' end if end subroutine em1 - - + + subroutine ep1(A1,i,j,k,idiag,ldA,v) ! partial of equ(i,k) wrt var(j,k+1) real(dp), pointer :: A1(:) real(dp) :: v @@ -423,7 +423,7 @@ subroutine enter_setmatrix( & logical, intent(out) :: need_solver_to_eval_jacobian integer, intent(in) :: ldA ! leading dimension of A real(dp), pointer, dimension(:) :: A1 ! =(ldA, neqs) - integer, intent(inout) :: idiag + integer, intent(inout) :: idiag integer, intent(in) :: lrpar, lipar real(dp), intent(inout) :: rpar(:) ! (lrpar) integer, intent(inout) :: ipar(:) ! (lipar) @@ -483,6 +483,6 @@ subroutine diffusion_set_xscale(nvar, nz, xold, xscale, lrpar, rpar, lipar, ipar xscale = 1.d0 ! max(xscale_min, abs(xold)) ierr = 0 end subroutine diffusion_set_xscale - - + + end module test_newton diff --git a/num/test/src/test_num.f90 b/num/test/src/test_num.f90 index 8ef99706e..8647b7f2f 100644 --- a/num/test/src/test_num.f90 +++ b/num/test/src/test_num.f90 @@ -1,6 +1,6 @@ program test_num - + use test_support use test_brent use test_newuoa @@ -9,24 +9,24 @@ program test_num !use test_radau5_pollu, only: do_test_radau5_pollu !use test_radau5_hires, only: do_test_radau5_hires use test_int_support - + use test_beam use test_chemakzo use test_medakzo use test_vdpol - + use test_diffusion use test_simplex use test_integrate - + use const_def use const_lib use num_def use mtx_lib use mtx_def use utils_lib, only: mesa_error - + implicit none @@ -37,26 +37,26 @@ program test_num logical :: do_numerical_jacobian, m_band, j_band, quiet character (len=32) :: my_mesa_dir - my_mesa_dir = '../..' - call const_init(my_mesa_dir,ierr) + my_mesa_dir = '../..' + call const_init(my_mesa_dir,ierr) if (ierr /= 0) then write(*,*) 'const_init failed' call mesa_error(__FILE__,__LINE__) - end if + end if call math_init() - quiet = .false. - m_band = .false. - j_band = .false. - do_numerical_jacobian = .false. + quiet = .false. + m_band = .false. + j_band = .false. + do_numerical_jacobian = .false. decsol = lapack ! newton solver do_numerical_jacobian = .false. - + write(*,*) 'call do_test_newton lapack' call do_test_newton(do_numerical_jacobian, lapack) - + write(*,*) 'call do_test_newton block_thomas_dble' call do_test_newton(do_numerical_jacobian, block_thomas_dble) @@ -88,7 +88,7 @@ program test_num call test_root_with_brackets call test_root2 call test_root3 - + ! explicit solvers call test_dopri(.false.,show_all) call test_dopri(.true.,show_all) @@ -103,14 +103,14 @@ program test_num do_numerical_jacobian = .true. do i=1,num_solvers call do_test_vdpol(i,decsol,do_numerical_jacobian,show_all,quiet) - end do + end do write(*,*) 'analytical jacobians' do_numerical_jacobian = .false. do i=1,num_solvers call do_test_vdpol(i,decsol,do_numerical_jacobian,show_all,quiet) end do - + ! test each implicit solver with banded matrix ! ijob M J test ! 2 I B medakzo @@ -122,15 +122,15 @@ program test_num if (i <= ros3p_solver) cycle call do_test_medakzo(i,decsol,do_numerical_jacobian,show_all,quiet) end do - - + + write(*,*) 'analytical jacobians' do_numerical_jacobian = .false. do i=1,num_solvers if (i <= ros3p_solver) cycle call do_test_medakzo(i,decsol,do_numerical_jacobian,show_all,quiet) end do - + ! as of dec, 2013, non-identity mass matrix causes diff results with ifort vs gfortran ! ! test each implicit solver with banded implicit ODE system and dense matrix @@ -155,8 +155,8 @@ program test_num ! if (i <= ros3p_solver) cycle ! call do_test_chemakzo(i,decsol,m_band,do_numerical_jacobian,show_all,quiet) ! end do - - + + ! test with m1 /= 0 ! ijob M J test ! 11 I F x beam diff --git a/num/test/src/test_pollu.f90 b/num/test/src/test_pollu.f90 index db9995218..7ba57ed61 100644 --- a/num/test/src/test_pollu.f90 +++ b/num/test/src/test_pollu.f90 @@ -34,12 +34,12 @@ subroutine pollu_jacob(n,x,h,y,f,dfdy,ld_dfdy,lrpar,rpar,lipar,ipar,ierr) double precision :: yprime(n) ierr = 0 ipar(i_njac) = ipar(i_njac) + 1 - call pollu_jeval(ld_dfdy,n,x,y,yprime,dfdy,ierr,rpar,ipar) - if (ierr == 0) call pollu_derivs(n, x, y, f, lrpar,rpar,lipar,ipar, ierr) + call pollu_jeval(ld_dfdy,n,x,y,yprime,dfdy,ierr,rpar,ipar) + if (ierr == 0) call pollu_derivs(n, x, y, f, lrpar,rpar,lipar,ipar, ierr) end subroutine pollu_jacob - subroutine pollu_sjac(n,x,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) + subroutine pollu_sjac(n,x,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) ! sparse jacobian. format either compressed row or compressed column. use mtx_lib,only:dense_to_row_sparse_with_diag,dense_to_col_sparse_with_diag use test_int_support,only:ipar_sparse_format @@ -70,7 +70,7 @@ subroutine pollu_solout(nr,xold,x,n,y,rwork,iwork,interp_y,lrpar,rpar,lipar,ipar ! x is the current x value; xold is the previous x value. ! y is the current y value. ! irtrn negative means terminate integration. - ! rwork and iwork hold info for + ! rwork and iwork hold info for integer, intent(in) :: nr, n, lrpar, lipar double precision, intent(in) :: xold, x double precision, intent(inout) :: y(n) @@ -93,8 +93,8 @@ end function interp_y irtrn = 0 !write(*,*) nr end subroutine pollu_solout - - + + subroutine do_test_pollu(which_solver,which_decsol,numerical_jacobian,show_all,quiet) use test_support,only:show_results,show_statistics,check_results use test_int_support,only:do_test_stiff_int @@ -110,18 +110,18 @@ subroutine do_test_pollu(which_solver,which_decsol,numerical_jacobian,show_all,q double precision :: h0, t(0:ndisc+1), atol(1), rtol(1) integer :: i, mujac, mljac, matrix_type_spec, ierr, imas, mlmas, mumas, m1, m2, itol, nstep integer :: ivect(nzo), jvect(nzo) - real(dp), target :: rpar_ary(lrpar) + real(dp), target :: rpar_ary(lrpar) integer, target :: ipar_ary(lipar) real(dp), pointer :: rpar(:) integer, pointer :: ipar(:) integer :: caller_id, nvar, nz real(dp), dimension(:), pointer :: lblk, dblk, ublk ! =(nvar,nvar,nz) - + nullify(lblk, dblk, ublk) caller_id = 0 nvar = 0 nz = 0 - + rpar => rpar_ary ipar => ipar_ary @@ -129,24 +129,24 @@ subroutine do_test_pollu(which_solver,which_decsol,numerical_jacobian,show_all,q t(0) = 0 t(1) = 60d0 - + itol = 0 ! scalar tolerances rtol(1) = 1d-5 atol(1) = 1d-5 h0 = 1d-7 ! initial step size - + call pollu_init(n,y,yprime,consis) - nstep=0 + nstep=0 mljac = n ! square matrix mujac = n matrix_type_spec = square_matrix_type imas = 0 mlmas = 0 - mumas = 0 - + mumas = 0 + m1 = 0 - m2 = 0 + m2 = 0 call do_test_stiff_int(which_solver,which_decsol,numerical_jacobian, & pollu_derivs,pollu_jacob,pollu_sjac,pollu_solout,iout, & @@ -158,20 +158,20 @@ subroutine do_test_pollu(which_solver,which_decsol,numerical_jacobian,show_all,q write(*,*) 'test_pollu ierr', ierr call mesa_error(__FILE__,__LINE__) end if - + call pollu_solut(n,0d0,yexact) call check_results(n,y,yexact,rtol(1)*2,ierr) if (ierr /= 0) then write(*,*) 'check results ierr', ierr call mesa_error(__FILE__,__LINE__) ! do_test_vdpol end if - + if (quiet) return - + call show_results(n,y,yexact,show_all) call show_statistics(ipar(i_nfcn),ipar(i_njac),nstep,show_all) end subroutine do_test_pollu - - + + end module test_pollu diff --git a/num/test/src/test_simplex.f90 b/num/test/src/test_simplex.f90 index c6acce704..230d4c010 100644 --- a/num/test/src/test_simplex.f90 +++ b/num/test/src/test_simplex.f90 @@ -1,20 +1,20 @@ module test_simplex - + use num_def use num_lib use math_lib - + implicit none - + integer :: num_calls - + logical, parameter :: show_details = .false. - + contains - - - subroutine do_test_simplex + + + subroutine do_test_simplex !call test_FR2 ! okay -- escapes from local min call test_FR4 ! okay -- escapes from local min !call test_FR6 ! okay -- escapes from local min @@ -24,7 +24,7 @@ subroutine do_test_simplex call test_PS ! okay call test_TR ! okay end subroutine do_test_simplex - + subroutine test1_simplex( & n, x_first, x_lower, x_upper, simplex, & @@ -49,29 +49,29 @@ subroutine test1_simplex( & num_fcn_calls_for_ars, num_accepted_for_ars, ierr integer :: seed real(dp) :: alpha, beta, gamma, delta - + include 'formats' - + write(*,*) 'testing NM_simplex with ' // trim(str) - + num_calls = 0 lrpar = 0; lipar = 0 allocate(rpar(lrpar), ipar(lipar)) - + x_atol = 1d-10 x_rtol = 1d-10 - + iter_max = 1000 fcn_calls_max = iter_max*10 seed = 1074698122 - + start_from_given_simplex_and_f = .false. alpha = 1d0 beta = 2d0 gamma = 0.5d0 delta = 0.5d0 - + call NM_simplex( & n, x_lower, x_upper, x_first, x_final, f_final, & simplex, f, start_from_given_simplex_and_f, & @@ -83,7 +83,7 @@ subroutine test1_simplex( & lrpar, rpar, lipar, ipar, & num_iters, num_fcn_calls, & num_fcn_calls_for_ars, num_accepted_for_ars, ierr) - + if (ierr /= 0) then write(*,*) 'failed in do_simplex' else @@ -108,15 +108,15 @@ subroutine test1_simplex( & deallocate(rpar, ipar) end subroutine test1_simplex - - + + subroutine test_WD ! testing with 4 dimensional Wood function integer, parameter :: n = 4 real(dp), dimension(n) :: x_first, x_lower, x_upper real(dp) :: simplex(n,n+1), centroid_weight_power logical :: enforce_bounds, adaptive_random_search - + x_first(1:n) = (/ -3d0, -1d0, -3d0, -1d0 /) x_lower(1:n) = (/ -4d0, -2d0, -4d0, -2d0 /) x_upper(1:n) = (/ 2d0, 2d0, 2d0, 2d0 /) @@ -124,12 +124,12 @@ subroutine test_WD enforce_bounds = .true. adaptive_random_search = .true. centroid_weight_power = 1d0 - + call test1_simplex( & n, x_first, x_lower, x_upper, simplex, & centroid_weight_power, enforce_bounds, & adaptive_random_search, fcn_WD, 'WD') - + end subroutine test_WD @@ -146,7 +146,7 @@ real(dp) function fcn_WD(n, x, lrpar, rpar, lipar, ipar, op_code, ierr) fcn_WD = WD(x) end function fcn_WD - + real(dp) function WD ( x ) ! Wood function real(dp), intent(in) :: x(:) integer :: i, n @@ -160,15 +160,15 @@ real(dp) function WD ( x ) ! Wood function end do num_calls = num_calls + 1 end function WD - - + + subroutine test_ER ! testing with 4 dimensional extended Rosenbrock integer, parameter :: n = 4 real(dp), dimension(n) :: x_first, x_lower, x_upper real(dp) :: simplex(n,n+1), centroid_weight_power logical :: enforce_bounds, adaptive_random_search - + x_first(1:n) = 3d0 x_lower(1:n) = -2d0 x_upper(1:n) = 5d0 @@ -176,12 +176,12 @@ subroutine test_ER enforce_bounds = .true. adaptive_random_search = .true. centroid_weight_power = 1d0 - + call test1_simplex( & n, x_first, x_lower, x_upper, simplex, & centroid_weight_power, enforce_bounds, & adaptive_random_search, fcn_ER, 'ER') - + end subroutine test_ER @@ -198,7 +198,7 @@ real(dp) function fcn_ER(n, x, lrpar, rpar, lipar, ipar, op_code, ierr) fcn_ER = ER(x) end function fcn_ER - + real(dp) function ER ( x ) ! extended Rosenbrock real(dp), intent(in) :: x(:) integer :: i, n @@ -209,22 +209,22 @@ real(dp) function ER ( x ) ! extended Rosenbrock end do num_calls = num_calls + 1 end function ER - - + + subroutine test_FR2 ! testing with 2 dimensional Freudenstein and Roth function integer, parameter :: n = 2 real(dp), dimension(n) :: x_first, x_lower, x_upper real(dp) :: simplex(n,n+1), centroid_weight_power logical :: enforce_bounds, adaptive_random_search - + ! NOTE --- this function has a local minimum ! and the starting values lead to the false-minimum first. - + ! true min = 0 at (5,4) ! false min = 48.98... at (11.41..., -0.8968...) ! starting at (0.5, -2) leads to the local min. - + x_first(1:n) = (/ 0.5d0, -2d0 /) x_lower(1:n) = -2d0 x_upper(1:n) = 6d0 @@ -232,26 +232,26 @@ subroutine test_FR2 enforce_bounds = .false. centroid_weight_power = 1d0 adaptive_random_search = .true. - + call test1_simplex( & n, x_first, x_lower, x_upper, simplex, & centroid_weight_power, enforce_bounds, & adaptive_random_search, fcn_FR, 'FR2') - + end subroutine test_FR2 - - + + subroutine test_FR4 ! testing with 4 dimensional Freudenstein and Roth function integer, parameter :: n = 4 real(dp), dimension(n) :: x_first, x_lower, x_upper real(dp) :: simplex(n,n+1), centroid_weight_power logical :: enforce_bounds, adaptive_random_search - + ! = 0 at (5,4) ! = 48.98... at (11.41..., -0.8968...) ! starting at (0.5, -2) leads to the bad local min. - + x_first(1:n) = (/ 0.5d0, -2d0, 0.5d0, -2d0 /) x_lower(1:n) = -2d0 x_upper(1:n) = 6d0 @@ -259,26 +259,26 @@ subroutine test_FR4 enforce_bounds = .false. centroid_weight_power = 1d0 adaptive_random_search = .true. - + call test1_simplex( & n, x_first, x_lower, x_upper, simplex, & centroid_weight_power, enforce_bounds, & adaptive_random_search, fcn_FR, 'FR4') - + end subroutine test_FR4 - - + + subroutine test_FR6 ! testing with 6 dimensional Freudenstein and Roth function integer, parameter :: n = 6 real(dp), dimension(n) :: x_first, x_lower, x_upper real(dp) :: simplex(n,n+1), centroid_weight_power logical :: enforce_bounds, adaptive_random_search - + ! = 0 at (5,4) ! = 48.98... at (11.41..., -0.8968...) ! starting at (0.5, -2) leads to the bad local min. - + x_first(1:n) = (/ 0.5d0, -2d0, 0.5d0, -2d0, 0.5d0, -2d0 /) x_lower(1:n) = -2d0 x_upper(1:n) = 6d0 @@ -286,12 +286,12 @@ subroutine test_FR6 enforce_bounds = .false. centroid_weight_power = 1d0 adaptive_random_search = .true. - + call test1_simplex( & n, x_first, x_lower, x_upper, simplex, & centroid_weight_power, enforce_bounds, & adaptive_random_search, fcn_FR, 'FR6') - + end subroutine test_FR6 @@ -308,7 +308,7 @@ real(dp) function fcn_FR(n, x, lrpar, rpar, lipar, ipar, op_code, ierr) fcn_FR = FR(x) end function fcn_FR - + real(dp) function FR ( x ) ! Freudenstein and Roth function real(dp), intent(in) :: x(:) integer :: i, n @@ -321,7 +321,7 @@ real(dp) function FR ( x ) ! Freudenstein and Roth function end do num_calls = num_calls + 1 end function FR - + subroutine test_BLE ! testing with 4 dimensional Beale function @@ -329,7 +329,7 @@ subroutine test_BLE real(dp), dimension(n) :: x_first, x_lower, x_upper real(dp) :: simplex(n,n+1), centroid_weight_power logical :: enforce_bounds, adaptive_random_search - + x_first(1:n) = 3d0 x_lower(1:n) = -2d0 x_upper(1:n) = 5d0 @@ -337,12 +337,12 @@ subroutine test_BLE enforce_bounds = .true. adaptive_random_search = .true. centroid_weight_power = 1d0 - + call test1_simplex( & n, x_first, x_lower, x_upper, simplex, & centroid_weight_power, enforce_bounds, & adaptive_random_search, fcn_BLE, 'BLE') - + end subroutine test_BLE @@ -359,7 +359,7 @@ real(dp) function fcn_BLE(n, x, lrpar, rpar, lipar, ipar, op_code, ierr) fcn_BLE = BLE(x) end function fcn_BLE - + real(dp) function BLE ( x ) ! Beale function real(dp), intent(in) :: x(:) integer :: i, n @@ -373,15 +373,15 @@ real(dp) function BLE ( x ) ! Beale function end do num_calls = num_calls + 1 end function BLE - - + + subroutine test_PS ! testing with 4 dimensional Powell singular function integer, parameter :: n = 4 real(dp), dimension(n) :: x_first, x_lower, x_upper real(dp) :: simplex(n,n+1), centroid_weight_power logical :: enforce_bounds, adaptive_random_search - + x_first(1:n) = (/ 3d0, -1d0, 0d0, 1d0 /) x_lower(1:n) = -1d0 x_upper(1:n) = 3d0 @@ -389,12 +389,12 @@ subroutine test_PS enforce_bounds = .true. adaptive_random_search = .true. centroid_weight_power = 1d0 - + call test1_simplex( & n, x_first, x_lower, x_upper, simplex, & centroid_weight_power, enforce_bounds, & adaptive_random_search, fcn_PS, 'PS') - + end subroutine test_PS @@ -411,7 +411,7 @@ real(dp) function fcn_PS(n, x, lrpar, rpar, lipar, ipar, op_code, ierr) fcn_PS = PS(x) end function fcn_PS - + real(dp) function PS ( x ) ! Powell singular function real(dp), intent(in) :: x(:) integer :: i, n @@ -426,15 +426,15 @@ real(dp) function PS ( x ) ! Powell singular function end do num_calls = num_calls + 1 end function PS - - + + subroutine test_TR ! testing with 4 dimensional Trigonometric function integer, parameter :: n = 4 real(dp), dimension(n) :: x_first, x_lower, x_upper real(dp) :: simplex(n,n+1), centroid_weight_power logical :: enforce_bounds, adaptive_random_search - + x_first(1:n) = 0.01d0 x_lower(1:n) = -0.1d0 x_upper(1:n) = 0.1d0 @@ -442,12 +442,12 @@ subroutine test_TR enforce_bounds = .true. adaptive_random_search = .true. centroid_weight_power = 1d0 - + call test1_simplex( & n, x_first, x_lower, x_upper, simplex, & centroid_weight_power, enforce_bounds, & adaptive_random_search, fcn_TR, 'TR') - + end subroutine test_TR @@ -464,7 +464,7 @@ real(dp) function fcn_TR(n, x, lrpar, rpar, lipar, ipar, op_code, ierr) fcn_TR = TR(x) end function fcn_TR - + real(dp) function TR ( x ) ! Trigonometric function real(dp), intent(in) :: x(:) integer :: j, i, n diff --git a/num/test/src/test_support.f90 b/num/test/src/test_support.f90 index e78727841..d8adae0fc 100644 --- a/num/test/src/test_support.f90 +++ b/num/test/src/test_support.f90 @@ -4,12 +4,12 @@ module test_support use math_lib use const_def, only: dp, arg_not_provided use utils_lib, only: mesa_error - + implicit none contains - + subroutine show_results(nv,y,expect,show_all) integer, intent(in) :: nv real(dp), dimension(nv), intent(in) :: y, expect @@ -35,8 +35,8 @@ subroutine show_results(nv,y,expect,show_all) end if write(*,*) end subroutine show_results - - + + subroutine show_statistics(nfcn,njac,nstep,show_all) integer, intent(in) :: nfcn,njac,nstep logical, intent(in) :: show_all @@ -48,7 +48,7 @@ subroutine show_statistics(nfcn,njac,nstep,show_all) write(*,*) end subroutine show_statistics - + subroutine check_results(nv,y,expect,tol,ierr) integer, intent(in) :: nv real(dp), dimension(nv), intent(in) :: y, expect @@ -93,7 +93,7 @@ real(dp) function f(x,dfdx,lrpar,rpar,lipar,ipar,ierr) f = x-3*sin(1-x) dfdx = 1+3*cos(1-x) end function f - + subroutine test_root_with_brackets integer, parameter :: lrpar=0, lipar=0 real(dp) :: x, dfdx @@ -102,7 +102,7 @@ subroutine test_root_with_brackets ! return value for safe_root will be bracketed by x1 and x3 real(dp) :: y1, y3 ! f(x1) and f(x3) integer :: imax ! max number of iterations for search - real(dp) :: epsx, epsy + real(dp) :: epsx, epsy ! stop seaching when x is determined to within epsx ! or when abs(f(x)) is less than epsy integer :: ierr @@ -127,7 +127,7 @@ subroutine test_root_with_brackets if (abs(x-expected_root) > 1d-6) call mesa_error(__FILE__,__LINE__) write(*,1) 'root', x end subroutine test_root_with_brackets - + real(dp) function test_f(x,dfdx,lrpar,rpar,lipar,ipar,ierr) ! returns with ierr = 0 if was able to evaluate f and df/dx at x @@ -139,10 +139,10 @@ real(dp) function test_f(x,dfdx,lrpar,rpar,lipar,ipar,ierr) integer, intent(out) :: ierr test_f = tanh(x) - 0.4621171572600098d0 dfdx = 1/cosh(x)**2 - ierr = 0 + ierr = 0 end function test_f - - + + subroutine test_root2 real(dp) :: x ! provide starting guess on input real(dp) :: x1,x3 ! bounds for x @@ -150,7 +150,7 @@ subroutine test_root2 integer, parameter :: imax = 50, lipar = 0, lrpar = 0 real(dp) :: dx real(dp), parameter :: epsx = 1d-10, epsy = 1d-10 - integer :: ierr + integer :: ierr real(dp), target :: rpar_ary(lrpar) integer, target :: ipar_ary(lipar) integer, pointer :: ipar(:) ! (lipar) @@ -160,22 +160,22 @@ subroutine test_root2 rpar => rpar_ary x = -1d0 dx = 0.1d0 - ierr = 0 - write(*,*) 'test_root2' + ierr = 0 + write(*,*) 'test_root2' call look_for_brackets(x,dx,x1,x3,test_f,y1,y3,imax,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) write(*,1) 'x1', x1 - write(*,1) 'x3', x3 + write(*,1) 'x3', x3 write(*,1) 'y1', y1 write(*,1) 'y3', y3 x = safe_root_with_brackets( & - test_f,x1,x3,y1,y3,imax,epsx,epsy,lrpar,rpar,lipar,ipar,ierr) + test_f,x1,x3,y1,y3,imax,epsx,epsy,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) write(*,1) 'safe_root', x - write(*,*) + write(*,*) end subroutine test_root2 - - + + subroutine test_root3 real(dp) :: x ! provide starting guess on input real(dp) :: x1, x3 ! bounds for x @@ -183,7 +183,7 @@ subroutine test_root3 integer, parameter :: newt_imax = 10, imax = 50, lipar = 0, lrpar = 0 real(dp) :: dx real(dp), parameter :: epsx = 1d-10, epsy = 1d-10 - integer :: ierr + integer :: ierr real(dp), target :: rpar_ary(lrpar) integer, target :: ipar_ary(lipar) integer, pointer :: ipar(:) ! (lipar) @@ -196,21 +196,21 @@ subroutine test_root3 x3 = arg_not_provided y1 = arg_not_provided y3 = arg_not_provided - ierr = 0 - write(*,*) 'test_root3' + ierr = 0 + write(*,*) 'test_root3' x = 0.1d0 ! not too bad initial guess. newton should find it okay. x = safe_root_with_guess( & test_f, x, dx, x1, x3, y1, y3, & - newt_imax, imax, epsx, epsy, lrpar, rpar, lipar, ipar, ierr) + newt_imax, imax, epsx, epsy, lrpar, rpar, lipar, ipar, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) write(*,1) 'first safe_root_with_guess', x x = -1d0 ! really bad guess will make it give up on newton x = safe_root_with_guess( & test_f, x, dx, x1, x3, y1, y3, & - newt_imax, imax, epsx, epsy, lrpar, rpar, lipar, ipar, ierr) + newt_imax, imax, epsx, epsy, lrpar, rpar, lipar, ipar, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) write(*,1) 'second safe_root_with_guess', x - write(*,*) + write(*,*) end subroutine test_root3 @@ -226,7 +226,7 @@ subroutine van_der_Pol_derivs(n,x,h,y,f,lrpar,rpar,lipar,ipar,ierr) ierr = 0 f(1) = y(2) f(2) = ((1 - y(1)*y(1))*y(2) - y(1))/rpar(1) - ! the derivatives do not depend on x + ! the derivatives do not depend on x end subroutine van_der_Pol_derivs @@ -235,7 +235,7 @@ subroutine solout(nr,xold,x,n,y,rwork,iwork,interp_y,lrpar,rpar,lipar,ipar,irtrn ! x is the current x value; xold is the previous x value. ! y is the current y value. ! irtrn negative means terminate integration. - ! rwork and iwork hold info for + ! rwork and iwork hold info for integer, intent(in) :: nr, n, lrpar, lipar real(dp), intent(in) :: xold, x real(dp), intent(inout) :: y(:) ! (n) @@ -263,12 +263,12 @@ end function interp_y xout = rpar(2) irtrn = 1 if (ipar(1) /= 1) return ! no output - + if (nr.eq.1) then write (6,99) x,y(1),y(2),nr-1 xout=x+0.2d0 else - do + do if (x >= xout-1d-10) then ierr = 0 y1 = interp_y(1,xout,rwork,iwork,ierr) @@ -309,14 +309,14 @@ subroutine test_dopri(do_853,show_all) real(dp), pointer :: rpar(:) ! (lrpar) integer, pointer :: iwork(:) real(dp), pointer :: work(:) - + ipar => ipar_ary rpar => rpar_ary work => work_ary iwork => iwork_ary y => y_ary - - write(*,*) + + write(*,*) write(*,*) 'vdpol' if (do_853) then write(*,*) 'dop853' @@ -328,18 +328,18 @@ subroutine test_dopri(do_853,show_all) xend = 2.0 y(1) = 2 y(2) = 0 - + lout = 0 max_steps = 0 max_step_size = 9 itol = 0 ! scalar tolerances iout = 2 ! want dense output - + rtol(1) = 1d-4 atol(1) = 1d-4 h = 1d-6 - + rpar(1) = eps rpar(2) = 0 if (show_all) then @@ -347,24 +347,24 @@ subroutine test_dopri(do_853,show_all) else ipar(1) = 0 end if - + iwork = 0 work = 0 iwork(5)=nrdens ! want dense output for all components iwork(4)=1 ! test for stiffness at each step - + if (do_853) then call dopri5_work_sizes(nv,nrdens,check_liwork,check_lwork) else call dop853_work_sizes(nv,nrdens,check_liwork,check_lwork) end if - + if (check_liwork > liwork .or. check_lwork > lwork) then write(*,*) 'need to enlarge work arrays for dopri5' call mesa_error(__FILE__,__LINE__) end if - + ierr = 0 if (do_853) then call dop853( & @@ -386,38 +386,38 @@ subroutine test_dopri(do_853,show_all) write(*,*) 'idid', idid call mesa_error(__FILE__,__LINE__) end if - + expect(1:2) = (/ 1.7632345401889102d+00, -8.3568868191466206d-01 /) - + call show_results(nv,y,expect,show_all) if (.not. show_all) return - + ! typical: fcn= 21530 step= 1468 accpt= 1345 rejct= 122 write (6,91) (iwork(j),j=17,20) 91 format(' fcn=',i8,' step=',i6,' accpt=',i6,' rejct=',i5) - + write(*,*) - + end subroutine test_dopri - + subroutine test_binary_search integer, parameter :: n = 100 integer :: k, loc(3) - + real(dp) :: val(3) real(dp), target :: vec_ary(n) real(dp), pointer :: vec(:) include 'formats' vec => vec_ary - + do k=1,n vec(k) = dble(k)*dble(k) end do - write(*,*) + write(*,*) write(*,*) 'binary_search, increasing values' - + loc = -1 val = [0d0, FLOOR(n/3d0)**2+2d0, vec(n)+1d0] do k=1,3 @@ -436,7 +436,7 @@ subroutine test_binary_search end if write(*,*) 'okay' enddo - + ! test decreasing values loc = -1 where(vec /= 0d0) vec = -vec @@ -459,12 +459,12 @@ subroutine test_binary_search call mesa_error(__FILE__,__LINE__) end if write(*,*) 'okay' - enddo + enddo write(*,*) - + end subroutine test_binary_search - - + + subroutine test_qsort use const_def integer, parameter :: n = 100 @@ -482,14 +482,14 @@ subroutine test_qsort end do write(*,*) end subroutine test_qsort - - + + real(dp) function g(x) result(y) real(dp), intent(in) :: x y = (x-3)*(x-8) end function g - - + + subroutine test_find0_quadratic real(dp) :: xx1, yy1, xx2, yy2, xx3, yy3, x, y integer :: ierr @@ -522,10 +522,10 @@ subroutine test_find0_quadratic y = g(x) write(*,1) 'x', x write(*,1) 'y', y - write(*,*) + write(*,*) end subroutine test_find0_quadratic - - + + subroutine test_find_max_quadratic real(dp) :: x1, y1, x2, y2, x3, y3, dx1, dx2, xmax, ymax integer :: ierr @@ -540,9 +540,9 @@ subroutine test_find_max_quadratic end if write(*,1) 'xmax', xmax, 1.85d0 write(*,1) 'ymax', ymax, 12.4083d0 - write(*,*) + write(*,*) end subroutine test_find_max_quadratic - - + + end module test_support diff --git a/num/test/src/test_vdpol.f90 b/num/test/src/test_vdpol.f90 index 7b576fbe7..beeb7a0a9 100644 --- a/num/test/src/test_vdpol.f90 +++ b/num/test/src/test_vdpol.f90 @@ -7,11 +7,11 @@ module test_vdpol use utils_lib, only: mesa_error implicit none - + logical, parameter :: dbg = .false. - + integer :: cnt = 0 - + contains @@ -70,7 +70,7 @@ subroutine vdpol_jac_blk_dble(n,caller_id,nvar,nz,x,h,y,f,lblk1,dblk1,ublk1,lrpa integer,intent(inout),pointer :: ipar(:) ! (lipar) real(dp),intent(inout),pointer :: rpar(:) ! (lrpar) integer,intent(out) :: ierr - + real(dp),dimension(:,:,:),pointer :: lblk,dblk,ublk ! =(nvar,nvar,nz) integer, parameter :: ld_dfdy = 2 ! for vdpol real(dp), target :: dfdy1(ld_dfdy*n) @@ -105,7 +105,7 @@ subroutine vdpol_jacob(n,x,h,y,f,dfdy,ld_dfdy,lrpar,rpar,lipar,ipar,ierr) call vdpol_jeval(ld_dfdy,n,x,y,yprime,dfdy,ierr,rpar,ipar) if (ierr == 0) call vdpol_derivs(n, x, h, y, f, lrpar,rpar,lipar,ipar, ierr) - + if (.false.) then write(*,*) 'jac_fcn y(1)', y(1) write(*,*) 'jac_fcn y(2)', y(2) @@ -119,7 +119,7 @@ subroutine vdpol_jacob(n,x,h,y,f,dfdy,ld_dfdy,lrpar,rpar,lipar,ipar,ierr) end subroutine vdpol_jacob - subroutine vdpol_sjac(n,x,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) + subroutine vdpol_sjac(n,x,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) ! sparse jacobian. format either compressed row or compressed column. use mtx_lib,only:dense_to_row_sparse_with_diag,dense_to_col_sparse_with_diag use test_int_support,only:ipar_sparse_format @@ -152,7 +152,7 @@ subroutine vdpol_solout(nr,xold,x,n,y,rwork,iwork,interp_y,lrpar,rpar,lipar,ipar ! x is the current x value; xold is the previous x value. ! y is the current y value. ! irtrn negative means terminate integration. - ! rwork and iwork hold info for + ! rwork and iwork hold info for integer, intent(in) :: nr, n, lrpar, lipar real(dp), intent(in) :: xold, x real(dp), intent(inout) :: y(:) ! (n) @@ -175,10 +175,10 @@ end function interp_y integer, intent(out) :: irtrn real(dp) :: xout, y1, y2 integer :: ierr - + if (dbg .and. nr > 450) stop - - + + ierr = 0 irtrn = 0 xout = rpar(1) @@ -206,8 +206,8 @@ end function interp_y rpar(1) = xout 99 format(1x,'x =',f5.2,' y =',2e18.10,' nstep =',i8) end subroutine vdpol_solout - - + + subroutine do_test_vdpol(which_solver,which_decsol,numerical_jacobian,show_all,quiet) use test_support,only:show_results,show_statistics,check_results use test_int_support,only:do_test_stiff_int @@ -223,62 +223,62 @@ subroutine do_test_vdpol(which_solver,which_decsol,numerical_jacobian,show_all,q integer, parameter :: ndisc = 0 real(dp) :: h0, t(0:ndisc+1), atol(1), rtol(1) integer :: mujac, mljac, matrix_type_spec, ierr, imas, mlmas, mumas, m1, m2, itol, iout, nstep - real(dp), target :: rpar_ary(lrpar) + real(dp), target :: rpar_ary(lrpar) integer, target :: ipar_ary(lipar) real(dp), pointer :: rpar(:) integer, pointer :: ipar(:) integer :: caller_id, nvar_blk_dble, nz_blk_dble real(dp), dimension(:), pointer :: lblk, dblk, ublk ! =(nvar,nvar,nz) real(dp), dimension(:), pointer :: uf_lblk, uf_dblk, uf_ublk ! =(nvar,nvar,nz) - + rpar => rpar_ary ipar => ipar_ary y => y_ary - + if (.not. quiet) write(*,*) 'vdpol' nullify(lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk) caller_id = 0 nvar_blk_dble = 0 nz_blk_dble = 0 - + t(0) = 0 t(1) = 2d0 - + itol = 0 ! scalar tolerances rtol(1) = 1d-8 atol(1) = 1d-8 h0 = 1d-10 ! initial step size - + rtol(1) = 1d-6 atol(1) = 1d-6 h0 = 1d-8 ! initial step size - + rtol(1) = 1d-4 atol(1) = 1d-4 h0 = 1d-4 ! initial step size - + mljac = n ! square matrix mujac = n matrix_type_spec = square_matrix_type imas = 0 mlmas = 0 - mumas = 0 - + mumas = 0 + m1 = 0 - m2 = 0 - + m2 = 0 + if (show_all) then iout = 1 else iout = 0 end if - + ipar = 0 - + call vdpol_init(n,y,yprime,consis) - nstep=0 + nstep=0 if (nvar_blk_dble == 0) then call do_test_stiff_int(which_solver,which_decsol,numerical_jacobian, & @@ -299,20 +299,20 @@ subroutine do_test_vdpol(which_solver,which_decsol,numerical_jacobian,show_all,q write(*,*) 'test_vdpol ierr', ierr call mesa_error(__FILE__,__LINE__) end if - + call vdpol_solut(n,0d0,yexact) !call check_results(n,y,yexact,rtol(1)*2,ierr) if (ierr /= 0) then write(*,*) 'check results ierr', ierr call mesa_error(__FILE__,__LINE__) ! do_test_vdpol end if - + if (quiet) return - + call show_results(n,y,yexact,show_all) call show_statistics(ipar(i_nfcn),ipar(i_njac),nstep,show_all) end subroutine do_test_vdpol - - + + end module test_vdpol diff --git a/package_template/private/pkg_mod.f90 b/package_template/private/pkg_mod.f90 index 79aabfbc1..91baec777 100644 --- a/package_template/private/pkg_mod.f90 +++ b/package_template/private/pkg_mod.f90 @@ -1,6 +1,6 @@ module mod_xxx - + implicit none end module mod_xxx diff --git a/package_template/public/pkg_def.f90 b/package_template/public/pkg_def.f90 index 3f9d3c16e..ade1144f3 100644 --- a/package_template/public/pkg_def.f90 +++ b/package_template/public/pkg_def.f90 @@ -1,6 +1,6 @@ module xxx_def - + implicit none end module xxx_def diff --git a/package_template/public/pkg_lib.f90 b/package_template/public/pkg_lib.f90 index b66d4bc31..041e8153d 100644 --- a/package_template/public/pkg_lib.f90 +++ b/package_template/public/pkg_lib.f90 @@ -1,15 +1,15 @@ module xxx_lib - + use xxx_def - + implicit none contains - + subroutine xxx - + end subroutine xxx end module xxx_lib diff --git a/package_template/test/src/test_pkg.f90 b/package_template/test/src/test_pkg.f90 index 0eb29f121..b5357fcba 100644 --- a/package_template/test/src/test_pkg.f90 +++ b/package_template/test/src/test_pkg.f90 @@ -5,10 +5,10 @@ module test_xxx_mod contains subroutine do_test - + write(*,*) 'done' - - end subroutine do_test + + end subroutine do_test end module test_xxx_mod diff --git a/rates/private/eval_coulomb.f90 b/rates/private/eval_coulomb.f90 index 24f10c5e8..37cc242a9 100644 --- a/rates/private/eval_coulomb.f90 +++ b/rates/private/eval_coulomb.f90 @@ -173,9 +173,9 @@ function mui_coulomb_PCR2009(cc, Z) result(mu) type(auto_diff_real_2var_order1) :: gamma - ! expressions taken from + ! expressions taken from ! [CP98]: Chabrier, G., \& Potekhin, A.~Y.\ 1998, \pre, 58, 4941 - ! [PC00]: Potekhin, A.~Y., \& Chabrier, G.\ 2000, \pre, 62, 8554 + ! [PC00]: Potekhin, A.~Y., \& Chabrier, G.\ 2000, \pre, 62, 8554 ! [P+09a]: Potekhin, A.~Y., Chabrier, G., \& Rogers, F.~J.\ 2009, \pre, 79, 016411 ! [P+09b]: Potekhin, A.~Y., Chabrier, G., Chugunov, A.~I., Dewitt, H.~E., \& Rogers, F.~J.\ 2009, \pre, 80, 047401 @@ -215,7 +215,7 @@ function fii(gamma) result(f) f = A1 * (sqrt(gamma * (A2 + gamma)) - A2 * log(sqrt(gamma/A2) + sqrt(1+gamma/A2))) + & 2 * A3 * (sqrt(gamma) - atan(sqrt(gamma))) - return + return end function fii @@ -257,7 +257,7 @@ function fie(rs, gamma_e, Z) result(f) h1 = 1d0 / (1d0 + pow(x/sqrt(1+x*x),6d0) * pow(Z,-1d0/3d0)) h2 = 1d0 / sqrt(1+x*x) - f = - gamma_e * (c_DH * sqrt(gamma_e) + c_TF * a * pow(gamma_e, nu) * g1 * h1) / & + f = - gamma_e * (c_DH * sqrt(gamma_e) + c_TF * a * pow(gamma_e, nu) * g1 * h1) / & (1d0 + (b * sqrt(gamma_e) + a * g2 * pow(gamma_e, nu)/rs) * h2) @@ -325,7 +325,7 @@ function Vs_coulomb_Itoh(cc, Z) result(Vs) type(auto_diff_real_2var_order1) :: Vs ! the screening potential in units of the fermi energy - ! code from Itoh, N., Tomizawa, N., Tamamura, M., Wanajo, S., & Nozawa, S. 2002, ApJ, 579, 380 + ! code from Itoh, N., Tomizawa, N., Tamamura, M., Wanajo, S., & Nozawa, S. 2002, ApJ, 579, 380 integer :: i type(auto_diff_real_2var_order1) :: rs, rs0, s, fj diff --git a/rates/private/eval_ecapture.f90 b/rates/private/eval_ecapture.f90 index a296b7d3f..9ae034e98 100644 --- a/rates/private/eval_ecapture.f90 +++ b/rates/private/eval_ecapture.f90 @@ -105,7 +105,7 @@ subroutine do_eval_ecapture_reaction_info( & kT = 1d3 * keV * T9 ! in MeV kT% d1val1 = kT% val kT% d1val2 = 0d0 - + mec2 = me * clight*clight / mev_to_ergs ! in MeV beta = mec2/kT ! dimesionless diff --git a/rates/private/eval_psi.f90 b/rates/private/eval_psi.f90 index e38e245e9..d861b51b5 100644 --- a/rates/private/eval_psi.f90 +++ b/rates/private/eval_psi.f90 @@ -98,7 +98,7 @@ end subroutine do_psi_Iec_and_Jec subroutine do_psi_Iee_and_Jee(beta, zeta, eta, I, J) use auto_diff - + ! calulate the phase space integral for electron emission (beta-decay) implicit none diff --git a/rates/private/eval_weak.f90 b/rates/private/eval_weak.f90 index e3574b8ed..a0e12a030 100644 --- a/rates/private/eval_weak.f90 +++ b/rates/private/eval_weak.f90 @@ -24,7 +24,7 @@ ! *********************************************************************** module eval_weak - + use const_def, only: dp use math_lib use utils_lib, only: mesa_error @@ -34,7 +34,7 @@ module eval_weak contains - + subroutine do_eval_weak_reaction_info( & n, ids, reaction_ids, T9, YeRho, & eta, d_eta_dlnT, d_eta_dlnRho, & @@ -53,7 +53,7 @@ subroutine do_eval_weak_reaction_info( & Q, dQ_dlnT, dQ_dlnRho, & Qneu, dQneu_dlnT, dQneu_dlnRho integer, intent(out) :: ierr - + real(dp) :: alfa, beta, d_alfa_dlnT, alfa_hi_Z, beta_hi_Z, d_alfa_hi_Z_dlnT integer :: i, ir, cid @@ -72,8 +72,8 @@ subroutine do_eval_weak_reaction_info( & end if !if (T9 >= max(T9_weaklib_full_on, T9_weaklib_full_on_hi_Z)) return - - ! revise lambda using rate for low T + + ! revise lambda using rate for low T ! alfa is fraction from weaklib if (T9 >= T9_weaklib_full_on) then alfa = 1d0 @@ -108,7 +108,7 @@ subroutine do_eval_weak_reaction_info( & if (ir == 0) cycle cid = weak_reaction_info(1,ir) if (weak_lowT_rate(ir) <= 0d0) cycle - if (cid <= 0) cycle + if (cid <= 0) cycle if (ids(i) <= 0) then lambda(i) = weak_lowT_rate(ir) dlambda_dlnT(i) = 0d0 @@ -125,10 +125,10 @@ subroutine do_eval_weak_reaction_info( & dlambda_dlnRho(i) = alfa*dlambda_dlnRho(i) end if end do - + end subroutine do_eval_weak_reaction_info - + subroutine do_eval_weaklib_reaction_info( & n, ids, T9_in, YeRho_in, & eta, d_eta_dlnT, d_eta_dlnRho, & @@ -147,9 +147,9 @@ subroutine do_eval_weaklib_reaction_info( & Q, dQ_dlnT, dQ_dlnRho, & Qneu, dQneu_dlnT, dQneu_dlnRho integer, intent(out) :: ierr - + logical, parameter :: dbg = .false. - + real(dp) :: T, T9, YeRho, lYeRho integer :: i, ir, in, out, rxn_idx logical :: neg @@ -168,27 +168,27 @@ subroutine do_eval_weaklib_reaction_info( & include 'formats' ierr = 0 - + T9 = T9_in YeRho = YeRho_in lYeRho = log10(YeRho_in) if (is_bad(lYeRho)) then ierr = -1 return - + write(*,1) 'lYeRho', lYeRho write(*,1) 'YeRho_in', YeRho_in write(*,1) 'log10(YeRho_in)', log10(YeRho_in) !call mesa_error(__FILE__,__LINE__,'weak lYeRho') end if - + if (n == 0) then write(*,*) 'problem in eval_weak_reaction_info: n == 0' write(*,2) 'n', n write(*,1) 'T9', T9 return end if - + do i = 1, n lambda(i) = 0d0 @@ -241,7 +241,7 @@ subroutine do_eval_weaklib_reaction_info( & lYeRho = table % lYeRhos(table % num_lYeRho) call table% interpolate(T9, lYeRho, & - lambda(i), dlambda_dlnT(i), dlambda_dlnRho(i), & + lambda(i), dlambda_dlnT(i), dlambda_dlnRho(i), & Qneu(i), dQneu_dlnT(i), dQneu_dlnRho(i), ierr) in = weak_lhs_nuclide_id(ir) @@ -306,18 +306,18 @@ subroutine do_eval_weaklib_reaction_info( & write(*,2) 'Qneu', i, Qneu(i) call show_stuff end if - + end do - + if (is_bad(lYeRho)) then ierr = -1 return call show_stuff end if - - + + contains - + subroutine show_stuff integer :: i include 'formats' @@ -345,10 +345,10 @@ subroutine show_stuff end if end do call mesa_error(__FILE__,__LINE__) - end subroutine show_stuff - + end subroutine show_stuff + end subroutine do_eval_weaklib_reaction_info - + diff --git a/rates/private/load_weak.f90 b/rates/private/load_weak.f90 index 0b3978172..4e099619f 100644 --- a/rates/private/load_weak.f90 +++ b/rates/private/load_weak.f90 @@ -24,7 +24,7 @@ ! *********************************************************************** module load_weak - + use rates_def use const_def, only: dp use utils_lib, only: mesa_error @@ -32,15 +32,15 @@ module load_weak use suzuki_tables, only: private_load_suzuki_tables implicit none - + private :: private_load_weak_tables contains - - + + subroutine load_weak_data(ierr) - integer, intent(out) :: ierr - ierr = 0 + integer, intent(out) :: ierr + ierr = 0 call private_load_weak_tables(ierr) if (ierr /= 0) return @@ -53,13 +53,13 @@ subroutine load_weak_data(ierr) call load_weak_info_list(ierr) end subroutine load_weak_data - - + + subroutine load_weak_info_list(ierr) use utils_lib use math_lib, only: str_to_vector integer, intent(out) :: ierr - + integer :: iounit, i, nvec character (len=256) :: filename, string character(len=iso_name_length) :: lhs, rhs @@ -71,10 +71,10 @@ subroutine load_weak_info_list(ierr) logical, parameter :: dbg = .false. include 'formats' - + ierr = 0 vec => vec_ary - + filename = trim(weak_data_dir) // '/weak_info.list' ierr = 0 open(newunit=iounit, file=trim(filename), action='read', status='old', iostat=ierr) @@ -82,7 +82,7 @@ subroutine load_weak_info_list(ierr) write(*,*) 'failed to open ' // trim(filename) return end if - + if (dbg) then write(*,'(A)') write(*,*) 'weak info filename <' // trim(filename) // '>' @@ -101,7 +101,7 @@ subroutine load_weak_info_list(ierr) allocate(weak_info_list_halflife(max_num_weak_info)) allocate(weak_info_list_Qneu(max_num_weak_info)) num_weak_info_list_reactions = 0 - do i = 1, max_num_weak_info ! keep reading until end of file + do i = 1, max_num_weak_info ! keep reading until end of file read(iounit,fmt='(a5,a5,a)',iostat=ierr) lhs, rhs, string if (ierr == 0) then call str_to_vector(string, vec, nvec, ierr) @@ -111,40 +111,40 @@ subroutine load_weak_info_list(ierr) ierr = 0; exit end if weak_info_list_halflife(i) = vec(1) - weak_info_list_Qneu(i) = vec(2) + weak_info_list_Qneu(i) = vec(2) call create_weak_dict_key(lhs, rhs, key) !write(*,'(a)') 'weak info list key ' // trim(key) call integer_dict_define(weak_info_list_dict, key, i, ierr) if (failed('integer_dict_define')) return num_weak_info_list_reactions = i end do - + close(iounit) - + if (num_weak_info_list_reactions == 0) then ierr = -1 write(*,*) 'failed trying to read weak_info.list -- no reactions?' return end if - + if (num_weak_info_list_reactions == max_num_weak_info) then ierr = -1 write(*,*) 'failed trying to read weak_info.list -- too many reactions?' return end if - + call integer_dict_create_hash(weak_info_list_dict, ierr) if (ierr /= 0) return - + call realloc_double(weak_info_list_halflife, num_weak_info_list_reactions, ierr) if (ierr /= 0) return - + call realloc_double(weak_info_list_Qneu, num_weak_info_list_reactions, ierr) if (ierr /= 0) return - - + + contains - + logical function failed(str) character (len=*) :: str failed = (ierr /= 0) @@ -152,17 +152,17 @@ logical function failed(str) write(*,*) 'failed: ' // trim(str) end if end function failed - - + + end subroutine load_weak_info_list - - + + subroutine private_load_weak_tables(ierr) use utils_lib use chem_lib, only: chem_get_iso_id use chem_def, only: iso_name_length integer, intent(out) :: ierr - + integer :: iounit, i, ios, id character (len=256) :: filename, cache_filename, string character(len=iso_name_length) :: lhs1, rhs1, lhs2, rhs2, weak_lhs, weak_rhs @@ -177,11 +177,11 @@ subroutine private_load_weak_tables(ierr) integer, parameter :: i_ldecay = 1, i_lcapture = 2, i_lneutrino = 3 logical, parameter :: dbg = .false. - + include 'formats' - + ierr = 0 - + ios = -1 if (rates_use_cache) then cache_filename = trim(rates_cache_dir) // '/weakreactions.bin' @@ -193,9 +193,9 @@ subroutine private_load_weak_tables(ierr) close(iounit) end if end if - + if (ios /= 0) then ! need to read data file - + filename = trim(weak_data_dir) // '/weakreactions.tables' ierr = 0 open(newunit=iounit, file=trim(filename), action='read', status='old', iostat=ierr) @@ -203,7 +203,7 @@ subroutine private_load_weak_tables(ierr) write(*,*) 'failed to open ' // trim(filename) return end if - + if (dbg) then write(*,'(A)') write(*,*) 'weaklib filename <' // trim(filename) // '>' @@ -219,15 +219,15 @@ subroutine private_load_weak_tables(ierr) end do if (.not. skip_line()) return - + read(iounit,*,iostat=ierr) num_weak_reactions if (failed('read num_weak_reactions')) return - + if (dbg) write(*,2) 'num_weak_reactions', num_weak_reactions - + call alloc if (failed('allocate')) return - + do i = 1, num_weak_reactions if (.not. skip_line()) return if (mod(i,2)==1) then ! first of pair @@ -280,9 +280,9 @@ subroutine private_load_weak_tables(ierr) call read_table(i,i_lneutrino) if (failed('read lneutrino')) return end do - + close(iounit) - + if (rates_use_cache) then open(newunit=iounit, file=trim(cache_filename), iostat=ios, & action='write', form='unformatted') @@ -291,16 +291,16 @@ subroutine private_load_weak_tables(ierr) close(iounit) end if end if - + end if - + nullify(weak_reactions_dict) do i = 1, num_weak_reactions call create_weak_dict_key(weak_lhs_nuclide_name(i), weak_rhs_nuclide_name(i), key) call integer_dict_define(weak_reactions_dict, key, i, ierr) if (failed('integer_dict_define')) return end do - + call integer_dict_create_hash(weak_reactions_dict, ierr) if (failed('integer_dict_create_hash')) return @@ -312,8 +312,8 @@ subroutine private_load_weak_tables(ierr) end do if (dbg) write(*,*) 'finished load_weak_tables' - - + + contains @@ -321,19 +321,19 @@ subroutine read_weak_cache(iounit,ios) integer, intent(in) :: iounit integer, intent(out) :: ios integer :: n, i - + include 'formats' - + read(iounit,iostat=ios) num_weak_reactions if (ios /= 0) return - + if (dbg) write(*,2) 'num_weak_reactions', num_weak_reactions - + call alloc if (failed('allocate')) return - + n = num_weak_reactions - + read(iounit,iostat=ios) & weak_lhs_nuclide_id(1:n), & weak_rhs_nuclide_id(1:n), & @@ -345,20 +345,20 @@ subroutine read_weak_cache(iounit,ios) read(iounit, iostat=ios) & weak_reactions_tables(i) % t % data(1,1:weak_num_T9,1:weak_num_lYeRho,1:3) end do - + end subroutine read_weak_cache subroutine write_weak_cache(iounit) integer, intent(in) :: iounit integer :: n, i - + include 'formats' - + write(iounit) num_weak_reactions - + n = num_weak_reactions - + write(iounit) & weak_lhs_nuclide_id(1:n), & weak_rhs_nuclide_id(1:n), & @@ -370,15 +370,15 @@ subroutine write_weak_cache(iounit) write(iounit, iostat=ios) & weak_reactions_tables(i) % t % data(1,1:weak_num_T9,1:weak_num_lYeRho,1:3) end do - + end subroutine write_weak_cache - - + + subroutine alloc integer :: i type(weaklib_rate_table) :: table - + allocate( & weak_reaclib_id(num_weak_reactions), & weak_lhs_nuclide_name(num_weak_reactions), & @@ -392,10 +392,10 @@ subroutine alloc table = weaklib_rate_table(weak_reaction_T9s, weak_reaction_lYeRhos) allocate(weak_reactions_tables(i)% t, source=table) end do - + end subroutine alloc - - + + subroutine adjust_name(nm) character(len=iso_name_length) :: nm nm = adjustl(nm) @@ -405,8 +405,8 @@ subroutine adjust_name(nm) nm = 'neut' end if end subroutine adjust_name - - + + subroutine read_table(i,ii) use math_lib, only: str_to_vector integer, intent(in) :: i, ii @@ -445,8 +445,8 @@ subroutine read_table(i,ii) !if (dbg) write(*,'(a,2i6,99f9.3)') 'read_table', j, skip, buffer end do end subroutine read_table - - + + logical function failed(str) character (len=*) :: str failed = (ierr /= 0) @@ -454,8 +454,8 @@ logical function failed(str) write(*,*) 'failed: ' // trim(str) end if end function failed - - + + logical function skip_line() logical, parameter :: dbg = .false. if (dbg) then @@ -516,7 +516,7 @@ subroutine load_user_weak_tables(ierr) rate_loop: do t = token(iounit, n, i, buffer, rate_name) - if (t == eof_token) exit + if (t == eof_token) exit rate_loop if (t /= name_token) then call error; return end if diff --git a/rates/private/pycno.f90 b/rates/private/pycno.f90 index 465b042b1..8aceef7a8 100644 --- a/rates/private/pycno.f90 +++ b/rates/private/pycno.f90 @@ -32,13 +32,13 @@ module pycno use utils_lib use const_def, only: dp use math_lib - + implicit none - - + + contains - - subroutine FL_epsnuc_3alf(T, Rho, Y, UE, r, drdT, drdRho) + + subroutine FL_epsnuc_3alf(T, Rho, Y, UE, r, drdT, drdRho) real(dp), intent(in) :: T ! temperature real(dp), intent(in) :: Rho ! density real(dp), intent(in) :: Y ! helium mass fraction @@ -56,7 +56,7 @@ subroutine FL_epsnuc_3alf(T, Rho, Y, UE, r, drdT, drdRho) real(dp) :: F1, dF1dT, dF1dRho, F2, dF2dT, dF2dRho real(dp) :: dR6dRho, dR6TdRho, dR6T13dRho, dR6T16dRho real(dp) :: dT6dT, dT612dT, dT62dT, dT613dT, dT623dT, dT632dT, dT653dT - + ! DEBUG real(dp), parameter :: AF_0 = 1.9005324047511074D+00 real(dp), parameter :: B1_denom_0 = 2.9602238143383192D-01 @@ -81,7 +81,7 @@ subroutine FL_epsnuc_3alf(T, Rho, Y, UE, r, drdT, drdRho) real(dp) :: A2, dA2dT, B2_numerator, dB2_numerator_dT include 'formats' - + R6=RHO*1d-6 dR6dRho = 1d-6 R6T=2d0*R6/UE @@ -89,7 +89,7 @@ subroutine FL_epsnuc_3alf(T, Rho, Y, UE, r, drdT, drdRho) R6T16=pow(R6T,1d0/6d0) dR6T16dRho = (1d0/6d0)*dR6TdRho*R6T16/R6T - R6T13=R6T16*R6T16 + R6T13=R6T16*R6T16 dR6T13dRho = 2*R6T16*dR6T16dRho T6=T*1d-6 dT6dT=1d-6 @@ -100,153 +100,153 @@ subroutine FL_epsnuc_3alf(T, Rho, Y, UE, r, drdT, drdRho) dT623dT=2*T613*dT613dT T653=T623*T6 dT653dT = dT623dT*T6 + T623*dT6dT - + T62=T6*T6 T612=sqrt(T6) dT612dT=0.5d0*dT6dT/T612 T632=T6*T612 - dT632dT=1.5d0*T612*dT6dT - + dT632dT=1.5d0*T612*dT6dT + U=1.35D0*R6T13/T623 dUdT = -U * dT623dT / T623 dUdRho = U * dR6T13dRho / R6T13 - + U32 = U*sqrt(U) U52 = U*U32 if (U < 1) then ! strong screening regime, eqn 4.8a in F&L - + A1 = pow2(1d0-4.222D-2*T623) + 2.643D-5*T653 dA1dT = -2d0*4.222d-2*dT623dT*(1d0 - 4.222D-2*T623) + 2.643D-5*dT653dT - + B1_denom=A1*T623 dB1_denom_dT = dA1dT*T623 + A1*dT623dT - + B1_numerator = 16.16D0*exp(-134.92d0/T613) dB1_numerator_dT = B1_numerator*134.92d0*dT613dT/(T613*T613) - + B1=B1_numerator/B1_denom dB1dT = dB1_numerator_dT/B1_denom - B1*dB1_denom_dT/B1_denom - + A2 = pow2(1d0-2.807D-2*T623) + 2.704D-6*T653 dA2dT = -2*2.807D-2*dT623dT*(1d0-2.807D-2*T623) + 2.704D-6*dT653dT - + B2_denom=A2*T623 dB2_denom_dT = dA2dT*T623 + A2*dT623dT - + B2_numerator = 244.6D0*pow5(1D0+3.528D-3*T623) * exp(-235.72D0/T613) dB2_numerator_dT = B2_numerator* & (5D0*3.528D-3*dT623dT/(1D0+3.528D-3*T623) + 235.72D0*dT613dT/T623) B2=B2_numerator/B2_denom dB2dT = dB2_numerator_dT/B2_denom - B2*dB2_denom_dT/B2_denom - + if (5.458D3 > R6T) then - + E1 = -1065.1D0/T6 dE1dT = -E1 * dT6dT / T6 - + F1 = exp(E1)/T632 dF1dT = F1 * (dE1dT - dT632dT/T632) - + B1=B1+F1 dB1dT = dB1dT + dF1dT - + endif - + if (1.836D4 > R6T) then - + E2 = -3336.4D0/T6 dE2dT = -E2 * dT6dT / T6 - + F2 = exp(E2)/T632 dF2dT = F2 * (dE2dT - dT632dT/T632) - + B2=B2+F2 dB2dT = dB2dT + dF2dT - + endif - + G1=B1*exp(60.492D0*R6T13/T6) dG1dT = G1*(dB1dT/B1 - 60.492D0*R6T13*dT6dT/(T6*T6)) dG1dRho=0 - + G2=B2*exp(106.35D0*R6T13/T6) dG2dT = G2*(dB2dT/B2 - 106.35D0*R6T13*dT6dT/(T6*T6)) - dG2dRho=0 + dG2dRho=0 else ! pycnonuclear regime, eqn 4.8b in F&L - + AF=1d0/U32 + 1d0 dAFdT = -1.5d0 * dUdT/U52 dAFdRho = -1.5d0 * dUdRho/U52 - + B1_denom=T612*(pow2(1.0d0-5.680D-2*R6T13)+8.815D-7*T62) dB1_denom_dT = B1_denom*dT612dT/T612 + T612*8.815D-7*dT62dT dB1_denom_dRho = -2*5.680D-2*(1.0d0-5.680D-2*R6T13)*T612*dR6T13dRho - + B1=1.178D0*AF*exp(-77.554d0/R6T16)/B1_denom dB1dT = B1 * (dAFdT/AF - dB1_denom_dT/B1_denom) dB1dRho = B1 * (dAFdRho/AF + 77.554d0*dR6T16dRho/(R6T16*R6T16) - dB1_denom_dRho/B1_denom) - + B2_denom=T612*(pow2(1.0d0-3.791D-2*R6T13)+5.162D-8*T62) dB2_denom_dT = B2_denom*dT612dT/T612 + T612*5.162D-8*dT62dT - + tmp = pow(Rho/UE,1d0/3d0) dB2_denom_dRho = T612*(-0.000252733d0 + 9.58112d-8*tmp)*tmp/Rho - + B2=13.48D0*AF*pow5(1.0d0+5.070D-3*R6T13)*exp(-135.08D0/R6T16)/B2_denom dB2dT = B2 * (dAFdT/AF - dB2_denom_dT/B2_denom) - dB2dRho = B2 * (dAFdRho/AF + 135.08D0*dR6T16dRho/(R6T16*R6T16) - dB2_denom_dRho/B2_denom) - + dB2dRho = B2 * (dAFdRho/AF + 135.08D0*dR6T16dRho/(R6T16*R6T16) - dB2_denom_dRho/B2_denom) + if (5.458D3 > R6T) then - + E1 = (60.492d0*R6T13 - 1065.1D0)/T6 dE1dT = -E1 * dT6dT / T6 dE1dRho = 60.492d0*dR6T13dRho/T6 - + F1 = exp(E1)/T632 dF1dT = F1 * (dE1dT - dT632dT/T632) dF1dRho = F1 * dE1dRho - + !write(*,1) 'E1', E1 !write(*,1) 'F1', F1 G1=B1+F1 dG1dT = dB1dT + dF1dT dG1dRho = dB1dRho + dF1dRho - + else - + G1=B1; dG1dRho = dB1dRho; dG1dT = dB1dT - + endif - + if (1.836D4 > R6T) then - + E2 = (106.35D0*R6T13 - 3336.4D0)/T6 dE2dT = -E2 * dT6dT / T6 dE2dRho = 106.35D0*dR6T13dRho/T6 - + F2 = exp(E2)/T632 dF2dT = F2 * (dE2dT - dT632dT/T632) dF2dRho = F2 * dE2dRho - + !write(*,1) 'E2', E2 !write(*,1) 'F2', F2 - + G2=B2+F2 dG2dT = dB2dT + dF2dT dG2dRho = dB2dRho + dF2dRho - + else - + G2=B2; dG2dRho = dB2dRho; dG2dT = dB2dT - + endif endif - + r=5.120D29*G1*G2*Y*Y*Y*R6*R6 ! ergs/g/sec, eqn 4.7 in F&L if (r < 1d-99 .or. G1 < 1d-99 .or. G2 < 1d-99) then @@ -257,7 +257,7 @@ subroutine FL_epsnuc_3alf(T, Rho, Y, UE, r, drdT, drdRho) drdRho = r * (dG1dRho/G1 + dG2dRho/G2 + 2*dR6dRho/R6) return - + write(*,1) 'T', T write(*,1) 'RHO', RHO write(*,1) 'r', r @@ -265,9 +265,9 @@ subroutine FL_epsnuc_3alf(T, Rho, Y, UE, r, drdT, drdRho) write(*,1) 'G2', G2 write(*,1) 'U', U write(*,'(A)') - + write(*,1) 'abs(Rho_0 - Rho)', abs(Rho_0 - Rho) - + if (.true. .and. abs(Rho_0 - Rho) > 1d-2) then write(*,'(A)') write(*,1) 'analytic drdRho', drdRho @@ -282,7 +282,7 @@ subroutine FL_epsnuc_3alf(T, Rho, Y, UE, r, drdT, drdRho) write(*,1) 'analytic dUdRho', dUdRho write(*,1) 'numeric dUdRho', (U_0 - U) / (Rho_0 - Rho) write(*,'(A)') - write(*,1) 'analytic AF', dAFdRho + write(*,1) 'analytic AF', dAFdRho write(*,1) 'numeric AF', (AF_0 - AF) / (Rho_0 - Rho) write(*,'(A)') write(*,1) 'analytic B1_denom', dB1_denom_dRho @@ -291,34 +291,34 @@ subroutine FL_epsnuc_3alf(T, Rho, Y, UE, r, drdT, drdRho) write(*,1) 'analytic B1', dB1dRho write(*,1) 'numeric B1', (B1_0 - B1) / (Rho_0 - Rho) write(*,'(A)') - write(*,1) 'analytic B2_denom', dB2_denom_dRho + write(*,1) 'analytic B2_denom', dB2_denom_dRho write(*,1) 'numeric B2_denom', (B2_denom_0 - B2_denom) / (Rho_0 - Rho) write(*,'(A)') - write(*,1) 'analytic B2', dB2dRho + write(*,1) 'analytic B2', dB2dRho write(*,1) 'numeric B2', (B2_0 - B2) / (Rho_0 - Rho) write(*,'(A)') - write(*,1) 'analytic E1', dE1dRho + write(*,1) 'analytic E1', dE1dRho write(*,1) 'numeric E1', (E1_0 - E1) / (Rho_0 - Rho) write(*,'(A)') - write(*,1) 'analytic F1', dF1dRho + write(*,1) 'analytic F1', dF1dRho write(*,1) 'numeric F1', (F1_0 - F1) / (Rho_0 - Rho) write(*,'(A)') - write(*,1) 'analytic E2', dE2dRho + write(*,1) 'analytic E2', dE2dRho write(*,1) 'numeric E2', (E2_0 - E2) / (Rho_0 - Rho) write(*,'(A)') - write(*,1) 'analytic F2', dF2dRho + write(*,1) 'analytic F2', dF2dRho write(*,1) 'numeric F2', (F2_0 - F2) / (Rho_0 - Rho) write(*,'(A)') - call mesa_error(__FILE__,__LINE__,'FL_epsnuc_3alf') + call mesa_error(__FILE__,__LINE__,'FL_epsnuc_3alf') end if - + end if end subroutine FL_epsnuc_3alf end module pycno - - + + diff --git a/rates/private/ratelib.f90 b/rates/private/ratelib.f90 index bfb7549c6..7bcb81eb5 100644 --- a/rates/private/ratelib.f90 +++ b/rates/private/ratelib.f90 @@ -35,13 +35,13 @@ module ratelib use chem_lib, only: chem_get_iso_id use const_def, only: dp, ln2 use math_lib - + implicit none real(dp), parameter :: lowT9_cutoff = 1d-3 ! all non-pp rates except decays go to 0 below this - + real(dp), parameter :: lowT9pp_cutoff = 1d-5 ! all pp rates except decays go to 0 below this real(dp) oneth, twoth, fourth, fiveth, elvnth, fivfour, onesix, & @@ -73,12 +73,12 @@ module ratelib ! wk82 wiescher and kettner, ap. j., 263, 891 (1982) ! c96 champagne 1996 - + ! Hydrogen ! rpp, p(p,e+nu)h2 - + subroutine rate_pp_fxt(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp @@ -87,46 +87,46 @@ subroutine rate_pp_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9pp_cutoff) then fr = 0; rr = 0; return - end if - + end if + if (tf% t9 .le. 3d0) then - aa = 4.01d-15 * tf% t9i23 * exp(-3.380d0*tf% t9i13) - bb = 1.0d0 + 0.123d0*tf% t913 + 1.09d0*tf% t923 + 0.938d0*tf% t9 + aa = 4.01d-15 * tf% t9i23 * exp(-3.380d0*tf% t9i13) + bb = 1.0d0 + 0.123d0*tf% t913 + 1.09d0*tf% t923 + 0.938d0*tf% t9 term = aa * bb else term = 1.1581136d-15 end if - fr = term + fr = term rr = 0.0d0 end subroutine rate_pp_fxt - - + + subroutine rate_pp_nacre(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr real(dp) :: term - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) if (tf% t9 < lowT9pp_cutoff) then fr = 0; rr = 0; return - end if - + end if + call rnacre(tf, & 4.08d-15, 3.381d0, 0d0, & ! a0, a1, a2 3.82d0, 1.51d0, 0.144d0, -1.14d-02, 0d0, & ! b0, b1, b2, b3, b4 0d0, 0d0, & ! c0, c1 0d0, 0d0, & ! d0, d1 0d0, 0d0, 0d0, & ! e0, e1, e2 - term) - fr = term + term) + fr = term rr = 0.0d0 end subroutine rate_pp_nacre - + subroutine rate_pp_jina(tf, temp, fr, rr) ! cf88 type (T_Factors) :: tf @@ -135,17 +135,17 @@ subroutine rate_pp_jina(tf, temp, fr, rr) ! cf88 integer :: ierr include 'formats' ierr = 0 -! p p d bet+w 1.44206d+00 +! p p d bet+w 1.44206d+00 call reaclib_rate_for_handle('r_h1_h1_wk_h2', tf% T9, fr, rr, ierr) if (ierr /= 0) then write(*,'(a)') 'failed to get reaclib rate r_h1_h1_wk_h2' call rate_pp_fxt(tf, temp, fr, rr) end if end subroutine rate_pp_jina - - + + ! rpep, p(e-p, nu)h2 - + subroutine rate_pep_fxt(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp @@ -154,8 +154,8 @@ subroutine rate_pep_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9pp_cutoff) then fr = 0; rr = 0; return - end if - + end if + if ((tf% T9) <= 3d0) then aa = 1.36d-20 * (tf% T9i76) * exp(-3.380d0*(tf% T9i13)) bb = (1.0d0 - 0.729d0*(tf% T913) + 9.82d0*(tf% T923)) @@ -163,10 +163,10 @@ subroutine rate_pep_fxt(tf, temp, fr, rr) else term = 7.3824387d-21 end if - fr = term + fr = term rr = 0.0d0 end subroutine rate_pep_fxt - + subroutine rate_pep_jina(tf, temp, fr, rr) ! cf88 type (T_Factors) :: tf @@ -174,15 +174,15 @@ subroutine rate_pep_jina(tf, temp, fr, rr) ! cf88 real(dp), intent(out) :: fr, rr integer :: ierr ierr = 0 -! p p d ecw 1.44206d+00 +! p p d ecw 1.44206d+00 call reaclib_rate_for_handle('r_h1_h1_ec_h2', tf% T9, fr, rr, ierr) if (ierr /= 0) then write(*,'(a)') 'failed to get reaclib rate r_h1_h1_ec_h2' call rate_pep_fxt(tf, temp, fr, rr) end if end subroutine rate_pep_jina - - + + ! rdpg, h2(p,g)he3 @@ -195,17 +195,17 @@ subroutine rate_dpg_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9pp_cutoff) then fr = 0; rr = 0; return - end if - - aa = 2.24d+03 * tf% t9i23 * exp(-3.720d0*tf% t9i13) + end if + + aa = 2.24d+03 * tf% t9i23 * exp(-3.720d0*tf% t9i13) bb = 1.0d0 + 0.112d0*tf% t913 + 3.38d0*tf% t923 + 2.65d0*tf% t9 - term = aa * bb - fr = term + term = aa * bb + fr = term rev = 1.63d+10 * tf% t932 * exp(-63.750d0*tf% t9i) rr = rev * term !if (temp > 3.1d6 .and. temp < 3.2d6) write(*,1) 'rates dpg', fr, temp end subroutine rate_dpg_fxt - + subroutine rate_dpg_nacre(tf, temp, fr, rr) type (T_Factors) :: tf @@ -215,11 +215,11 @@ subroutine rate_dpg_nacre(tf, temp, fr, rr) if (tf% t9 < lowT9pp_cutoff) then fr = 0; rr = 0; return - end if - + end if + if (tf% T9 <= 0.11d0) then - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) @@ -229,10 +229,10 @@ subroutine rate_dpg_nacre(tf, temp, fr, rr) 0d0, 0d0, & ! c0, c1 0d0, 0d0, & ! d0, d1 0d0, 0d0, 0d0, & ! e0, e1, e2 - term) + term) else - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) @@ -242,21 +242,21 @@ subroutine rate_dpg_nacre(tf, temp, fr, rr) 0d0, 0d0, & ! c0, c1 0d0, 0d0, & ! d0, d1 0d0, 0d0, 0d0, & ! e0, e1, e2 - term) + term) end if call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 1.63d10, 63.749d0, & ! a0, a1 - rev) - fr = term + rev) + fr = term rr = rev * term end subroutine rate_dpg_nacre - + subroutine rate_dpg_jina(tf, temp, fr, rr) ! cf88 type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p d he3 de04 5.49300d+00 +! p d he3 de04 5.49300d+00 call jina_reaclib_2_1(ih1, ih2, ihe3, tf, fr, rr, 'rate_dpg_jina') end subroutine rate_dpg_jina @@ -269,8 +269,8 @@ subroutine rate_png_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9pp_cutoff) then fr = 0; rr = 0; return - end if - + end if + ! p(n, g)d @@ -279,7 +279,7 @@ subroutine rate_png_fxt(tf, temp, fr, rr) aa = 1.0d0 - 0.8504d0*(tf% T912) + 0.4895d0*(tf% T9) & - 0.09623d0*(tf% T932) + 8.471d-3*(tf% T92) & - 2.80d-4*(tf% T952) - + term = 4.742d4 * aa ! wagoner, schramm 1977 @@ -289,20 +289,20 @@ subroutine rate_png_fxt(tf, temp, fr, rr) ! term = 4.4d4 * aa ! dtermdt = 4.4d4 * daa - fr = term + fr = term rev = 4.71d+09 * (tf% T932) * exp(-25.82d0*(tf% T9i)) rr = rev * term end subroutine rate_png_fxt - - + + subroutine rate_ddg_jina(tf, temp, fr, rr) ! cf88 type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! d d he4 cf88n 2.38470d+01 +! d d he4 cf88n 2.38470d+01 call jina_reaclib_2_1(ih2, ih2, ihe4, tf, fr, rr, 'rate_ddg_jina') end subroutine rate_ddg_jina @@ -310,7 +310,7 @@ end subroutine rate_ddg_jina ! Helium ! rhe3p, he3(p,e+nu)he4 - + subroutine rate_hep_jina(tf, temp, fr, rr) ! cf88 type (T_Factors) :: tf @@ -318,7 +318,7 @@ subroutine rate_hep_jina(tf, temp, fr, rr) ! cf88 real(dp), intent(out) :: fr, rr integer :: ierr ierr = 0 -! p he3 he4 bet+w 1.97960d+01 +! p he3 he4 bet+w 1.97960d+01 call reaclib_rate_for_handle('r_h1_he3_wk_he4', tf% T9, fr, rr, ierr) if (ierr /= 0) then write(*,'(a)') 'failed to get reaclib rate r_h1_he3_wk_he4' @@ -335,15 +335,15 @@ subroutine rate_hep_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9pp_cutoff) then fr = 0; rr = 0; return - end if - + end if + if ((tf% T9) <= 3d0) then aa = 8.78d-13 * (tf% T9i23) * exp(-6.141d0*(tf% T9i13)) term = aa else term = 5.9733434d-15 end if - fr = term + fr = term rr = 0.0d0 end subroutine rate_hep_fxt @@ -354,91 +354,91 @@ subroutine rate_he3d_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! d he3 p he4 de04 1.83530d+01 +! d he3 p he4 de04 1.83530d+01 call jina_reaclib_2_2(ih2, ihe3, ih1, ihe4, tf, fr, rr, 'rate_he3d_jina') end subroutine rate_he3d_jina -! r33, he3(he3, 2p)he4 +! r33, he3(he3, 2p)he4 subroutine rate_he3he3_nacre(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr real(dp) term, rev - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) if (tf% t9 < lowT9pp_cutoff) then fr = 0; rr = 0; return - end if - + end if + call rnacre(tf, & 5.59d10, 12.277d0, 0d0, & ! a0, a1, a2 -0.135d0, 2.54d-2, -1.29d-03, 0d0, 0d0, & ! b0, b1, b2, b3, b4 0d0, 0d0, & ! c0, c1 0d0, 0d0, & ! d0, d1 0d0, 0d0, 0d0, & ! e0, e1, e2 - term) + term) call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 3.392d-10, 149.23d0, & ! a0, a1 - rev) - fr = term - rr = rev * term + rev) + fr = term + rr = rev * term end subroutine rate_he3he3_nacre subroutine rate_he3he3_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he3 he3 h1 h1 he4 +! he3 he3 h1 h1 he4 call jina_reaclib_2_3(ihe3, ihe3, ih1, ih1, ihe4, tf, fr, rr, 'rate_he3he3_jina') end subroutine rate_he3he3_jina -! r34, he4(he3,g)be7 +! r34, he4(he3,g)be7 subroutine rate_he3he4_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 he3 be7 de04 1.58700d+00 +! he4 he3 be7 de04 1.58700d+00 call jina_reaclib_2_1(ihe4, ihe3, ibe7, tf, fr, rr, 'rate_he3he4_jina') end subroutine rate_he3he4_jina - + subroutine rate_he3he4_nacre(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr real(dp) term, rev - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) if (tf% t9 < lowT9pp_cutoff) then fr = 0; rr = 0; return - end if - + end if + call rnacre(tf, & 5.46d6, 12.827d0, 0d0, & ! a0, a1, a2 -0.307d0, 8.81d-2, -1.06d-2, 4.46d-4, 0d0, & ! b0, b1, b2, b3, b4 0d0, 0d0, & ! c0, c1 0d0, 0d0, & ! d0, d1 0d0, 0d0, 0d0, & ! e0, e1, e2 - term) + term) call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 1.113d10, 18.412d0, & ! a0, a1 - rev) + rev) fr = term - rr = rev * term + rr = rev * term end subroutine rate_he3he4_nacre @@ -452,19 +452,19 @@ subroutine rate_tripalf_jina(tf, temp, fr, rr) real(dp), intent(out) :: fr, rr real(dp) :: fr1, rr1 include 'formats' - -! he4 he4 he4 c12 fy05r 7.27500d+00 + +! he4 he4 he4 c12 fy05r 7.27500d+00 call jina_reaclib_3_1(ihe4, ihe4, ihe4, ic12, tf, fr, rr, 'rate_tripalf_jina') - - return + + return call rate_tripalf_reaclib(tf, temp, fr1, rr1) - + write(*,1) 'fr', fr write(*,1) 'fr1', fr1 write(*,1) 'rr', rr write(*,1) 'rr1', rr1 write(*,'(A)') - call mesa_error(__FILE__,__LINE__,'rate_tripalf_jina') + call mesa_error(__FILE__,__LINE__,'rate_tripalf_jina') end subroutine rate_tripalf_jina @@ -491,13 +491,13 @@ subroutine rate_tripalf_reaclib(tf, temp, fr, rr) -1.178840d+01, -1.024460d+00, -2.357000d+01, 2.048860d+01, & -1.298820d+01, -2.000000d+01, -2.166670d+00, & fr3) - fr = fr1 + fr2 + fr3 + fr = fr1 + fr2 + fr3 ! use the fxt reverse rate term rev = 2.00d+20*(tf% t93)*exp(-84.424d0*(tf% t9i)) - rr = fr * rev + rr = fr * rev end subroutine rate_tripalf_reaclib - + subroutine rate_tripalf_nacre(tf, temp, fr, rr) type (T_Factors) :: tf @@ -505,26 +505,26 @@ subroutine rate_tripalf_nacre(tf, temp, fr, rr) real(dp), intent(out) :: fr, rr real(dp) :: r2abe, rbeac, bb, term, rev ! he4(a, g)be8 - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + call rnacre(tf, & 2.43d9, 13.490d0, 1d0/0.15d0, & ! a0, a1, a2 74.5d0, 0d0, 0d0, 0d0, 0d0, & ! b0, b1, b2, b3, b4 6.09d5, 1.054d0, & ! c0, c1 0d0, 0d0, & ! d0, d1 0d0, 0d0, 0d0, & ! e0, e1, e2 - r2abe) + r2abe) ! be8(a, g)c12 - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) @@ -534,19 +534,19 @@ subroutine rate_tripalf_nacre(tf, temp, fr, rr) 130.7d0, 3.338d0, & ! c0, c1 2.51d4, 20.307d0, & ! d0, d1 0d0, 0d0, 0d0, & ! e0, e1, e2 - rbeac) + rbeac) if (tf% T9 <= 0.03d0) then bb = 3.07d-16*(1d0 - 29.1d0*(tf% T9) + 1308d0*(tf% T92)) if (bb < 0) then bb = 0 - end if + end if else bb = 3.44d-16*(1 + 0.0158d0*pow(tf% T9,-0.65d0)) - end if + end if term = r2abe * rbeac * bb call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 2.003d20, 84.415d0, & ! a0, a1 - rev) + rev) fr = term rr = rev * term end subroutine rate_tripalf_nacre @@ -563,15 +563,15 @@ subroutine rate_tripalf_fxt(tf, temp, fr, rr) q1, q2 parameter (rc28 = 0.1d0, & q1 = 1.0d0/0.009604d0, & - q2 = 1.0d0/0.055225d0) + q2 = 1.0d0/0.055225d0) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + ! this is a(a, g)be8 - aa = 7.40d+05 * (tf% t9i32) * exp(-1.0663d0*(tf% t9i)) + aa = 7.40d+05 * (tf% t9i32) * exp(-1.0663d0*(tf% t9i)) bb = 4.164d+09 * (tf% t9i23) * exp(-13.49d0*(tf% t9i13) - (tf% t92)*q1) @@ -581,7 +581,7 @@ subroutine rate_tripalf_fxt(tf, temp, fr, rr) r2abe = aa + bb * cc ! this is be8(a, g)c12 - dd = 130.0d0 * (tf% t9i32) * exp(-3.3364d0*(tf% t9i)) + dd = 130.0d0 * (tf% t9i32) * exp(-3.3364d0*(tf% t9i)) ee = 2.510d+07 * (tf% t9i23) * exp(-23.57d0*(tf% t9i13) - (tf% t92)*q2) @@ -601,13 +601,13 @@ subroutine rate_tripalf_fxt(tf, temp, fr, rr) ! low temperature rate else - uu = 0.8d0*exp(-pow(0.025d0*(tf% t9i),3.263d0)) + uu = 0.8d0*exp(-pow(0.025d0*(tf% t9i),3.263d0)) yy = 0.2d0 + uu ! fixes a typo in Frank's original - vv = 4.0d0*exp(-pow((tf% t9)/0.025d0,9.227d0)) + vv = 4.0d0*exp(-pow((tf% t9)/0.025d0,9.227d0)) zz = 1.0d0 + vv aa = 1.0d0/zz f1 = 0.01d0 + yy * aa ! fixes a typo in Frank's original - term = 2.90d-16 * r2abe * rbeac * f1 + xx + term = 2.90d-16 * r2abe * rbeac * f1 + xx end if rev = 2.00d+20*(tf% t93)*exp(-84.424d0*(tf% t9i)) @@ -633,19 +633,19 @@ subroutine rate_he3ng_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + ! he3(n, g)he4 term = 6.62d0 * (1.0d0 + 905.0d0*(tf% T9)) - fr = term + fr = term rev = 2.61d+10 * (tf% T932) * exp(-238.81d0*(tf% T9i)) rr = rev * term end subroutine rate_he3ng_fxt - - -! Lithium + + +! Lithium ! rli7pa, li7(p,a)he4 @@ -655,33 +655,33 @@ subroutine rate_li7pa_nacre(tf, temp, fr, rr) real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr real(dp) term, rev - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) if (tf% t9 < lowT9pp_cutoff) then fr = 0; rr = 0; return - end if - + end if + call rnacre(tf, & 7.20d8, 8.473d0, 1d0/6.5d0, & ! a0, a1, a2 1.05d0, -0.653d0, 0.185d0, -2.12d-2, 9.30d-4, & ! b0, b1, b2, b3, b4 0d0, 0d0, & ! c0, c1 0d0, 0d0, & ! d0, d1 9.85d6, 0.576d0, 10.415d0, & ! e0, e1, e2 - term) + term) call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 4.676d0, 201.30d0, & ! a0, a1 - rev) + rev) fr = term rr = rev * term end subroutine rate_li7pa_nacre - - + + subroutine rate_li7pa_jina(tf, temp, fr, rr) ! jina reaclib type (T_Factors) :: tf real(dp), intent(in) :: temp @@ -690,10 +690,10 @@ subroutine rate_li7pa_jina(tf, temp, fr, rr) ! jina reaclib end subroutine rate_li7pa_jina -! rli7pg, li7(p,g)be8 => 2 he4 +! rli7pg, li7(p,g)be8 => 2 he4 -! Beryllium +! Beryllium ! rbe7ec, be7(e-, nu)li7 @@ -705,10 +705,10 @@ subroutine rate_be7em_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9pp_cutoff) then fr = 0; rr = 0; return - end if - + end if + if (tf% T9 <= 3d0 .and. tf% T9 >= 1d-3) then - aa = 0.0027d0*(tf% T9i) * exp(2.515d-3*(tf% T9i)) + aa = 0.0027d0*(tf% T9i) * exp(2.515d-3*(tf% T9i)) bb = 1.0d0 - 0.537d0*(tf% T913) + 3.86d0*(tf% T923) + aa term = 1.34d-10 * (tf% T9i12) * bb else @@ -719,7 +719,7 @@ subroutine rate_be7em_fxt(tf, temp, fr, rr) end subroutine rate_be7em_fxt - subroutine rate_be7em_jina(tf, temp, fr, rr) + subroutine rate_be7em_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr @@ -732,7 +732,7 @@ subroutine rate_be7em_jina(tf, temp, fr, rr) end if end subroutine rate_be7em_jina - + ! rbe7pg, be7(p,g)b8 subroutine rate_be7pg_nacre(tf, temp, fr, rr) @@ -740,35 +740,35 @@ subroutine rate_be7pg_nacre(tf, temp, fr, rr) real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr real(dp) term, rev - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) if (tf% t9 < lowT9pp_cutoff) then fr = 0; rr = 0; return - end if - + end if + call rnacre(tf, & 2.61d5, 10.264d0, 0d0, & ! a0, a1, a2 -5.11d-2, 4.68d-2, -6.60d-3, 3.12d-4, 0d0, & ! b0, b1, b2, b3, b4 2.05d3, 7.345d0, & ! c0, c1 0d0, 0d0, & ! d0, d1 0d0, 0d0, 0d0, & ! e0, e1, e2 - term) + term) call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 1.306d10, 1.594d0, & ! a0, a1 - rev) - fr = term + rev) + fr = term rr = rev * term end subroutine rate_be7pg_nacre - + subroutine rate_be7pg_jina(tf, temp, fr, rr) ! jina reaclib cf88 -! p be7 b8 cf88n 1.37000d-01 +! p be7 b8 cf88n 1.37000d-01 type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr @@ -779,7 +779,7 @@ end subroutine rate_be7pg_jina ! rbe7dp be7(d,p)2he4 subroutine rate_be7dp_jina(tf, temp, fr, rr) -! d be7 p he4 he4 cf88n 1.67660d+01 +! d be7 p he4 he4 cf88n 1.67660d+01 type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr @@ -789,11 +789,11 @@ subroutine rate_be7dp_jina(tf, temp, fr, rr) end subroutine rate_be7dp_jina -! rbe7dp be7(he3,2p)2he4 +! rbe7dp be7(he3,2p)2he4 subroutine rate_be7he3_jina(tf, temp, fr, rr) -! he3 be7 p p he4 he4 mafon 1.12721d+01 +! he3 be7 p p he4 he4 mafon 1.12721d+01 type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr @@ -810,7 +810,7 @@ end subroutine rate_be7he3_jina ! Boron -! rb8ep, b8(e+, nu)be8 => 2a +! rb8ep, b8(e+, nu)be8 => 2a subroutine rate_b8ep(tf, temp, fr, rr) type (T_Factors) :: tf @@ -834,11 +834,11 @@ subroutine rate_b8_wk_he4_he4_jina(tf, temp, fr, rr) call rate_b8ep(tf, temp, fr, rr) end if end subroutine rate_b8_wk_he4_he4_jina - + ! rb8gp, b8(g,p)be7 ! see rbe7pg - + ! Carbon @@ -850,28 +850,28 @@ subroutine rate_c12pg_nacre(tf, temp, fr, rr) real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr real(dp) term, rev - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + call rnacre(tf, & 2.00d7, 13.692d0, 1d0/0.46d0, & ! a0, a1, a2 9.89d0, -59.8d0, 266d0, 0d0, 0d0, & ! b0, b1, b2, b3, b4 1.00d5, 4.913d0, & ! c0, c1 4.24d5, 21.62d0, & ! d0, d1 0d0, 0d0, 0d0, & ! e0, e1, e2 - term) + term) call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 8.847d9, 22.553d0, & ! a0, a1 - rev) - fr = term - rr = rev * term + rev) + fr = term + rr = rev * term end subroutine rate_c12pg_nacre @@ -882,19 +882,19 @@ subroutine rate_c12pg_jina(tf, temp, fr, rr) ! jina reaclib nacre ! p c12 n13 nacrn 1.94300d+00 call jina_reaclib_2_1(ih1, ic12, in13, tf, fr, rr, 'rate_c12pg_jina') end subroutine rate_c12pg_jina - + ! rc12ap, c12(a,p)n15 subroutine rate_n15pa_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p n15 he4 c12 nacrr 4.96600d+00 +! p n15 he4 c12 nacrr 4.96600d+00 call jina_reaclib_2_2(ih1, in15, ihe4, ic12, tf, fr, rr, 'rate_n15pa_jina') end subroutine rate_n15pa_jina -! rc12ag, c12(a,g)o16 +! rc12ag, c12(a,g)o16 subroutine rate_c12ag_fxt(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp @@ -905,8 +905,8 @@ subroutine rate_c12ag_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 1.0d0 + 0.0489d0*(tf% t9i23) bb = (tf% t92)*aa*aa cc = exp(-32.120d0*(tf% t9i13) - (tf% t92)*q1) @@ -939,24 +939,24 @@ subroutine rate_c12ag_nacre(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + ! note: uses T9i2 instead of T9i23, so special case it. - aa = 6.66d7 * (tf% T9i2) * exp(-32.123d0*(tf% T9i13) - (tf% T92)/(4.6d0*4.6d0)) - bb = 1 + 2.54d0*(tf% T9) + 1.04d0*(tf% T92) - 0.226d0*(tf% T93) + aa = 6.66d7 * (tf% T9i2) * exp(-32.123d0*(tf% T9i13) - (tf% T92)/(4.6d0*4.6d0)) + bb = 1 + 2.54d0*(tf% T9) + 1.04d0*(tf% T92) - 0.226d0*(tf% T93) if (bb < 0) bb = 0 - cc = 1.39d3 * (tf% T9i32) * exp(-28.930d0*(tf% T9i)) + cc = 1.39d3 * (tf% T9i32) * exp(-28.930d0*(tf% T9i)) termE1 = aa * bb + cc - aa = 6.56d7 * (tf% T9i2) * exp(-32.123d0*(tf% T9i13) - (tf% T92)/(1.3d0*1.3d0)) - bb = 1 + 9.23d0*(tf% T9) - 13.7d0*(tf% T92) + 7.4d0*(tf% T93) + aa = 6.56d7 * (tf% T9i2) * exp(-32.123d0*(tf% T9i13) - (tf% T92)/(1.3d0*1.3d0)) + bb = 1 + 9.23d0*(tf% T9) - 13.7d0*(tf% T92) + 7.4d0*(tf% T93) termE2 = aa * bb - termRes = 19.2d0 * (tf% T92) * exp(-26.9d0*(tf% T9i)) + termRes = 19.2d0 * (tf% T92) * exp(-26.9d0*(tf% T9i)) term = termE1 + termE2 + termRes rev = 5.132d10 * (tf% T932) * exp(-83.109d0*(tf% T9i)) fr = term rr = rev * term end subroutine rate_c12ag_nacre - + subroutine rate_c12ag_kunz(tf, temp, fr, rr) ! kunz et al (2002) @@ -966,30 +966,30 @@ subroutine rate_c12ag_kunz(tf, temp, fr, rr) real(dp) :: term, rev, aa, bb, cc, dd, ee real(dp), parameter :: & a0 = 1.21d8, a1 = 6.06d-2, a2 = 32.12d0, a3 = 1.7d0, a4 = 7.4d8, & - a5 = 0.47d0, a6 = 32.12d0, a9tilda = 3.06d10, a11 = 38.534d0 + a5 = 0.47d0, a6 = 32.12d0, a9tilda = 3.06d10, a11 = 38.534d0 include 'formats' if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = a0 * (tf% T9i2) * exp(-a2*(tf% T9i13) - (tf% T92)/(a3*a3)) bb = 1 / pow(1 + a1*(tf% T9i23),2) - cc = a4 * (tf% T9i2) * exp(-a6*(tf% T9i13)) + cc = a4 * (tf% T9i2) * exp(-a6*(tf% T9i13)) dd = 1 / pow(1 + a5*(tf% T9i23),2) - ee = a9tilda * (tf% T9i13) * exp(-a11*(tf% T9i13)) - term = aa*bb + cc*dd + ee - rev = 5.132d10 * (tf% T932) * exp(-83.109d0*(tf% T9i)) - fr = term + ee = a9tilda * (tf% T9i13) * exp(-a11*(tf% T9i13)) + term = aa*bb + cc*dd + ee + rev = 5.132d10 * (tf% T932) * exp(-83.109d0*(tf% T9i)) + fr = term rr = rev * term end subroutine rate_c12ag_kunz - - subroutine rate_c12ag_jina(tf, temp, fr, rr) + + subroutine rate_c12ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 c12 o16 bu96n 7.16192d+00 +! he4 c12 o16 bu96n 7.16192d+00 call jina_reaclib_2_1(ihe4, ic12, io16, tf, fr, rr, 'rate_c12ag_jina') end subroutine rate_c12ag_jina @@ -1000,7 +1000,7 @@ subroutine rate_c12c12p_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! c12 c12 p na23 cf88r 2.24200d+00 +! c12 c12 p na23 cf88r 2.24200d+00 call jina_reaclib_2_2(ic12, ic12, ih1, ina23, tf, fr, rr, 'rate_c12c12p_jina') end subroutine rate_c12c12p_jina @@ -1013,7 +1013,7 @@ subroutine rate_c12c12_fxt(tf, temp, fr, rr) real(dp) :: term, T9a, dt9a, T9a13, T9a56, aa, zz if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if + end if aa = 1.0d0 + 0.0396d0*tf% t9 zz = 1.0d0/aa t9a = tf% t9*zz @@ -1033,13 +1033,13 @@ subroutine rate_c12c12_fxt_basic(tf, temp, fr, rr) real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr real(dp) :: term,t9a,t9a13,t9a56,aa,zz - + include 'formats' if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 1.0d0 + 0.0396d0*tf% t9 zz = 1.0d0/aa t9a = tf% t9*zz @@ -1074,7 +1074,7 @@ subroutine rate_c12c12a_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! c12 c12 he4 ne20 cf88r 4.62100d+00 +! c12 c12 he4 ne20 cf88r 4.62100d+00 call jina_reaclib_2_2(ic12, ic12, ihe4, ine20, tf, fr, rr, 'rate_c12c12a_jina') end subroutine rate_c12c12a_jina @@ -1096,7 +1096,7 @@ subroutine rate_c12c12npa(tf, temp, & fr2 = 0; rr2 = 0 fr3 = 0; rr3 = 0 return - end if + end if aa = 1.0d0 + 0.0396d0*(tf% T9) @@ -1116,7 +1116,7 @@ subroutine rate_c12c12npa(tf, temp, & b24n = 0.055d0 - bb - else + else bb = 1.0d0 + 0.0789d0*(tf% T9) + 7.74d0*(tf% T92) @@ -1209,8 +1209,8 @@ subroutine rate_c12o16_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + ! c12 + o16 reaction; see cf88 references 47-4 if ((tf% T9).ge.0.5d0) then aa = 1.0d0 + 0.055d0*(tf% T9) @@ -1218,7 +1218,7 @@ subroutine rate_c12o16_fxt(tf, temp, fr, rr) T9a13 = pow(T9a,oneth) T9a23 = T9a13*T9a13 T9a56 = pow(T9a,fivsix) - aa = exp(-0.18d0*T9a*T9a) + aa = exp(-0.18d0*T9a*T9a) bb = 1.06d-03*exp(2.562d0*T9a23) cc = aa + bb term = 1.72d+31 * T9a56 * (tf% T9i32) * exp(-106.594d0/T9a13)/cc @@ -1227,7 +1227,7 @@ subroutine rate_c12o16_fxt(tf, temp, fr, rr) term = 0.0d0 endif fr = term - rr = 0.0d0 + rr = 0.0d0 end subroutine rate_c12o16_fxt subroutine rate_c12o16_jina(tf, temp, fr, rr) @@ -1273,7 +1273,7 @@ subroutine rate_c12o16p_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! c12 o16 p al27 cf88r 5.17100d+00 +! c12 o16 p al27 cf88r 5.17100d+00 call jina_reaclib_2_2(ic12, io16, ih1, ial27, tf, fr, rr, 'rate_c12o16p_jina') end subroutine rate_c12o16p_jina @@ -1281,7 +1281,7 @@ subroutine rate_c12o16a_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! c12 o16 he4 mg24 cf88r 6.77100d+00 +! c12 o16 he4 mg24 cf88r 6.77100d+00 call jina_reaclib_2_2(ic12, io16, ihe4, img24, tf, fr, rr, 'rate_c12o16a_jina') end subroutine rate_c12o16a_jina @@ -1292,7 +1292,7 @@ end subroutine rate_c12o16a_jina subroutine rate_c12o16npa(tf, temp, & fr1, rr1, & ! c12(o16,n)si27 - fr2, rr2, & ! c12(o16,p)al27 + fr2, rr2, & ! c12(o16,p)al27 fr3, rr3) ! c12(o16,a)mg24 type (T_Factors) :: tf @@ -1308,7 +1308,7 @@ subroutine rate_c12o16npa(tf, temp, & fr2 = 0; rr2 = 0 fr3 = 0; rr3 = 0 return - end if + end if if ((tf% T9).ge.0.5d0) then aa = 1.0d0 + 0.055d0*(tf% T9) @@ -1316,7 +1316,7 @@ subroutine rate_c12o16npa(tf, temp, & t9a13 = pow(t9a,oneth) T9a23 = T9a13*T9a13 t9a56 = pow(t9a,fivsix) - aa = exp(-0.18d0*T9a*T9a) + aa = exp(-0.18d0*T9a*T9a) bb = 1.06d-03*exp(2.562d0*T9a23) cc = aa + bb dd = 1.72d+31 * T9a56 * (tf% T9i32) * exp(-106.594d0/T9a13)/cc @@ -1361,40 +1361,40 @@ subroutine rate_c12o16npa(tf, temp, & end subroutine rate_c12o16npa -! rc13pg, c13(p,g)n14 +! rc13pg, c13(p,g)n14 subroutine rate_c13pg_nacre(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr real(dp) term, rev, bb, gs - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + call rnacre(tf, & 9.57d7, 13.72d0, 1d0, & ! a0, a1, a2 3.56d0, 0d0, 0d0, 0d0, 0d0, & ! b0, b1, b2, b3, b4 1.50d6, 5.930d0, & ! c0, c1 0d0, 0d0, & ! d0, d1 6.83d5, -0.864d0, 12.057d0, & ! e0, e1, e2 - gs) + gs) bb = 2.070d0 * exp(-37.938d0*(tf% T9i)) if (bb > 1) then ! guard against rate going negative bb = 1 - end if + end if term = gs * (1 - bb) call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 1.190d10, 87.619d0, & ! a0, a1 - rev) - fr = term - rr = rev * term + rev) + fr = term + rr = rev * term end subroutine rate_c13pg_nacre @@ -1402,7 +1402,7 @@ subroutine rate_c13pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p c13 n14 nacrr 7.55100d+00 +! p c13 n14 nacrr 7.55100d+00 call jina_reaclib_2_1(ih1, ic13, in14, tf, fr, rr, 'rate_c13pg_jina') end subroutine rate_c13pg_jina @@ -1411,7 +1411,7 @@ subroutine rate_c13an_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 c13 n o16 nacrn 2.21600d+00 +! he4 c13 n o16 nacrn 2.21600d+00 call jina_reaclib_2_2(ihe4, ic13, ineut, io16, tf, fr, rr, 'rate_c13an_jina') end subroutine rate_c13an_jina @@ -1424,8 +1424,8 @@ subroutine rate_c13an_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 6.77d+15 * (tf% T9i23) * exp(-32.329d0*(tf% T9i13) - (tf% T92)*q1) bb = 1.0d0 + 0.013d0*(tf% T913) + 2.04d0*(tf% T923) + 0.184d0*(tf% T9) cc = aa * bb @@ -1434,51 +1434,51 @@ subroutine rate_c13an_fxt(tf, temp, fr, rr) ff = 2.0d+09 * (tf% T9i32) * exp(-20.409d0*(tf% T9i)) gg = 2.92d+09 * (tf% T9i32) * exp(-29.283d0*(tf% T9i)) term = cc + dd + ee + ff + gg - fr = term + fr = term rev = 5.79d+00 * exp(-25.711d0*(tf% T9i)) rr = rev * term end subroutine rate_c13an_fxt ! Nitrogen - -! rn13pg, n13(p,g)o14 + +! rn13pg, n13(p,g)o14 subroutine rate_n13pg_nacre(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr real(dp) term, rev - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + call rnacre(tf, & 4.02d7, 15.205d0, 1d0/0.54d0, & ! a0, a1, a2 3.81d0, 18.6d0, 32.3d0, 0d0, 0d0, & ! b0, b1, b2, b3, b4 0d0, 0d0, & ! c0, c1 0d0, 0d0, & ! d0, d1 3.25d5, -1.35d0, 5.926d0, & ! e0, e1, e2 - term) + term) call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 3.571d10, 53.705d0, & ! a0, a1 - rev) - fr = term - rr = rev * term + rev) + fr = term + rr = rev * term end subroutine rate_n13pg_nacre subroutine rate_n13pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p n13 o14 lg06n 4.62797d+00 +! p n13 o14 lg06n 4.62797d+00 call jina_reaclib_2_1(ih1, in13, io14, tf, fr, rr, 'rate_n13pg_jina') end subroutine rate_n13pg_jina @@ -1488,20 +1488,20 @@ subroutine rate_n13ap_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 n13 p o16 cf88n 5.21800d+00 +! he4 n13 p o16 cf88n 5.21800d+00 call jina_reaclib_2_2(ihe4, in13, ih1, io16, tf, fr, rr, 'rate_n13ap_jina') end subroutine rate_n13ap_jina ! rn13gp, n13(g,p)c12 ! see c12pg -! n14(p,g)o15 +! n14(p,g)o15 subroutine rate_n14pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p n14 o15 im05n 7.29680d+00 +! p n14 o15 im05n 7.29680d+00 call jina_reaclib_2_1(ih1, in14, io15, tf, fr, rr, 'rate_n14pg_jina') end subroutine rate_n14pg_jina @@ -1517,8 +1517,8 @@ subroutine rate_n14pg_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 4.90d+07 * (tf% T9i23) * exp(-15.228d0*(tf% T9i13) - (tf% T92)*q1) bb = 1.0d0 + 0.027d0*(tf% T913) - 0.778d0*(tf% T923) - 0.149d0*(tf% T9) & + 0.261d0*(tf% T943) + 0.127d0*(tf% T953) @@ -1527,59 +1527,59 @@ subroutine rate_n14pg_fxt(tf, temp, fr, rr) ee = 2.19d+04 * exp(-12.530d0*(tf% T9i)) term = cc + dd + ee rev = 2.70d+10 * (tf% T932) * exp(-84.678d0*(tf% T9i)) - fr = term - rr = rev * term + fr = term + rr = rev * term end subroutine rate_n14pg_fxt - + subroutine rate_n14pg_nacre(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr real(dp) term, rev - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + call rnacre(tf, & 4.83d7, 15.231d0, 1d0/0.8d0, & ! a0, a1, a2 -2.00d0, 3.41d0, -2.43d0, 0d0, 0d0, & ! b0, b1, b2, b3, b4 2.36d3, 3.010d0, & ! c0, c1 0d0, 0d0, & ! d0, d1 6.72d3, 0.380d0, 9.530d0, & ! e0, e1, e2 - term) + term) call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 2.699d10, 84.677d0, & ! a0, a1 - rev) - fr = term - rr = rev * term + rev) + fr = term + rr = rev * term end subroutine rate_n14pg_nacre - + ! rn14ap, n14(a,p)o17 ! see ro17pa - -! rn14gp, n14(g,p)c13 + +! rn14gp, n14(g,p)c13 ! see rc13pg - -! rn14ag, n14(a,g)f18 - -! n14(a,g)f18 + +! rn14ag, n14(a,g)f18 + +! n14(a,g)f18 subroutine rate_n14ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 n14 f18 ga00r 4.41500d+00 +! he4 n14 f18 ga00r 4.41500d+00 call jina_reaclib_2_1(ihe4, in14, if18, tf, fr, rr, 'rate_n14ag_jina') end subroutine rate_n14ag_jina -! rn15pg, n15(p,g)o16 +! rn15pg, n15(p,g)o16 subroutine rate_n15pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf @@ -1591,15 +1591,15 @@ end subroutine rate_n15pg_jina ! rn15pa, n15(p,a)c12 ! see rc12ap - -! rn15ap, n15(a,p)o18 + +! rn15ap, n15(a,p)o18 ! see ro18pa - + ! Oxygen -! ro14ap, o14(a,p)f17 +! ro14ap, o14(a,p)f17 subroutine rate_o14ap_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -1610,19 +1610,19 @@ subroutine rate_o14ap_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 1.68d+13 * (tf% T9i23) * exp(-39.388d0*(tf% T9i13)- (tf% T92)*q1) bb = 1.0d0 + 0.011d0*(tf% T913) + 13.117d0*(tf% T923) + 0.971d0*(tf% T9) & + 85.295d0*(tf% T943) + 16.061d0*(tf% T953) cc = aa * bb dd = 3.31d+04 * (tf% T9i32) * exp(-11.733d0*(tf% T9i)) - ee = 1.79d+07 * (tf% T9i32) * exp(-22.609d0*(tf% T9i)) + ee = 1.79d+07 * (tf% T9i32) * exp(-22.609d0*(tf% T9i)) ff = 9.00d+03 * (tf% T9113) * exp(-12.517d0*(tf% T9i)) term = cc + dd + ee + ff - fr = term + fr = term rev = 4.93d-01*exp(-13.820d0*(tf% T9i)) - rr = rev * term + rr = rev * term end subroutine rate_o14ap_fxt @@ -1630,17 +1630,17 @@ subroutine rate_o14ap_jina(tf, temp, fr, rr) ! Hahn 1996 PhRvC 54, 4, p1999- type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 o14 p f17 Ha96r 1.19200d+00 +! he4 o14 p f17 Ha96r 1.19200d+00 call jina_reaclib_2_2(ihe4, io14, ih1, if17, tf, fr, rr, 'rate_o14ap_jina') end subroutine rate_o14ap_jina - - -! ro14ag, o14(a,g)ne18 + + +! ro14ag, o14(a,g)ne18 subroutine rate_o14ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 o14 ne18 wh87n 5.11400d+00 +! he4 o14 ne18 wh87n 5.11400d+00 call jina_reaclib_2_1(ihe4, io14, ine18, tf, fr, rr, 'rate_o14ag_jina') end subroutine rate_o14ag_jina @@ -1651,10 +1651,10 @@ end subroutine rate_o14ag_jina ! see rn13pg -! ro15ap, o15(a,p)f18 +! ro15ap, o15(a,p)f18 ! see rf18pa - -! ro15ag, o15(a,g)ne19 + +! ro15ag, o15(a,g)ne19 subroutine rate_o15ag_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -1667,8 +1667,8 @@ subroutine rate_o15ag_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 3.57d+11 * (tf% T9i23) * exp(-39.584d+0*(tf% T9i13) - (tf% T92)*q1) bb = 1.0d0 + 0.011d0*(tf% T913) - 0.273d0*(tf% T923) - 0.020d0*(tf% T9) cc = aa*bb @@ -1685,19 +1685,19 @@ subroutine rate_o15ag_fxt(tf, temp, fr, rr) end subroutine rate_o15ag_fxt - subroutine rate_o15ag_jina(tf, temp, fr, rr) + subroutine rate_o15ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 o15 ne19 Ha96n 3.52900d+00 +! he4 o15 ne19 Ha96n 3.52900d+00 call jina_reaclib_2_1(ihe4, io15, ine19, tf, fr, rr, 'rate_o15ag_jina') end subroutine rate_o15ag_jina ! ro15gp, o15(g,p)n14 - ! see rn14pg + ! see rn14pg -! ro16pg, o16(p,g)f17 +! ro16pg, o16(p,g)f17 subroutine rate_o16pg_nacre(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp @@ -1706,32 +1706,32 @@ subroutine rate_o16pg_nacre(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 7.37d7 * pow((tf% T9),-0.82d0) * exp(-16.696d0*(tf% T9i13)) bbm1 = 202d0 * exp(-70.348d0*(tf% T9i) - 0.161d0*(tf% T9)) - bb = 1 + bbm1 - term = aa * bb + bb = 1 + bbm1 + term = aa * bb call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 3.037d9, 6.966d0, & ! a0, a1 - rev) - fr = term - rr = rev * term + rev) + fr = term + rr = rev * term end subroutine rate_o16pg_nacre - + subroutine rate_o16pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p o16 f17 nacrn 6.00000d-01 +! p o16 f17 nacrn 6.00000d-01 call jina_reaclib_2_1(ih1, io16, if17, tf, fr, rr, 'rate_o16pg_jina') end subroutine rate_o16pg_jina - + ! ro16ap, o16(a,p)f19 ! see rf19pa - -! ro16ag, o16(a,g)ne20 + +! ro16ag, o16(a,g)ne20 subroutine rate_o16ag_nacre(tf, temp, fr, rr) type (T_Factors) :: tf @@ -1741,10 +1741,10 @@ subroutine rate_o16ag_nacre(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + end if + + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) @@ -1754,10 +1754,10 @@ subroutine rate_o16ag_nacre(tf, temp, fr, rr) 51.1d0, 10.32d0, & ! c0, c1 616.1d0, 12.200d0, & ! d0, d1 0.41d0, 2.966d0, 11.900d0, & ! e0, e1, e2 - term) + term) call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 5.653d10, 54.886d0, & ! a0, a1 - rev) + rev) fr = term rr = rev * term end subroutine rate_o16ag_nacre @@ -1766,7 +1766,7 @@ subroutine rate_o16ag_jina(tf, temp, fr, rr) ! jina reaclib -- nacre type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 o16 ne20 nacrr 4.73000d+00 +! he4 o16 ne20 nacrr 4.73000d+00 call jina_reaclib_2_1(ihe4, io16, ine20, tf, fr, rr, 'rate_o16ag_jina') end subroutine rate_o16ag_jina @@ -1774,10 +1774,10 @@ end subroutine rate_o16ag_jina ! ro16gp, o16(g,p)n15 ! see rn15pg - -! ro16ga, o16(g,a)c12 + +! ro16ga, o16(g,a)c12 ! see rc12ag - + ! r1616 cf88 fxt subroutine rate_o16o16_fxt(tf, temp, fr, rr) @@ -1788,13 +1788,13 @@ subroutine rate_o16o16_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + term = 7.10d36 * (tf% T9i23) * & exp(-135.93d0*(tf% T9i13) - 0.629d0*(tf% T923) & - 0.445d0*(tf% T943) + 0.0103d0*(tf% T9)*(tf% T9)) fr = term - rr = 0.0d0 + rr = 0.0d0 end subroutine rate_o16o16_fxt subroutine rate_o16o16g_fxt(tf, temp, fr, rr) @@ -1814,7 +1814,7 @@ subroutine rate_o16o16p_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! o16 o16 p p31 cf88r 7.67800d+00 +! o16 o16 p p31 cf88r 7.67800d+00 call jina_reaclib_2_2(io16, io16, ih1, ip31, tf, fr, rr, 'rate_o16o16p_jina') end subroutine rate_o16o16p_jina @@ -1824,7 +1824,7 @@ subroutine rate_o16o16a_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! o16 o16 he4 si28 cf88r 9.59300d+00 +! o16 o16 he4 si28 cf88r 9.59300d+00 call jina_reaclib_2_2(io16, io16, ihe4, isi28, tf, fr, rr, 'rate_o16o16a_jina') end subroutine rate_o16o16a_jina @@ -1883,7 +1883,7 @@ subroutine rate_o16o16npad(tf, temp, & fr3 = 0; rr3 = 0 fr4 = 0; rr4 = 0 return - end if + end if aa = 7.10d36 * (tf% T9i23) * & @@ -1946,7 +1946,7 @@ end subroutine rate_o16o16npad subroutine fowthrsh(x, thrs) -! fowler threshold fudge function. +! fowler threshold fudge function. ! err func rational (abramowitz p.299)7.1.25 and its derivative ! declare @@ -1967,33 +1967,33 @@ subroutine fowthrsh(x, thrs) end if end subroutine fowthrsh - - + + ! o17(a,g)ne21 - - -! ro17pa, o17(p,a)n14 + + +! ro17pa, o17(p,a)n14 subroutine rate_o17pa_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p o17 he4 n14 ct07r 1.19164d+00 +! p o17 he4 n14 ct07r 1.19164d+00 call jina_reaclib_2_2(ih1, io17, ihe4, in14, tf, fr, rr, 'rate_o17pa_jina') end subroutine rate_o17pa_jina -! ro17pg, o17(p,g)f18 - +! ro17pg, o17(p,g)f18 + subroutine rate_o17pg_jina(tf, temp, fr, rr) ! jina reaclib Chafa et al. (2007) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p o17 f18 ct07n 5.60650d+00 +! p o17 f18 ct07n 5.60650d+00 call jina_reaclib_2_1(ih1, io17, if18, tf, fr, rr, 'rate_o17pg_jina') end subroutine rate_o17pg_jina -! ro18pa, o18(p,a)n15 +! ro18pa, o18(p,a)n15 subroutine rate_o18pa_nacre(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2003,10 +2003,10 @@ subroutine rate_o18pa_nacre(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + end if + + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) @@ -2016,17 +2016,17 @@ subroutine rate_o18pa_nacre(tf, temp, fr, rr) 9.91d-14, 0.232d0, & ! c0, c1 2.58d4, 1.665d0, & ! d0, d1 3.24d8, -0.378d0, 6.395d0, & ! e0, e1, e2 - gs) + gs) bb = 1.968d0 * exp(-25.673d0*(tf% T9i) - 0.083d0*(tf% T9)) if (bb > 1) then ! guard against rate going negative bb = 1 - end if + end if term = gs * (1 - bb) call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 1.660d-1, 46.192d0, & ! a0, a1 - rev) - fr = term - rr = rev * term + rev) + fr = term + rr = rev * term end subroutine rate_o18pa_nacre @@ -2034,55 +2034,55 @@ subroutine rate_o18pa_jina(tf, temp, fr, rr) ! jina reaclib nacre type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p o18 he4 n15 nacrn 3.98100d+00 +! p o18 he4 n15 nacrn 3.98100d+00 call jina_reaclib_2_2(ih1, io18, ihe4, in15, tf, fr, rr, 'rate_o18pa_jina') end subroutine rate_o18pa_jina - -! ro18pg, o18(p,g)f19 + +! ro18pg, o18(p,g)f19 subroutine rate_o18pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p o18 f19 nacrr 7.99400d+00 +! p o18 f19 nacrr 7.99400d+00 call jina_reaclib_2_1(ih1, io18, if19, tf, fr, rr, 'rate_o18pg_jina') end subroutine rate_o18pg_jina -! ro18ag, o18(a,g)ne22 +! ro18ag, o18(a,g)ne22 subroutine rate_o18ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 o18 ne22 dh03r 9.66900d+00 +! he4 o18 ne22 dh03r 9.66900d+00 call jina_reaclib_2_1(ihe4, io18, ine22, tf, fr, rr, 'rate_o18ag_jina') end subroutine rate_o18ag_jina - -! Fluorine + +! Fluorine -! rf17pa, f17(p,a)o14 +! rf17pa, f17(p,a)o14 ! see ro14ap - -! rf17gp, f17(g,p)o16 - ! see ro16pg - - -! rf17ap f17(a,p)ne20 + +! rf17gp, f17(g,p)o16 + ! see ro16pg + + +! rf17ap f17(a,p)ne20 subroutine rate_f17ap_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 f17 p ne20 nacr 4.13000d+00 +! he4 f17 p ne20 nacr 4.13000d+00 call jina_reaclib_2_2(ihe4, if17, ih1, ine20, tf, fr, rr, 'rate_f17ap_jina') end subroutine rate_f17ap_jina -! rf18pa, f18(p,a)o15 +! rf18pa, f18(p,a)o15 subroutine rate_f18pa_wk82(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2092,8 +2092,8 @@ subroutine rate_f18pa_wk82(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 1.66d-10 * (tf% T9i32) * exp(-0.302d0*(tf% T9i)) bb = 1.56d+05 * (tf% T9i32) * exp(-3.84d0*(tf% T9i)) cc = 1.36d+06 * (tf% T9i32) * exp(-5.22d0*(tf% T9i)) @@ -2101,9 +2101,9 @@ subroutine rate_f18pa_wk82(tf, temp, fr, rr) ee = 8.9d-04 * (tf% T9i32) * exp(-1.51d0*(tf% T9i)) ff = 3.0d+05 * (tf% T9i32) * exp(-4.29d0*(tf% T9i)) term = aa + bb + cc + dd + ee + ff - fr = term + fr = term rev = 4.93d-01 * exp(-33.433d0*(tf% T9i)) - rr = rev * term + rr = rev * term end subroutine rate_f18pa_wk82 @@ -2111,26 +2111,26 @@ subroutine rate_f18pa_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p f18 he4 o15 sh03r 2.88215d+00 +! p f18 he4 o15 sh03r 2.88215d+00 call jina_reaclib_2_2(ih1, if18, ihe4, io15, tf, fr, rr, 'rate_f18pa_jina') end subroutine rate_f18pa_jina ! rf18gp, f18(g,p)o17 - ! see ro17pg + ! see ro17pg -! rf19pg, f19(p,g)ne20 +! rf19pg, f19(p,g)ne20 subroutine rate_f19pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p f19 ne20 cf88r 1.28480d+01 +! p f19 ne20 cf88r 1.28480d+01 call jina_reaclib_2_1(ih1, if19, ine20, tf, fr, rr, 'rate_f19pg_jina') end subroutine rate_f19pg_jina -! rf19pa, f19(p,a)o16 +! rf19pa, f19(p,a)o16 subroutine rate_f19pa_nacre(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2140,10 +2140,10 @@ subroutine rate_f19pa_nacre(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + end if + + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) @@ -2153,20 +2153,20 @@ subroutine rate_f19pa_nacre(tf, temp, fr, rr) 3.80d6, 3.752d0, & ! c0, c1 0d0, 0d0, & ! d0, d1 3.27d7, -0.193d0, 6.587d0, & ! e0, e1, e2 - gs) - dd = 7.30d8 * pow(tf% T9,-0.201d0) * exp(-16.249d0*(tf% T9i)) + gs) + dd = 7.30d8 * pow(tf% T9,-0.201d0) * exp(-16.249d0*(tf% T9i)) gs = gs + dd bb = 0.755d0 * exp(-1.755d0*(tf% T9i) - 0.174d0*(tf% T9)) term = gs * (1 + bb) call rnacre_rev(tf, & ! a0 T932 exp(-a1/T9) 6.538d-1, 94.154d0, & ! a0, a1 - rev) - fr = term - rr = rev * term + rev) + fr = term + rr = rev * term end subroutine rate_f19pa_nacre - subroutine rate_f19pa_jina(tf, temp, fr, rr) ! jina reaclib + subroutine rate_f19pa_jina(tf, temp, fr, rr) ! jina reaclib type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr @@ -2174,11 +2174,11 @@ subroutine rate_f19pa_jina(tf, temp, fr, rr) ! jina reaclib end subroutine rate_f19pa_jina -! rf19gp, f19(g,p)o18 +! rf19gp, f19(g,p)o18 ! see ro18pg - - -! rf19ap, f19(a,p)ne22 + + +! rf19ap, f19(a,p)ne22 subroutine rate_f19ap_cf88(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp @@ -2186,25 +2186,25 @@ subroutine rate_f19ap_cf88(tf, temp, fr, rr) real(dp) :: term if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if + end if term = 4.50d18*tf% T9i23*exp(-43.467d0*tf% T9i13-pow(tf% T9/0.637d0,2))+ & 7.98d04*tf% T932*exp(-12.760d0*tf% T9i) fr = term*6.36d00*exp(-19.439d0*tf% T9i) rr = 0.0d0 end subroutine rate_f19ap_cf88 - subroutine rate_f19ap_jina(tf, temp, fr, rr) ! jina reaclib + subroutine rate_f19ap_jina(tf, temp, fr, rr) ! jina reaclib type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 f19 p ne22 cf88r 1.67500d+00 +! he4 f19 p ne22 cf88r 1.67500d+00 call jina_reaclib_2_2(ihe4, if19, ih1, ine22, tf, fr, rr, 'rate_f19ap_jina') end subroutine rate_f19ap_jina - + ! Neon - + ! rne18ap, ne18(a,p)na21 subroutine rate_ne18ap_fxt(tf, temp, fr, rr) @@ -2225,8 +2225,8 @@ subroutine rate_ne18ap_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + ! note: ! r = 1.09 * a1**oneth + 2.3 ! c1 = 7.833e9 * 0.31 * ztot**fourth/(ared**fivsix) @@ -2241,17 +2241,17 @@ subroutine rate_ne18ap_fxt(tf, temp, fr, rr) cc = (tf% T923) * bb dd = pow(aa,oneth) ee = (tf% T9i13) * dd - term = c1*exp(c3 - c4*ee)/cc - fr = term + term = c1*exp(c3 - c4*ee)/cc + fr = term rev = 0.0d0 rr = 0.0d0 end subroutine rate_ne18ap_fxt - subroutine rate_ne18ap_jina(tf, temp, fr, rr) ! jina reaclib + subroutine rate_ne18ap_jina(tf, temp, fr, rr) ! jina reaclib type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 ne18 p na21 GW95r 2.62700d+00 +! he4 ne18 p na21 GW95r 2.62700d+00 call jina_reaclib_2_2(ihe4, ine18, ih1, ina21, tf, fr, rr, 'rate_ne18ap_jina') end subroutine rate_ne18ap_jina @@ -2261,14 +2261,14 @@ subroutine rate_ne18ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 ne18 mg22 rath 8.14100d+00 +! he4 ne18 mg22 rath 8.14100d+00 call jina_reaclib_2_1(ihe4, ine18, img22, tf, fr, rr, 'rate_ne18ag_jina') end subroutine rate_ne18ag_jina - + ! rne18gp, ne18(g,p)f17 - ! see rf17pg + ! see rf17pg ! rne19pg, ne19(p,g)na20 @@ -2282,11 +2282,11 @@ subroutine rate_ne19pg_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 1.71d+6 * (tf% T9i23) * exp(-19.431d0*(tf% T9i13)) bb = 1.0d0 + 0.021d0*(tf% T913) + 0.130d0*(tf% T923) + 1.95d-2*(tf% T9) & - + 3.86d-2*(tf% T943) + 1.47d-02*(tf% T953) + + 3.86d-2*(tf% T943) + 1.47d-02*(tf% T953) cc = aa*bb dd = 1.89d+5 * (tf% T9i23) * exp(-19.431d0*(tf% T9i13) - (tf% T92)*q1) ee = 1.0d0 + 0.021d0*(tf% T913) + 2.13d0*(tf% T923) + 0.320d0*(tf% T9) & @@ -2294,28 +2294,28 @@ subroutine rate_ne19pg_fxt(tf, temp, fr, rr) ff = dd*ee gg = 8.45d+3 * (tf% T9i54) * exp(-7.64d0*(tf% T9i)) term = cc + ff + gg - fr = term + fr = term rev = 7.39d+09 * (tf% T932) * exp(-25.519d0*(tf% T9i)) - rr = rev * term + rr = rev * term end subroutine rate_ne19pg_fxt - - + + subroutine rate_ne19pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p ne19 na20 cf88r 2.19900d+00 +! p ne19 na20 cf88r 2.19900d+00 call jina_reaclib_2_1(ih1, ine19, ina20, tf, fr, rr, 'rate_ne19pg_jina') end subroutine rate_ne19pg_jina ! rne19ga, ne19(g,a)o15 ! see r016ag - + ! rne19gp, ne19(g,p)f18 - ! see rf18pg + ! see rf18pg -! rne20pg, ne20(p,g)na21 +! rne20pg, ne20(p,g)na21 subroutine rate_ne20pg_nacre(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2325,89 +2325,89 @@ subroutine rate_ne20pg_nacre(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 2.35d7 * pow(tf% T9,-1.84d0) * exp(-19.451d0*(tf% T9i13)) * (1 + 10.80d0*(tf% T9)) gs = aa - aa = 18.0d0 * (tf% T9i32) * exp(-4.247d0*(tf% T9i)) + aa = 18.0d0 * (tf% T9i32) * exp(-4.247d0*(tf% T9i)) gs = gs + aa - aa = 9.83d0 * (tf% T9i32) * exp(-4.619d0*(tf% T9i)) + aa = 9.83d0 * (tf% T9i32) * exp(-4.619d0*(tf% T9i)) gs = gs + aa - aa = 6.76d4 * pow(tf% T9,-0.641d0) * exp(-11.922d0*(tf% T9i)) + aa = 6.76d4 * pow(tf% T9,-0.641d0) * exp(-11.922d0*(tf% T9i)) gs = gs + aa bb = 7.929d0 * exp(-20.108d0*(tf% T9i) - 0.327d0*(tf% T9)) if (bb > 1) then ! guard against rate going negative bb = 1 - end if + end if term = gs * (1 - bb) rev = 4.637d9 * (tf% T932) * exp(-28.214d0*(tf% T9i)) - fr = term + fr = term rr = rev * term end subroutine rate_ne20pg_nacre - - + + subroutine rate_ne20pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p ne20 na21 nacrr 2.43100d+00 +! p ne20 na21 nacrr 2.43100d+00 call jina_reaclib_2_1(ih1, ine20, ina21, tf, fr, rr, 'rate_ne20pg_jina') end subroutine rate_ne20pg_jina - - -! ne20(a,p)na23 + + +! ne20(a,p)na23 subroutine rate_ne20ap_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr include 'formats' -! he4 ne20 p na23 ha04rv -2.37900d+00 +! he4 ne20 p na23 ha04rv -2.37900d+00 call jina_reaclib_2_2(ih1, ina23, ihe4, ine20, tf, rr, fr, 'rate_ne20ap_jina') end subroutine rate_ne20ap_jina - -! rne20ag, ne20(a,g)mg24 + +! rne20ag, ne20(a,g)mg24 subroutine rate_ne20ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 ne20 mg24 nacrr 9.31600d+00 +! he4 ne20 mg24 nacrr 9.31600d+00 call jina_reaclib_2_1(ihe4, ine20, img24, tf, fr, rr, 'rate_ne20ag_jina') end subroutine rate_ne20ag_jina -! rne20ga, ne20(g,a)o16 +! rne20ga, ne20(g,a)o16 ! see ro16ag - -! rne20gp, ne20(g,p)f19 + +! rne20gp, ne20(g,p)f19 ! see rf19pg - + ! rne22pg, ne22(p,g)na23 subroutine rate_ne22pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p ne22 na23 ha01r 8.79400d+00 +! p ne22 na23 ha01r 8.79400d+00 call jina_reaclib_2_1(ih1, ine22, ina23, tf, fr, rr, 'rate_ne22pg_jina') end subroutine rate_ne22pg_jina - -! ne22(n,g)ne23 + +! ne22(n,g)ne23 subroutine rate_ne22ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 ne22 mg26 nacr 1.06150d+01 +! he4 ne22 mg26 nacr 1.06150d+01 call jina_reaclib_2_1(ihe4, ine22, img26, tf, fr, rr, 'rate_ne22ag_jina') end subroutine rate_ne22ag_jina - + subroutine rate_na23pa_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p na23 he4 ne20 ha04n 2.37900d+00 +! p na23 he4 ne20 ha04n 2.37900d+00 call jina_reaclib_2_2(ih1, ina23, ihe4, ine20, tf, fr, rr, 'rate_na23pa_jina') end subroutine rate_na23pa_jina @@ -2416,7 +2416,7 @@ subroutine rate_na23pg_jina(tf, temp, fr, rr) real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr rr = 0 -! p na23 mg24 ha04r 1.16910d+01 +! p na23 mg24 ha04r 1.16910d+01 call jina_reaclib_2_1(ih1, ina23, img24, tf, fr, rr, 'rate_na23pg_jina') end subroutine rate_na23pg_jina @@ -2433,11 +2433,11 @@ subroutine rate_mg24ag_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - - aa = 4.78d+01 * (tf% T9i32) * exp(-13.506d0*(tf% T9i)) + end if + + aa = 4.78d+01 * (tf% T9i32) * exp(-13.506d0*(tf% T9i)) bb = 2.38d+03 * (tf% T9i32) * exp(-15.218d0*(tf% T9i)) - cc = 2.47d+02 * (tf% T932) * exp(-15.147d0*(tf% T9i)) + cc = 2.47d+02 * (tf% T932) * exp(-15.147d0*(tf% T9i)) dd = rc121 * 1.72d-09 * (tf% T9i32) * exp(-5.028d0*(tf% T9i)) ee = rc121* 1.25d-03 * (tf% T9i32) * exp(-7.929d0*(tf% T9i)) ff = rc121 * 2.43d+01 * (tf% T9i) * exp(-11.523d0*(tf% T9i)) @@ -2455,14 +2455,14 @@ subroutine rate_mg24ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 mg24 si28 cf88r 9.98400d+00 +! he4 mg24 si28 cf88r 9.98400d+00 call jina_reaclib_2_1(ihe4, img24, isi28, tf, fr, rr, 'rate_mg24ag_jina') end subroutine rate_mg24ag_jina ! rmg24ga, mg24(g,a)ne20 ! see rne20ag - + ! rmg24ap, mg24(a,p)al27 subroutine rate_mg24ap_fxt(tf, temp, fr, rr) @@ -2472,19 +2472,19 @@ subroutine rate_mg24ap_fxt(tf, temp, fr, rr) real(dp) term, aa, bb, cc, dd, ee, ff, gg, & term1, term2, rev, rc148, q1 parameter (rc148 = 0.1d0, & - q1 = 1.0d0/0.024649d0) + q1 = 1.0d0/0.024649d0) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 1.10d+08 * (tf% T9i23) * exp(-23.261d0*(tf% T9i13) - (tf% T92)*q1) bb = 1.0d0 + 0.018d0*(tf% T913) + 12.85d0*(tf% T923) + 1.61d0*(tf% T9) & + 89.87d0*(tf% T943) + 28.66d0*(tf% T953) term1 = aa * bb - aa = 129.0d0 * (tf% T9i32) * exp(-2.517d0*(tf% T9i)) - bb = 5660.0d0 * (tf% T972) * exp(-3.421d0*(tf% T9i)) - cc = rc148 * 3.89d-08 * (tf% T9i32) * exp(-0.853d0*(tf% T9i)) + aa = 129.0d0 * (tf% T9i32) * exp(-2.517d0*(tf% T9i)) + bb = 5660.0d0 * (tf% T972) * exp(-3.421d0*(tf% T9i)) + cc = rc148 * 3.89d-08 * (tf% T9i32) * exp(-0.853d0*(tf% T9i)) dd = rc148 * 8.18d-09 * (tf% T9i32) * exp(-1.001d0*(tf% T9i)) term2 = aa + bb + cc + dd ee = oneth*exp(-9.792d0*(tf% T9i)) @@ -2502,13 +2502,13 @@ subroutine rate_mg24ap_jina(tf, temp, fr, rr) real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr rr = 0 -! he4 mg24 p al27 il01rv -1.60060d+00 +! he4 mg24 p al27 il01rv -1.60060d+00 call jina_reaclib_2_2(ih1, ial27, ihe4, img24, tf, rr, fr, 'rate_mg24ap_jina') end subroutine rate_mg24ap_jina -! Aluminum +! Aluminum -! ral27pg, al27(p,g)si28 +! ral27pg, al27(p,g)si28 subroutine rate_al27pg_c96(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2518,8 +2518,8 @@ subroutine rate_al27pg_c96(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 1.32d+09 * (tf% T9i23) * exp(-23.26d0*(tf% T9i13)) bb = 3.22d-10 * (tf% T9i32) * exp(-0.836d0*(tf% T9i))*0.17d0 cc = 1.74d+00 * (tf% T9i32) * exp(-2.269d0*(tf% T9i)) @@ -2528,27 +2528,27 @@ subroutine rate_al27pg_c96(tf, temp, fr, rr) ff = 1.34d+02 * (tf% T9i32) * exp(-3.654d0*(tf% T9i)) gg = 1.77d+04 * pow(tf% T9, 0.53d0) * exp(-4.588d0*(tf% T9i)) term = aa + bb + cc + dd + ee + ff + gg - fr = term + fr = term rev = 1.13d+11 * (tf% T932) * exp(-134.434d0*(tf% T9i)) rr = rev * term end subroutine rate_al27pg_c96 - + subroutine rate_al27pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p al27 si28 il01r 1.15860d+01 +! p al27 si28 il01r 1.15860d+01 call jina_reaclib_2_1(ih1, ial27, isi28, tf, fr, rr, 'rate_al27pg_jina') end subroutine rate_al27pg_jina -! Silicon - -! rsi28ag, si28(a,g)s32 +! Silicon + +! rsi28ag, si28(a,g)s32 subroutine rate_si28ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 si28 s32 rath 6.94800d+00 +! he4 si28 s32 rath 6.94800d+00 call jina_reaclib_2_1(ihe4, isi28, is32, tf, fr, rr, 'rate_si28ag_jina') !if (abs(temp - 3.0097470376051402D+09) < 1d2) then ! include 'formats' @@ -2561,13 +2561,13 @@ subroutine rate_si28ag_fxt(tf, temp, fr, rr) real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr real(dp) term, aa, rev, z, z2, z3 - + include 'formats' if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -2580,14 +2580,14 @@ subroutine rate_si28ag_fxt(tf, temp, fr, rr) !if (abs(temp - 3.0097470376051402D+09) < 1d2) then ! write(*,1) 'rate_si28ag_fxt', fr, rr, temp !end if - + end subroutine rate_si28ag_fxt ! rsi28ga, si28(g,a)mg24 ! see rmg24ag - -! rsi28ap, si28(a,p)p31 + +! rsi28ap, si28(a,p)p31 subroutine rate_si28ap_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2597,8 +2597,8 @@ subroutine rate_si28ap_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -2614,7 +2614,7 @@ subroutine rate_si28ap_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 si28 p p31 il01rv -1.91710d+00 +! he4 si28 p p31 il01rv -1.91710d+00 call jina_reaclib_2_2(ih1, ip31, ihe4, isi28, tf, rr, fr, 'rate_si28ap_jina') end subroutine rate_si28ap_jina @@ -2622,9 +2622,9 @@ end subroutine rate_si28ap_jina ! rsi28gp, si28(g,p)al27 ! see ral27pg -! Phosphorus +! Phosphorus -! rp31pg, p31(p,g)s32 +! rp31pg, p31(p,g)s32 subroutine rate_p31pg_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2635,8 +2635,8 @@ subroutine rate_p31pg_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -2652,28 +2652,28 @@ subroutine rate_p31pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p p31 s32 il01n 8.86400d+00 +! p p31 s32 il01n 8.86400d+00 call jina_reaclib_2_1(ih1, ip31, is32, tf, fr, rr, 'rate_p31pg_jina') end subroutine rate_p31pg_jina -! rp31pa, p31(p,a)si28 +! rp31pa, p31(p,a)si28 ! see rsi28ap - -! Sulfur - - -! rs32ag, s32(a,g)ar36 + +! Sulfur + + +! rs32ag, s32(a,g)ar36 subroutine rate_s32ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 s32 ar36 rath 6.63900d+00 +! he4 s32 ar36 rath 6.63900d+00 call jina_reaclib_2_1(ihe4, is32, iar36, tf, fr, rr, 'rate_s32ag_jina') end subroutine rate_s32ag_jina -! rs32ag, s32(a,g)ar36 +! rs32ag, s32(a,g)ar36 subroutine rate_s32ag_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2683,8 +2683,8 @@ subroutine rate_s32ag_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -2696,10 +2696,10 @@ subroutine rate_s32ag_fxt(tf, temp, fr, rr) end subroutine rate_s32ag_fxt -! rs32ga, s32(g,a)si28 +! rs32ga, s32(g,a)si28 ! see rsi28ag - -! rs32ap, s32(a,p)cl35 + +! rs32ap, s32(a,p)cl35 subroutine rate_s32ap_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2709,8 +2709,8 @@ subroutine rate_s32ap_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -2726,11 +2726,11 @@ subroutine rate_s32ap_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 s32 p cl35 il01rv -1.86700d+00 +! he4 s32 p cl35 il01rv -1.86700d+00 call jina_reaclib_2_2(ih1, icl35, ihe4, is32, tf, rr, fr, 'rate_s32ap_jina') end subroutine rate_s32ap_jina -! rs32gp, s32(g,p)p31 +! rs32gp, s32(g,p)p31 ! see rp31pg @@ -2746,8 +2746,8 @@ subroutine rate_cl35pg_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + aa = 1.0d0 + 1.761d-1*(tf% T9) - 1.322d-2*(tf% T92) + 5.245d-4*(tf% T93) term = 4.48d+16 * (tf% T9i23) * exp(-29.483d0*(tf% T9i13) * aa) fr = term @@ -2760,26 +2760,26 @@ subroutine rate_cl35pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p cl35 ar36 il01r 8.50600d+00 +! p cl35 ar36 il01r 8.50600d+00 call jina_reaclib_2_1(ih1, icl35, iar36, tf, fr, rr, 'rate_cl35pg_jina') end subroutine rate_cl35pg_jina ! rcl35pa, cl35(p,a)s32 - ! see rs32ap + ! see rs32ap + +! Argon -! Argon - - -! rar36ag, ar36(a,g)ca40 + +! rar36ag, ar36(a,g)ca40 subroutine rate_ar36ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp - real(dp), intent(out) :: fr, rr -! he4 ar36 ca40 rath 7.04000d+00 + real(dp), intent(out) :: fr, rr +! he4 ar36 ca40 rath 7.04000d+00 call jina_reaclib_2_1(ihe4, iar36, ica40, tf, fr, rr, 'rate_ar36ag_jina') end subroutine rate_ar36ag_jina -! rar36ag, ar36(a,g)ca40 +! rar36ag, ar36(a,g)ca40 subroutine rate_ar36ag_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2789,7 +2789,7 @@ subroutine rate_ar36ag_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if + end if z = min((tf% T9), 10.0d0) z2 = z*z @@ -2801,10 +2801,10 @@ subroutine rate_ar36ag_fxt(tf, temp, fr, rr) rr = rev * term end subroutine rate_ar36ag_fxt -! rar36ga, ar36(g,a)s32 +! rar36ga, ar36(g,a)s32 ! see rs32ag - -! rar36ap, ar36(a,p)k39 + +! rar36ap, ar36(a,p)k39 subroutine rate_ar36ap_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2814,8 +2814,8 @@ subroutine rate_ar36ap_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -2831,13 +2831,13 @@ subroutine rate_ar36ap_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 ar36 p k39 rath v -1.28800d+00 +! he4 ar36 p k39 rath v -1.28800d+00 call jina_reaclib_2_2(ih1, ik39, ihe4, iar36, tf, rr, fr, 'rate_ar36ap_jina') end subroutine rate_ar36ap_jina -! rar36gp, ar36(g,p)cl35 +! rar36gp, ar36(g,p)cl35 ! see rcl35pg - + ! Potassium ! rk39pg, k39(p,g)ca40 @@ -2850,8 +2850,8 @@ subroutine rate_k39pg_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -2867,27 +2867,27 @@ subroutine rate_k39pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p k39 ca40 rath 8.32800d+00 +! p k39 ca40 rath 8.32800d+00 call jina_reaclib_2_1(ih1, ik39, ica40, tf, fr, rr, 'rate_k39pg_jina') end subroutine rate_k39pg_jina ! rk39pa, k39(p,a)ar36 ! see rar36ap -! Calcium - - -! rca40ag, ca40(a,g)ti44 +! Calcium + + +! rca40ag, ca40(a,g)ti44 subroutine rate_ca40ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr include 'formats' -! he4 ca40 ti44 rath 5.12700d+00 +! he4 ca40 ti44 rath 5.12700d+00 call jina_reaclib_2_1(ihe4, ica40, iti44, tf, fr, rr, 'rate_ca40ag_jina') end subroutine rate_ca40ag_jina -! rca40ag, ca40(a,g)ti44 +! rca40ag, ca40(a,g)ti44 subroutine rate_ca40ag_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2897,8 +2897,8 @@ subroutine rate_ca40ag_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -2910,10 +2910,10 @@ subroutine rate_ca40ag_fxt(tf, temp, fr, rr) end subroutine rate_ca40ag_fxt -! rca40ga, ca40(g,a)ar36 +! rca40ga, ca40(g,a)ar36 ! see rar36ag -! rca40ap, ca40(a,p)sc43(p,g)ti44 +! rca40ap, ca40(a,p)sc43(p,g)ti44 subroutine rate_ca40ap_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2923,8 +2923,8 @@ subroutine rate_ca40ap_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -2940,20 +2940,20 @@ subroutine rate_ca40ap_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 ca40 p sc43 rath v -3.52300d+00 +! he4 ca40 p sc43 rath v -3.52300d+00 call jina_reaclib_2_2(ih1, isc43, ihe4, ica40, tf, rr, fr, 'rate_ca40ap_jina') end subroutine rate_ca40ap_jina -! rca40ap, ca40(a,p)sc43 +! rca40ap, ca40(a,p)sc43 ! see rsc43pa - -! rca40gp, ca40(g,p)k39 + +! rca40gp, ca40(g,p)k39 ! see rk39pg - -! Scandium -! rsc43pg, sc43(p,g)ti44 +! Scandium + +! rsc43pg, sc43(p,g)ti44 subroutine rate_sc43pg_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -2963,8 +2963,8 @@ subroutine rate_sc43pg_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -2980,28 +2980,28 @@ subroutine rate_sc43pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p sc43 ti44 rath 8.65000d+00 +! p sc43 ti44 rath 8.65000d+00 call jina_reaclib_2_1(ih1, isc43, iti44, tf, fr, rr, 'rate_sc43pg_jina') end subroutine rate_sc43pg_jina ! rsc43pa, sc43(p,a)ca40 ! see rca40ap - -! Titanium - - -! rti44ag, ti44(a,g)cr48 + +! Titanium + + +! rti44ag, ti44(a,g)cr48 subroutine rate_ti44ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 ti44 cr48 rath 7.69200d+00 +! he4 ti44 cr48 rath 7.69200d+00 call jina_reaclib_2_1(ihe4, iti44, icr48, tf, fr, rr, 'rate_ti44ag_jina') end subroutine rate_ti44ag_jina -! rti44ag, ti44(a,g)cr48 +! rti44ag, ti44(a,g)cr48 subroutine rate_ti44ag_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -3011,8 +3011,8 @@ subroutine rate_ti44ag_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -3024,9 +3024,9 @@ subroutine rate_ti44ag_fxt(tf, temp, fr, rr) end subroutine rate_ti44ag_fxt -! rti44ga, ti44(g,a)ca40 +! rti44ga, ti44(g,a)ca40 ! see rca40ag - + ! rti44ap, ti44(a,p)v47 subroutine rate_ti44ap_fxt(tf, temp, fr, rr) @@ -3037,8 +3037,8 @@ subroutine rate_ti44ap_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -3054,18 +3054,18 @@ subroutine rate_ti44ap_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 ti44 p v47 chw0r -4.10500d-01 +! he4 ti44 p v47 chw0r -4.10500d-01 call jina_reaclib_2_2(ihe4, iti44, ih1, iv47, tf, fr, rr, 'rate_ti44ap_jina') end subroutine rate_ti44ap_jina - -! rti44gp, ti44(g,p)sc43 + +! rti44gp, ti44(g,p)sc43 ! see rsc43pg - -! Vanadium -! rv47pg, v47(p,g)cr48 +! Vanadium + +! rv47pg, v47(p,g)cr48 subroutine rate_v47pg_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -3075,8 +3075,8 @@ subroutine rate_v47pg_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -3092,28 +3092,28 @@ subroutine rate_v47pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p v47 cr48 nfisn 8.10607d+00 +! p v47 cr48 nfisn 8.10607d+00 call jina_reaclib_2_1(ih1, iv47, icr48, tf, fr, rr, 'rate_v47pg_jina') end subroutine rate_v47pg_jina -! rv47pa, v47(p,a)ti44 +! rv47pa, v47(p,a)ti44 ! see rti44ap - -! Chromium - - -! rcr48ag, cr48(a,g)fe52 + +! Chromium + + +! rcr48ag, cr48(a,g)fe52 subroutine rate_cr48ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 cr48 fe52 rath 7.93900d+00 +! he4 cr48 fe52 rath 7.93900d+00 call jina_reaclib_2_1(ihe4, icr48, ife52, tf, fr, rr, 'rate_cr48ag_jina') end subroutine rate_cr48ag_jina -! rcr48ag, cr48(a,g)fe52 +! rcr48ag, cr48(a,g)fe52 subroutine rate_cr48ag_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -3123,8 +3123,8 @@ subroutine rate_cr48ag_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -3136,10 +3136,10 @@ subroutine rate_cr48ag_fxt(tf, temp, fr, rr) end subroutine rate_cr48ag_fxt -! rcr48ga, cr48(g,a)ti44 +! rcr48ga, cr48(g,a)ti44 ! see rti44ag -! rcr48ap, cr48(a,p)mn51 +! rcr48ap, cr48(a,p)mn51 subroutine rate_cr48ap_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -3149,8 +3149,8 @@ subroutine rate_cr48ap_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -3166,18 +3166,18 @@ subroutine rate_cr48ap_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! he4 cr48 p mn51 rath 5.58000d-01 +! he4 cr48 p mn51 rath 5.58000d-01 call jina_reaclib_2_2(ihe4, icr48, ih1, imn51, tf, fr, rr, 'rate_cr48ap_jina') end subroutine rate_cr48ap_jina -! rcr48gp, cr48(g,p)v47 +! rcr48gp, cr48(g,p)v47 ! see rv47pg -! Manganese +! Manganese -! rmn51pg, mn51(p,g)fe52 +! rmn51pg, mn51(p,g)fe52 subroutine rate_mn51pg_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -3187,8 +3187,8 @@ subroutine rate_mn51pg_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -3204,16 +3204,16 @@ subroutine rate_mn51pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p mn51 fe52 rath 7.38100d+00 +! p mn51 fe52 rath 7.38100d+00 call jina_reaclib_2_1(ih1, imn51, ife52, tf, fr, rr, 'rate_mn51pg_jina') end subroutine rate_mn51pg_jina -! rmn51pa, mn51(p,a)cr48 +! rmn51pa, mn51(p,a)cr48 ! see rcr48ap -! rfe52ag, fe52(a,g)ni56 +! rfe52ag, fe52(a,g)ni56 subroutine rate_fe52ag_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -3223,8 +3223,8 @@ subroutine rate_fe52ag_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -3236,10 +3236,10 @@ subroutine rate_fe52ag_fxt(tf, temp, fr, rr) end subroutine rate_fe52ag_fxt -! rfe52ga, fe52(g,a)cr48 +! rfe52ga, fe52(g,a)cr48 ! see rcr48ag -! rfe52ap, fe52(a,p)co55 +! rfe52ap, fe52(a,p)co55 subroutine rate_fe52ap_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -3249,8 +3249,8 @@ subroutine rate_fe52ap_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -3262,18 +3262,18 @@ subroutine rate_fe52ap_fxt(tf, temp, fr, rr) end subroutine rate_fe52ap_fxt -! rfe52gp, fe52(g,p)mn51 +! rfe52gp, fe52(g,p)mn51 ! see mg51pg - + subroutine rate_fe52ng_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! n fe52 fe53 rath 1.06840d+01 +! n fe52 fe53 rath 1.06840d+01 call jina_reaclib_2_1(ineut, ife52, ife53, tf, fr, rr, 'rate_fe52ng_jina') - end subroutine rate_fe52ng_jina + end subroutine rate_fe52ng_jina subroutine rate_fe52ng_fxt(tf, temp, fr, rr) @@ -3284,13 +3284,13 @@ subroutine rate_fe52ng_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + ! fe52(n, g)fe53 tq2 = (tf% T9) - 0.348d0 term = 9.604d+05 * exp(-0.0626d0*tq2) fr = term - rev = 2.43d+09 * (tf% T932) * exp(-123.951d0*(tf% T9i)) + rev = 2.43d+09 * (tf% T932) * exp(-123.951d0*(tf% T9i)) rr = rev * term end subroutine rate_fe52ng_fxt @@ -3303,8 +3303,8 @@ subroutine rate_fe53ng_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + ! fe53(n, g)fe54 tq1 = (tf% T9)/0.348d0 tq10 = pow(tq1, 0.10d0) @@ -3320,9 +3320,9 @@ subroutine rate_fe53ng_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! n fe53 fe54 rath 1.33780d+01 +! n fe53 fe54 rath 1.33780d+01 call jina_reaclib_2_1(ineut, ife53, ife54, tf, fr, rr, 'rate_fe53ng_jina') - end subroutine rate_fe53ng_jina + end subroutine rate_fe53ng_jina subroutine rate_fe54pg_fxt(tf, temp, fr, rr) @@ -3333,8 +3333,8 @@ subroutine rate_fe54pg_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + ! fe54(p, g)co55 z = min((tf% T9), 10.0d0) z2 = z*z @@ -3384,9 +3384,9 @@ subroutine rate_fe55ng_jina(tf, temp, fr, rr) end subroutine rate_fe55ng_jina -! Cobalt +! Cobalt -! rco55pg, co55(p,g)ni56 +! rco55pg, co55(p,g)ni56 subroutine rate_co55pg_fxt(tf, temp, fr, rr) type (T_Factors) :: tf @@ -3396,8 +3396,8 @@ subroutine rate_co55pg_fxt(tf, temp, fr, rr) if (tf% t9 < lowT9_cutoff) then fr = 0; rr = 0; return - end if - + end if + z = min((tf% T9), 10.0d0) z2 = z*z z3 = z2*z @@ -3409,22 +3409,22 @@ subroutine rate_co55pg_fxt(tf, temp, fr, rr) end subroutine rate_co55pg_fxt -! rco55pa, co55(p,a)fe52 +! rco55pa, co55(p,a)fe52 ! see rfe52ap -! Nickel +! Nickel -! rni56ga, ni56(g,a)fe52 +! rni56ga, ni56(g,a)fe52 ! see rfe52ag - -! rni56gp, ni56(g,p)co55 + +! rni56gp, ni56(g,p)co55 ! see rco55pg - + subroutine rate_v44pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p v44 cr45 rath 3.10000d+00 +! p v44 cr45 rath 3.10000d+00 call jina_reaclib_2_1(ih1, iv44, icr45, tf, fr, rr, 'rate_v44pg_jina') end subroutine rate_v44pg_jina @@ -3433,7 +3433,7 @@ subroutine rate_v45pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p v45 cr46 rath 4.88600d+00 +! p v45 cr46 rath 4.88600d+00 call jina_reaclib_2_1(ih1, iv45, icr46, tf, fr, rr, 'rate_v45pg_jina') end subroutine rate_v45pg_jina @@ -3441,7 +3441,7 @@ subroutine rate_co53pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p co53 ni54 rath 3.85600d+00 +! p co53 ni54 rath 3.85600d+00 call jina_reaclib_2_1(ih1, ico53, ini54, tf, fr, rr, 'rate_co53pg_jina') end subroutine rate_co53pg_jina @@ -3450,7 +3450,7 @@ subroutine rate_co54pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p co54 ni55 rath 4.61400d+00 +! p co54 ni55 rath 4.61400d+00 call jina_reaclib_2_1(ih1, ico54, ini55, tf, fr, rr, 'rate_co54pg_jina') end subroutine rate_co54pg_jina @@ -3458,7 +3458,7 @@ subroutine rate_ga62pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p ga62 ge63 nfisn 2.23867d+00 +! p ga62 ge63 nfisn 2.23867d+00 call jina_reaclib_2_1(ih1, iga62, ige63, tf, fr, rr, 'rate_ga62pg_jina') end subroutine rate_ga62pg_jina @@ -3467,12 +3467,12 @@ subroutine rate_ga63pg_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr -! p ga63 ge64 rath 5.02500d+00 +! p ga63 ge64 rath 5.02500d+00 call jina_reaclib_2_1(ih1, iga63, ige64, tf, fr, rr, 'rate_ga63pg_jina') end subroutine rate_ga63pg_jina - + ! ni56 - + subroutine rate_fe52ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp @@ -3502,10 +3502,10 @@ subroutine rate_fe54pg_jina(tf, temp, fr, rr) real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr call jina_reaclib_2_1(ih1, ife54, ico55, tf, fr, rr, 'rate_fe54pg_jina') - end subroutine rate_fe54pg_jina + end subroutine rate_fe54pg_jina ! ni58 - + subroutine rate_fe54ag_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp @@ -3526,9 +3526,9 @@ subroutine rate_fe56pg_jina(tf, temp, fr, rr) real(dp), intent(in) :: temp real(dp), intent(out) :: fr, rr call jina_reaclib_2_1(ih1, ife56, ico57, tf, fr, rr, 'rate_fe56pg_jina') - end subroutine rate_fe56pg_jina + end subroutine rate_fe56pg_jina + - subroutine rate_c12_c12_to_h1_na23_jina(tf, temp, fr, rr) type (T_Factors) :: tf real(dp), intent(in) :: temp @@ -3536,7 +3536,7 @@ subroutine rate_c12_c12_to_h1_na23_jina(tf, temp, fr, rr) call jina_reaclib_2_2( & ic12, ic12, ih1, ina23, tf, fr, rr, 'rate_c12_c12_to_h1_na23_jina') end subroutine rate_c12_c12_to_h1_na23_jina - + subroutine rate_he4_ne20_to_c12_c12_jina(tf, temp, fr, rr) type (T_Factors) :: tf @@ -3545,7 +3545,7 @@ subroutine rate_he4_ne20_to_c12_c12_jina(tf, temp, fr, rr) call jina_reaclib_2_2( & ihe4, ine20, ic12, ic12, tf, fr, rr, 'rate_he4_ne20_to_c12_c12_jina') end subroutine rate_he4_ne20_to_c12_c12_jina - + subroutine rate_he4_mg24_to_c12_o16_jina(tf, temp, fr, rr) type (T_Factors) :: tf @@ -3554,8 +3554,8 @@ subroutine rate_he4_mg24_to_c12_o16_jina(tf, temp, fr, rr) call jina_reaclib_2_2( & ihe4, img24, ic12, io16, tf, fr, rr, 'rate_he4_mg24_to_c12_o16_jina') end subroutine rate_he4_mg24_to_c12_o16_jina - - + + subroutine tfactors(tf, logT_in, temp_in) use const_def, only: ln10 @@ -3566,10 +3566,10 @@ subroutine tfactors(tf, logT_in, temp_in) real(dp), intent(in) :: logT_in, temp_in real(dp) :: logT, temp - + logT = max(logT_in, 0d0) temp = max(temp_in, 1d0) - + tf% lnT9 = (logT - 9)*ln10 tf% T9 = temp * 1.0d-9 tf% T92 = tf% T9 * tf% T9 @@ -3636,7 +3636,7 @@ subroutine tfactors(tf, logT_in, temp_in) tf% T9i65 = tf% T9i * tf% T9i15 tf% T9i17 = 1.0d0 / tf% T917 - tf% T9i27 = tf% T9i17 * tf% T9i17 + tf% T9i27 = tf% T9i17 * tf% T9i17 tf% T9i47 = tf% T9i27 * tf% T9i27 tf% T9i18 = 1.0d0 / tf% T918 @@ -3645,20 +3645,20 @@ subroutine tfactors(tf, logT_in, temp_in) end subroutine tfactors - + subroutine show_nacre_terms( & tf, a0, a1, a2, b0, b1, b2, b3, b4, c0, c1, d0, d1, e0, e1, e2) type (T_Factors) :: tf real(dp), intent(in) :: a0, a1, a2, b0, b1, b2, b3, b4, & c0, c1, d0, d1, e0, e1, e2 - + include 'formats' real(dp) :: aa, bb, cc, dd, ee - aa = a0 * (tf% T9i23) * exp(-a1*(tf% T9i13) - (tf% T92)*(a2*a2)) + aa = a0 * (tf% T9i23) * exp(-a1*(tf% T9i13) - (tf% T92)*(a2*a2)) bb = 1 + b0*(tf% T9) + b1*(tf% T92) + b2*(tf% T93) + b3*(tf% T94) + b4*(tf% T95) - cc = c0 * (tf% T9i32) * exp(-c1*(tf% T9i)) - dd = d0 * (tf% T9i32) * exp(-d1*(tf% T9i)) - ee = e0 * pow(tf% T9,e1) * exp(-e2*(tf% T9i)) + cc = c0 * (tf% T9i32) * exp(-c1*(tf% T9i)) + dd = d0 * (tf% T9i32) * exp(-d1*(tf% T9i)) + ee = e0 * pow(tf% T9,e1) * exp(-e2*(tf% T9i)) write(*,1) 'aa', aa write(*,1) 'bb', bb @@ -3666,13 +3666,13 @@ subroutine show_nacre_terms( & write(*,1) 'cc', cc write(*,1) 'dd', dd write(*,1) 'ee', ee - + end subroutine show_nacre_terms - + subroutine rnacre( & - ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) - ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) + ! a0 T9i23 exp(-a1 T9i13 - (T9*a2)^2) + ! * (1 + b0 T9 + b1 T92 + b2 T93 + b3 T94 + b4 T95) ! + c0 T9i32 exp(-c1/T9) ! + d0 T9i32 exp(-d1/T9) ! + e0 T9^e1 exp(-e2/T9) & @@ -3682,26 +3682,26 @@ subroutine rnacre( & c0, c1, d0, d1, e0, e1, e2 real(dp), intent(out) :: term real(dp) :: aa, bb, cc, dd, ee - aa = a0 * (tf% T9i23) * exp(-a1*(tf% T9i13) - (tf% T92)*(a2*a2)) + aa = a0 * (tf% T9i23) * exp(-a1*(tf% T9i13) - (tf% T92)*(a2*a2)) bb = 1 + b0*(tf% T9) + b1*(tf% T92) + b2*(tf% T93) + b3*(tf% T94) + b4*(tf% T95) if (bb < 0) then bb = 0 end if - cc = c0 * (tf% T9i32) * exp(-c1*(tf% T9i)) - dd = d0 * (tf% T9i32) * exp(-d1*(tf% T9i)) - ee = e0 * pow(tf% T9,e1) * exp(-e2*(tf% T9i)) + cc = c0 * (tf% T9i32) * exp(-c1*(tf% T9i)) + dd = d0 * (tf% T9i32) * exp(-d1*(tf% T9i)) + ee = e0 * pow(tf% T9,e1) * exp(-e2*(tf% T9i)) term = aa * bb + cc + dd + ee end subroutine rnacre - + subroutine rnacre_rev(tf, a0, a1, rev) ! a0 T932 exp(-a1/T9) real(dp), intent(in) :: a0, a1 real(dp), intent(out) :: rev type (T_Factors) :: tf rev = a0 * (tf% T932) * exp(-a1*(tf% T9i)) - end subroutine rnacre_rev - - + end subroutine rnacre_rev + + subroutine jina_reaclib_1_1(i1, o1, tf, fr, rr, str) integer, intent(in) :: i1, o1 type (T_Factors) :: tf @@ -3717,8 +3717,8 @@ subroutine jina_reaclib_1_1(i1, o1, tf, fr, rr, str) call mesa_error(__FILE__,__LINE__) end if end subroutine jina_reaclib_1_1 - - + + subroutine jina_reaclib_1_2(i1, o1, o2, tf, fr, rr, str) integer, intent(in) :: i1, o1, o2 type (T_Factors) :: tf @@ -3734,8 +3734,8 @@ subroutine jina_reaclib_1_2(i1, o1, o2, tf, fr, rr, str) call mesa_error(__FILE__,__LINE__) end if end subroutine jina_reaclib_1_2 - - + + subroutine jina_reaclib_1_3(i1, o1, o2, o3, tf, fr, rr, str) integer, intent(in) :: i1, o1, o2, o3 type (T_Factors) :: tf @@ -3751,8 +3751,8 @@ subroutine jina_reaclib_1_3(i1, o1, o2, o3, tf, fr, rr, str) call mesa_error(__FILE__,__LINE__) end if end subroutine jina_reaclib_1_3 - - + + subroutine jina_reaclib_1_4(i1, o1, o2, o3, o4, tf, fr, rr, str) integer, intent(in) :: i1, o1, o2, o3, o4 type (T_Factors) :: tf @@ -3768,8 +3768,8 @@ subroutine jina_reaclib_1_4(i1, o1, o2, o3, o4, tf, fr, rr, str) call mesa_error(__FILE__,__LINE__) end if end subroutine jina_reaclib_1_4 - - + + subroutine jina_reaclib_2_1(i1, i2, o1, tf, fr, rr, str) integer, intent(in) :: i1, i2, o1 type (T_Factors) :: tf @@ -3785,8 +3785,8 @@ subroutine jina_reaclib_2_1(i1, i2, o1, tf, fr, rr, str) call mesa_error(__FILE__,__LINE__) end if end subroutine jina_reaclib_2_1 - - + + subroutine jina_reaclib_2_2(i1, i2, o1, o2, tf, fr, rr, str) integer, intent(in) :: i1, i2, o1, o2 type (T_Factors) :: tf @@ -3802,8 +3802,8 @@ subroutine jina_reaclib_2_2(i1, i2, o1, o2, tf, fr, rr, str) call mesa_error(__FILE__,__LINE__) end if end subroutine jina_reaclib_2_2 - - + + subroutine jina_reaclib_2_3(i1, i2, o1, o2, o3, tf, fr, rr, str) integer, intent(in) :: i1, i2, o1, o2, o3 type (T_Factors) :: tf @@ -3819,8 +3819,8 @@ subroutine jina_reaclib_2_3(i1, i2, o1, o2, o3, tf, fr, rr, str) call mesa_error(__FILE__,__LINE__) end if end subroutine jina_reaclib_2_3 - - + + subroutine jina_reaclib_2_4(i1, i2, o1, o2, o3, o4, tf, fr, rr, str) integer, intent(in) :: i1, i2, o1, o2, o3, o4 type (T_Factors) :: tf @@ -3836,8 +3836,8 @@ subroutine jina_reaclib_2_4(i1, i2, o1, o2, o3, o4, tf, fr, rr, str) call mesa_error(__FILE__,__LINE__) end if end subroutine jina_reaclib_2_4 - - + + subroutine jina_reaclib_3_1(i1, i2, i3, o1, tf, fr, rr, str) integer, intent(in) :: i1, i2, i3, o1 type (T_Factors) :: tf @@ -3853,8 +3853,8 @@ subroutine jina_reaclib_3_1(i1, i2, i3, o1, tf, fr, rr, str) call mesa_error(__FILE__,__LINE__) end if end subroutine jina_reaclib_3_1 - - + + subroutine jina_reaclib_3_2(i1, i2, i3, o1, o2, tf, fr, rr, str) integer, intent(in) :: i1, i2, i3, o1, o2 type (T_Factors) :: tf @@ -3870,8 +3870,8 @@ subroutine jina_reaclib_3_2(i1, i2, i3, o1, o2, tf, fr, rr, str) call mesa_error(__FILE__,__LINE__) end if end subroutine jina_reaclib_3_2 - - + + subroutine jina_reaclib_4_2(i1, i2, i3, i4, o1, o2, tf, fr, rr, str) integer, intent(in) :: i1, i2, i3, i4, o1, o2 type (T_Factors) :: tf @@ -3887,8 +3887,8 @@ subroutine jina_reaclib_4_2(i1, i2, i3, i4, o1, o2, tf, fr, rr, str) call mesa_error(__FILE__,__LINE__) end if end subroutine jina_reaclib_4_2 - - + + subroutine try1_reaclib_1_1(i1, o1, tf, fr, rr, str, ierr) integer, intent(in) :: i1, o1 type (T_Factors) :: tf @@ -3908,8 +3908,8 @@ subroutine try1_reaclib_1_1(i1, o1, tf, fr, rr, str, ierr) str, num_in, nuclides_in, num_out, nuclides_out, tf% T9, & fr, rr, ierr) end subroutine try1_reaclib_1_1 - - + + subroutine try1_reaclib_1_2(i1, o1, o2, tf, fr, rr, str, ierr) integer, intent(in) :: i1, o1, o2 type (T_Factors) :: tf @@ -3930,8 +3930,8 @@ subroutine try1_reaclib_1_2(i1, o1, o2, tf, fr, rr, str, ierr) str, num_in, nuclides_in, num_out, nuclides_out, tf% T9, & fr, rr, ierr) end subroutine try1_reaclib_1_2 - - + + subroutine try1_reaclib_1_3(i1, o1, o2, o3, tf, fr, rr, str, ierr) integer, intent(in) :: i1, o1, o2, o3 type (T_Factors) :: tf @@ -3953,8 +3953,8 @@ subroutine try1_reaclib_1_3(i1, o1, o2, o3, tf, fr, rr, str, ierr) str, num_in, nuclides_in, num_out, nuclides_out, tf% T9, & fr, rr, ierr) end subroutine try1_reaclib_1_3 - - + + subroutine try1_reaclib_1_4(i1, o1, o2, o3, o4, tf, fr, rr, str, ierr) integer, intent(in) :: i1, o1, o2, o3, o4 type (T_Factors) :: tf @@ -3977,8 +3977,8 @@ subroutine try1_reaclib_1_4(i1, o1, o2, o3, o4, tf, fr, rr, str, ierr) str, num_in, nuclides_in, num_out, nuclides_out, tf% T9, & fr, rr, ierr) end subroutine try1_reaclib_1_4 - - + + subroutine try1_reaclib_2_1(i1, i2, o1, tf, fr, rr, str, ierr) integer, intent(in) :: i1, i2, o1 type (T_Factors) :: tf @@ -3999,8 +3999,8 @@ subroutine try1_reaclib_2_1(i1, i2, o1, tf, fr, rr, str, ierr) str, num_in, nuclides_in, num_out, nuclides_out, tf% T9, & fr, rr, ierr) end subroutine try1_reaclib_2_1 - - + + subroutine try1_reaclib_2_2(i1, i2, o1, o2, tf, fr, rr, str, ierr) integer, intent(in) :: i1, i2, o1, o2 type (T_Factors) :: tf @@ -4022,8 +4022,8 @@ subroutine try1_reaclib_2_2(i1, i2, o1, o2, tf, fr, rr, str, ierr) str, num_in, nuclides_in, num_out, nuclides_out, tf% T9, & fr, rr, ierr) end subroutine try1_reaclib_2_2 - - + + subroutine try1_reaclib_2_3(i1, i2, o1, o2, o3, tf, fr, rr, str, ierr) integer, intent(in) :: i1, i2, o1, o2, o3 type (T_Factors) :: tf @@ -4046,8 +4046,8 @@ subroutine try1_reaclib_2_3(i1, i2, o1, o2, o3, tf, fr, rr, str, ierr) str, num_in, nuclides_in, num_out, nuclides_out, tf% T9, & fr, rr, ierr) end subroutine try1_reaclib_2_3 - - + + subroutine try1_reaclib_2_4(i1, i2, o1, o2, o3, o4, tf, fr, rr, str, ierr) integer, intent(in) :: i1, i2, o1, o2, o3, o4 type (T_Factors) :: tf @@ -4071,8 +4071,8 @@ subroutine try1_reaclib_2_4(i1, i2, o1, o2, o3, o4, tf, fr, rr, str, ierr) str, num_in, nuclides_in, num_out, nuclides_out, tf% T9, & fr, rr, ierr) end subroutine try1_reaclib_2_4 - - + + subroutine try1_reaclib_3_1(i1, i2, i3, o1, tf, fr, rr, str, ierr) integer, intent(in) :: i1, i2, i3, o1 type (T_Factors) :: tf @@ -4094,8 +4094,8 @@ subroutine try1_reaclib_3_1(i1, i2, i3, o1, tf, fr, rr, str, ierr) str, num_in, nuclides_in, num_out, nuclides_out, tf% T9, & fr, rr, ierr) end subroutine try1_reaclib_3_1 - - + + subroutine try1_reaclib_3_2(i1, i2, i3, o1, o2, tf, fr, rr, str, ierr) integer, intent(in) :: i1, i2, i3, o1, o2 type (T_Factors) :: tf @@ -4118,8 +4118,8 @@ subroutine try1_reaclib_3_2(i1, i2, i3, o1, o2, tf, fr, rr, str, ierr) str, num_in, nuclides_in, num_out, nuclides_out, tf% T9, & fr, rr, ierr) end subroutine try1_reaclib_3_2 - - + + subroutine try1_reaclib_4_2(i1, i2, i3, i4, o1, o2, tf, fr, rr, str, ierr) integer, intent(in) :: i1, i2, i3, i4, o1, o2 type (T_Factors) :: tf @@ -4143,14 +4143,14 @@ subroutine try1_reaclib_4_2(i1, i2, i3, i4, o1, o2, tf, fr, rr, str, ierr) str, num_in, nuclides_in, num_out, nuclides_out, tf% T9, & fr, rr, ierr) end subroutine try1_reaclib_4_2 - - + + subroutine reaclib_rate( & str, num_in, nuclides_in, num_out, nuclides_out, T9, & lambda, rlambda, ierr) use reaclib_support, only: reaction_handle character (len=*), intent(in) :: str - integer, intent(in) :: num_in, nuclides_in(:) + integer, intent(in) :: num_in, nuclides_in(:) integer, intent(in) :: num_out, nuclides_out(:) real(dp), intent(in) :: T9 real(dp), intent(out) :: lambda, rlambda @@ -4164,8 +4164,8 @@ subroutine reaclib_rate( & call reaction_handle(num_in, num_out, iso_ids, '-', handle) call reaclib_rate_for_handle(handle, T9, lambda, rlambda, ierr) end subroutine reaclib_rate - - + + subroutine reaclib_rate_for_handle(handle, T9, lambda, rlambda, ierr) use reaclib_eval, only: do_reaclib_indices_for_reaction, do_reaclib_reaction_rates character (len=*), intent(in) :: handle @@ -4203,15 +4203,15 @@ subroutine reaclib_rate_for_handle(handle, T9, lambda, rlambda, ierr) return end if end subroutine reaclib_rate_for_handle - - + + subroutine reaclib_rate_and_dlnT_for_handle( & handle, T9, lambda, dlambda_dlnT, rlambda, drlambda_dlnT, ierr) use reaclib_eval, only: do_reaclib_indices_for_reaction, do_reaclib_reaction_rates character (len=*), intent(in) :: handle real(dp), intent(in) :: T9 real(dp), intent(out) :: lambda, dlambda_dlnT, rlambda, drlambda_dlnT - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: lo, hi include 'formats' ierr = 0 @@ -4227,7 +4227,7 @@ subroutine reaclib_rate_and_dlnT_for_handle( & lo, hi, handle, T9, lambda, dlambda_dlnT, rlambda, drlambda_dlnT, ierr) end subroutine reaclib_rate_and_dlnT_for_handle - + subroutine reaclib_rate_and_dlnT( & lo, hi, handle, T9, lambda, dlambda_dlnT, rlambda, drlambda_dlnT, ierr) use reaclib_eval, only: do_reaclib_reaction_rates @@ -4235,7 +4235,7 @@ subroutine reaclib_rate_and_dlnT( & character (len=*), intent(in) :: handle real(dp), intent(in) :: T9 real(dp), intent(out) :: lambda, dlambda_dlnT, rlambda, drlambda_dlnT - integer, intent(out) :: ierr + integer, intent(out) :: ierr logical, parameter :: forward_only = .false. include 'formats' ierr = 0 @@ -4247,7 +4247,7 @@ subroutine reaclib_rate_and_dlnT( & call do_reaclib_reaction_rates( & lo, hi, T9, reaclib_rates, chem_isos, forward_only, & lambda, dlambda_dlnT, rlambda, drlambda_dlnT, & - ierr) + ierr) if (ierr /= 0) then write(*,*) 'failed in reaclib_reaction_rates ' // trim(handle) return @@ -4337,29 +4337,29 @@ subroutine mazurek_init(ierr) rv(:) = (/ 6D0, 7D0, 8D0, 9D0, 10D0, 11D0 /) tv(:) = (/ 2D0, 4D0, 6D0, 8D0, 10D0, 12D0, 14D0 /) ierr = 0 - do k=2,4 - rfdm(k)=1.d0/((rv(k-1)-rv(k))*(rv(k-1)-rv(k+1))*(rv(k-1)-rv(k+2))) - rfd0(k)=1.d0/((rv(k)-rv(k-1))*(rv(k)-rv(k+1))*(rv(k)-rv(k+2))) - rfd1(k)=1.d0/((rv(k+1)-rv(k-1))*(rv(k+1)-rv(k))*(rv(k+1)-rv(k+2))) - rfd2(k)=1.d0/((rv(k+2)-rv(k-1))*(rv(k+2)-rv(k))*(rv(k+2)-rv(k+1))) + do k=2,4 + rfdm(k)=1.d0/((rv(k-1)-rv(k))*(rv(k-1)-rv(k+1))*(rv(k-1)-rv(k+2))) + rfd0(k)=1.d0/((rv(k)-rv(k-1))*(rv(k)-rv(k+1))*(rv(k)-rv(k+2))) + rfd1(k)=1.d0/((rv(k+1)-rv(k-1))*(rv(k+1)-rv(k))*(rv(k+1)-rv(k+2))) + rfd2(k)=1.d0/((rv(k+2)-rv(k-1))*(rv(k+2)-rv(k))*(rv(k+2)-rv(k+1))) enddo - do j=2,5 - tfdm(j)=1.d0/((tv(j-1)-tv(j))*(tv(j-1)-tv(j+1))*(tv(j-1)-tv(j+2))) - tfd0(j)=1.d0/((tv(j)-tv(j-1))*(tv(j)-tv(j+1))*(tv(j)-tv(j+2))) - tfd1(j)=1.d0/((tv(j+1)-tv(j-1))*(tv(j+1)-tv(j))*(tv(j+1)-tv(j+2))) - tfd2(j)=1.d0/((tv(j+2)-tv(j-1))*(tv(j+2)-tv(j))*(tv(j+2)-tv(j+1))) + do j=2,5 + tfdm(j)=1.d0/((tv(j-1)-tv(j))*(tv(j-1)-tv(j+1))*(tv(j-1)-tv(j+2))) + tfd0(j)=1.d0/((tv(j)-tv(j-1))*(tv(j)-tv(j+1))*(tv(j)-tv(j+2))) + tfd1(j)=1.d0/((tv(j+1)-tv(j-1))*(tv(j+1)-tv(j))*(tv(j+1)-tv(j+2))) + tfd2(j)=1.d0/((tv(j+2)-tv(j-1))*(tv(j+2)-tv(j))*(tv(j+2)-tv(j+1))) enddo end subroutine mazurek_init - subroutine mazurek(btemp,bden,y56,ye,rn56ec,sn56ec) + subroutine mazurek(btemp,bden,y56,ye,rn56ec,sn56ec) use rates_def, only: tv,rv,rfdm,rfd0,rfd1,rfd2,tfdm,tfd0,tfd1,tfd2 real(dp), intent(in) :: btemp,bden,y56,ye real(dp), intent(out) :: rn56ec,sn56ec -! this routine evaluates mazurek's 1973 fits for the ni56 electron -! capture rate rn56ec and neutrino loss rate sn56ec +! this routine evaluates mazurek's 1973 fits for the ni56 electron +! capture rate rn56ec and neutrino loss rate sn56ec -! input: +! input: ! y56 = nickel56 molar abundance ! ye = electron to baryon number, zbar/abar @@ -4367,13 +4367,13 @@ subroutine mazurek(btemp,bden,y56,ye,rn56ec,sn56ec) ! rn56ec = ni56 electron capture rate ! sn56ec = ni56 neutrino loss rate -! declare +! declare integer jp,kp,jr,jd,ii,ik,ij real(dp) rnt(2),rne(2,7),datn(2,6,7), & t9,r,rfm,rf0,rf1,rf2,dfacm,dfac0,dfac1,dfac2, & tfm,tf0,tf1,tf2,tfacm,tfac0,tfac1,tfac2 -! initialize +! initialize data (((datn(ii,ik,ij),ik=1,6),ij=1,7),ii=1,1) / & -3.98d0, -2.84d0, -1.41d0, 0.20d0, 1.89d0, 3.63d0, & -3.45d0, -2.62d0, -1.32d0, 0.22d0, 1.89d0, 3.63d0, & @@ -4381,7 +4381,7 @@ subroutine mazurek(btemp,bden,y56,ye,rn56ec,sn56ec) -2.04d0, -1.87d0, -1.01d0, 0.34d0, 1.94d0, 3.62d0, & -1.50d0, -1.41d0, -0.80d0, 0.45d0, 1.99d0, 3.60d0, & -1.00d0, -0.95d0, -0.54d0, 0.60d0, 2.06d0, 3.58d0, & - -0.52d0, -0.49d0, -0.21d0, 0.79d0, 2.15d0, 3.55d0 / + -0.52d0, -0.49d0, -0.21d0, 0.79d0, 2.15d0, 3.55d0 / data (((datn(ii,ik,ij),ik=1,6),ij=1,7),ii=2,2) / & -3.68d0, -2.45d0, -0.80d0, 1.12d0, 3.13d0, 5.19d0, & -2.91d0, -2.05d0, -0.64d0, 1.16d0, 3.14d0, 5.18d0, & @@ -4389,76 +4389,76 @@ subroutine mazurek(btemp,bden,y56,ye,rn56ec,sn56ec) -1.16d0, -0.99d0, -0.11d0, 1.37d0, 3.20d0, 5.18d0, & -0.48d0, -0.40d0, 0.22d0, 1.54d0, 3.28d0, 5.16d0, & 0.14d0, 0.19d0, 0.61d0, 1.78d0, 3.38d0, 5.14d0, & - 0.75d0, 0.78d0, 1.06d0, 2.07d0, 3.51d0, 5.11d0 / + 0.75d0, 0.78d0, 1.06d0, 2.07d0, 3.51d0, 5.11d0 / -! calculate ni56 electron capture and neutrino loss rates +! calculate ni56 electron capture and neutrino loss rates rn56ec = 0.0d0 sn56ec = 0.0d0 if (btemp*1d-9 < lowT9_cutoff) return - + if ( (btemp .lt. 2.0d9) .or. (bden*ye .lt. 1.0d6)) return t9 = min(btemp, 1.4d10) * 1.0d-9 - r = max(6.0d0,min(11.0d0,log10(bden*ye))) - jp = min(max(2,int(0.5d0*t9)), 5) - kp = min(max(2,int(r)-5), 4) - rfm = r - rv(kp-1) - rf0 = r - rv(kp) - rf1 = r - rv(kp+1) - rf2 = r - rv(kp+2) - dfacm = rf0*rf1*rf2*rfdm(kp) - dfac0 = rfm*rf1*rf2*rfd0(kp) - dfac1 = rfm*rf0*rf2*rfd1(kp) - dfac2 = rfm*rf0*rf1*rfd2(kp) - tfm = t9 - tv(jp-1) - tf0 = t9 - tv(jp) - tf1 = t9 - tv(jp+1) - tf2 = t9 - tv(jp+2) - tfacm = tf0*tf1*tf2*tfdm(jp) - tfac0 = tfm*tf1*tf2*tfd0(jp) - tfac1 = tfm*tf0*tf2*tfd1(jp) - tfac2 = tfm*tf0*tf1*tfd2(jp) + r = max(6.0d0,min(11.0d0,log10(bden*ye))) + jp = min(max(2,int(0.5d0*t9)), 5) + kp = min(max(2,int(r)-5), 4) + rfm = r - rv(kp-1) + rf0 = r - rv(kp) + rf1 = r - rv(kp+1) + rf2 = r - rv(kp+2) + dfacm = rf0*rf1*rf2*rfdm(kp) + dfac0 = rfm*rf1*rf2*rfd0(kp) + dfac1 = rfm*rf0*rf2*rfd1(kp) + dfac2 = rfm*rf0*rf1*rfd2(kp) + tfm = t9 - tv(jp-1) + tf0 = t9 - tv(jp) + tf1 = t9 - tv(jp+1) + tf2 = t9 - tv(jp+2) + tfacm = tf0*tf1*tf2*tfdm(jp) + tfac0 = tfm*tf1*tf2*tfd0(jp) + tfac1 = tfm*tf0*tf2*tfd1(jp) + tfac2 = tfm*tf0*tf1*tfd2(jp) ! evaluate the spline fits - do jr = 1,2 - do jd = jp-1,jp+2 + do jr = 1,2 + do jd = jp-1,jp+2 rne(jr,jd) = dfacm*datn(jr,kp-1,jd) + dfac0*datn(jr,kp,jd) & - + dfac1*datn(jr,kp+1,jd) + dfac2*datn(jr,kp+2,jd) + + dfac1*datn(jr,kp+1,jd) + dfac2*datn(jr,kp+2,jd) enddo rnt(jr) = tfacm*rne(jr,jp-1) + tfac0*rne(jr,jp) & - + tfac1*rne(jr,jp+1) + tfac2*rne(jr,jp+2) + + tfac1*rne(jr,jp+1) + tfac2*rne(jr,jp+2) enddo ! set the output rn56ec = exp10(rnt(1)) sn56ec = 6.022548d+23 * 8.18683d-7 * y56 * exp10(rnt(2)) - return + return end subroutine mazurek - + subroutine n14_electron_capture_rate(T,Rho,UE,rate) real(dp), intent(in) :: T ! temperature real(dp), intent(in) :: Rho ! density real(dp), intent(in) :: UE ! electron molecular weight real(dp), intent(out) :: rate ! (s^-1) - + real(dp) :: Q, AMC2, AMULTIP, AL92, T8, X, XFER, EF, Y, AA, GUESS, ELCAP - + ! from Lars - - + + ! Inputs are T in K, rho in gr/cm^3, and UE=electron mean mol. weight ! -! Gives a reasonable estimate (i.e. within factor of 50% or so) of the -! electron capture rate for electrons on 14N in a plasma assumed to be quite -! degenerate. +! Gives a reasonable estimate (i.e. within factor of 50% or so) of the +! electron capture rate for electrons on 14N in a plasma assumed to be quite +! degenerate. ! -! x=KT/Q, y=E_FERMI/Q -! -! ELCAP is the rate in 1/seconds +! x=KT/Q, y=E_FERMI/Q ! +! ELCAP is the rate in 1/seconds ! -! Let's start by putting in the Q value, electron rest mass and +! +! Let's start by putting in the Q value, electron rest mass and ! temperature in units of keV. ! ! @@ -4469,22 +4469,22 @@ subroutine n14_electron_capture_rate(T,Rho,UE,rate) T8 = T/1d8 X = 8.617d0*T8/Q ! -! For this value of the density, find the electron fermi momentum +! For this value of the density, find the electron fermi momentum ! assuming that the KT corrections to the electron EOS are not -! important. +! important. ! - XFER = pow(RHO/(0.9739D6*UE),1d0/3d0) + XFER = pow(RHO/(0.9739D6*UE),1d0/3d0) ! ! The parameter we need that is used in the fitting formula is -! the electron Fermi energy +! the electron Fermi energy ! EF = AMC2*SQRT(1.0D0 + XFER*XFER) Y = EF/Q - IF(Y .LT. (1.0D0 + AL92*X)) THEN + IF(Y .LT. (1.0D0 + AL92*X)) THEN AA = (Y-1.0D0)/X GUESS = 2.0D0*X*X*X*exp(AA) ELSE - GUESS = pow3(Y-1.0D0+(3.0D0-AL92)*X)/3.0D0 + GUESS = pow3(Y-1.0D0+(3.0D0-AL92)*X)/3.0D0 ENDIF ! ! Now multiply by the prefactors .. . @@ -4493,7 +4493,7 @@ subroutine n14_electron_capture_rate(T,Rho,UE,rate) rate = ELCAP - + end subroutine n14_electron_capture_rate @@ -4504,10 +4504,10 @@ subroutine ecapnuc(etakep,temp,rho,rpen,rnep,spen,snep) ! given the electron degeneracy parameter etakep (chemical potential ! without the electron's rest mass divided by kt) and the temperature temp, -! this routine calculates rates for +! this routine calculates rates for ! electron capture on protons rpen (captures/sec/proton), -! positron capture on neutrons rnep (captures/sec/neutron), -! and their associated neutrino energy loss rates +! positron capture on neutrons rnep (captures/sec/neutron), +! and their associated neutrino energy loss rates ! spen (ergs/sec/proton) and snep (ergs/sec/neutron) ! declare @@ -4530,7 +4530,7 @@ subroutine ecapnuc(etakep,temp,rho,rpen,rnep,spen,snep) qndeca = 1.2533036d-06, & tmean = 886.7d0, & rho_low_cutoff = 1d-9, eta_low_cutoff = -50d0) - + ! tmean and qndeca are the mean lifetime and decay energy of the neutron @@ -4548,7 +4548,7 @@ subroutine ecapnuc(etakep,temp,rho,rpen,rnep,spen,snep) iflag = 0 qn = qn1 - + ! chemical potential including the electron rest mass etaef = etakep + c2me/kerg/temp @@ -4567,7 +4567,7 @@ subroutine ecapnuc(etakep,temp,rho,rpen,rnep,spen,snep) ! protect from overflowing with large eta values if (eta .le. 6.8d+02) then exeta = exp(eta) - else + else exeta = 0.0d0 end if etael2 = etael*etael @@ -4660,9 +4660,9 @@ subroutine ecapnuc(etakep,temp,rho,rpen,rnep,spen,snep) 506 continue return end subroutine ecapnuc - + end module ratelib - - + + diff --git a/rates/private/rates_initialize.f90 b/rates/private/rates_initialize.f90 index c8438be47..5e7526719 100644 --- a/rates/private/rates_initialize.f90 +++ b/rates/private/rates_initialize.f90 @@ -27,14 +27,14 @@ module rates_initialize use const_def use math_lib use rates_def - - + + implicit none - - + + contains - - + + subroutine finish_rates_def_init use utils_lib, only: integer_dict_define, integer_dict_create_hash, integer_dict_size use reaclib_input, only: do_extract_rates @@ -47,19 +47,19 @@ subroutine finish_rates_def_init ! will be allocated by extract_nuclides_from_chem_isos logical :: use_weaklib include 'formats' - + ierr = 0 call integer_dict_create_hash(reaction_names_dict, ierr) if (ierr /= 0) then write(*,*) 'FATAL ERROR: rates_def_init failed in integer_dict_create_hash' return end if - + ! set up reaclib info allocate(set(num_chem_isos)) - + call generate_nuclide_set(chem_isos% name, set) - + use_weaklib = .true. call do_extract_rates(set, chem_isos, reaclib_rates, use_weaklib, ierr) deallocate(set) @@ -67,52 +67,52 @@ subroutine finish_rates_def_init write(*,*) 'FATAL ERROR: extract_reaclib_rates failed in rates_def_init' return end if - + end subroutine finish_rates_def_init - - + + subroutine do_add_reaction_for_handle(reaction_handle, ierr) use reaclib_support, only: do_parse_reaction_handle character (len=*), intent(in) :: reaction_handle ! to be added integer, intent(out) :: ierr - + integer :: ir, num_in, num_out integer :: particles_in, particles_out logical :: already_defined integer :: iso_ids(max_num_reaction_inputs+max_num_reaction_outputs) integer :: cin(max_num_reaction_inputs), cout(max_num_reaction_outputs) character (len=16) :: op ! e.g., 'pg', 'wk', 'to', or ... - + logical, parameter :: weak = .false. logical, parameter :: dbg = .false. - + include 'formats' - + ierr = 0 - + if (dbg) write(*,*) 'do_add_reaction_for_handle ' // trim(reaction_handle) - + call do_parse_reaction_handle( & reaction_handle, particles_in, particles_out, iso_ids, op, ierr) if (ierr /= 0) then write(*,'(a)') 'add_reaction_for_handle failed in reaclib_parse_handle ' // & - trim(reaction_handle) + trim(reaction_handle) return end if - + call alloc_reaction_ir(reaction_handle, ir, already_defined, ierr) if (already_defined) return if (ierr /= 0) return - + reaction_inputs(:,ir) = 0 reaction_outputs(:,ir) = 0 - + cin(:) = 1 cout(:) = 1 call setup(reaction_inputs(:,ir), num_in, cin, 0, particles_in) call setup(reaction_outputs(:,ir), num_out, cout, particles_in, particles_out) - + call set_reaction_info( & ir, num_in, num_out, particles_in, particles_out, weak, reaction_handle, ierr) if (ierr /= 0) then @@ -120,10 +120,10 @@ subroutine do_add_reaction_for_handle(reaction_handle, ierr) end if if (dbg) write(*,*) 'done do_add_reaction_for_handle ' // trim(reaction_handle) - - + + contains - + subroutine setup(reaction_io, num, cnt, k, num_particles) integer :: reaction_io(:), num, cnt(:), k, num_particles @@ -146,35 +146,35 @@ end subroutine setup end subroutine do_add_reaction_for_handle - - + + subroutine do_add_reaction_from_reaclib(reaction_handle, reverse_handle, indx, ierr) - + character (len=*), intent(in) :: reaction_handle ! to be added character (len=*), intent(in) :: reverse_handle ! = '' if not a reverse integer, intent(in) :: indx ! index in reaclib rates integer, intent(out) :: ierr - + integer :: i, ir, chapter, num_in, num_out integer :: particles_in, particles_out logical :: weak, reverse, already_defined integer :: cin(max_num_reaction_inputs), cout(max_num_reaction_outputs) type (reaction_data), pointer :: r =>null() - + logical, parameter :: dbg = .false. - + include 'formats' - + ierr = 0 i = indx reverse = (len_trim(reverse_handle) > 0) r => reaclib_rates - + cin(:) = 1 cout(:) = 1 - + if (dbg) write(*,'(a, 2x, i5)') 'do_add_reaction_from_reaclib ' // trim(reaction_handle), i - + if (reverse) then if (reverse_handle /= r% reaction_handle(i)) then write(*,'(a)') trim(reverse_handle) // ' ' // trim(r% reaction_handle(i)) @@ -190,14 +190,14 @@ subroutine do_add_reaction_from_reaclib(reaction_handle, reverse_handle, indx, i return end if end if - + chapter = r% chapter(i) weak = (adjustl(r% reaction_flag(i)) == 'w') - + call alloc_reaction_ir(reaction_handle, ir, already_defined, ierr) if (already_defined) return if (ierr /= 0) return - + reaction_inputs(:,ir) = 0 reaction_outputs(:,ir) = 0 @@ -212,7 +212,7 @@ subroutine do_add_reaction_from_reaclib(reaction_handle, reverse_handle, indx, i call setup(reaction_inputs(:,ir), num_in, cin, particles_out, particles_in) call setup(reaction_outputs(:,ir), num_out, cout, 0, particles_out) end if - + call set_reaction_info( & ir, num_in, num_out, particles_in, particles_out, weak, reaction_handle, ierr) if (ierr /= 0) then @@ -220,10 +220,10 @@ subroutine do_add_reaction_from_reaclib(reaction_handle, reverse_handle, indx, i end if if (dbg) write(*,*) 'done do_add_reaction_from_reaclib' - - + + contains - + subroutine setup(reaction_test, num, cnt, k, num_particles) integer :: reaction_test(:), num, cnt(:), k, num_particles @@ -246,16 +246,16 @@ end subroutine setup end subroutine do_add_reaction_from_reaclib - - + + subroutine alloc_reaction_ir(reaction_handle, ir, already_defined, ierr) character (len=*), intent(in) :: reaction_handle integer, intent(out) :: ir logical, intent(out) :: already_defined - integer, intent(out) :: ierr - logical, parameter :: dbg = .false. + integer, intent(out) :: ierr + logical, parameter :: dbg = .false. include 'formats' - ierr = 0 + ierr = 0 ir = get_rates_reaction_id(reaction_handle) if (ir > 0) then already_defined = .true. @@ -276,8 +276,8 @@ subroutine alloc_reaction_ir(reaction_handle, ir, already_defined, ierr) end if !$omp end critical (lock_alloc_reaction_ir) end subroutine alloc_reaction_ir - - + + subroutine set_reaction_info( & ir, num_in, num_out, particles_in, particles_out, weak, reaction_handle, ierr) use chem_def @@ -286,22 +286,22 @@ subroutine set_reaction_info( & logical, intent(in) :: weak character (len=*), intent(in) :: reaction_handle integer, intent(out) :: ierr - + integer :: j, iso_in, iso_out, weak_j, cin1 - + logical, parameter :: dbg = .false. - + include 'formats' - + ierr = 0 - + reaction_Name(ir) = reaction_handle - + if (dbg) write(*,*) 'call get_Qtotal' std_reaction_Qs(ir) = get_Qtotal(ir) std_reaction_neuQs(ir) = 0d0 weak_lowT_rate(ir) = -1d99 - + iso_in = reaction_inputs(num_in*2,ir) cin1 = reaction_inputs(num_in*2-1,ir) iso_out = reaction_outputs(num_out*2,ir) @@ -314,7 +314,7 @@ subroutine set_reaction_info( & end do call mesa_error(__FILE__,__LINE__,'set_reaction_info') end if - + if (iso_out < 0 .or. iso_out > num_chem_isos) then write(*,2) 'bad iso_out', iso_out write(*,2) 'num_out', num_out @@ -325,7 +325,7 @@ subroutine set_reaction_info( & end do call mesa_error(__FILE__,__LINE__,'set_reaction_info') end if - + if (weak) then weak_reaction_info(1,ir) = iso_in weak_reaction_info(2,ir) = iso_out @@ -338,7 +338,7 @@ subroutine set_reaction_info( & end if reaction_ye_rho_exponents(1,ir) = 0 ! 1 for electron captures, 0 for rest. - + if (particles_in > 1) then reaction_screening_info(1,ir) = reaction_inputs(2,ir) if (cin1 > 1) then @@ -394,21 +394,21 @@ subroutine set_reaction_info( & end select else if (particles_in == 1 .and. particles_out == 2 .and. .not. weak) then reaction_categories(ir) = iphoto - end if + end if reaction_Info(ir) = reaction_handle - + if (dbg) write(*,'(a,3x,i5)') 'call integer_dict_define ' // trim(reaction_handle), ir call integer_dict_define(reaction_names_dict, reaction_handle, ir, ierr) if (ierr /= 0) then write(*,*) 'FATAL ERROR: set_reaction_info failed in integer_dict_define' return - end if - + end if + end subroutine set_reaction_info - + subroutine set_weak_lowT_rate(ir, ierr) use chem_def use utils_lib, only: integer_dict_define @@ -420,11 +420,11 @@ subroutine set_weak_lowT_rate(ir, ierr) integer, intent(out) :: ierr integer :: i, lo, hi, weak_reaclib_id_i real(dp) :: half_life, lambda, dlambda_dlnT, rlambda, drlambda_dlnT - + include 'formats' - + weak_reaclib_id_i = 0 - + if (weak_reaction_info(1,ir) == 0 .or. weak_reaction_info(2,ir) == 0) return call do_reaclib_indices_for_reaction( & @@ -434,7 +434,7 @@ subroutine set_weak_lowT_rate(ir, ierr) i = do_get_weak_info_list_id( & chem_isos% name(weak_reaction_info(1,ir)), & chem_isos% name(weak_reaction_info(2,ir))) - if (i > 0) then + if (i > 0) then half_life = weak_info_list_halflife(i) if (half_life > 0d0) then weak_lowT_rate(ir) = ln2/half_life @@ -464,10 +464,10 @@ subroutine set_weak_lowT_rate(ir, ierr) chem_isos% name(weak_reaction_info(2,ir))) if (weak_reaclib_id_i == 0) return weak_reaclib_id(weak_reaclib_id_i) = ir - + end subroutine set_weak_lowT_rate - - + + logical function is_pp_reaction(reaction_handle) character (len=*), intent(in) :: reaction_handle is_pp_reaction = & @@ -480,10 +480,10 @@ logical function is_pp_reaction(reaction_handle) reaction_handle == 'r_h1_li7_to_he4_he4' .or. & reaction_handle == 'r_li7_pa_he4' .or. & reaction_handle == 'r_be7_pg_b8' .or. & - reaction_handle == 'r_b8_wk_he4_he4' + reaction_handle == 'r_b8_wk_he4_he4' end function is_pp_reaction - - + + logical function is_cno_reaction(reaction_handle) character (len=*), intent(in) :: reaction_handle is_cno_reaction = & @@ -509,8 +509,8 @@ logical function is_cno_reaction(reaction_handle) reaction_handle == 'r_f19_pa_o16' .or. & reaction_handle == 'r_ne18_wk_f18' end function is_cno_reaction - - + + subroutine free_raw_rates_records type (rate_table_info), pointer :: ri =>null() integer :: i @@ -523,27 +523,27 @@ subroutine free_raw_rates_records deallocate(raw_rates_records) end if end subroutine free_raw_rates_records - - + + subroutine init_raw_rates_records(ierr) use utils_lib use utils_def integer, intent(out) :: ierr - + type (rate_table_info), pointer :: ri =>null() integer :: i, iounit, n, t character (len=256) :: dir, rate_name, rate_fname, filename character (len=256) :: buffer logical :: okay - + logical, parameter :: dbg = .false. - + include 'formats' - + if (dbg) write(*,*) 'init_raw_rates_records' - + ierr = 0 - + ! first try local rate_tables_dir dir = rates_table_dir filename = trim(dir) // '/rate_list.txt' @@ -559,7 +559,7 @@ subroutine init_raw_rates_records(ierr) end if end if rates_table_dir = dir - + n = 0 i = 0 @@ -567,7 +567,7 @@ subroutine init_raw_rates_records(ierr) rate_loop: do t = token(iounit, n, i, buffer, rate_name) - if (t == eof_token) exit + if (t == eof_token) exit rate_loop if (t /= name_token) then call error; return end if @@ -581,25 +581,25 @@ subroutine init_raw_rates_records(ierr) if (ierr /= 0) call error() end do rate_loop - + close(iounit) - + if (dbg) call mesa_error(__FILE__,__LINE__,'read rates') !call check - - - + + + contains - - + + subroutine check ! check that there are cases for all of the rates use ratelib, only: tfactors use raw_rates, only: set_raw_rate real(dp) :: logT, temp, raw_rate integer :: i, ierr - type (T_Factors) :: tf - + type (T_Factors) :: tf + logT = 8 temp = exp10(logT) call tfactors(tf, logT, temp) @@ -615,8 +615,8 @@ subroutine check end do if (.not. okay) call mesa_error(__FILE__,__LINE__,'init_raw_rates_records') end subroutine check - - + + logical function failed(str) character (len=*), intent(in) :: str failed = .false. @@ -629,14 +629,14 @@ logical function failed(str) failed = .true. return end function failed - - + + subroutine error ierr = -1 close(iounit) end subroutine error - - + + end subroutine init_raw_rates_records subroutine rate_from_file(rate_name, filename, ierr) @@ -647,7 +647,7 @@ subroutine rate_from_file(rate_name, filename, ierr) logical,parameter :: dbg=.false. type (rate_table_info), pointer :: ri =>null() - ierr = 0 + ierr = 0 if (len_trim(rate_name) == 0 .or. len_trim(filename)==0) return @@ -658,7 +658,7 @@ subroutine rate_from_file(rate_name, filename, ierr) if (ierr /= 0 .or. ir <= 0) then write(*,*) 'invalid rate file ' // trim(rate_name) ierr = -1 - return + return end if end if if (dbg) write(*,*) 'rate_fname ', trim(filename) @@ -671,7 +671,7 @@ subroutine rate_from_file(rate_name, filename, ierr) end subroutine rate_from_file - + subroutine read_reaction_parameters(reactionlist_filename, ierr) use utils_lib use chem_lib @@ -679,19 +679,19 @@ subroutine read_reaction_parameters(reactionlist_filename, ierr) use const_def, only: mesa_data_dir character (len=*), intent(in) :: reactionlist_filename integer, intent(out) :: ierr - + character (len=256) :: line, filename, rname, cname integer :: iounit, len, i, j, jj, k, cnt, ir, ic, ii, n, num_reactions character (len=maxlen_reaction_Info) :: info logical, parameter :: dbg = .false. - + include 'formats' ierr = 0 - + call alloc_and_init_reaction_parameters(ierr) if (ierr /= 0) return - + ! first try the reaction_filename alone filename = trim(reactionlist_filename) open(newunit=iounit, file=trim(filename), action='read', status='old', iostat=ierr) @@ -724,12 +724,12 @@ subroutine read_reaction_parameters(reactionlist_filename, ierr) if (dbg) write(*,*) '(line(1:1) == !)' cycle end if - + i = 1; j = 35 rname = line(i:j) - + if (dbg) write(*,*) trim(rname) - + if (line(i:i+1) == 'r ') then call increase_num_reactions(ierr) if (ierr /= 0) then @@ -749,7 +749,7 @@ subroutine read_reaction_parameters(reactionlist_filename, ierr) end if ir = rates_reaction_id_max if (dbg) write(*,*) 'size(reaction_Name,dim=1), ir', size(reaction_Name,dim=1), ir - reaction_Name(ir) = rname + reaction_Name(ir) = rname call integer_dict_define(reaction_names_dict, reaction_Name(ir), ir, ierr) if (ierr /= 0) then write(*,*) 'FATAL ERROR: rates_def_init failed in integer_dict_define' @@ -757,7 +757,7 @@ subroutine read_reaction_parameters(reactionlist_filename, ierr) end if end if - i = 36; j = 70 + i = 36; j = 70 call read_inputs if (ierr /= 0) return @@ -768,44 +768,44 @@ subroutine read_reaction_parameters(reactionlist_filename, ierr) i = 110; j = 127 call read_Q if (ierr /= 0) return - + i = 128; j = 143 call read_Qneu if (ierr /= 0) return - + i = 144; j = 149 call read_ye_rho_exponent1 if (ierr /= 0) return - + i = 150; j = 155 call read_ye_rho_exponent2 if (ierr /= 0) return - + i = 156; j = 160 call read_screening_info(1) if (ierr /= 0) return - + i = 162; j = 166 call read_screening_info(2) if (ierr /= 0) return - + i = 168; j = 172 call read_screening_info(3) if (ierr /= 0) return - + i = 174; j = 178 call read_weak_info(1) if (ierr /= 0) return - + i = 180; j = 184 call read_weak_info(2) if (ierr /= 0) return - + if (std_reaction_neuQs(ir) > 0) then weak_reaction_info(1,ir) = reaction_inputs(2,ir) weak_reaction_info(2,ir) = reaction_outputs(2,ir) end if - + if (std_reaction_neuQs(ir) == 0 .and. & weak_reaction_info(1,ir) > 0 .and. weak_reaction_info(2,ir) > 0) then j = do_get_weak_info_list_id( & @@ -814,7 +814,7 @@ subroutine read_reaction_parameters(reactionlist_filename, ierr) if (j > 0) std_reaction_neuQs(ir) = weak_info_list_Qneu(j) if (ierr /= 0) return end if - + if (std_reaction_neuQs(ir) > 0) then call set_weak_lowT_rate(ir, ierr) if (ierr /= 0) return @@ -823,35 +823,35 @@ subroutine read_reaction_parameters(reactionlist_filename, ierr) i = 190; j = 203 call read_category_id if (ierr /= 0) return - + i = 208 call read_reaction_Info if (ierr /= 0) return - + if (dbg) write(*,*) - + num_reactions = cnt - + end do - + if (dbg) write(*,*) 'num_reactions', num_reactions - + ierr = 0 close(iounit) - + num_reactions = rates_reaction_id_max - + call check_std_reaction_Qs call check_std_reaction_neuQs call check_reaction_categories call check_reaction_info - + if (dbg) call mesa_error(__FILE__,__LINE__,'read_reaction_parameters') - - + + contains - - + + subroutine read_inputs if (dbg) write(*,*) ' inputs <' // line(i:j) // '>',i,j @@ -862,7 +862,7 @@ subroutine read_inputs if (n == 0) exit if (dbg) write(*,*) 'n <' // line(i:j) // '>', i, j reaction_inputs(k,ir) = n - + ! fxt i = j+1; j = i+7 @@ -883,7 +883,7 @@ subroutine read_inputs end do end subroutine read_inputs - + subroutine read_outputs if (dbg) write(*,*) ' outputs: ' // line(i:j) @@ -963,13 +963,13 @@ subroutine read_screening_info(which) integer :: jj ii = read_iso() reaction_screening_info(which,ir) = ii - + !Hack to get around a bug in ifort 17,18, which returns len_trim(line(i:j)) < 0 empty=.true. do jj=i,j if(len_trim(line(jj:jj)) /= 0) empty=.false. end do - + if (ii <= 0 .and. .not. empty) then write(*,'(a)') 'bad iso name for screening in reaction_parameters file <' // line(i:j) // '>' write(*,'(a)') trim(line) @@ -986,16 +986,16 @@ subroutine read_weak_info(which) integer, intent(in) :: which logical :: empty integer :: jj - + ii = read_iso() weak_reaction_info(which,ir) = ii - + !Hack to get around a bug in ifort 7, 18 which returns len_trim(line(i:j)) < 0 empty=.true. do jj=i,j if(len_trim(line(jj:jj)) /= 0) empty=.false. end do - + if (ii <= 0 .and. .not. empty) then write(*,'(a)') 'bad iso name for weak in reaction_parameters file <' // line(i:j) // '>' write(*,'(a)') trim(line) @@ -1036,22 +1036,22 @@ subroutine read_reaction_Info info(j:j) = line(i:i) i = i+1 else - info(j:j) = ' ' + info(j:j) = ' ' end if end do reaction_Info(ir) = info if (dbg) write(*,*) 'info: ' // trim(reaction_Info(ir)) end subroutine read_reaction_Info - - + + integer function read_iso() use chem_def, only: iso_name_length character (len=64) :: str str = line(i:j) read_iso = chem_get_iso_id(str) end function read_iso - - + + integer function read_int() character (len=64) :: str integer :: ierr @@ -1059,8 +1059,8 @@ integer function read_int() read(str,fmt=*,iostat=ierr) read_int if (ierr /= 0) read_int = 0 end function read_int - - + + real(dp) function read_dbl() use math_lib, only: str_to_double integer :: ierr @@ -1072,8 +1072,8 @@ real(dp) function read_dbl() read_dbl = 0d0 end if end function read_dbl - - + + logical function missing_dbl() character (len=64) :: str str = line(i:j) @@ -1087,39 +1087,39 @@ subroutine check_std_reaction_Qs do i=1,num_reactions if (std_reaction_Qs(i) < -1d50) then write(*,*) 'missing reaction_Q for reaction ' // trim(reaction_Name(i)), i, cnt+1 - write(*,*) + write(*,*) cnt = cnt+1 end if end do if (cnt > 0) call mesa_error(__FILE__,__LINE__,'check_std_reaction_Qs') end subroutine check_std_reaction_Qs - - + + subroutine check_std_reaction_neuQs integer :: i, cnt cnt = 0 do i=1,num_reactions if (std_reaction_neuQs(i) < -1d50) then write(*,*) 'missing std_reaction_neuQs for reaction ' // trim(reaction_Name(i)) - write(*,*) + write(*,*) cnt = cnt+1 end if end do if (cnt > 0) call mesa_error(__FILE__,__LINE__,'check_std_reaction_neuQs') end subroutine check_std_reaction_neuQs - - + + subroutine check_reaction_categories integer :: cnt, i cnt = 0 do i=1,num_reactions if (reaction_categories(i) < 0) then write(*,*) 'missing reaction_category for reaction ' // trim(reaction_Name(i)) - write(*,*) + write(*,*) cnt = cnt+1 end if end do - if (cnt > 0) call mesa_error(__FILE__,__LINE__,'check_reaction_categories') + if (cnt > 0) call mesa_error(__FILE__,__LINE__,'check_reaction_categories') end subroutine check_reaction_categories @@ -1130,7 +1130,7 @@ subroutine check_reaction_info if (len_trim(reaction_Info(i)) == 0) then write(*,*) 'missing info for reaction', i if (i > 1) write(*,*) 'following ' // trim(reaction_Info(i-1)) - write(*,*) + write(*,*) cnt = cnt+1 end if end do @@ -1143,28 +1143,28 @@ end subroutine read_reaction_parameters subroutine increase_num_reactions(ierr) integer, intent(out) :: ierr - + integer :: old_max, new_max, i type (rate_table_info), pointer :: old_raw_rates_records(:) =>null() type (rate_table_info), pointer :: ri =>null() - + include 'formats' old_max = rates_reaction_id_max rates_reaction_id_max = rates_reaction_id_max + 1 - + if (rates_reaction_id_max > size(std_reaction_Qs,dim=1)) then - + new_max = rates_reaction_id_max*2 + 1000 !write(*,3) 'increase size', rates_reaction_id_max, new_max - + old_raw_rates_records => raw_rates_records allocate(raw_rates_records(new_max)) do i=1,old_max raw_rates_records(i) = old_raw_rates_records(i) end do deallocate(old_raw_rates_records) - + call grow_reactions_arrays(old_max, new_max, ierr) if (ierr /= 0) return end if @@ -1181,7 +1181,7 @@ end subroutine increase_num_reactions subroutine alloc_and_init_reaction_parameters(ierr) integer, intent(out) :: ierr - + allocate( & reaction_Info(rates_reaction_id_max), & reaction_categories(rates_reaction_id_max), & @@ -1199,7 +1199,7 @@ subroutine alloc_and_init_reaction_parameters(ierr) weak_lowT_rate(rates_reaction_id_max), & stat=ierr) if (ierr /= 0) return - + reaction_Info(:) = '' reaction_categories(:) = -1 reaction_is_reverse(:) = 0 @@ -1214,15 +1214,15 @@ subroutine alloc_and_init_reaction_parameters(ierr) std_reaction_Qs(:) = -1d99 std_reaction_neuQs(:) = -1d99 weak_lowT_rate(:) = -1d99 - + end subroutine alloc_and_init_reaction_parameters - - + + real(dp) function get_Qtotal(ir) use chem_lib, only: reaction_Qtotal use chem_def, only: chem_isos integer, intent(in) :: ir - + integer :: num_in, num_out, reactants(100), k, n, i, ii, j include 'formats' i = 0 @@ -1250,13 +1250,13 @@ real(dp) function get_Qtotal(ir) end function get_Qtotal - - + + subroutine init_rates_info(reactionlist_filename, ierr) character (len=*), intent(in) :: reactionlist_filename - integer, intent(out) :: ierr ! 0 means AOK. + integer, intent(out) :: ierr ! 0 means AOK. include 'formats' - + ierr = 0 call init1_rates_info @@ -1265,7 +1265,7 @@ subroutine init_rates_info(reactionlist_filename, ierr) write(*,*) 'start_rates_def_init failed' return end if - + call read_reaction_parameters(reactionlist_filename, ierr) if (ierr /= 0) then write(*,*) 'rates_init failed in read_reaction_parameters' @@ -1277,11 +1277,11 @@ subroutine init_rates_info(reactionlist_filename, ierr) if (ierr /= 0) then write(*,*) 'rates_init failed in do_rates_init' return - end if - + end if + end subroutine init_rates_info - - + + subroutine init1_rates_info use rates_names, only: set_reaction_names type (rate_table_info), pointer :: ri =>null() @@ -1300,8 +1300,8 @@ subroutine init1_rates_info end do call set_reaction_names end subroutine init1_rates_info - - + + integer function lookup_rate_name(str) ! -1 if not found use rates_def character (len=*), intent(in) :: str @@ -1323,9 +1323,9 @@ subroutine grow_reactions_arrays(old_max, new_max, ierr) character (len=maxlen_reaction_Name), pointer :: new_reaction_Name(:) =>null() character (len=maxlen_reaction_Info), pointer :: new_reaction_Info(:) =>null() integer :: i - + include 'formats' - + allocate(new_reaction_Name(new_max)) do i=1,old_max new_reaction_Name(i) = reaction_Name(i) @@ -1348,9 +1348,9 @@ subroutine grow_reactions_arrays(old_max, new_max, ierr) call realloc_double(std_reaction_Qs,new_max,ierr); if (ierr /= 0) return call realloc_double(std_reaction_neuQs,new_max,ierr); if (ierr /= 0) return - + call realloc_double(weak_lowT_rate,new_max,ierr); if (ierr /= 0) return - + call realloc_integer2( & reaction_screening_info,size( & reaction_screening_info,dim=1),new_max,ierr); if (ierr /= 0) return @@ -1362,7 +1362,7 @@ subroutine grow_reactions_arrays(old_max, new_max, ierr) reaction_inputs,2*max_num_reaction_inputs,new_max,ierr); if (ierr /= 0) return call realloc_integer2( & reaction_outputs,2*max_num_reaction_outputs,new_max,ierr); if (ierr /= 0) return - + reaction_Info(rates_reaction_id_max:new_max) = '' reaction_categories(rates_reaction_id_max:new_max) = -1 @@ -1379,10 +1379,10 @@ subroutine grow_reactions_arrays(old_max, new_max, ierr) std_reaction_Qs(rates_reaction_id_max:new_max) = -1d99 std_reaction_neuQs(rates_reaction_id_max:new_max) = -1d99 weak_lowT_rate(rates_reaction_id_max:new_max) = -1d99 - + end subroutine grow_reactions_arrays - + subroutine free_reaction_arrays() if (ASSOCIATED(reaction_Name)) deallocate(reaction_Name) @@ -1422,7 +1422,7 @@ subroutine free_reaction_arrays() end subroutine free_reaction_arrays - + subroutine do_rates_init(ierr) use ratelib, only: mazurek_init integer, intent(out) :: ierr diff --git a/rates/private/rates_names.f90 b/rates/private/rates_names.f90 index 9f6f8e96f..dd7266e9d 100644 --- a/rates/private/rates_names.f90 +++ b/rates/private/rates_names.f90 @@ -26,19 +26,19 @@ module rates_names use utils_lib, only: mesa_error - + implicit none - - + + contains - + subroutine set_reaction_names use rates_def integer :: i, cnt - + cnt = 0 reaction_Name(:) = '' - + reaction_Name(ir1212) = 'r1212' reaction_Name(ir1216) = 'r1216' reaction_Name(ir1216_to_mg24) = 'r1216_to_mg24' @@ -241,10 +241,10 @@ subroutine set_reaction_names reaction_Name(irneut_to_prot) = 'rneut_to_prot' reaction_Name(irni56ec_to_fe54) = 'rni56ec_to_fe54' reaction_Name(irni56ec_to_fe56) = 'rni56ec_to_fe56' - + reaction_Name(irni56ec_to_co56) = 'rni56ec_to_co56' - reaction_Name(irco56ec_to_fe56) = 'rco56ec_to_fe56' - + reaction_Name(irco56ec_to_fe56) = 'rco56ec_to_fe56' + reaction_Name(irni56gp_aux) = 'rni56gp_aux' reaction_Name(irni56gp_to_fe52) = 'rni56gp_to_fe52' reaction_Name(irni56gprot_aux) = 'rni56gprot_aux' @@ -352,14 +352,14 @@ subroutine set_reaction_names reaction_Name(ir_al26_1_to_al26_2) = 'r_al26-1_to_al26-2' reaction_Name(ir_al26_2_to_al26_1) = 'r_al26-2_to_al26-1' - !reaction_Name(i) = '' + !reaction_Name(i) = '' cnt = 0 do i=1,num_predefined_reactions if (len_trim(reaction_Name(i)) == 0) then write(*,*) 'missing name for reaction', i if (i > 1) write(*,*) 'following ' // trim(reaction_Name(i-1)) - write(*,*) + write(*,*) cnt = cnt+1 end if end do @@ -368,7 +368,7 @@ subroutine set_reaction_names end subroutine set_reaction_names - + end module rates_names diff --git a/rates/private/rates_reverses.f90 b/rates/private/rates_reverses.f90 index c58b7c383..9c5dd6223 100644 --- a/rates/private/rates_reverses.f90 +++ b/rates/private/rates_reverses.f90 @@ -24,15 +24,15 @@ ! *********************************************************************** module rates_reverses - + implicit none - - + + contains - + subroutine set_reaction_reverses use rates_def - + reverse_reaction_id(ir_al27_pa_mg24) = ir_mg24_ap_al27 reverse_reaction_id(ir_mg24_ap_al27) = ir_al27_pa_mg24 @@ -44,7 +44,7 @@ subroutine set_reaction_reverses reverse_reaction_id(ir_b8_gp_be7) = ir_be7_pg_b8 reverse_reaction_id(ir_be7_pg_b8) = ir_b8_gp_be7 - + reverse_reaction_id(ir_c12_ag_o16) = ir_o16_ga_c12 reverse_reaction_id(ir_o16_ga_c12) = ir_c12_ag_o16 @@ -59,7 +59,7 @@ subroutine set_reaction_reverses reverse_reaction_id(ir_c13_an_o16) = ir_n14_gp_c13 reverse_reaction_id(ir_n14_gp_c13) = ir_c13_an_o16 - + reverse_reaction_id(ir_ca40_ag_ti44) = ir_ti44_ga_ca40 reverse_reaction_id(ir_ti44_ga_ca40) = ir_ca40_ag_ti44 @@ -71,7 +71,7 @@ subroutine set_reaction_reverses reverse_reaction_id(ir_f17_ap_ne20) = ir_o16_pg_f17 reverse_reaction_id(ir_o16_pg_f17) = ir_f17_ap_ne20 - + reverse_reaction_id(ir_f17_gp_o16) = ir_o14_ap_f17 reverse_reaction_id(ir_o14_ap_f17) = ir_f17_gp_o16 @@ -85,8 +85,8 @@ subroutine set_reaction_reverses reverse_reaction_id(ir_ne19_gp_f18) = ir_f18_pg_ne19 reverse_reaction_id(ir_f18_pa_o15) = ir_o15_ap_f18 - reverse_reaction_id(ir_o15_ap_f18) = ir_f18_pa_o15 - + reverse_reaction_id(ir_o15_ap_f18) = ir_f18_pa_o15 + reverse_reaction_id(ir_f19_gp_o18) = ir_o18_pg_f19 reverse_reaction_id(ir_o18_pg_f19) = ir_f19_gp_o18 @@ -104,16 +104,16 @@ subroutine set_reaction_reverses reverse_reaction_id(ir_mg24_ga_ne20) = ir_ne20_ag_mg24 reverse_reaction_id(ir_ne20_ag_mg24) = ir_mg24_ga_ne20 - + reverse_reaction_id(ir_n13_pg_o14) = ir_o14_gp_n13 reverse_reaction_id(ir_o14_gp_n13) = ir_n13_pg_o14 - + reverse_reaction_id(ir_n14_ap_o17) = ir_o17_pa_n14 reverse_reaction_id(ir_o17_pa_n14) = ir_n14_ap_o17 reverse_reaction_id(ir_n14_pg_o15) = ir_o15_gp_n14 reverse_reaction_id(ir_o15_gp_n14) = ir_n14_pg_o15 - + reverse_reaction_id(ir_n15_ap_o18) = ir_o18_pa_n15 reverse_reaction_id(ir_o18_pa_n15) = ir_n15_ap_o18 @@ -122,49 +122,49 @@ subroutine set_reaction_reverses reverse_reaction_id(ir_na23_pa_ne20) = ir_ne20_ap_na23 reverse_reaction_id(ir_ne20_ap_na23) = ir_na23_pa_ne20 - + reverse_reaction_id(ir_ne19_ga_o15) = ir_o15_ag_ne19 reverse_reaction_id(ir_o15_ag_ne19) = ir_ne19_ga_o15 reverse_reaction_id(ir_ne20_ga_o16) = ir_o16_ag_ne20 reverse_reaction_id(ir_o16_ag_ne20) = ir_ne20_ga_o16 - + reverse_reaction_id(ir_s32_ga_si28) = ir_si28_ag_s32 reverse_reaction_id(ir_si28_ag_s32) = ir_s32_ga_si28 - + reverse_reaction_id(irc12ap_to_o16) = iro16gp_to_c12 reverse_reaction_id(iro16gp_to_c12) = irc12ap_to_o16 - + reverse_reaction_id(iro16ap_to_ne20) = irne20gp_to_o16 reverse_reaction_id(irne20gp_to_o16) = iro16ap_to_ne20 - + reverse_reaction_id(irne20ap_to_mg24) = irmg24gp_to_ne20 reverse_reaction_id(irmg24gp_to_ne20) = irne20ap_to_mg24 - + reverse_reaction_id(irmg24ap_to_si28) = irsi28gp_to_mg24 reverse_reaction_id(irsi28gp_to_mg24) = irmg24ap_to_si28 - + reverse_reaction_id(irsi28ap_to_s32) = irs32gp_to_si28 reverse_reaction_id(irs32gp_to_si28) = irsi28ap_to_s32 - + reverse_reaction_id(irs32ap_to_ar36) = irar36gp_to_s32 reverse_reaction_id(irar36gp_to_s32) = irs32ap_to_ar36 - + reverse_reaction_id(irar36ap_to_ca40) = irca40gp_to_ar36 reverse_reaction_id(irca40gp_to_ar36) = irar36ap_to_ca40 - + reverse_reaction_id(irca40ap_to_ti44) = irti44gp_to_ca40 reverse_reaction_id(irti44gp_to_ca40) = irca40ap_to_ti44 - + reverse_reaction_id(irti44ap_to_cr48) = ircr48gp_to_ti44 reverse_reaction_id(ircr48gp_to_ti44) = irti44ap_to_cr48 - + reverse_reaction_id(ircr48ap_to_fe52) = irfe52gp_to_cr48 reverse_reaction_id(irfe52gp_to_cr48) = ircr48ap_to_fe52 - + reverse_reaction_id(irfe54ng_to_fe56) = irfe56gn_to_fe54 reverse_reaction_id(irfe56gn_to_fe54) = irfe54ng_to_fe56 - + reverse_reaction_id(irfe52neut_to_fe54) = irfe54g_to_fe52 reverse_reaction_id(irfe54g_to_fe52) = irfe52neut_to_fe54 @@ -173,7 +173,7 @@ subroutine set_reaction_reverses end subroutine set_reaction_reverses - + end module rates_reverses diff --git a/rates/private/rates_support.f90 b/rates/private/rates_support.f90 index 9fc001279..fbf466722 100644 --- a/rates/private/rates_support.f90 +++ b/rates/private/rates_support.f90 @@ -28,14 +28,14 @@ module rates_support use math_lib use rates_def use utils_lib, only: mv, switch_str, mesa_error - + implicit none integer, parameter :: cache_version = 4 - - + + contains - + subroutine do_get_raw_rates( & num_reactions, reaction_id, rattab, rattab_f1, nT8s, & ye, logtemp_in, btemp, bden, raw_rate_factor, logttab, & @@ -48,13 +48,13 @@ subroutine do_get_raw_rates( & real(dp), pointer, intent(in) :: rattab_f1(:) real(dp), intent(inout), dimension(:) :: rate_raw, rate_raw_dT, rate_raw_dRho integer, intent(out) :: ierr - + integer :: imax, iat0, iat, ir, i, irho integer, parameter :: mp = 4 real(dp), allocatable :: dtab(:), ddtab(:) - real(dp), pointer :: rattab_f(:,:,:) + real(dp), pointer :: rattab_f(:,:,:) real(dp) :: logtemp, fac - + include 'formats' ierr = 0 @@ -65,7 +65,7 @@ subroutine do_get_raw_rates( & rattab_f(1:4,1:nT8s,1:num_reactions) => rattab_f1(1:4*nT8s*num_reactions) do i = 1,num_reactions - + ir = reaction_id(i) !dtab(i) = ye**reaction_ye_rho_exponents(1,ir) select case(reaction_ye_rho_exponents(1,ir)) @@ -91,21 +91,21 @@ subroutine do_get_raw_rates( & end select ddtab(i) = irho*dtab(i)/bden - + end do - + if(warn_rates_for_high_temp .and. logtemp_in .ge. max_safe_logT_for_rates) then write(*,'(A,F0.6,A,F0.6,A)') "WARNING: evaluating rates with lgT=",logtemp_in," which is above lgT=",& max_safe_logT_for_rates,", rates have been truncated" end if - - + + if(logtemp_in .ge. max_safe_logT_for_rates) then logtemp = max_safe_logT_for_rates else logtemp = logtemp_in end if - + if (nrattab > 1) then imax = nrattab if (logtemp > rattab_thi) then @@ -131,31 +131,31 @@ subroutine do_get_raw_rates( & call mesa_error(__FILE__,__LINE__) end if end do - + do i=1,num_reactions fac = raw_rate_factor(i) rate_raw(i) = rate_raw(i)*fac rate_raw_dT(i) = rate_raw_dT(i)*fac rate_raw_dRho(i) = rate_raw_dRho(i)*fac end do - + if(logtemp .ge. max_safe_logT_for_rates) then rate_raw_dT(1:num_reactions) = 0d0 end if nullify(rattab_f) - + contains - + subroutine get_rates_from_table(r1, r2) use const_def, only: ln10 integer, intent(in) :: r1, r2 - + integer :: i, k real(dp) :: dt - + include 'formats' - + k = iat+1 ! starting guess for search do while (logtemp < logttab(k) .and. k > 1) k = k-1 @@ -164,9 +164,9 @@ subroutine get_rates_from_table(r1, r2) k = k+1 end do dt = logtemp - logttab(k) - + do i = r1,r2 - + rate_raw(i) = & (rattab_f(1,k,i) + dt*(rattab_f(2,k,i) + & dt*(rattab_f(3,k,i) + dt*rattab_f(4,k,i))) & @@ -180,16 +180,16 @@ subroutine get_rates_from_table(r1, r2) ) * dtab(i) / (btemp * ln10) end do - + end subroutine get_rates_from_table - - + + end subroutine do_get_raw_rates - + subroutine do_make_rate_tables( & num_reactions, cache_suffix, net_reaction_id, & - rattab, rattab_f1, nT8s, ttab, logttab, ierr) + rattab, rattab_f1, nT8s, ttab, logttab, ierr) use const_def use interp_1d_lib, only: interp_pm, interp_m3q use interp_1d_def, only: pm_work_size, mp_work_size @@ -199,7 +199,7 @@ subroutine do_make_rate_tables( & real(dp) :: rattab(:,:), ttab(:), logttab(:) real(dp), pointer :: rattab_f1(:) integer, intent(out) :: ierr - + integer :: i, j, operr, num_to_add_to_cache,thread_num real(dp) :: logT, btemp real(dp), pointer :: work1(:)=>null(), f1(:)=>null(), rattab_f(:,:,:)=>null() @@ -207,17 +207,17 @@ subroutine do_make_rate_tables( & real(dp), allocatable, target :: work(:,:) logical :: all_okay, a_okay, all_in_cache - + include 'formats' - + ierr = 0 - + rattab_f(1:4,1:nrattab,1:num_reactions) => & rattab_f1(1:4*nrattab*num_reactions) - + allocate(reaction_id(num_reactions)) reaction_id(:) = net_reaction_id(:) - + num_to_add_to_cache = 0 if (nrattab == 1) then all_in_cache = .false. @@ -235,9 +235,9 @@ subroutine do_make_rate_tables( & !stop end do end if - + if (all_in_cache) then - + !$OMP PARALLEL DO PRIVATE(i, logT, btemp) do i=1, nrattab logT = rattab_tlo + real(i-1,kind=dp)*rattab_tstp @@ -247,15 +247,15 @@ subroutine do_make_rate_tables( & end do !$OMP END PARALLEL DO - else - + else + if (num_to_add_to_cache > 20) then write(*,2) 'number not already in cache:', num_to_add_to_cache if (num_to_add_to_cache > 100) write(*,*) 'this will take some time .....' end if all_okay = .true. !x$OMP PARALLEL DO PRIVATE(i, operr, logT, btemp, a_okay, j) - ! Disable parralisation as this can cause bugs in the + ! Disable parralisation as this can cause bugs in the ! load tables See github bug #360 do i=1, nrattab logT = rattab_tlo + real(i-1,kind=dp)*rattab_tstp @@ -313,19 +313,19 @@ subroutine do_make_rate_tables( & !$OMP END PARALLEL DO deallocate(work) end if - + if (ierr == 0 .and. nrattab > 1 .and. .not. all_in_cache) then do i=1, num_reactions if (reaction_id(i) <= 0) cycle - call write_reaction_to_cache(reaction_id, cache_suffix, i, rattab) + call write_reaction_to_cache(reaction_id, cache_suffix, i, rattab) end do end if - + deallocate(reaction_id) end subroutine do_make_rate_tables - - + + subroutine reaction_filename(ir, cache_suffix, which, cache_filename, temp_cache_filename, ierr) integer, intent(in) :: ir, which character (len=*), intent(in) :: cache_suffix @@ -350,61 +350,61 @@ subroutine reaction_filename(ir, cache_suffix, which, cache_filename, temp_cache write(cache_filename,'(a)') & trim(rates_cache_dir) // '/' // & trim(reaction_Name(ir)) // '_' // trim(suffix) // '.bin' - + write(temp_cache_filename,'(a)') & trim(rates_temp_cache_dir) // '/' // & trim(reaction_Name(ir)) // '_' // trim(suffix) // '.bin' end subroutine reaction_filename - - - logical function read_reaction_from_cache(reaction_id, cache_suffix, i, rattab) + + + logical function read_reaction_from_cache(reaction_id, cache_suffix, i, rattab) integer, intent(in) :: i, reaction_id(:) character (len=*), intent(in) :: cache_suffix real(dp),intent(out) :: rattab(:,:) - + integer :: file_version, file_nrattab, file_which real(dp) :: file_rattab_thi, file_rattab_tlo, file_rattab_tstp character (len=256) :: cache_filename, temp_cache_filename integer :: io_unit, ios, ir, which, j, ierr, rir real(dp), parameter :: tiny = 1d-6 character (len=maxlen_reaction_Name) :: name - + logical, parameter :: show_read_cache = .false. logical :: reverse_is_table ierr = 0 read_reaction_from_cache = .false. if (.not. rates_use_cache) return - + ir = reaction_id(i) which = 1 - + reverse_is_table = .false. rir = reverse_reaction_id(ir) if(rir>0) reverse_is_table = raw_rates_records(reverse_reaction_id(ir))% use_rate_table - - + + if (raw_rates_records(ir)% use_rate_table .or. reverse_is_table) then which = 0 !Dont read a cached version of a users local rate return end if - + call reaction_filename(reaction_id(i), cache_suffix, which, cache_filename, temp_cache_filename, ierr) if (ierr /= 0) then if (show_read_cache) write(*,*) 'read cache -- bad reaction_filename ' // trim(cache_filename) return - end if - + end if + ios = 0 open(newunit=io_unit,file=trim(cache_filename),action='read', & status='old',iostat=ios,form='unformatted') if (ios /= 0) then if (show_read_cache) write(*,*) 'read cache failed for open ' // trim(cache_filename) return - end if - + end if + read(io_unit, iostat=ios) & name, file_which, file_version, file_nrattab, & file_rattab_thi, file_rattab_tlo, file_rattab_tstp @@ -412,20 +412,20 @@ logical function read_reaction_from_cache(reaction_id, cache_suffix, i, rattab) if (show_read_cache) write(*,*) 'read cache failed for read header ' // trim(cache_filename) close(io_unit) return - end if - + end if + if (name /= reaction_Name(ir)) then if (show_read_cache) write(*,*) 'read cache failed for name' close(io_unit) return end if - + if (which /= file_which) then if (show_read_cache) write(*,*) 'read cache failed for which reaction' close(io_unit) return end if - + if (cache_version /= file_version) then if (show_read_cache) write(*,*) 'read cache failed for version' close(io_unit) @@ -449,7 +449,7 @@ logical function read_reaction_from_cache(reaction_id, cache_suffix, i, rattab) close(io_unit) return end if - + do j = 1, nrattab read(io_unit, iostat=ios) rattab(i,j) if (ios /= 0) then @@ -457,17 +457,17 @@ logical function read_reaction_from_cache(reaction_id, cache_suffix, i, rattab) close(io_unit) return end if - end do - + end do + close(io_unit) - + read_reaction_from_cache = .true. - + end function read_reaction_from_cache - - - - subroutine write_reaction_to_cache(reaction_id, cache_suffix, i, rattab) + + + + subroutine write_reaction_to_cache(reaction_id, cache_suffix, i, rattab) integer, intent(in) :: i character (len=*), intent(in) :: cache_suffix integer, intent(in) :: reaction_id(:) @@ -475,30 +475,30 @@ subroutine write_reaction_to_cache(reaction_id, cache_suffix, i, rattab) character (len=256) :: cache_filename, temp_cache_filename integer :: io_unit, ios, ir, which, ierr, j, rir - + logical, parameter :: show_write_cache = .true. logical :: reverse_is_table - + ierr = 0 if (.not. rates_use_cache) return - + ir = reaction_id(i) which = 1 reverse_is_table = .false. rir = reverse_reaction_id(ir) if(rir>0) reverse_is_table = raw_rates_records(reverse_reaction_id(ir))% use_rate_table - + if (raw_rates_records(ir)% use_rate_table .or. reverse_is_table) which = 0 - - ! Write cache file to temporary storage that is local to the run, - ! then at the end move the file atomicly to the final cache location + + ! Write cache file to temporary storage that is local to the run, + ! then at the end move the file atomicly to the final cache location call reaction_filename(reaction_id(i), cache_suffix, which, cache_filename, temp_cache_filename, ierr) if (ierr /= 0) return - - ios = 0 + + ios = 0 open(newunit=io_unit, file=trim(switch_str(temp_cache_filename, cache_filename, use_mesa_temp_cache)),& iostat=ios, action='write', form='unformatted') if (ios /= 0) then @@ -507,26 +507,26 @@ subroutine write_reaction_to_cache(reaction_id, cache_suffix, i, rattab) end if if (show_write_cache) write(*,'(a)') 'write ' // trim(cache_filename) - + write(io_unit) & reaction_Name(ir), which, cache_version, nrattab, & rattab_thi, rattab_tlo, rattab_tstp do j = 1, nrattab write(io_unit) rattab(i,j) - end do + end do close(io_unit) if(use_mesa_temp_cache) call mv(temp_cache_filename,cache_filename,.true.) - - + + end subroutine write_reaction_to_cache - - subroutine do_show_reaction_from_cache(cache_filename, ierr) + + subroutine do_show_reaction_from_cache(cache_filename, ierr) character (len=*) :: cache_filename integer, intent(out) :: ierr - + integer :: version, nrattab, which real(dp) :: rattab_thi, rattab_tlo, rattab_tstp, rate, T8, logT integer :: ios, j, io_unit @@ -540,8 +540,8 @@ subroutine do_show_reaction_from_cache(cache_filename, ierr) if (ios /= 0) then write(*,*) 'read cache failed for open ' // trim(cache_filename) return - end if - + end if + read(io_unit, iostat=ios) & name, which, version, nrattab, & rattab_thi, rattab_tlo, rattab_tstp @@ -549,12 +549,12 @@ subroutine do_show_reaction_from_cache(cache_filename, ierr) write(*,*) 'read cache failed for read header ' // trim(cache_filename) close(io_unit) return - end if - + end if + write(*,'(a)') '# T8 rate' write(*,'(A)') write(*,*) nrattab - + do j = 1, nrattab read(io_unit, iostat=ios) rate if (ios /= 0) then @@ -565,11 +565,11 @@ subroutine do_show_reaction_from_cache(cache_filename, ierr) logT = rattab_tlo + dble(j-1)*rattab_tstp T8 = exp10(logT - 8d0) write(*,'(1pe26.16,3x,1pe26.16e3)') T8, rate - end do + end do write(*,'(A)') - + close(io_unit) - + end subroutine do_show_reaction_from_cache @@ -583,12 +583,12 @@ subroutine get_net_rates_for_tables( & integer, intent(in) :: num_reactions, reaction_id(:) real(dp), intent(inout) :: rates(:) integer, intent(out) :: ierr - + integer :: i, ir type (T_Factors) :: tf include 'formats' - + ierr = 0 call tfactors(tf, logT, btemp) @@ -604,10 +604,10 @@ subroutine get_net_rates_for_tables( & call mesa_error(__FILE__,__LINE__,'get_net_rates_for_tables') end if end do - + end subroutine get_net_rates_for_tables - - + + subroutine do_eval_reaclib_21( & ir, temp, den, rate_raw, reverse_rate_raw, ierr) use raw_rates, only: get_reaclib_rate_and_dlnT @@ -615,29 +615,29 @@ subroutine do_eval_reaclib_21( & real(dp), intent(in) :: temp, den real(dp), intent(inout) :: rate_raw(:), reverse_rate_raw(:) integer, intent(out) :: ierr - + real(dp) :: lambda, dlambda_dlnT, rlambda, drlambda_dlnT - + include 'formats' - + ierr = 0 call get_reaclib_rate_and_dlnT( & ir, temp, lambda, dlambda_dlnT, rlambda, drlambda_dlnT, ierr) if (ierr /= 0) return - + if (reaction_ye_rho_exponents(2,ir) /= 1) then ierr = -1 return end if - + rate_raw(i_rate) = lambda*den rate_raw(i_rate_dT) = dlambda_dlnT*den/temp rate_raw(i_rate_dRho) = lambda - + reverse_rate_raw(i_rate) = rlambda reverse_rate_raw(i_rate_dT) = drlambda_dlnT/temp reverse_rate_raw(i_rate_dRho) = 0d0 - + return !$omp critical (rates_eval_reaclib_21) @@ -655,10 +655,10 @@ subroutine do_eval_reaclib_21( & write(*,1) 'reverse_rate_raw', reverse_rate_raw(1:num_rvs) write(*,'(A)') !$omp end critical (rates_eval_reaclib_21) - + end subroutine do_eval_reaclib_21 - + subroutine do_eval_reaclib_22( & ir, temp, den, rate_raw, reverse_rate_raw, ierr) use raw_rates, only: get_reaclib_rate_and_dlnT @@ -666,29 +666,29 @@ subroutine do_eval_reaclib_22( & real(dp), intent(in) :: temp, den real(dp), intent(inout) :: rate_raw(:), reverse_rate_raw(:) integer, intent(out) :: ierr - + real(dp) :: lambda, dlambda_dlnT, rlambda, drlambda_dlnT - + include 'formats' - + ierr = 0 call get_reaclib_rate_and_dlnT( & ir, temp, lambda, dlambda_dlnT, rlambda, drlambda_dlnT, ierr) if (ierr /= 0) return - + if (reaction_ye_rho_exponents(2,ir) /= 1) then ierr = -1 return end if - + rate_raw(i_rate) = lambda*den rate_raw(i_rate_dT) = dlambda_dlnT*den/temp rate_raw(i_rate_dRho) = lambda - + reverse_rate_raw(i_rate) = rlambda*den reverse_rate_raw(i_rate_dT) = drlambda_dlnT*den/temp reverse_rate_raw(i_rate_dRho) = rlambda - + return !$omp critical (rates_eval_reaclib_22) @@ -707,9 +707,9 @@ subroutine do_eval_reaclib_22( & write(*,'(A)') !call mesa_error(__FILE__,__LINE__,'do_eval_reaclib_22') !$omp end critical (rates_eval_reaclib_22) - + end subroutine do_eval_reaclib_22 - + end module rates_support diff --git a/rates/private/raw_rates.f90 b/rates/private/raw_rates.f90 index bf327a8f8..068035245 100644 --- a/rates/private/raw_rates.f90 +++ b/rates/private/raw_rates.f90 @@ -5,14 +5,14 @@ ! MESA is free software; you can use it and/or modify ! it under the combined terms and restrictions of the MESA MANIFESTO ! and the GNU General Library Public License as published -! by the Free Software Foundation; either version 2 of the License, +! by the Free Software Foundation; either version 2 of the License, ! or (at your option) any later version. ! ! You should have received a copy of the MESA MANIFESTO along with ! this software; if not, it is available at the mesa website: ! http://mesa.sourceforge.net/ ! -! MESA is distributed in the hope that it will be useful, +! MESA is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ! See the GNU Library General Public License for more details. @@ -24,10 +24,10 @@ ! *********************************************************************** module raw_rates - + use rates_def use const_def !, only: missing_value, dp - + implicit none abstract interface @@ -39,13 +39,13 @@ subroutine rate_fcn(tf, temp, fr, rr) real(dp), intent(out) :: fr, rr end subroutine rate_fcn end interface - + logical, parameter :: show_rates = .false. - + contains - - + + subroutine set_raw_rates(n, irs, temp, tf, rates, ierr) use rates_def, only : T_Factors integer, intent(in) :: n @@ -70,7 +70,7 @@ subroutine set_raw_rates(n, irs, temp, tf, rates, ierr) end do end subroutine set_raw_rates - + subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) use ratelib @@ -85,7 +85,7 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) real(dp) :: rr include 'formats' - + ierr = 0 ! See if the rate or its reverse is being loaded from a rate_table @@ -101,7 +101,7 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) if (raw_rates_records(rir)% use_rate_table) then reaclib_id_ir = do_reaclib_lookup(reaction_name(ir), reaclib_rates% reaction_dict) ! if ir == a reverse rate (e.g r_o16_ga_c12) will have reaclib_id_ir == 0 - ! if ir == a forward rate (e.g r_c12_ag_o16) will have reaclib_id_ir /= 0 + ! if ir == a forward rate (e.g r_c12_ag_o16) will have reaclib_id_ir /= 0 if(reaclib_id_ir == 0 ) then ! We want a reverse rate from a forward table @@ -117,7 +117,7 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) call mesa_error(__FILE__,__LINE__) return end if - end if + end if else if (raw_rates_records(ir)% use_rate_table) then ! Only ir is set as a table rate and rate does not have a reverse call eval_table(ir, tf, temp, raw_rate, rr, ierr) @@ -127,9 +127,9 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) select case(ir) - case(ir_he4_he4_he4_to_c12) ! triple alpha to c12 + case(ir_he4_he4_he4_to_c12) ! triple alpha to c12 call do1(rate_tripalf_jina) - + case(ir_c12_to_he4_he4_he4) ! c12 to 3 alpha call do1_reverse(rate_tripalf_jina) @@ -142,7 +142,7 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(ir1212) ! c12(c12,n)mg23, c12(c12,p)na23, c12(c12,a)ne20 call do1(rate_c12c12_fxt_multi) ! NOTE: Gasques option for c12+c12 is implemented in net, not in rates. - + case(ir1216) call do1(rate_c12o16_fxt) @@ -155,20 +155,20 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(ir1216_to_si28) ! ! c12 + o16 -> si28 call do1(rate_c12o16p_jina) - case(ir1616a) ! o16(o16, a)si28 + case(ir1616a) ! o16(o16, a)si28 call do1(rate_o16o16a_jina) - case(ir1616g) ! o16(o16, g)s32 + case(ir1616g) ! o16(o16, g)s32 ! no jina rate call do1(rate_o16o16g_fxt) case(ir1616p_aux) ! o16(o16, p)p31 call do1(rate_o16o16p_jina) - case(ir1616ppa) ! o16(o16, p)p31(p, a)si28 + case(ir1616ppa) ! o16(o16, p)p31(p, a)si28 call do1(rate_o16o16p_jina) - case(ir1616ppg) ! o16(o16, p)p31(p, g)s32 + case(ir1616ppg) ! o16(o16, p)p31(p, g)s32 call do1(rate_o16o16p_jina) case(ir_he3_ag_be7) ! he3(he4, g)be7 @@ -187,7 +187,7 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(ir_be7_wk_li7) ! be7(e-, nu)li7 ! This is now actually handled by a custom rate call do1(rate_be7em_fxt) - + case(ir_c12_pg_n13) call do1(rate_c12pg_nacre) @@ -235,7 +235,7 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(ir_n14_gp_c13) ! n14(g, p)c13 call do1_reverse(rate_c13pg_nacre) - + case(ir_n14_pg_o15) call do1(rate_n14pg_nacre) @@ -263,7 +263,7 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(ir_o18_pa_n15) ! o18(p, a)n15 and n15(a, p)o18 call do1(rate_o18pa_nacre) - case(iral27pa_aux) ! al27(p, a)mg24 + case(iral27pa_aux) ! al27(p, a)mg24 call do1_reverse(rate_mg24ap_jina) case(iral27pg_aux) ! al27(p, g)si28 @@ -272,16 +272,16 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(irar36ap_aux) ! ar36(a, p)k39 call do1(rate_ar36ap_jina) - case(irar36ap_to_ca40) + case(irar36ap_to_ca40) call do1(rate_ar36ap_jina) case(irar36gp_aux) ! ar36(g, p)cl35 call do1_reverse(rate_cl35pg_jina) - case(irar36gp_to_s32) + case(irar36gp_to_s32) call do1_reverse(rate_cl35pg_jina) - case(irbe7ec_li7_aux) ! be7(e-, nu)li7(p, a)he4 + case(irbe7ec_li7_aux) ! be7(e-, nu)li7(p, a)he4 call do1(rate_be7em_fxt) case(irbe7pg_b8_aux) ! be7(p, g)b8(e+, nu)be8(, a)he4 @@ -299,40 +299,40 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(irc12ap_to_o16) ! c12(a, p)n15(p, g)o16 call do1_reverse(rate_n15pa_jina) - case(irca40ap_aux) ! ca40(a, p)sc43 + case(irca40ap_aux) ! ca40(a, p)sc43 call do1(rate_ca40ap_jina) case(irca40ap_to_ti44) call do1(rate_ca40ap_jina) - case(irca40gp_aux) ! ca40(g, p)k39 + case(irca40gp_aux) ! ca40(g, p)k39 call do1_reverse(rate_k39pg_jina) - case(irca40gp_to_ar36) + case(irca40gp_to_ar36) call do1_reverse(rate_k39pg_jina) - case(ircl35pa_aux) ! cl35(p, a)s32 + case(ircl35pa_aux) ! cl35(p, a)s32 call do1_reverse(rate_s32ap_jina) case(ircl35pg_aux) ! cl35(p, g)ar36 call do1(rate_cl35pg_jina) - case(irco55gprot_aux) ! co55(g, prot)fe54 + case(irco55gprot_aux) ! co55(g, prot)fe54 call do1_reverse(rate_fe54pg_jina) - case(irco55pg_aux) ! co55(p, g)ni56 + case(irco55pg_aux) ! co55(p, g)ni56 call do1(rate_co55pg_jina) - case(irco55protg_aux) ! co55(prot, g)ni56 + case(irco55protg_aux) ! co55(prot, g)ni56 call do1(rate_co55pg_jina) - case(ircr48ap_aux) ! cr48(a, p)mn51 + case(ircr48ap_aux) ! cr48(a, p)mn51 call do1(rate_cr48ap_jina) case(ircr48ap_to_fe52) call do1(rate_cr48ap_jina) - case(ircr48gp_aux) ! cr48(g, p)v47 + case(ircr48gp_aux) ! cr48(g, p)v47 call do1_reverse(rate_v47pg_jina) case(ircr48gp_to_ti44) @@ -341,13 +341,13 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(irf19pg_aux) ! f19(p, g)ne20 call do1(rate_f19pg_jina) - case(irfe52ap_aux) ! fe52(a, p)co55 + case(irfe52ap_aux) ! fe52(a, p)co55 call do1(rate_fe52ap_jina) case(irfe52ap_to_ni56) ! fe52(a, p)co55(p, g)ni56 call do1(rate_fe52ap_jina) - case(irfe52aprot_aux) ! fe52(a, prot)co55 + case(irfe52aprot_aux) ! fe52(a, prot)co55 call do1(rate_fe52ap_jina) case(irfe52aprot_to_fe54) ! fe52(a, prot)co55(g, prot)fe54 @@ -356,7 +356,7 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(irfe52aprot_to_ni56) ! fe52(a, prot)co55(prot, g)ni56 call do1(rate_fe52ap_jina) - case(irfe52gp_aux) ! fe52(g, p)mn51 + case(irfe52gp_aux) ! fe52(g, p)mn51 call do1_reverse(rate_mn51pg_jina) case(irfe52gp_to_cr48) @@ -377,19 +377,19 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(irfe54a_to_ni56) ! fe54 + alpha -> ni56 + 2 neut call do1(rate_fe54a_jina) - case(irfe54an_aux) ! fe54(a,n)ni57 + case(irfe54an_aux) ! fe54(a,n)ni57 call do1(rate_fe54an_jina) case(irfe54an_to_ni56) ! fe54(a,n)ni57(g,n)ni56 - call do1(rate_fe54an_jina) + call do1(rate_fe54an_jina) case(irfe54aprot_to_fe56) ! fe54(a, prot)co57(g, prot)fe56 - call do1(rate_fe54ap_jina) + call do1(rate_fe54ap_jina) case(irfe54g_to_fe52) ! fe54(g, neut)fe53(g, neut)fe52 call do1_reverse(rate_fe53ng_jina) - case(irfe54ng_aux) ! fe54(neut, g)fe55 + case(irfe54ng_aux) ! fe54(neut, g)fe55 call do1(rate_fe54ng_jina) case(irfe54ng_to_fe56) ! fe54(neut, g)fe55(neut, g)fe56 @@ -399,15 +399,15 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) raw_rate = -1 ! rate calculated by special routine. case(irfe54prot_to_ni56) ! fe54(prot, g)co55(prot, g)ni56 - raw_rate = -1 ! rate calculated by special routine. + raw_rate = -1 ! rate calculated by special routine. case(irfe54protg_aux) ! fe54(prot, g)co55 call do1(rate_fe54pg_jina) - case(irfe55gn_aux) ! fe55(g, neut)fe54 + case(irfe55gn_aux) ! fe55(g, neut)fe54 call do1_reverse(rate_fe54ng_jina) - case(irfe55ng_aux) ! fe55(neut, g)fe56 + case(irfe55ng_aux) ! fe55(neut, g)fe56 call do1(rate_fe55ng_jina) case(irfe56ec_fake_to_mn56) @@ -452,7 +452,7 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(irfe56ee_to_ni56) raw_rate = -1 ! rate calculated by special routine. - case(irfe56gn_aux) ! fe56(g, neut)fe55 + case(irfe56gn_aux) ! fe56(g, neut)fe55 call do1_reverse(rate_fe55ng_jina) case(irfe56gn_to_fe54) ! fe56(g, neut)fe55(g, neut)fe54 @@ -485,22 +485,22 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(irk39pa_aux) ! k39(p, a)ar36 call do1_reverse(rate_ar36ap_jina) - case(irk39pg_aux) ! k39(p, g)ca40 + case(irk39pg_aux) ! k39(p, g)ca40 call do1(rate_k39pg_jina) - case(irmg24ap_aux) ! mg24(a, p)al27 + case(irmg24ap_aux) ! mg24(a, p)al27 call do1(rate_mg24ap_jina) case(irmg24ap_to_si28) call do1(rate_mg24ap_jina) - case(irmg24gp_aux) ! mg24(g, p)na23 + case(irmg24gp_aux) ! mg24(g, p)na23 call do1_reverse(rate_na23pg_jina) - case(irmg24gp_to_ne20) ! mg24(g, p)na23(p, a)ne20 + case(irmg24gp_to_ne20) ! mg24(g, p)na23(p, a)ne20 call do1_reverse(rate_na23pg_jina) - case(irmn51pg_aux) ! mn51(p, g)fe52 + case(irmn51pg_aux) ! mn51(p, g)fe52 call do1(rate_mn51pg_jina) case(irn14_to_c12) ! n14(p, g)o15(e+nu)n15(p, a)c12 @@ -530,10 +530,10 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(irn15pg_aux) ! n15(p, g)o16 call do1(rate_n15pg_jina) - case(irna23pa_aux) ! na23(p, a)ne20 + case(irna23pa_aux) ! na23(p, a)ne20 call do1(rate_na23pa_jina) - case(irna23pg_aux) ! na23(p, g)mg24 + case(irna23pg_aux) ! na23(p, g)mg24 call do1(rate_na23pg_jina) case(irne18ag_to_mg24) ! ne18(a, g)mg22 -> mg24 @@ -545,7 +545,7 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(irne18ap_to_mg24) ! ne18(a, p)na21(p, g)mg22 -> mg24 call do1(rate_ne18ap_jina) - case(irne19pg_to_mg22) ! ne19(p, g)na20(p, g)mg21(e+nu)na21(p, g)mg22 + case(irne19pg_to_mg22) ! ne19(p, g)na20(p, g)mg21(e+nu)na21(p, g)mg22 call do1(rate_ne19pg_jina) case(irne19pg_to_mg24) ! ne19(p, g)na20(p, g)mg21(e+nu)na21(p, g)mg22 -> mg24 @@ -563,7 +563,7 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(irne20gp_to_o16) ! ne20(g, p)f19(p, a)o16 call do1_reverse(rate_f19pg_jina) - case(irne20pg_to_mg22) ! ne20(p, g)na21(p, g)mg22 + case(irne20pg_to_mg22) ! ne20(p, g)na21(p, g)mg22 call do1(rate_ne20pg_nacre) case(irne20pg_to_mg24) ! ne20(p, g)na21(p, g)mg22 -> mg24 @@ -584,25 +584,25 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(irco56ec_to_fe56) raw_rate = -1 ! rate calculated by special routine. - case(irni56gp_aux) ! ni56(g, p)co55 + case(irni56gp_aux) ! ni56(g, p)co55 call do1_reverse(rate_co55pg_jina) - case(irni56gp_to_fe52) ! ni56(g, p)co55(p, a)fe52 + case(irni56gp_to_fe52) ! ni56(g, p)co55(p, a)fe52 raw_rate = -1 ! rate calculated by special routine. - case(irni56gprot_aux) ! ni56(g, prot)co55 + case(irni56gprot_aux) ! ni56(g, prot)co55 call do1_reverse(rate_co55pg_jina) - case(irni56gprot_to_fe52) ! ni56(g, prot)co55(prot, a)fe52 + case(irni56gprot_to_fe52) ! ni56(g, prot)co55(prot, a)fe52 raw_rate = -1 ! rate calculated by special routine. - case(irni56gprot_to_fe54) ! ni56(g, prot)co55(g, prot)fe54 + case(irni56gprot_to_fe54) ! ni56(g, prot)co55(g, prot)fe54 raw_rate = -1 ! rate calculated by special routine. case(irni56ng_to_fe54) ! ni56(n,g)ni57(n,a)fe54 raw_rate = -1 ! rate calculated by special routine. - case(irni57na_aux) ! ni57(n,a)fe54 + case(irni57na_aux) ! ni57(n,a)fe54 call do1_reverse(rate_fe54an_jina) case(iro16_to_n14) ! o16(p, g)f17(e+nu)o17(p, a)n14 @@ -617,7 +617,7 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(iro16ap_to_ne20) ! o16(a, p)f19(p, a)ne20 call do1_reverse(rate_f19pa_nacre) - case(iro16gp_aux) ! o16(g, p)n15 + case(iro16gp_aux) ! o16(g, p)n15 call do1_reverse(rate_n15pg_jina) case(iro16gp_to_c12) ! o16(g, p)n15(p, a)c12 @@ -626,10 +626,10 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(iro17_to_o18) ! o17(p, g)f18(e+nu)o18 call do1(rate_o17pg_jina) - case(irp31pa_aux) ! p31(p, a)si28 + case(irp31pa_aux) ! p31(p, a)si28 call do1_reverse(rate_si28ap_jina) - case(irp31pg_aux) ! p31(p, g)s32 + case(irp31pg_aux) ! p31(p, g)s32 call do1(rate_p31pg_jina) case(irpep_to_he3) ! p(e-p, nu)h2(p, g)he3 @@ -644,52 +644,52 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) case(irprot_to_neut) ! prot(e-nu)neut raw_rate = -1 ! rate calculated by special routine. - case(irs32ap_aux) ! s32(a, p)cl35 + case(irs32ap_aux) ! s32(a, p)cl35 call do1(rate_s32ap_jina) - case(irs32ap_to_ar36) + case(irs32ap_to_ar36) call do1(rate_s32ap_jina) - case(irs32gp_aux) ! s32(g, p)p31 + case(irs32gp_aux) ! s32(g, p)p31 call do1_reverse(rate_p31pg_jina) - case(irs32gp_to_si28) + case(irs32gp_to_si28) call do1_reverse(rate_p31pg_jina) - case(irsc43pa_aux) ! sc43(p, a)ca40 + case(irsc43pa_aux) ! sc43(p, a)ca40 call do1_reverse(rate_ca40ap_jina) - case(irsc43pg_aux) ! sc43(p, g)ti44 + case(irsc43pg_aux) ! sc43(p, g)ti44 call do1(rate_sc43pg_jina) - case(irsi28ap_aux) ! si28(a, p)p31 + case(irsi28ap_aux) ! si28(a, p)p31 call do1(rate_si28ap_jina) - case(irsi28ap_to_s32) + case(irsi28ap_to_s32) call do1(rate_si28ap_jina) case(irsi28gp_aux) ! si28(g, p)al27 call do1_reverse(rate_al27pg_jina) - case(irsi28gp_to_mg24) + case(irsi28gp_to_mg24) call do1_reverse(rate_al27pg_jina) - case(irti44ap_aux) ! ti44(a, p)v47 + case(irti44ap_aux) ! ti44(a, p)v47 call do1(rate_ti44ap_jina) - case(irti44ap_to_cr48) + case(irti44ap_to_cr48) call do1(rate_ti44ap_jina) - case(irti44gp_aux) ! ti44(g, p)sc43 + case(irti44gp_aux) ! ti44(g, p)sc43 call do1_reverse(rate_sc43pg_jina) case(irti44gp_to_ca40) call do1_reverse(rate_sc43pg_jina) - case(irv47pa_aux) ! v47(p, a)ti44 + case(irv47pa_aux) ! v47(p, a)ti44 call do1_reverse(rate_ti44ap_jina) - case(irv47pg_aux) ! v47(p, g)cr48 + case(irv47pg_aux) ! v47(p, g)cr48 call do1(rate_v47pg_jina) case(ir_h1_h1_wk_h2) ! p(p, e+nu)h2 @@ -708,69 +708,69 @@ subroutine set_raw_rate(ir, temp, tf, raw_rate, ierr) call do1(rate_be7pg_nacre) case(ir_b8_wk_he4_he4) ! b8(p=>n)be8=>2 he4 - call do1(rate_b8ep) + call do1(rate_b8ep) - case(irmn51pa_aux) ! mn51(p, a)cr48 + case(irmn51pa_aux) ! mn51(p, a)cr48 call do1_reverse(rate_cr48ap_jina) case(irfe54gn_aux) ! fe54(g, n)fe53 call do1_reverse(rate_fe53ng_jina) - case(irco55pa_aux) ! co55(p, a)fe52 + case(irco55pa_aux) ! co55(p, a)fe52 call do1_reverse(rate_fe52ap_jina) - case(irco55prota_aux) ! co55(prot, a)fe52 + case(irco55prota_aux) ! co55(prot, a)fe52 call do1_reverse(rate_fe52ap_jina) case(ir_h1_he3_wk_he4) ! he3(p, e+nu)he4 call do1(rate_hep_fxt) - + case(ir_he3_ng_he4) call do1(rate_he3ng_fxt) - + case(ir_he4_gn_he3) call do1_reverse(rate_he3ng_fxt) - + case(ir_h1_ng_h2) call do1(rate_png_fxt) - + case(ir_h2_gn_h1) call do1_reverse(rate_png_fxt) - + case(ir_he3_gp_h2) call do1_reverse(rate_dpg_nacre) - + case(ir_c12_c12_to_h1_na23) call do1(rate_c12_c12_to_h1_na23_jina) - + case(ir_he4_ne20_to_c12_c12) call do1(rate_he4_ne20_to_c12_c12_jina) - + case(ir_c12_c12_to_he4_ne20) call do1_reverse(rate_he4_ne20_to_c12_c12_jina) - + case(ir_he4_mg24_to_c12_o16) call do1(rate_he4_mg24_to_c12_o16_jina) case default call do_default(ierr) - + end select if(associated(rates_other_rate_get)) then call rates_other_rate_get(ir, temp, tf, raw_rate, ierr) end if - - + + contains - subroutine do_default(ierr) - integer, intent(out) :: ierr ! set ierr to -1 if cannot find rate - real(dp) :: lambda, dlambda_dlnT, rlambda, drlambda_dlnT + subroutine do_default(ierr) + integer, intent(out) :: ierr ! set ierr to -1 if cannot find rate + real(dp) :: lambda, dlambda_dlnT, rlambda, drlambda_dlnT include 'formats' - ierr = 0 + ierr = 0 ! look for rate in reaclib call get_reaclib_rate_and_dlnT( & ir, temp, lambda, dlambda_dlnT, rlambda, drlambda_dlnT, ierr) @@ -782,13 +782,13 @@ subroutine do1(rate_fcn1) procedure(rate_fcn) :: rate_fcn1 call eval_raw_rate(ir, rate_fcn1, tf, temp, raw_rate, rr, ierr) end subroutine do1 - - + + subroutine do1_reverse(rate_fcn1) procedure(rate_fcn) :: rate_fcn1 call eval_raw_rate(ir, rate_fcn1, tf, temp, rr, raw_rate, ierr) end subroutine do1_reverse - + end subroutine set_raw_rate @@ -845,7 +845,7 @@ subroutine eval_raw_rate(ir, rate_fcn1, tf, temp, fr, rr, ierr) return end if end subroutine eval_raw_rate - + subroutine eval_table(ir, tf, temp, fr, rr, ierr) use interp_1d_lib, only: interp_values use ratelib @@ -864,7 +864,7 @@ subroutine eval_table(ir, tf, temp, fr, rr, ierr) if (.not. ri% use_rate_table) then ierr = -1 return - end if + end if if (ri% need_to_read) then !$omp critical (load_rate_table) if (ri% need_to_read) then @@ -876,7 +876,7 @@ subroutine eval_table(ir, tf, temp, fr, rr, ierr) write(*,*) 'failed to load table ' // trim(ri% rate_fname) return end if - end if + end if x(1) = temp*1d-8 call interp_values(ri% T8s, ri% nT8s, ri% f1, nv, x, vals, ierr) fr = vals(1) @@ -910,7 +910,7 @@ subroutine eval_table_reverse(ir, rir, tf, temp, fr, rr, ierr) call do_reaclib_indices_for_reaction(reaction_name(rir), reaclib_rates, lo, hi, ierr) if(ierr/=0) then write(*,*) "Error: Could not get reaclib index for rate ",rir, ' ',trim(reaction_name(rir)) - return + return end if inv_lambda = 0d0 @@ -921,9 +921,9 @@ subroutine eval_table_reverse(ir, rir, tf, temp, fr, rr, ierr) ln_lambda, lambda, dlambda_dlnT, & inv_lambda, dinv_lambda_dlnT) - fr = inv_lambda(1) * fr_table + fr = inv_lambda(1) * fr_table - rr = 0 + rr = 0 end subroutine eval_table_reverse @@ -937,7 +937,7 @@ subroutine get_interp_table(f_name, nT8s, T8s_out, f1_out, ierr) real(dp), pointer :: T8s_out(:) ! will be allocated. (nT8s) real(dp), pointer :: f1_out(:) ! will be allocated. (4,nT8s) integer, intent(out) :: ierr - + integer :: iounit, j, nvec real(dp), pointer :: work(:)=> null() real(dp), pointer :: T8s(:)=> null() @@ -945,15 +945,15 @@ subroutine get_interp_table(f_name, nT8s, T8s_out, f1_out, ierr) character (len=256) :: line, rate_file real(dp), target :: vec_ary(20) real(dp), pointer :: vec(:)=> null() - + ierr = 0 vec => vec_ary ! Look for the file based on its name first - + rate_file = trim(f_name) - + open(newunit=iounit,file=trim(rate_file),action='read',status='old',iostat=ierr) if (ierr /= 0) then ! Look in rates_table_dir @@ -977,7 +977,7 @@ subroutine get_interp_table(f_name, nT8s, T8s_out, f1_out, ierr) allocate(T8s(nT8s), f1(4*nT8s), stat=ierr) if (failed('allocate')) return f(1:4,1:nT8s) => f1(1:4*nT8s) - + do j=1,nT8s read(iounit,'(a)',iostat=ierr) line if (ierr == 0) call str_to_vector(line, vec, nvec, ierr) @@ -989,26 +989,26 @@ subroutine get_interp_table(f_name, nT8s, T8s_out, f1_out, ierr) T8s(j) = vec(1) f(1,j) = vec(2) end do - + allocate(work(nT8s*pm_work_size), stat=ierr) if (failed('allocate')) return call interp_pm(T8s, nT8s, f1, pm_work_size, work, & 'rates get_interp_table', ierr) deallocate(work) - + if (failed('interp_pm')) return - + close(iounit) - + ! don't set the pointers until have finished setting up the data - + if (associated(T8s_out)) deallocate(T8s_out) if (associated(f1_out)) deallocate(f1_out) T8s_out => T8s f1_out => f1 - + contains logical function failed(str) @@ -1020,9 +1020,9 @@ logical function failed(str) failed = .true. return end function failed - + end subroutine get_interp_table - + subroutine get_reaclib_rate_and_dlnT( & ir, temp, lambda, dlambda_dlnT, rlambda, drlambda_dlnT, ierr) @@ -1032,10 +1032,10 @@ subroutine get_reaclib_rate_and_dlnT( & real(dp), intent(out) :: lambda, dlambda_dlnT, rlambda, drlambda_dlnT integer, intent(out) :: ierr integer :: reverse - + include 'formats' ierr = 0 - + reverse = reaction_is_reverse(ir) if (reverse == 0) then ! that means don't know reverse = reaclib_reverse(reaction_Name(ir)) @@ -1053,21 +1053,21 @@ subroutine get_reaclib_rate_and_dlnT( & else !write(*,1) 'call do_jina_reaclib ' // trim(reaction_Name(ir)) call do_jina_reaclib - end if - + end if + return - + write(*,1) 'temp', temp write(*,1) 'lambda', lambda write(*,1) 'dlambda_dlnT', dlambda_dlnT write(*,1) 'rlambda', rlambda write(*,1) 'drlambda_dlnT', drlambda_dlnT - + call mesa_error(__FILE__,__LINE__,'get_reaclib_rate_and_dlnT') - + contains - - + + subroutine get_reaclib_lo_hi(ir, handle, lo, hi, ierr) use reaclib_eval, only: do_reaclib_indices_for_reaction integer, intent(in) :: ir @@ -1085,8 +1085,8 @@ subroutine get_reaclib_lo_hi(ir, handle, lo, hi, ierr) reaction_reaclib_lo(ir) = lo reaction_reaclib_hi(ir) = hi end subroutine get_reaclib_lo_hi - - + + subroutine do_jina_reaclib integer :: ierr, lo, hi include 'formats' @@ -1109,8 +1109,8 @@ subroutine do_jina_reaclib return end if end subroutine do_jina_reaclib - - + + subroutine do_jina_reaclib_reverse(reverse_handle) character (len=*) :: reverse_handle integer :: ierr, lo, hi, r_id @@ -1119,7 +1119,7 @@ subroutine do_jina_reaclib_reverse(reverse_handle) r_id = reverse_reaction_id(ir) if (r_id == 0) then ! don't know r_id = get_rates_reaction_id(reverse_handle) - if (r_id == 0) then + if (r_id == 0) then write(*,'(a,3x,i5)') & trim(reverse_handle) // ' failed in reaclib_index', r_id !call mesa_error(__FILE__,__LINE__,'raw_rates') @@ -1142,7 +1142,7 @@ subroutine do_jina_reaclib_reverse(reverse_handle) end if end subroutine do_jina_reaclib_reverse - + end subroutine get_reaclib_rate_and_dlnT diff --git a/rates/private/reaclib_eval.f90 b/rates/private/reaclib_eval.f90 index b4084987b..a027b106e 100644 --- a/rates/private/reaclib_eval.f90 +++ b/rates/private/reaclib_eval.f90 @@ -22,11 +22,11 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module reaclib_eval use rates_def use math_lib - + implicit none real(dp), parameter :: & @@ -35,8 +35,8 @@ module reaclib_eval contains - - + + subroutine reaction_rates( & num_lambdas, lo, hi, T9, rates, nuclides, forward_only, & lambda, dlambda_dlnT, & @@ -50,30 +50,30 @@ subroutine reaction_rates( & real(dp), intent(out) :: lambda, dlambda_dlnT real(dp), intent(out) :: rlambda, drlambda_dlnT integer, intent(out) :: ierr - + real(dp), dimension(num_lambdas), target :: & ln_lambdas_ar, lambdas_ar, dlambdas_dlnT_ar, & ln_rlambdas_ar, rlambdas_ar, drlambdas_dlnT_ar real(dp), dimension(:), pointer :: & ln_lambdas, lambdas, dlambdas_dlnT, & ln_rlambdas, rlambdas, drlambdas_dlnT - + include 'formats' - + ierr = 0 - + ln_lambdas => ln_lambdas_ar lambdas => lambdas_ar dlambdas_dlnT => dlambdas_dlnT_ar ln_rlambdas => ln_rlambdas_ar rlambdas => rlambdas_ar drlambdas_dlnT => drlambdas_dlnT_ar - + call compute_some_lambdas( & num_lambdas, lo, hi, T9, rates, ln_lambdas, lambdas, dlambdas_dlnT) lambda = sum(lambdas(1:num_lambdas)) dlambda_dlnT = sum(dlambdas_dlnT(1:num_lambdas)) - + if (forward_only) then rlambda = 0 drlambda_dlnT = 0 @@ -87,7 +87,7 @@ subroutine reaction_rates( & end if end subroutine reaction_rates - + subroutine compute_some_lambdas( & num_lambdas, lo, hi, T9, rates, ln_lambda, lambda, dlambda_dlnT) @@ -97,38 +97,38 @@ subroutine compute_some_lambdas( & real(dp), intent(in) :: T9 type(reaction_data), intent(in) :: rates real(dp), dimension(:), intent(out) :: ln_lambda, lambda, dlambda_dlnT - + real(dp) :: T9inv, ln1 real(dp), dimension(7) :: T9fac, dT9fac_dT9, dT9fac_dlnT integer :: i, j - + include 'formats' T9inv = 1d0/T9 - + T9fac(1) = 1d0 dT9fac_dT9(1) = 0d0 - + T9fac(2) = T9inv dT9fac_dT9(2) = -T9inv*T9inv - + T9fac(3) = pow(T9inv,one_third) dT9fac_dT9(3) = -one_third*pow(T9inv,four_thirds) - + T9fac(4) = pow(T9,one_third) dT9fac_dT9(4) = one_third*pow(T9inv,two_thirds) - + T9fac(5) = T9 dT9fac_dT9(5) = 1d0 - + T9fac(6) = pow(T9,five_thirds) dT9fac_dT9(6) = five_thirds*pow(T9,two_thirds) - + T9fac(7) = log(T9) dT9fac_dT9(7) = T9inv - + dT9fac_dlnT = T9*dT9fac_dT9 - + do i = lo, hi j = i+1-lo ln1 = dot_product(T9fac(:), rates% coefficients(:,i)) @@ -143,9 +143,9 @@ subroutine compute_some_lambdas( & dot_product(dT9fac_dlnT(:), rates% coefficients(:,i))*lambda(j) end if end do - + end subroutine compute_some_lambdas - + subroutine compute_some_inverse_lambdas( & num_lambdas, lo, hi, T9, rates, & @@ -159,14 +159,14 @@ subroutine compute_some_inverse_lambdas( & type(reaction_data), intent(in) :: rates real(dp), dimension(:), intent(in) :: ln_lambda, lambda, dlambda_dlnT real(dp), dimension(:), intent(out) :: inv_lambda, dinv_lambda_dlnT - + integer :: indx,indxp integer :: i, j real(dp), dimension(num_lambdas) :: A, Qratio, dQratio_dlnT real(dp) :: tfac, dtfac_dlnT, lnT9, T9i, dT9i_dlnT, ln1, fac1, dfac1_dlnT, dln1_dlnT,blurp - + include 'formats' - + ! find index of partition function and logarithmically interpolate indx = get_partition_fcn_indx(T9) if (indx >= npart) indx = npart-1 @@ -185,51 +185,51 @@ subroutine compute_some_inverse_lambdas( & dQratio_dlnT(j) = Qratio(j)*log(A(j))*dtfac_dlnT end do end if - + lnT9 = log(T9) T9i = 1d0/T9 dT9i_dlnT = -T9i - + do i = lo, hi - + j = i+1-lo - + ln1 = ln_lambda(j) + & rates% inverse_coefficients(1,i) + & rates% inverse_coefficients(2,i)*T9i + & 1.5d0*rates% inverse_exp(i)*lnT9 - + if (ln1 < ln1_max) then fac1 = exp(ln1) - + dln1_dlnT = dlambda_dlnT(j)/max(1d-99,lambda(j)) + & rates% inverse_coefficients(2,i)*dT9i_dlnT + & 1.5d0*rates% inverse_exp(i) - + dfac1_dlnT = dln1_dlnT*fac1 - + else ln1 = ln1_max fac1 = lam_max ! == exp(ln1_max) dln1_dlnT = 0 dfac1_dlnT = 0 end if - - inv_lambda(j) = fac1*Qratio(j) + + inv_lambda(j) = fac1*Qratio(j) if (lambda(j) < 1d-99) then dinv_lambda_dlnT(j) = 0 cycle end if - + dinv_lambda_dlnT(j) = dfac1_dlnT*Qratio(j) + fac1*dQratio_dlnT(j) end do - + end subroutine compute_some_inverse_lambdas - - + + integer function do_reaclib_lookup(handle, rates_dict) result(indx) - ! returns first reaction index that matches handle. + ! returns first reaction index that matches handle. ! there may be several following that one having the same handle. ! returns 0 if handle doesn't match any of the reactions use utils_lib, only: integer_dict_lookup @@ -240,8 +240,8 @@ integer function do_reaclib_lookup(handle, rates_dict) result(indx) call integer_dict_lookup(rates_dict, handle, indx, ierr) if (ierr /= 0) indx = 0 end function do_reaclib_lookup - - + + subroutine do_reaclib_indices_for_reaction(handle, rates, lo, hi, ierr) character(len=*), intent(in) :: handle ! as in rates% reaction_handle type(reaction_data), intent(in) :: rates @@ -271,8 +271,8 @@ subroutine do_reaclib_indices_for_reaction(handle, rates, lo, hi, ierr) end if end do end subroutine do_reaclib_indices_for_reaction - - + + subroutine do_reaclib_reaction_rates( & lo, hi, T9, rates, nuclides, forward_only, & lambda, dlambda_dlnT, & @@ -292,7 +292,7 @@ subroutine do_reaclib_reaction_rates( & rlambda, drlambda_dlnT, & ierr) end subroutine do_reaclib_reaction_rates - + end module reaclib_eval diff --git a/rates/private/reaclib_input.f90 b/rates/private/reaclib_input.f90 index d434b7694..f4f2d40c4 100644 --- a/rates/private/reaclib_input.f90 +++ b/rates/private/reaclib_input.f90 @@ -22,10 +22,10 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module reaclib_input use rates_def - use utils_lib, only: mesa_error + use utils_lib, only: mesa_error implicit none @@ -33,8 +33,8 @@ module reaclib_input integer :: nreaclib contains - - + + subroutine do_extract_rates(set,nuclides,rates,use_weaklib,ierr) use reaclib_support use chem_def, only: nuclide_set, nuclide_data @@ -48,20 +48,20 @@ subroutine do_extract_rates(set,nuclides,rates,use_weaklib,ierr) if (dbg) write(*,*) 'call extract_rates_from_reaclib', nreaclib call extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_weaklib,ierr) if (failed('extract_rates_from_reaclib')) return - + if (dbg) write(*,*) 'call set_up_network_information' call set_up_network_information(rates) - + if (dbg) write(*,*) 'call assign_weights' call assign_weights(rates) - + if (dbg) write(*,*) 'call compute_rev_ratio' call compute_rev_ratio(rates,nuclides) - + if (dbg) write(*,*) 'return from do_extract_rates' contains - + logical function failed(msg) character (len=*), intent(in) :: msg if (ierr /= 0) then @@ -71,10 +71,10 @@ logical function failed(msg) failed = .false. end if end function failed - + end subroutine do_extract_rates - - + + subroutine do_read_reaclib(ierr) use utils_lib, only: integer_dict_define, integer_dict_create_hash use math_lib, only: str_to_double @@ -88,15 +88,15 @@ subroutine do_read_reaclib(ierr) character(len=iso_name_length) :: species character(len=256) :: filename, cache_filename, buf character(len=12) :: Qvalue_str - + logical, parameter :: use_cache = .true. - + include 'formats' ierr = 0 - + cache_filename = trim(rates_cache_dir) // '/jina_reaclib.bin' - + filename = trim(reaclib_dir) // '/' //trim(reaclib_filename) open(newunit=reaclib_unitno, file=filename, iostat=ierr, status="old", action="read") if ( ierr /= 0 ) then @@ -126,7 +126,7 @@ subroutine do_read_reaclib(ierr) do i = 1, max_nreaclib read(unit=reaclib_unitno, fmt=line0, iostat=ierr) reaclib% chapter(i) if (ierr /= 0 ) then ! assume end of file - ierr = 0; exit + ierr = 0; exit end if read(unit=reaclib_unitno,fmt=line1,iostat=ierr,err=100) & reaclib% species(1,i), reaclib% species(2,i), reaclib% species(3,i), & @@ -168,7 +168,7 @@ subroutine do_read_reaclib(ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) count = count + 1 end do - + nreaclib = count close(reaclib_unitno) @@ -184,15 +184,15 @@ subroutine do_read_reaclib(ierr) return 100 call mesa_error(__FILE__,__LINE__,'error in do_read_reaclib') - - + + contains - - + + subroutine read_reaclib_cache(io,ios) integer, intent(in) :: io integer, intent(out) :: ios - integer :: n + integer :: n ios = 0 read(io,iostat=ios) nreaclib if (ios /= 0) return @@ -204,11 +204,11 @@ subroutine read_reaclib_cache(io,ios) reaclib% reaction_flag(1:n), & reaclib% reverse_flag(1:n), & reaclib% Qvalue(1:n), & - reaclib% coefficients(1:ncoefficients,1:n) - if (ios /= 0) return + reaclib% coefficients(1:ncoefficients,1:n) + if (ios /= 0) return end subroutine read_reaclib_cache - - + + subroutine write_reaclib_cache(io) integer, intent(in) :: io integer :: n @@ -221,12 +221,12 @@ subroutine write_reaclib_cache(io) reaclib% reaction_flag(1:n), & reaclib% reverse_flag(1:n), & reaclib% Qvalue(1:n), & - reaclib% coefficients(1:ncoefficients,1:n) - end subroutine write_reaclib_cache - - + reaclib% coefficients(1:ncoefficients,1:n) + end subroutine write_reaclib_cache + + end subroutine do_read_reaclib - + subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_weaklib,ierr) use chem_def, only: & @@ -257,11 +257,11 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we integer :: rate_ipp, rate_ipep logical, parameter :: dbg = .false. - + include 'formats' ierr = 0 - + if (dbg) write(*,*) 'call allocate_reaction_data' call allocate_reaction_data(r,max_nreaclib,max_weaklib_rates,ierr) if (ierr /= 0) then @@ -269,7 +269,7 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we return end if - count = 0 + count = 0 if (use_weaklib) then ! add weaklib rates first if (dbg) write(*,*) 'add weaklib rates' do i = 1, nuclides% nnuclides @@ -285,7 +285,7 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we r% weaklib_ids(count) = indx r% also_in_reaclib(count) = .false. r% chapter(count) = 1 - r% pspecies(1,count) = get_nuclide_index_in_set(name_i,set) + r% pspecies(1,count) = get_nuclide_index_in_set(name_i,set) r% pspecies(2,count) = get_nuclide_index_in_set(name_j,set) r% pspecies(3:max_species_per_reaction,count) = 0 r% coefficients(:,count) = 0 @@ -294,7 +294,7 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we call get_reaction_handle( & 1, 1, r% pspecies(:,count), nuclides, & r% reaction_flag(count), r% reaction_handle(count)) - r% reverse_handle(count) = '' + r% reverse_handle(count) = '' r% Q(count) = 0 r% Qneu(count) = 0 r% reaction_flag(count) = 'w' @@ -303,13 +303,13 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we end do end do end if - - weaklib_count = count + + weaklib_count = count num_skip_for_weaklib = 0 num_from_reaclib = 0 loc_count = 0 rate_ipp = 0; rate_ipep = 0 - + if (dbg) write(*,*) 'loop_over_rates' loop_over_rates: do i = 1,nreaclib include_this_rate = .true. @@ -322,14 +322,14 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we l = get_nuclide_index_in_set(reaclib% species(j,i),set) if (l == nuclide_not_found) then include_this_rate = .false. - exit + exit loop_over_nuclides else pspecies(j) = l end if end do loop_over_nuclides - is_weak = (use_weaklib .and. num_in == 1 .and. num_out == 1) + is_weak = (use_weaklib .and. num_in == 1 .and. num_out == 1) ! only include forward rates ! Define the reverse rate as being the endothermic reaction, always @@ -369,7 +369,7 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we write(*,*) 'failed to find', indx call mesa_error(__FILE__,__LINE__) end if - cycle + cycle loop_over_rates end if end if count = count + 1 @@ -402,26 +402,26 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we r% Q(count) = r% Q(count) + Q end if end do - + r% Qneu(count) = 0 - + if (handle == 'r_b8_to_he4_he4') then r% Qneu(count) = 0.6735D+01 - + else if (handle == 'r_h1_he3_to_he4') then r% Qneu(count) = 9.628D0 - + else if (handle == 'r_h1_h1_ec_h2') then rate_ipep = count r% Qneu(count) = 1.445D0 - + else if (handle == 'r_h1_h1_wk_h2') then rate_ipp = count r% Qneu(count) = 0.2668D0 - + else if (handle == 'r_he3_ec_h3') then r% Qneu(count) = 10D0 ! who knows? who cares? - + else if (adjustl(reaclib% reaction_flag(i)) == 'w') then ! check weak_info list name1 = reaclib% species(1,i) if (num_out == 1) then @@ -437,14 +437,14 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we write(*,2) trim(name1) // ' ' // trim(name2) // & ' ' // trim(handle) // ' Qneu', count, r% Qneu(count) end if - + if (reaclib% reaction_flag(i) == 'w' .and. .false.) then write(*,2) 'reaclib weak ' // trim(handle) // ' Qneu', count, r% Qneu(count) end if end if end do loop_over_rates - + if (.false.) then write(*,2) 'num_skip_for_weaklib', num_skip_for_weaklib write(*,2) 'weaklib_count', weaklib_count @@ -453,17 +453,17 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we write(*,2) 'total num reactions', count call mesa_error(__FILE__,__LINE__,'extract_rates_from_reaclib') end if - + ! we can now stuff our temporary file into the output and discard the temporary - + if (dbg) write(*,*) 'call allocate_reaction_data' call allocate_reaction_data(rates,count,weaklib_count,ierr) if (ierr /= 0) then print *,'unable to allocate storage for rates' return end if - + rates% nreactions = count rates% nuclides => nuclides @@ -472,7 +472,7 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we rates% weaklib_ids(i) = r% weaklib_ids(i) rates% also_in_reaclib(i) = r% also_in_reaclib(i) end do - + do i=1,count rates% reaction_handle(i) = r% reaction_handle(i) rates% reverse_handle(i) = r% reverse_handle(i) @@ -487,7 +487,7 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we rates% coefficients(j,i) = r% coefficients(j,i) end do end do - + nullify(rates% reaction_dict) nullify(rates% reverse_dict) do i=1,count @@ -502,7 +502,7 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we do j=1,num_in+num_out min_Z = min(min_Z, nuclides% Z(rates% pspecies(j,i))) end do - cat = -1 + cat = -1 ! NOTE: reaction categories that are used by net are set in rates_initialize if (chapter == r_one_one) then if (min_Z > 0) then @@ -598,12 +598,12 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we cat = i_burn_cr else if (max_lhs_Z <= 28) then cat = i_burn_fe - else + else cat = iother end if end if rates% category(i) = cat - + call integer_dict_define(rates% reaction_dict, rates% reaction_handle(i), i, ierr) if (ierr /= 0) then write(*,*) 'FATAL ERROR: extract_rates_from_reaclib failed in integer_dict_define' @@ -617,14 +617,14 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we end if end if end do - + if (dbg) write(*,*) 'call integer_dict_create_hash reaction_dict' call integer_dict_create_hash(rates% reaction_dict, ierr) if (ierr /= 0) then write(*,*) 'FATAL ERROR: extract_rates_from_reaclib failed in integer_dict_create_hash' call mesa_error(__FILE__,__LINE__) end if - + if (dbg) write(*,*) 'call integer_dict_create_hash reverse_dict' call integer_dict_create_hash(rates% reverse_dict, ierr) if (ierr /= 0) then @@ -639,11 +639,11 @@ subroutine extract_rates_from_reaclib(reaclib,nreaclib,nuclides,rates,set,use_we where (rates% reaction_flag == ' ') rates% reaction_flag = '-' if (dbg) write(*,*) 'done extract_rates_from_reaclib' - - + + contains - - + + subroutine get_weaklib_name(i,name) integer, intent(in) :: i character (len=iso_name_length), intent(out) :: name @@ -670,7 +670,7 @@ real(dp) function neutrino_Q(b1, b2) neutrino_Q = abs(0.5d0 * sum * 0.511d0 * (1.0d0 - 1.0d0/sum2) & * (1.0d0 - 1.0d0/(4.0d0*sum) - 1.0d0/(9.0d0*sum2))) end function neutrino_Q - - + + end module reaclib_input diff --git a/rates/private/reaclib_print.f90 b/rates/private/reaclib_print.f90 index 32f27bfdc..72d7b97f2 100644 --- a/rates/private/reaclib_print.f90 +++ b/rates/private/reaclib_print.f90 @@ -22,10 +22,10 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module reaclib_print use rates_def - + implicit none contains @@ -49,7 +49,7 @@ subroutine write_reaction_data(unitno, rates, ierr) rates% inverse_part(:, i) end do end subroutine write_reaction_data - + subroutine pretty_print_reactions(unitno, rates, nuclides, ierr) integer, intent(in) :: unitno @@ -70,8 +70,8 @@ subroutine pretty_print_reactions(unitno, rates, nuclides, ierr) if (pass == 1) write(unitno,'(/,a,/)') 'reverse reactions' end do end subroutine pretty_print_reactions - - + + subroutine do_pretty_print_reaction(unitno, i, rates, nuclides, reverse, str, ierr) integer, intent(in) :: unitno, i type(reaction_data), intent(in) :: rates @@ -112,9 +112,9 @@ subroutine do_pretty_print_reaction(unitno, i, rates, nuclides, reverse, str, ie write(unitno,fmt='(a)') trim(str_nxt) str = str_nxt end if - + contains - + subroutine write_n_to_m(n,m) integer, intent(in) :: n, m integer :: j @@ -136,8 +136,8 @@ subroutine write_n_to_m(n,m) end do end if end subroutine write_n_to_m - - + + end subroutine do_pretty_print_reaction @@ -160,8 +160,8 @@ subroutine print_short_format_reactions(unitno, rates, nuclides, ierr) if (pass == 1) write(unitno,'(/,a,/)') 'reverse reactions' end do end subroutine print_short_format_reactions - - + + subroutine do_print_short_format_reaction(unitno, i, rates, nuclides, reverse, str, ierr) use reaclib_support, only: get1_reaction_handle integer, intent(in) :: unitno, i @@ -170,28 +170,28 @@ subroutine do_print_short_format_reaction(unitno, i, rates, nuclides, reverse, s logical, intent(in) :: reverse character (len=100), intent(inout) :: str integer, intent(out) :: ierr - + character (len=100) :: str_nxt integer :: chapter, num_in, num_out - + ierr = 0 str = '' - + if (reverse .and. & (rates% reaction_flag(i) == 'w' .or. rates% reaction_flag(i) == 'e')) return - + chapter = rates% chapter(i) num_in = Nin(chapter) num_out = Nout(chapter) - + call get1_reaction_handle( & num_in, num_out, rates% pspecies(:,i), nuclides, reverse, & - rates% reaction_flag(i), str_nxt) + rates% reaction_flag(i), str_nxt) if (trim(str_nxt) /= trim(str) .and. len_trim(str_nxt) > 0) then write(unitno,fmt='(a)') trim(str_nxt) str = str_nxt end if - + end subroutine do_print_short_format_reaction diff --git a/rates/private/reaclib_support.f90 b/rates/private/reaclib_support.f90 index 299642e99..171cb61af 100644 --- a/rates/private/reaclib_support.f90 +++ b/rates/private/reaclib_support.f90 @@ -22,16 +22,16 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module reaclib_support use rates_def use math_lib use chem_lib - + implicit none contains - + subroutine set_up_network_information(rates) type(reaction_data), intent(inout) :: rates @@ -56,19 +56,19 @@ subroutine set_up_network_information(rates) ! mark the end of the last chapter rates% bookmarks(2,current_chapter) = rates% nreactions end subroutine set_up_network_information - + subroutine assign_weights(rates) type(reaction_data), intent(inout) :: rates integer :: i, i1, i2, i3, i4 - + include 'formats' ! check for allocation if (.not.associated(rates% weight)) then return end if - + do i = 1, rates% nreactions i1 = -1; i2 = -2; i3 = -3; i4 = -4 select case (rates% chapter(i)) @@ -104,7 +104,7 @@ subroutine assign_weights(rates) end select call set_weight(rates% weight(i)) end do - + do i = 1, rates% nreactions i1 = -1; i2 = -2; i3 = -3; i4 = -4 select case (rates% chapter(i)) @@ -146,11 +146,11 @@ subroutine assign_weights(rates) call set_weight(rates% weight_reverse(i)) end do - - + + contains - - + + subroutine set_weight(w) ! nuclei are sorted, so if identical, then are adjacent in list real(dp), intent(out) :: w @@ -170,10 +170,10 @@ subroutine set_weight(w) w = 1d0 end if end subroutine set_weight - + end subroutine assign_weights - + subroutine compute_rev_ratio(rates,winvn) use const_def, only : pi, kB=>boltzm, NA=>avo, hbar, & @@ -186,14 +186,14 @@ subroutine compute_rev_ratio(rates,winvn) integer, dimension(max_species_per_reaction) :: ps integer :: Ni,No,Nt,i real(dp) :: fac, massfac, sum1, sum2, tmp - - + + include 'formats' - + ! Get these consistently from the isotopes.data file mp=winvn%W(chem_get_iso_id('prot')) mn=winvn%W(chem_get_iso_id('neut')) - + fac = pow(1d9*kB/(2d0*pi*hbar*hbar*NA),1.5d0)/NA massfac = conv*NA/(c*c) @@ -205,7 +205,7 @@ subroutine compute_rev_ratio(rates,winvn) rates% inverse_coefficients(:,i) = (/-huge(1d0), 0d0/) rates% inverse_exp(i) = 0d0 rates% inverse_part(:,i) = 1d0 - cycle + cycle loop_over_rates end if Ni = Nin(rates% chapter(i)) No = Nout(rates% chapter(i)) @@ -230,7 +230,7 @@ subroutine compute_rev_ratio(rates,winvn) ! fac shows up as fac^(Ni-No) in rates% inverse_coefficients(1,i) ! so rates% inverse_coefficients(1,i) contains terms for ! fac^(n) == fac^(Ni-No), where n = Ni - No. - + ! The T makes its way back into our expression inside ! the subroutine compute_some_inverse_lambdas, in reaclib_eval.f90. ! It appears in log form as 1.5d0*rates% inverse_exp(i)*lnT9, where, @@ -271,10 +271,10 @@ subroutine do_parse_reaction_handle(handle, num_in, num_out, iso_ids, op, ierr) integer, intent(out) :: iso_ids(:) ! holds chem_ids for input and output species character (len=*), intent(out) :: op ! e.g., 'pg', 'wk', 'to', or ... integer, intent(out) :: ierr - + integer :: len, i, j, cnt, cid, extra_in, extra_out logical :: doing_inputs - + num_in = 0; num_out = 0; op = '' ierr = -1 len = len_trim(handle) @@ -331,7 +331,7 @@ subroutine do_parse_reaction_handle(handle, num_in, num_out, iso_ids, op, ierr) ! trim(handle) // ' -- problem with ' // handle(i:j) return end select - end if + end if end if num_in = cnt doing_inputs = .false. @@ -352,9 +352,9 @@ subroutine do_parse_reaction_handle(handle, num_in, num_out, iso_ids, op, ierr) end do num_out = cnt - num_in ierr = 0 - + contains - + subroutine nxt j = i do @@ -365,7 +365,7 @@ subroutine nxt end if end do end subroutine nxt - + end subroutine do_parse_reaction_handle @@ -378,7 +378,7 @@ subroutine reaction_handle(num_in, num_out, iso_ids, reaction_flag, handle) logical, parameter :: reverse = .false. call get1_reaction_handle(num_in, num_out, iso_ids, chem_isos, reverse, reaction_flag, handle) end subroutine reaction_handle - + subroutine reverse_reaction_handle(num_in, num_out, iso_ids, handle) use chem_def, only: chem_isos integer, intent(in) :: num_in, num_out @@ -387,8 +387,8 @@ subroutine reverse_reaction_handle(num_in, num_out, iso_ids, handle) logical, parameter :: reverse = .true. character (len=1), parameter :: reaction_flag = '-' call get1_reaction_handle(num_in, num_out, iso_ids, chem_isos, reverse, reaction_flag, handle) - end subroutine reverse_reaction_handle - + end subroutine reverse_reaction_handle + subroutine get_reaction_handle(num_in, num_out, pspecies, nuclides, reaction_flag, handle) integer, intent(in) :: num_in, num_out integer, intent(in) :: pspecies(:) @@ -398,7 +398,7 @@ subroutine get_reaction_handle(num_in, num_out, pspecies, nuclides, reaction_fla logical, parameter :: reverse = .false. call get1_reaction_handle(num_in, num_out, pspecies, nuclides, reverse, reaction_flag, handle) end subroutine get_reaction_handle - + subroutine get_reverse_reaction_handle(num_in, num_out, pspecies, nuclides, handle) integer, intent(in) :: num_in, num_out integer, intent(in) :: pspecies(:) @@ -408,7 +408,7 @@ subroutine get_reverse_reaction_handle(num_in, num_out, pspecies, nuclides, hand character (len=1), parameter :: reaction_flag = '-' call get1_reaction_handle(num_in, num_out, pspecies, nuclides, reverse, reaction_flag, handle) end subroutine get_reverse_reaction_handle - + subroutine get1_reaction_handle( & num_in, num_out, pspecies_in, nuclides, reverse, reaction_flag, handle) use chem_def, only: ih1, ih2, ih3, ihe3, ihe4, ibe7, ili7, chem_isos @@ -421,16 +421,16 @@ subroutine get1_reaction_handle( & integer :: in1, in2, out1, out2, num, pspecies(num_in + num_out) logical :: do_long_form, ec_flag, wk_flag - + include 'formats' - + num = num_in + num_out pspecies(1:num) = pspecies_in(1:num) call sort(num_in, pspecies(1:num_in)) call sort(num_out, pspecies(num_in+1:num)) ec_flag = (reaction_flag == 'e') wk_flag = (reaction_flag == 'w') - + if (ec_flag) then ! special cases if (reverse) then handle = '' @@ -452,7 +452,7 @@ subroutine get1_reaction_handle( & if (nuclides% chem_id(pspecies(1)) == ibe7 .and. & nuclides% chem_id(pspecies(2)) == ili7) then handle = 'r_be7_wk_li7' - return + return end if end if else if (wk_flag) then @@ -498,7 +498,7 @@ subroutine get1_reaction_handle( & end if else if (num_in == 2 .and. num_out == 2) then call do_n_to_m(2,2) - do_long_form = two_two() + do_long_form = two_two() end if if (do_long_form) then @@ -509,9 +509,9 @@ subroutine get1_reaction_handle( & handle = trim(handle) // '_' // nuclides% name(out1) end if - + contains - + subroutine sort(n, species) integer :: n integer :: species(n) @@ -545,7 +545,7 @@ subroutine sort(n, species) end do end do end subroutine sort - + subroutine long_form integer :: i, cid character (len=3) :: op @@ -581,7 +581,7 @@ subroutine long_form end do end if end subroutine long_form - + logical function one_one() one_one = .true. if (in1 == 0 .or. out1 == 0) return @@ -596,7 +596,7 @@ logical function one_one() one_one = .true. end if end function one_one - + logical function one_two() one_two = .true. if (in1 == 0 .or. out1 == 0 .or. out2 == 0 .or. out1 == out2) return @@ -625,7 +625,7 @@ logical function one_two() one_two = .true. end if end function one_two - + logical function two_one() include 'formats' two_one = .true. @@ -647,12 +647,12 @@ logical function two_one() two_one = .true. end if end function two_one - + logical function two_two() two_two = .true. if (in1 == 0 .or. in2 == 0 .or. out1 == 0 .or. out2 == 0) return - + ! Special case r_li7_pa_he4, this must come first otherwise the out1==out2 ! check will label this rate as a _to_ reaction instead of an _ap reaction if (nuclides% Z(in1) == 1 .and. nuclides% N(in1) == 0 .and. & @@ -665,7 +665,7 @@ logical function two_two() end if if(in1==in2 .or. out1==out2) return - + two_two = .false. if (nuclides% Z(in1) == 2 .and. nuclides% N(in1) == 2 .and. & nuclides% Z(out1) == 1 .and. nuclides% N(out1) == 0 .and. & @@ -701,7 +701,7 @@ logical function two_two() two_two = .true. end if end function two_two - + subroutine do_n_to_m(n,m) integer, intent(in) :: n, m ! each is either 1 or 2 in1 = 0; in2 = 0; out1 = 0; out2 = 0 @@ -747,7 +747,7 @@ subroutine do_n_to_m(n,m) end if end if end subroutine do_n_to_m - + subroutine switch_if_necessary(iso1,iso2) integer, intent(inout) :: iso1, iso2 integer :: j @@ -759,9 +759,9 @@ subroutine switch_if_necessary(iso1,iso2) j = iso1; iso1 = iso2; iso2 = j; return end if end subroutine switch_if_necessary - - + + end subroutine get1_reaction_handle - + end module reaclib_support diff --git a/rates/private/screen.f90 b/rates/private/screen.f90 index c9c48fd38..96f1b375e 100644 --- a/rates/private/screen.f90 +++ b/rates/private/screen.f90 @@ -27,11 +27,11 @@ module screen use const_def use rates_def use math_lib - + implicit none - + contains - + subroutine do_screen_set_context( & sc, temp, den, logT, logRho, zbar, abar, z2bar, & screening_mode, num_isos, y, iso_z158) @@ -42,8 +42,8 @@ subroutine do_screen_set_context( & y(:), & iso_z158(:) ! Z**1.58 integer, intent(in) :: screening_mode - - real(dp), parameter :: x13 = 1.0d0/3.0d0 + + real(dp), parameter :: x13 = 1.0d0/3.0d0 real(dp), parameter :: x14 = 1.0d0/4.0d0 real(dp), parameter :: x53 = 5.0d0/3.0d0 real(dp), parameter :: x532 = 5.0d0/32.0d0 @@ -52,10 +52,10 @@ subroutine do_screen_set_context( & real(dp), parameter :: co2 = x13 * 4.248719d3 real(dp) :: qq integer :: j - + logical, parameter :: debug = .false. !logical, parameter :: debug = .true. - + include 'formats' if (screening_mode == no_screening .or. zbar == 0d0) return @@ -68,7 +68,7 @@ subroutine do_screen_set_context( & sc% abar = abar sc% z2bar = z2bar - ! get the info that depends only on temp, den, and overall composition + ! get the info that depends only on temp, den, and overall composition sc% ytot = 1.0d0/abar sc% rr = den * sc% ytot @@ -82,9 +82,9 @@ subroutine do_screen_set_context( & end do sc% z1pt58bar = abar * qq sc% zbar13 = pow(zbar,1d0/3d0) - - sc% pp = sqrt(sc% rr * sc% tempi * (z2bar + zbar)) - qq = 0.5d0/(sc% pp) *(z2bar + zbar) + + sc% pp = sqrt(sc% rr * sc% tempi * (z2bar + zbar)) + qq = 0.5d0/(sc% pp) *(z2bar + zbar) sc% dppdt = qq*sc% rr*sc% dtempi sc% dppdd = qq*sc% ytot*sc% tempi @@ -102,11 +102,11 @@ subroutine do_screen_set_context( & sc% aa = 2.27493d5 * sc% tempi * sc% xni sc% daadt = 2.27493d5 * sc% dtempi * sc% xni sc% daadd = 2.27493d5 * sc% tempi * sc% dxnidd - + ! ion and electron sphere radii (itoh 1979 eq 1-3) sc% ntot = den / (amu*abar) sc% a_e = pow((3.d0 /(pi4 * zbar * sc% ntot)),x13) - + end subroutine do_screen_set_context diff --git a/rates/private/screen5.f90 b/rates/private/screen5.f90 index c0564d665..fd7b3c535 100644 --- a/rates/private/screen5.f90 +++ b/rates/private/screen5.f90 @@ -27,11 +27,11 @@ module screen5 use rates_def use const_def, only: ln10, pi, two_13 use math_lib - + implicit none contains - + subroutine screen5_init_AZ_info( & zs13, zhat, zhat2, lzav, aznut, zs13inv, a1, z1, a2, z2, ierr) !..compute and store things that only depend on reaction A's and Z's @@ -44,15 +44,15 @@ subroutine screen5_init_AZ_info( & ! zs13inv = 1 / zs13 real(dp), intent(in) :: a1, z1, a2, z2 integer, intent(out) :: ierr - - real(dp), parameter :: x13 = 1.0d0/3.0d0 + + real(dp), parameter :: x13 = 1.0d0/3.0d0 real(dp), parameter :: x14 = 1.0d0/4.0d0 real(dp), parameter :: x53 = 5.0d0/3.0d0 real(dp), parameter :: x532 = 5.0d0/32.0d0 real(dp), parameter :: x512 = 5.0d0/12.0d0 - + ierr = 0 - + if (z1 <= 0 .or. z2 <= 0) then zs13 = 0 zs13inv = 0 @@ -69,28 +69,28 @@ subroutine screen5_init_AZ_info( & zhat2 = pow(z1 + z2, x512) - pow(z1,x512) - pow(z2,x512) lzav = x53 * log(max(1d-99,z1*z2/(z1 + z2))) aznut = pow(z1*z1*z2*z2*a1*a2/(a1 + a2), x13) - + end subroutine screen5_init_AZ_info - + subroutine fxt_screen5(sc, zs13, zhat, zhat2, lzav, aznut, zs13inv, & a1, z1, a2, z2, scor, scordt, scordd, ierr) !..this subroutine calculates screening factors and their derivatives -!..for nuclear reaction rates in the weak, intermediate and strong regimes. +!..for nuclear reaction rates in the weak, intermediate and strong regimes. -!..based on graboske, dewit, grossman and cooper apj 181 457 1973 for weak screening. +!..based on graboske, dewit, grossman and cooper apj 181 457 1973 for weak screening. -!..based on alastuey and jancovici apj 226 1034 1978, -!..with plasma parameters from itoh et al apj 234 1079 1979, for strong screening. +!..based on alastuey and jancovici apj 226 1034 1978, +!..with plasma parameters from itoh et al apj 234 1079 1979, for strong screening. !..input: !..temp = temperature !..den = density !..zbar = mean charge per nucleus -!..abar = mean number of nucleons per nucleus +!..abar = mean number of nucleons per nucleus !..z2bar = mean square charge per nucleus !..z1 a1 = charge and number in the entrance channel !..z2 a2 = charge and number in the exit channel -!..jscreen = counter of which reaction is being calculated +!..jscreen = counter of which reaction is being calculated !..init = flag to compute the more expensive functions just once !..output: @@ -137,24 +137,24 @@ subroutine fxt_screen5(sc, zs13, zhat, zhat2, lzav, aznut, zs13inv, & real(dp), parameter :: alph12_lim = 1.6d0 ! ln(10) real(dp), parameter :: h12_max = 300d0 - real(dp), parameter :: x13 = 1.0d0/3.0d0 + real(dp), parameter :: x13 = 1.0d0/3.0d0 real(dp), parameter :: x14 = 1.0d0/4.0d0 real(dp), parameter :: x53 = 5.0d0/3.0d0 real(dp), parameter :: x532 = 5.0d0/32.0d0 real(dp), parameter :: x512 = 5.0d0/12.0d0 real(dp), parameter :: fact = two_13 ! the cube root of 2 real(dp), parameter :: co2 = x13 * 4.248719d3 - + logical, parameter :: debug = .false. !logical :: debug - + include 'formats' !debug = (abs(a1 - 4d0) < 1d-14 .and. abs(a2 - 12d0) < 1d-14) - + ierr = 0 - + if (z1 <= 0d0 .or. z2 <= 0d0) then scor = 1d0 scordt = 0d0 @@ -174,71 +174,71 @@ subroutine fxt_screen5(sc, zs13, zhat, zhat2, lzav, aznut, zs13inv, & !tempi = sc% tempi !dtempi = sc% dtempi !deni = sc% deni - - !pp = sc% pp + + !pp = sc% pp !dppdt = sc% dppdt !dppdd = sc% dppdd - + qlam0z = sc% qlam0z qlam0zdt = sc% qlam0zdt qlam0zdd = sc% qlam0zdd - + taufac = sc% taufac taufacdt = sc% taufacdt - + !xni = sc% xni !dxnidd = sc% dxnidd - + aa = sc% aa daadt = sc% daadt daadd = sc% daadd -!..calculate individual screening factors +!..calculate individual screening factors bb = z1 * z2 gamp = aa gampdt = daadt gampdd = daadd - qq = fact * bb * zs13inv - gamef = qq * gamp + qq = fact * bb * zs13inv + gamef = qq * gamp gamefdt = qq * gampdt gamefdd = qq * gampdd - tau12 = taufac * aznut + tau12 = taufac * aznut tau12dt = taufacdt * aznut - - qq = 1.0d0/tau12 + + qq = 1.0d0/tau12 alph12 = gamef * qq alph12dt = (gamefdt - alph12*tau12dt) * qq alph12dd = gamefdd * qq -!..limit alph12 to alph12_lim to prevent unphysical behavior. -!..this should really be replaced by a pycnonuclear reaction rate formula - if (alph12 .gt. alph12_lim) then +!..limit alph12 to alph12_lim to prevent unphysical behavior. +!..this should really be replaced by a pycnonuclear reaction rate formula + if (alph12 .gt. alph12_lim) then - alph12 = alph12_lim + alph12 = alph12_lim alph12dt = 0.0d0 alph12dd = 0.0d0 - gamef = alph12 * tau12 + gamef = alph12 * tau12 gamefdt = alph12 * tau12dt - gamefdd = 0.0d0 - - qq = zs13/(fact * bb) + gamefdd = 0.0d0 + + qq = zs13/(fact * bb) gamp = gamef * qq gampdt = gamefdt * qq gampdd = 0.0d0 - - end if + + end if -!..weak screening regime - h12w = bb * qlam0z +!..weak screening regime + h12w = bb * qlam0z dh12wdt = bb * qlam0zdt dh12wdd = bb * qlam0zdd - h12 = h12w + h12 = h12w dh12dt = dh12wdt dh12dd = dh12wdd @@ -252,21 +252,21 @@ subroutine fxt_screen5(sc, zs13, zhat, zhat2, lzav, aznut, zs13inv, & if (debug) write(*, 1) 'sc% aa', sc% aa if (debug) write(*, 1) 'sc% tempi', sc% tempi if (debug) write(*, 1) 'sc% xni', sc% xni - + gamefx = 0.3d0 if (gamef .gt. gamefx) then if (debug) write(*,1) 'intermediate and strong sceening regime' gamp14 = pow(gamp,x14) rr = 1.0d0/gamp - qq = 0.25d0*gamp14*rr + qq = 0.25d0*gamp14*rr gamp14dt = qq * gampdt gamp14dd = qq * gampdd - + cc = 0.896434d0 * gamp * zhat & - 3.44740d0 * gamp14 * zhat2 & - 0.5551d0 * (log(gamp) + lzav) & - - 2.996d0 + - 2.996d0 dccdt = 0.896434d0 * gampdt * zhat & - 3.44740d0 * gamp14dt * zhat2 & @@ -276,83 +276,83 @@ subroutine fxt_screen5(sc, zs13, zhat, zhat2, lzav, aznut, zs13inv, & - 3.44740d0 * gamp14dd * zhat2 & - 0.5551d0*rr*gampdd - a3 = alph12 * alph12 * alph12 + a3 = alph12 * alph12 * alph12 da3 = 3.0d0 * alph12 * alph12 - + qq = 0.014d0 + 0.0128d0*alph12 dqqdt = 0.0128d0*alph12dt dqqdd = 0.0128d0*alph12dd - + rr = x532 - alph12*qq - drrdt = -(alph12dt*qq + alph12*dqqdt) - drrdd = -(alph12dd*qq + alph12*dqqdd) - + drrdt = -(alph12dt*qq + alph12*dqqdt) + drrdd = -(alph12dd*qq + alph12*dqqdd) + ss = tau12*rr dssdt = tau12dt*rr + tau12*drrdt dssdd = tau12*drrdd - + tt = -0.0098d0 + 0.0048d0*alph12 dttdt = 0.0048d0*alph12dt dttdd = 0.0048d0*alph12dd - + uu = 0.0055d0 + alph12*tt duudt = alph12dt*tt + alph12*dttdt duudd = alph12dd*tt + alph12*dttdd - - vv = gamef * alph12 * uu - dvvdt= gamefdt*alph12*uu + gamef*alph12dt*uu + gamef*alph12*duudt - dvvdd= gamefdd*alph12*uu + gamef*alph12dd*uu + gamef*alph12*duudd - + + vv = gamef * alph12 * uu + dvvdt= gamefdt*alph12*uu + gamef*alph12dt*uu + gamef*alph12*duudt + dvvdd= gamefdd*alph12*uu + gamef*alph12dd*uu + gamef*alph12*duudd + h12 = cc - a3 * (ss + vv) rr = da3 * (ss + vv) dh12dt = dccdt - rr*alph12dt - a3*(dssdt + dvvdt) dh12dd = dccdd - rr*alph12dd - a3*(dssdd + dvvdd) - + rr = 1.0d0 - 0.0562d0*a3 ss = -0.0562d0*da3 drrdt = ss*alph12dt drrdd = ss*alph12dd - + if (debug) write(*, 1) 'rr', rr if (rr .ge. 0.77d0) then xlgfac = rr - dxlgfacdt = drrdt - dxlgfacdd = drrdd + dxlgfacdt = drrdt + dxlgfacdd = drrdd else xlgfac = 0.77d0 dxlgfacdt = 0.0d0 dxlgfacdd = 0.0d0 - end if + end if - h12 = log(xlgfac) + h12 + h12 = log(xlgfac) + h12 rr = 1.0d0/xlgfac - dh12dt = rr*dxlgfacdt + dh12dt - dh12dd = rr*dxlgfacdd + dh12dd - - + dh12dt = rr*dxlgfacdt + dh12dt + dh12dd = rr*dxlgfacdd + dh12dd + + if (debug) write(*, 1) 'gamef', gamef gamefs = 0.8d0 - if (gamef .le. gamefs) then + if (gamef .le. gamefs) then dgamma = 1.0d0/(gamefs - gamefx) - + rr = dgamma*(gamefs - gamef) drrdt = -dgamma*gamefdt drrdd = -dgamma*gamefdd - + ss = dgamma*(gamef - gamefx) dssdt = dgamma*gamefdt dssdd = dgamma*gamefdd - - vv = h12 + + vv = h12 h12x = h12 dh12xdt = dh12dt dh12xdd = dh12dd - + h12 = h12w*rr + vv*ss dh12dt = dh12wdt*rr + h12w*drrdt + dh12dt*ss + vv*dssdt dh12dd = dh12wdd*rr + h12w*drrdd + dh12dd*ss + vv*dssdd @@ -361,30 +361,30 @@ subroutine fxt_screen5(sc, zs13, zhat, zhat2, lzav, aznut, zs13inv, & if (debug) write(*, 1) 'gamefx', gamefx if (debug) write(*,*) 'intermediate screening' - + else if (debug) write(*,*) 'strong screening' - end if - + end if + !..end of intermediate and strong screening if - + else if (debug) then write(*,*) 'weak screening' - end if + end if if (debug) write(*, 1) 'h12', h12 if (debug) write(*, 1) 'h12/ln10', h12/ln10 if (debug) write(*, *) !..machine limit the output - h12 = max(min(h12, h12_max), 0.0d0) - scor = exp(h12) + h12 = max(min(h12, h12_max), 0.0d0) + scor = exp(h12) if (h12 .eq. h12_max) then scordt = 0.0d0 scordd = 0.0d0 - else + else scordt = scor * dh12dt scordd = scor * dh12dd end if @@ -399,8 +399,8 @@ subroutine fxt_screen5(sc, zs13, zhat, zhat2, lzav, aznut, zs13inv, & end subroutine fxt_screen5 - - + + diff --git a/rates/private/screen_chugunov.f90 b/rates/private/screen_chugunov.f90 index 12d6402dd..0265e7c7f 100644 --- a/rates/private/screen_chugunov.f90 +++ b/rates/private/screen_chugunov.f90 @@ -22,18 +22,18 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + ! Implement screening a la Chugunov, DeWitt & Yakovlev 2007, PhRvD, 76, 025028 - + module screening_chugunov use math_lib use const_def use rates_def, only: screen_info use math_def - + implicit none private - + ! there are various realms of applicability in the Chugunov paper, for ! the particle-in-cell Monte-Carlo calculations, for the MKB ! approximation, and for the Potekhin-Cabrier-based fit to the MKB @@ -45,7 +45,7 @@ module screening_chugunov real(dp), parameter :: tp2 = 0.2d0 !< minimum allowed ratio T/T_p before fading out real(dp), parameter :: tp1 = 0.1d0 !< floor value of T/T_p (T_p = plasma temperature) real(dp), parameter :: deltatp = tp2 - tp1 !< Blend over the tp boundary - + ! coefficients from chugunov real(dp), parameter :: c_a1 = 2.7822d0 real(dp), parameter :: c_a2 = 98.34d0 @@ -55,25 +55,25 @@ module screening_chugunov real(dp), parameter :: c_b3 = 1.12d0 real(dp), parameter :: c_b4 = 65.d0 real(dp), parameter :: alfa = 0.022d0 - - real(dp), parameter :: x13 = 1.0d0/3.0d0 - real(dp), parameter :: x12 = 1.0d0/2.0d0 - real(dp), parameter :: x23 = 2.0d0/3.0d0 - real(dp), parameter :: x32 = 3.0d0/2.0d0 - real(dp), parameter :: x43 = 4.0d0/3.0d0 - real(dp), parameter :: x53 = 5.0d0/3.0d0 - + + real(dp), parameter :: x13 = 1.0d0/3.0d0 + real(dp), parameter :: x12 = 1.0d0/2.0d0 + real(dp), parameter :: x23 = 2.0d0/3.0d0 + real(dp), parameter :: x32 = 3.0d0/2.0d0 + real(dp), parameter :: x43 = 4.0d0/3.0d0 + real(dp), parameter :: x53 = 5.0d0/3.0d0 + real(dp), parameter :: h0fitlim = 300d0, h0fit0 = 295d0 real(dp), parameter :: deltah0fit = h0fitlim - h0fit0 - + public eval_screen_chugunov - + contains - - + + subroutine eval_screen_chugunov(sc, z1, z2, a1, a2, screen, dscreendt, dscreendd, ierr) implicit none - + type (Screen_Info) :: sc real(dp),intent(in) :: z1, z2 !< charge numbers of reactants real(dp),intent(in) :: a1, a2 !< mass numbers of reactants @@ -81,9 +81,9 @@ subroutine eval_screen_chugunov(sc, z1, z2, a1, a2, screen, dscreendt, dscreendd real(dp),intent(out) :: dscreendt !< on return, temperature derivative of the screening factor real(dp),intent(out) :: dscreendd !< on return, density derivative of the screening factor integer, intent(out) :: ierr - + real(dp) :: z1z2 !< z1*z2 - real(dp) :: t1, dt1dt, dt1dd + real(dp) :: t1, dt1dt, dt1dd real(dp) :: t2, dt2dt, dt2dd real(dp) :: t3, dt3dt, dt3dd !< the three terms in the fitting formula for h0fit real(dp) :: h0fit, dh0fitdt, dh0fitdd !< mean field fit @@ -110,14 +110,14 @@ subroutine eval_screen_chugunov(sc, z1, z2, a1, a2, screen, dscreendt, dscreendd real(dp) :: temp, rho, abar, zbar, rr real(dp) :: alpha, dalphadgam, dbetadgam, dalphadtn,dbetadtn real(dp) :: tk, dtkdt, dtkdd - + ! check whether both reactants are charged ions - + screen = 1d0 dscreendt = 0d0 dscreendd = 0d0 ierr = 0 - + ! Must be charged ions if (z1 <= 0d0 .or. z2 <= 0d0) then return @@ -125,52 +125,52 @@ subroutine eval_screen_chugunov(sc, z1, z2, a1, a2, screen, dscreendt, dscreendd ! No free charges to screen things if(sc% zbar<=1d0) return - - + + rho = sc% den temp = sc% temp zbar = sc% zbar abar = sc% abar rr = sc% rr ! den/abar - + ! ion masses and number densities mav = abar * amu ! ntot = den / (amu*abar) ntot = sc% ntot dntotdd = 1d0/(amu*abar) - + ! ion and electron sphere radii (itoh 1979 eq 1-3) !a_e = pow((3.d0 /(pi4 * zbar * ntot)),x13) a_e = sc% a_e a_1 = a_e * pre_z(int(z1))%z1_3 !pow(z1,x13) a_2 = a_e * pre_z(int(z2))%z1_3 !pow(z2,x13) - + da_1dd = -x13 * a_1/rho da_2dd = -x13 * a_2/rho - + a_av = 0.5d0 * (a_1 + a_2) - da_avdd = 0.5d0 * (da_1dd + da_2dd) + da_avdd = 0.5d0 * (da_1dd + da_2dd) z1z2 = z1 * z2 - + ! bohr radius and normalised ion sphere radius - + a_b = rbohr/z1z2/ntot rs = a_av / a_b - + ! plasma frequency and temperature (chugunov 2007 eq 2) - + wp = sqrt((pi4 * z1z2 * qe * qe * ntot/mav)) dwpdd = x12 * wp/rho - + tp = hbar*wp/kerg dtpdd = (hbar/kerg) * dwpdd - + tn = temp/tp dtndt = 1d0/tp dtndd = -tn/tp * dtpdd - + ! Revise temperature used if nearing low tp values tk = temp dtkdt = 1d0 @@ -183,68 +183,68 @@ subroutine eval_screen_chugunov(sc, z1, z2, a1, a2, screen, dscreendt, dscreendd dtkdt = 0d0 dtkdd = tp1 * dtpdd denom = 0d0 ! Set as zero overwise floating point issues cause small error in the subtraction (tk * dtpdd - tp * dtkdd) - + else if (tn .gt.tp1 .and. tn .le. tp2) then - + alpha = 0.5d0 * (1d0 - cospi((tn-tp1)/deltatp)) dalphadtn = 0.5d0 * (pi/deltatp) * sinpi((tn-tp1)/deltatp) - + beta = 1.d0 - alpha dbetadtn = -dalphadtn - + dtkdt = (dbetadtn * dtndt * tp1 * tp) + (dalphadtn * dtndt * tp2 * tp) dtkdd = (beta * tp1 * dtpdd) + (dbetadtn * dtndd * tp1 * tp) + & (alpha * tp2 * dtpdd) + (dalphadtn * dtndd * tp2 * tp) - + tk = beta * (tp1 * tp) + alpha * (tp2 * tp) denom = tp * (tk * dtpdd - tp * dtkdd)/(tk * tk * tk) end if - + ! zeta (chugunov 2007 eq 3) U = four_thirds*(tp * tp)/(pi2 * tk * tk) zeta = pow(U,x13) - dzetadt = -x23 * (zeta/tk) * dtkdt + dzetadt = -x23 * (zeta/tk) * dtkdt dzetadd = x13 * (zeta/U) * (four_thirds/pi2) * 2.d0 * denom ! coulomb coupling parameter gamma (itoh 1979 eq 4) gam = z1z2 * qe * qe/(a_av * tk * kerg) - dgamdt = -(gam / tk) * dtkdt + dgamdt = -(gam / tk) * dtkdt dgamdd = -(gam/(a_av * tk)) * (tk * da_avdd + a_av * dtkdd) if (gam >=gamfitlim) then - + gam = gamfitlim dgamdt = 0d0 dgamdd = 0d0 - + else if (gam .le. gamfitlim .and. gam .ge. g0 ) then alpha = 0.5d0 * (1d0 - cospi((gam-g0)/deltagam)) dalphadgam = 0.5d0 * pi * sinpi((gam-g0)/deltagam) * (1d0/deltagam) beta = 1.d0 - alpha dbetadgam = -dalphadgam - - dgamdt = beta * dgamdt + (dbetadgam * dgamdt) * gam + (dalphadgam * dgamdt) * gamfitlim - dgamdd = beta * dgamdd + (dbetadgam * dgamdd) * gam + (dalphadgam * dgamdd) * gamfitlim - + + dgamdt = beta * dgamdt + (dbetadgam * dgamdt) * gam + (dalphadgam * dgamdt) * gamfitlim + dgamdd = beta * dgamdd + (dbetadgam * dgamdd) * gam + (dalphadgam * dgamdd) * gamfitlim + gam = beta * gam + alpha * gamfitlim - + end if - + ! coefficients of zeta dependent on the ion coulomb coupling ! parameter (gam) (chugunov 2007, just after eq 21) - + beta = 0.41d0 - 0.6d0/gam dbetadt = 0.6d0/(gam * gam) * dgamdt dbetadd = 0.6d0/(gam * gam) * dgamdd - + gama = 0.06d0 + 2.2d0/gam dgamadt = -2.2d0/(gam * gam) * dgamdt dgamadd = -2.2d0/(gam * gam) * dgamdd - + ! gamma tilda (chugunov 2007 eq 21) zeta2 = zeta * zeta zeta3 = zeta2 * zeta - + U = (1d0 + alfa * zeta + beta * zeta2 + gama * zeta3) denom = pow(U,-x13) denom2 = denom/U ! pow(U,-x43) @@ -254,51 +254,51 @@ subroutine eval_screen_chugunov(sc, z1, z2, a1, a2, screen, dscreendt, dscreendd ddenomdd = -x13 * denom2 * & ((alfa * dzetadd) + (zeta2 * dbetadd + 2d0 * dzetadd * beta * zeta) + & (zeta3 * dgamadd + 3d0 * dzetadd * gama * zeta2 )) - + gamtild = gam * denom dgamtilddt = ddenomdt * gam + dgamdt * denom dgamtilddd = ddenomdd * gam + dgamdd * denom - + gamtild2 = gamtild * gamtild ! for for mean field potential H (chugunov 2007 eq 19) - + A = gamtild * sqrt(gamtild) dAdt = x32 * (A/gamtild) * dgamtilddt dAdd = x32 * (A/gamtild) * dgamtilddd - + B = c_a1/sqrt(c_a2 + gamtild) dBdt = -1d0/2d0 * B/(c_a2 + gamtild) * dgamtilddt dBdd = -1d0/2d0 * B/(c_a2 + gamtild) * dgamtilddd - + C = c_a3/(1d0 + gamtild) dCdt = -C/(1d0 + gamtild) * dgamtilddt dCdd = -C/(1d0 + gamtild) * dgamtilddd - + t1 = A * ( B + C ) dt1dt = A * ( dBdt + dCdt ) + dAdt * ( B + C ) dt1dd = A * ( dBdd + dCdd ) + dAdd * ( B + C ) - + denom = c_b2 + gamtild ddenomdt = dgamtilddt ddenomdd = dgamtilddd t2 = c_b1 * gamtild2 / denom dt2dt = (( denom * c_b1 * 2d0 * gamtild * dgamtilddt ) - (c_b1 * gamtild2 * ddenomdt)) / (denom * denom) dt2dd = (( denom * c_b1 * 2d0 * gamtild * dgamtilddd ) - (c_b1 * gamtild2 * ddenomdd))/ (denom * denom) - + denom = c_b4 + gamtild2 ddenomdt = 2d0 * gamtild * dgamtilddt ddenomdd = 2d0 * gamtild * dgamtilddd t3 = c_b3 * gamtild2 / denom dt3dt = (( denom * c_b3 * 2d0 * gamtild * dgamtilddt ) - (c_b3 * gamtild2 * ddenomdt)) / (denom * denom) dt3dd = (( denom * c_b3 * 2d0 * gamtild * dgamtilddd ) - (c_b3 * gamtild2 * ddenomdd)) / (denom * denom) - + h0fit = t1 + t2 + t3 dh0fitdt = dt1dt + dt2dt + dt3dt dh0fitdd = dt1dd + dt2dd + dt3dd - - dscreendt = dh0fitdt * screen - dscreendd = dh0fitdd * screen - + + dscreendt = dh0fitdt * screen + dscreendd = dh0fitdd * screen + ! limit screening factor to h0fitlim if (h0fit > h0fitlim) then h0fit = h0fitlim @@ -309,8 +309,8 @@ subroutine eval_screen_chugunov(sc, z1, z2, a1, a2, screen, dscreendt, dscreendd screen = exp(h0fit) dscreendt = dh0fitdt * screen dscreendd = dh0fitdd * screen - + end subroutine eval_screen_chugunov - + end module screening_chugunov - + diff --git a/rates/private/weaklib_tables.f90 b/rates/private/weaklib_tables.f90 index 030e93334..3e17d9438 100644 --- a/rates/private/weaklib_tables.f90 +++ b/rates/private/weaklib_tables.f90 @@ -216,7 +216,7 @@ subroutine interpolate_weaklib_table(table, T9, lYeRho, & xget = T9 yget = lYeRho - + if (weak_bicubic) then call setup_for_bicubic_interpolations else @@ -269,7 +269,7 @@ subroutine interpolate_weaklib_table(table, T9, lYeRho, & Qneu = exp10(lneutrino)/lambda dQneu_dlnT = ln10*T9*Qneu*d_lneutrino_dT9 - dlambda_dlnT*Qneu/lambda dQneu_dlnRho = Qneu*d_lneutrino_dlYeRho - dlambda_dlnRho*Qneu/lambda - + contains subroutine find_location ! set ix, jy; x is T9; y is lYeRho @@ -345,7 +345,7 @@ subroutine setup_for_bicubic_interpolations end subroutine setup_for_bicubic_interpolations subroutine do_bicubic_interpolations(fin, fval, df_dx, df_dy, ierr) - ! derived from routines in the PSPLINE package written by Doug McCune + ! derived from routines in the PSPLINE package written by Doug McCune real(dp), dimension(:,:,:) :: fin ! the spline data array, dimensions (4, nx, ny) real(dp), intent(out) :: fval, df_dx, df_dy integer, intent(out) :: ierr @@ -433,7 +433,7 @@ subroutine setup_for_linear_interp dlYeRho = lYeRho - y0 delta_lYeRho = y1 - y0 y_beta = dlYeRho / delta_lYeRho ! fraction of y1 result - y_alfa = 1 - y_beta ! fraction of y0 result + y_alfa = 1 - y_beta ! fraction of y0 result if (is_bad(y_alfa) .or. y_alfa < 0 .or. y_alfa > 1) then write(*,1) 'weaklib: y_alfa', y_alfa write(*,1) 'T9', T9 @@ -456,13 +456,13 @@ subroutine setup_for_linear_interp write(*,1) 'y_alfa, y_beta', y_alfa, y_beta write(*,'(A)') end if - + end subroutine setup_for_linear_interp subroutine do_linear_interp(f, fval, df_dx, df_dy, ierr) use interp_1d_lib use utils_lib, only: is_bad - real(dp), dimension(:,:,:) :: f ! (4, nx, ny) + real(dp), dimension(:,:,:) :: f ! (4, nx, ny) real(dp), intent(out) :: fval, df_dx, df_dy integer, intent(out) :: ierr @@ -480,7 +480,7 @@ subroutine do_linear_interp(f, fval, df_dx, df_dy, ierr) fval = x_alfa*fx0 + x_beta*fx1 df_dx = (fx1 - fx0)/(x1 - x0) - df_dy = (fy1 - fy0)/(y1 - y0) + df_dy = (fy1 - fy0)/(y1 - y0) if (is_bad(fval)) then ierr = -1 diff --git a/rates/public/rates_def.f90 b/rates/public/rates_def.f90 index d9d7b54a1..f8ef0aaeb 100644 --- a/rates/public/rates_def.f90 +++ b/rates/public/rates_def.f90 @@ -28,18 +28,18 @@ module rates_def use const_def, only: dp use chem_def, only: iso_name_length, nuclide_data, npart use auto_diff - + implicit none ! weaklib - - character (len=256) :: weak_data_dir + + character (len=256) :: weak_data_dir ! ecapture character (len=1000) :: ecapture_states_file character (len=1000) :: ecapture_transitions_file - + ! reaclib @@ -89,16 +89,16 @@ module rates_def type reaction_data - + integer :: nreactions integer :: nchapters_included integer, dimension(nchapters) :: chapters_present type(nuclide_data), pointer :: nuclides=>NULL() - + integer :: num_from_weaklib integer, dimension(:), pointer :: weaklib_ids=>NULL() ! (num_from_weaklib) logical, dimension(:), pointer :: also_in_reaclib=>NULL() ! (num_from_weaklib) - + integer, dimension(2, nchapters) :: bookmarks character(len=max_id_length), dimension(:), pointer :: reaction_handle=>NULL(), reverse_handle=>NULL() integer, dimension(:), pointer :: category=>NULL() @@ -115,36 +115,36 @@ module rates_def real(dp), dimension(:), pointer :: Q=>NULL() real(dp), dimension(:), pointer :: Qneu=>NULL() type (integer_dict), pointer :: reaction_dict=>NULL(), reverse_dict=>NULL() - + end type reaction_data - - + + character (len=256) :: reaclib_dir, reaclib_filename ! reactions information - + integer, parameter :: maxlen_reaction_Name = 32 character (len=maxlen_reaction_Name), pointer :: reaction_Name(:)=>NULL() ! (rates_reaction_id_max) - + integer, parameter :: maxlen_reaction_Info = 72 character (len=maxlen_reaction_Info), pointer :: reaction_Info(:)=>NULL() ! (rates_reaction_id_max) - - real(dp), pointer :: std_reaction_Qs(:)=>NULL() ! (rates_reaction_id_max) + + real(dp), pointer :: std_reaction_Qs(:)=>NULL() ! (rates_reaction_id_max) ! set at initialization; read-only afterwards. ! avg energy including neutrinos - - real(dp), pointer :: std_reaction_neuQs(:)=>NULL() ! (rates_reaction_id_max) + + real(dp), pointer :: std_reaction_neuQs(:)=>NULL() ! (rates_reaction_id_max) ! set at initialization; read-only afterwards. ! avg neutrino loss - - real(dp), pointer :: weak_lowT_rate(:)=>NULL() ! (rates_reaction_id_max) + + real(dp), pointer :: weak_lowT_rate(:)=>NULL() ! (rates_reaction_id_max) ! these are from reaclib or weak_info.list ! set at initialization; read-only afterwards. - + integer, pointer :: reaction_screening_info(:,:)=>NULL() !(3,rates_reaction_id_max) ! reaction_screen_info(1:2,i) = [chem_id1, chem_id2] for screening. 0's if no screening. - + integer, pointer :: weak_reaction_info(:,:)=>NULL() ! (2,rates_reaction_id_max) ! weak_reaction_info(1:2,i) = [chem_id_in, chem_id_out]. 0's if not a weak reaction. @@ -156,8 +156,8 @@ module rates_def ! (0,1) for standard 2 body reactions ! (0,2) for 3 body reactions such as triple alpha ! (1,1) for 2 body electron captures - ! (1,2) for 3 body electron captures (e.g., pep) - + ! (1,2) for 3 body electron captures (e.g., pep) + integer, parameter :: max_num_reaction_inputs = 3 integer, pointer :: reaction_inputs(:,:)=>NULL() ! (2*max_num_reaction_inputs,rates_reaction_id_max) ! up to max_num_reaction_inputs pairs of coefficients and chem id's, terminated by 0's. @@ -170,15 +170,15 @@ module rates_def ! up to max_num_reaction_outputs pairs of coefficients and chem id's, terminated by 0's. ! e.g., o16(p,g)f17 would be (/ 1, if17, 0 /) ! c12(a, p)n15 would be (/ 1, in15, 1, ih1, 0 /) - + ! weak_info_list - + integer :: num_weak_info_list_reactions real(dp), pointer :: weak_info_list_halflife(:)=>NULL(), weak_info_list_Qneu(:)=>NULL() type (integer_dict), pointer :: weak_info_list_dict=>NULL() ! weak - + real(dp) :: & T9_weaklib_full_off = 0.01d0, & ! use pure reaclib for T <= this T9_weaklib_full_on = 0.02d0 ! use pure weaklib for T >= this @@ -203,7 +203,7 @@ module rates_def real(dp), allocatable :: data(:,:,:,:) ! (4, num_T9, num_lYeRho, 3) contains - + procedure(setup_weak_table), deferred :: setup procedure(interpolate_weak_table), deferred :: interpolate @@ -243,16 +243,16 @@ end subroutine interpolate_weak_table weak_lhs_nuclide_name=>NULL(), weak_rhs_nuclide_name=>NULL() ! (num_weak_reactions) type (integer_dict), pointer :: weak_reactions_dict=>NULL() - logical :: weak_bicubic = .false. + logical :: weak_bicubic = .false. ! true means do bicubic splines for interpolation ! false means just do bilinear ! bilinear is safe; bicubic can overshoot near jumps ! Suzuki et al. (2016) logical :: use_suzuki_tables = .false. - + ! ecapture - + logical :: do_ecapture = .false. type (integer_dict), pointer :: ecapture_states_number_dict=>NULL() @@ -284,10 +284,10 @@ end subroutine interpolate_weak_table character(len=iso_name_length), dimension(:), pointer :: ecapture_nuclide_name=>NULL(), & ecapture_lhs_nuclide_name=>NULL(), ecapture_rhs_nuclide_name=>NULL() ! (num_ecapture_reactions) type (integer_dict), pointer :: ecapture_reactions_dict=>NULL() - + integer, pointer :: reaction_categories(:)=>NULL() ! (rates_reaction_id_max) set by net using reactions.list info - + integer, pointer,dimension(:) :: & reaction_is_reverse, reaction_reaclib_lo, reaction_reaclib_hi, reverse_reaction_id @@ -296,19 +296,19 @@ end subroutine interpolate_weak_table - + ! for tabular evaluation of the raw reaction rates real(dp) :: rattab_thi != 10.301029995664d0 ! log10(highest temp = 2e10) real(dp) :: rattab_tlo != 5.30102999566398d0 ! log10(lowest temp = 2e5) real(dp) :: rattab_temp_hi != 10**rattab_thi real(dp) :: rattab_temp_lo != 10**rattab_tlo - + integer :: rattab_points_per_decade = 2000 integer :: nrattab ! number of reaction rate table temperatures ! nrattab = *(rattab_thi - rattab_tlo) + 1 - + real(dp) :: rattab_tstp != (rattab_thi-rattab_tlo)/(nrattab-1)! step size - + ! reactions for hardwired nets and reactions with multiple choices for rates integer, parameter :: ir1212 = 1 integer, parameter :: ir1216 = ir1212+1 @@ -459,7 +459,7 @@ end subroutine interpolate_weak_table integer, parameter :: irfe54protg_aux = irfe54prot_to_ni56+1 integer, parameter :: irfe55gn_aux = irfe54protg_aux+1 integer, parameter :: irfe55ng_aux = irfe55gn_aux+1 - + integer, parameter :: irfe56ec_fake_to_mn56 = irfe55ng_aux+1 integer, parameter :: irfe56ec_fake_to_mn57 = irfe56ec_fake_to_mn56+1 integer, parameter :: irfe56ec_fake_to_cr56 = irfe56ec_fake_to_mn57+1 @@ -473,7 +473,7 @@ end subroutine interpolate_weak_table integer, parameter :: irfe56ec_fake_to_cr64 = irfe56ec_fake_to_cr63+1 integer, parameter :: irfe56ec_fake_to_cr65 = irfe56ec_fake_to_cr64+1 integer, parameter :: irfe56ec_fake_to_cr66 = irfe56ec_fake_to_cr65+1 - + integer, parameter :: irfe56ee_to_ni56 = irfe56ec_fake_to_cr66+1 integer, parameter :: irfe56gn_aux = irfe56ee_to_ni56+1 integer, parameter :: irfe56gn_to_fe54 = irfe56gn_aux+1 @@ -618,7 +618,7 @@ end subroutine interpolate_weak_table integer, parameter :: ir_co57_pa_fe54 = ir_fe54_ap_co57+1 integer, parameter :: ir_fe56_pg_co57 = ir_co57_pa_fe54+1 integer, parameter :: ir_co57_gp_fe56 = ir_fe56_pg_co57+1 - + integer, parameter :: ir_c12_c12_to_h1_na23 = ir_co57_gp_fe56+1 integer, parameter :: ir_he4_ne20_to_c12_c12 = ir_c12_c12_to_h1_na23+1 integer, parameter :: ir_c12_c12_to_he4_ne20 = ir_he4_ne20_to_c12_c12+1 @@ -635,7 +635,7 @@ end subroutine interpolate_weak_table integer :: rates_reaction_id_max - + ! for mazurek's ni56 electron capture rate interpolation real(dp) :: tv(7),rv(6),rfdm(4),rfd0(4),rfd1(4),rfd2(4),tfdm(5),tfd0(5),tfd1(5),tfd2(5) @@ -700,20 +700,20 @@ end subroutine interpolate_weak_table real(dp) :: T976 real(dp) :: T9i76 end type T_Factors - - - + + + ! rate results components - - integer, parameter :: i_rate = 1 - integer, parameter :: i_rate_dT = 2 - integer, parameter :: i_rate_dRho = 3 + + integer, parameter :: i_rate = 1 + integer, parameter :: i_rate_dT = 2 + integer, parameter :: i_rate_dRho = 3 integer, parameter :: num_rvs = 3 - - - + + + ! screening - + integer, parameter :: no_screening = 0 ! 1 was graboske screening so leave undefined so its an error if people keep trying to use it integer, parameter :: extended_screening = 2 @@ -725,7 +725,7 @@ end subroutine interpolate_weak_table ! with equations (4-215) and (4-221) of Clayton (1968). integer, parameter :: chugunov_screening = 4 ! based on code from Sam Jones - ! Implements screening from Chugunov et al (2007) + ! Implements screening from Chugunov et al (2007) integer, parameter :: other_screening = 5 ! User defined screening type Screen_Info @@ -765,7 +765,7 @@ end subroutine interpolate_weak_table subroutine other_screening_interface(sc, z1, z2, a1, a2, screen, dscreendt, dscreendd, ierr) import dp, screen_info implicit none - + type (Screen_Info) :: sc ! See rates_def real(dp),intent(in) :: z1, z2 !< charge numbers of reactants real(dp),intent(in) :: a1, a2 !< mass numbers of reactants @@ -773,29 +773,29 @@ subroutine other_screening_interface(sc, z1, z2, a1, a2, screen, dscreendt, dscr real(dp),intent(out) :: dscreendt !< on return, temperature derivative of the screening factor real(dp),intent(out) :: dscreendd !< on return, density derivative of the screening factor integer, intent(out) :: ierr - + end subroutine other_screening_interface subroutine other_rate_get_interface(ir, temp, tf, raw_rate, ierr) import dp, t_factors implicit none - + integer :: ir ! Rate id real(dp),intent(in) :: temp !< Temperature type (T_Factors) :: tf !< Various temperature factors real(dp),intent(inout) :: raw_rate !< Unscreened reaction_rate, note this will have the default mesa rate on entry integer, intent(out) :: ierr - + end subroutine other_rate_get_interface end interface - - + + real(dp) :: reaclib_min_T9 ! for T9 < this, return 0 for reaclib strong rates type (integer_dict), pointer :: reaction_names_dict - + logical :: have_finished_initialization = .false. logical :: rates_use_cache = .true. @@ -808,12 +808,12 @@ end subroutine other_rate_get_interface ! choices for various rates ! NOTE: if change these, must edit raw_rates to match. - - ! NACRE = Angulo et al. 1999 Nucl. Phys. A, 656, 3 + + ! NACRE = Angulo et al. 1999 Nucl. Phys. A, 656, 3 ! This is for reactions that care about thier values beloew 10^7K ! JR = jina reaclib -- (Sakharuk et al. 2006) ! This is for everything else - ! CF88 = Frank Timmes' version of + ! CF88 = Frank Timmes' version of ! Caughlin, G. R. & Fowler, W. A. 1988, Atom. Data and Nuc. Data Tables, 40, 283 ! This fills in some of the gaps for rates not in REACLIB or NACRE @@ -821,14 +821,14 @@ end subroutine other_rate_get_interface ! will generate possibly un-physical values as the partition table cuts off at 1d10 ! and the polynomial fits to the rates cuts off at 1d10. We truncate the rates whether ! the warn flag is on or off, to stop the truncation set a higher max_safe_logT_for_rates - - ! Warn if rates exceed the max usable temperature + + ! Warn if rates exceed the max usable temperature logical :: warn_rates_for_high_temp = .true. real(dp) :: max_safe_logT_for_rates = 10d0 - + ! Maximum sensible value for a reaction rate ! This is to try and catch rates that go bad - real(dp),parameter :: max_safe_rate_for_any_temp = 1d40 + real(dp),parameter :: max_safe_rate_for_any_temp = 1d40 ! info for rates being evaluated using tables (rate_list.txt) type rate_table_info @@ -839,16 +839,16 @@ end subroutine other_rate_get_interface real(dp), pointer :: T8s(:) ! (nT8s) real(dp), pointer :: f1(:) ! =(4,nT8s) end type rate_table_info - + type (rate_table_info), pointer :: raw_rates_records(:) character (len=1000) :: rates_table_dir type (integer_dict), pointer :: skip_warnings_dict - + type (reaction_data), target :: reaclib_rates - + character (len=1000) :: rates_dir, rates_cache_dir, rates_temp_cache_dir - + ! coulomb corrections for weak reactions @@ -867,23 +867,23 @@ end subroutine other_rate_get_interface type(auto_diff_real_2var_order1) :: rs type(auto_diff_real_2var_order1) :: gamma_e end type Coulomb_Info - - + + logical :: star_debugging_rates_flag real(dp) :: rates_test_partials_val, rates_test_partials_dval_dx real(dp) :: rates_test_partials_logT_lo, rates_test_partials_logT_hi real(dp) :: rates_test_partials_logRho_lo, rates_test_partials_logRho_hi - + contains - - + + subroutine set_rates_cache_dir(rates_cache_dir_in, ierr) use const_def, only: mesa_data_dir, mesa_caches_dir, mesa_temp_caches_dir, use_mesa_temp_cache use utils_lib, only : mkdir, switch_str character (len=*), intent(in) :: rates_cache_dir_in integer, intent(out) :: ierr - ierr = 0 + ierr = 0 rates_dir = trim(mesa_data_dir) // '/rates_data' if (len_trim(rates_cache_dir_in) > 0) then rates_cache_dir = rates_cache_dir_in @@ -893,10 +893,10 @@ subroutine set_rates_cache_dir(rates_cache_dir_in, ierr) rates_cache_dir = trim(rates_dir) // '/cache' end if if (rates_use_cache) call mkdir(rates_cache_dir) - + rates_temp_cache_dir=trim(mesa_temp_caches_dir)//'/rates_cache' - if (use_mesa_temp_cache) call mkdir(rates_temp_cache_dir) - + if (use_mesa_temp_cache) call mkdir(rates_temp_cache_dir) + end subroutine set_rates_cache_dir @@ -904,11 +904,11 @@ subroutine start_rates_def_init(ierr) use utils_lib, only: integer_dict_define use math_lib integer, intent(out) :: ierr - + integer :: i - ierr = 0 + ierr = 0 star_debugging_rates_flag = .false. - call create_skip_warnings_dict(ierr) + call create_skip_warnings_dict(ierr) if (ierr /= 0) return nullify(reaction_names_dict) do i=1,rates_reaction_id_max @@ -919,20 +919,20 @@ subroutine start_rates_def_init(ierr) end if end do call do_start_rates_def_init(ierr) - + end subroutine start_rates_def_init - - + + subroutine create_skip_warnings_dict(ierr) use utils_lib use utils_def integer, intent(out) :: ierr - + integer :: iounit, n, i, t character (len=256) :: buffer, string, filename, list_filename - + ierr = 0 - + nullify(skip_warnings_dict) list_filename = 'skip_warnings.list' @@ -948,13 +948,13 @@ subroutine create_skip_warnings_dict(ierr) return end if end if - + n = 0 i = 0 - + reaction_loop: do t = token(iounit, n, i, buffer, string) - if (t == eof_token) exit + if (t == eof_token) exit reaction_loop if (t /= name_token) then call error; return end if @@ -964,7 +964,7 @@ subroutine create_skip_warnings_dict(ierr) return end if end do reaction_loop - + close(iounit) call integer_dict_create_hash(skip_warnings_dict, ierr) @@ -974,15 +974,15 @@ subroutine create_skip_warnings_dict(ierr) end if contains - + subroutine error ierr = -1 close(iounit) end subroutine error end subroutine create_skip_warnings_dict - - + + integer function reaclib_index(handle) result(indx) use utils_lib, only: integer_dict_lookup character(len=*), intent(in) :: handle ! as in rates% reaction_handle @@ -991,8 +991,8 @@ integer function reaclib_index(handle) result(indx) call integer_dict_lookup(reaclib_rates% reaction_dict, handle, indx, ierr) if (ierr /= 0) indx = 0 end function reaclib_index - - + + integer function reaclib_reverse(handle) result(indx) use utils_lib, only: integer_dict_lookup character(len=*), intent(in) :: handle ! as in rates% reaction_handle @@ -1001,18 +1001,18 @@ integer function reaclib_reverse(handle) result(indx) call integer_dict_lookup(reaclib_rates% reverse_dict, handle, indx, ierr) if (ierr /= 0) indx = 0 end function reaclib_reverse - - + + subroutine weaklib_init(ierr) use const_def, only: mesa_data_dir - integer, intent(out) :: ierr + integer, intent(out) :: ierr ierr = 0 weak_data_dir = trim(mesa_data_dir) // '/rates_data' nullify(weak_reactions_dict) nullify(weak_info_list_dict) end subroutine weaklib_init - - + + subroutine free_weak_info use utils_lib, only: integer_dict_free @@ -1025,7 +1025,7 @@ subroutine free_weak_info end do deallocate(weak_reactions_tables) endif - + if (ASSOCIATED(weak_lhs_nuclide_id)) deallocate(weak_lhs_nuclide_id) if (ASSOCIATED(weak_rhs_nuclide_id)) deallocate(weak_rhs_nuclide_id) if (ASSOCIATED(weak_lhs_nuclide_name)) deallocate(weak_lhs_nuclide_name) @@ -1043,7 +1043,7 @@ end subroutine free_weak_info subroutine ecapture_init(ierr) - integer, intent(out) :: ierr + integer, intent(out) :: ierr ierr = 0 @@ -1077,8 +1077,8 @@ subroutine free_ecapture_info if (ASSOCIATED(ecapture_states_offset_dict)) call integer_dict_free(ecapture_states_offset_dict) end subroutine free_ecapture_info - - + + subroutine reaclib_init(jina_reaclib_filename) use const_def, only: mesa_data_dir character (len=*), intent(in) :: jina_reaclib_filename @@ -1088,8 +1088,8 @@ subroutine reaclib_init(jina_reaclib_filename) if (len_trim(reaclib_filename) == 0) & reaclib_filename = 'jina_reaclib_results_20171020_default' end subroutine reaclib_init - - + + subroutine allocate_reaclib_data(r, n, ierr) type(reaclib_data), intent(inout) :: r integer, intent(in) :: n @@ -1100,16 +1100,16 @@ subroutine allocate_reaclib_data(r, n, ierr) r% label(n), r% reaction_flag(n), r% reverse_flag(n), & r% Qvalue(n), r% coefficients(ncoefficients,1:n), stat=ierr) end subroutine allocate_reaclib_data - + subroutine free_reaclib_data(reaclib) type(reaclib_data), intent(inout) :: reaclib - if (allocated(reaclib% chapter)) & + if (allocated(reaclib% chapter)) & deallocate( & reaclib% chapter, reaclib% species, reaclib% label, reaclib% reaction_flag, & reaclib% reverse_flag, reaclib% Qvalue, reaclib% coefficients) end subroutine free_reaclib_data - + subroutine allocate_reaction_data(r, n, nweak, ierr) type(reaction_data), intent(out) :: r @@ -1127,7 +1127,7 @@ subroutine allocate_reaction_data(r, n, nweak, ierr) nullify(r% reverse_dict) end subroutine allocate_reaction_data - + subroutine free_reaction_data(r) use utils_lib, only: integer_dict_free @@ -1146,21 +1146,21 @@ end subroutine free_reaction_data subroutine do_start_rates_def_init(ierr) use math_lib - integer, intent(out) :: ierr + integer, intent(out) :: ierr ierr = 0 call set_rattab_range(5.30102999566398d0, 10.301029995664d0) - - reaclib_min_T9 = 1d-2 + + reaclib_min_T9 = 1d-2 ! need <= 2d-3 for pre-ms li7 burning ! pre-ms deuterium burning needs much lower (4d-4) ! but that seems to cause problems during advanced burning. - + end subroutine do_start_rates_def_init - - + + subroutine set_rattab_range(tlo, thi) use math_lib - real(dp), intent(in) :: tlo, thi + real(dp), intent(in) :: tlo, thi if (abs(thi - tlo) < 1d-6) then rattab_tlo = tlo rattab_temp_lo = exp10(rattab_tlo) @@ -1183,11 +1183,11 @@ subroutine set_rattab_range(tlo, thi) rattab_tstp = (rattab_thi-rattab_tlo)/(nrattab-1) end if end subroutine set_rattab_range - - + + integer function get_rates_reaction_id(reaction_name) result(value) use utils_lib, only: integer_dict_lookup - character (len=*), intent(in) :: reaction_name + character (len=*), intent(in) :: reaction_name integer :: ierr ierr = 0 call integer_dict_lookup(reaction_names_dict, reaction_name, value, ierr) @@ -1200,18 +1200,18 @@ subroutine create_ecapture_dict_key(ecapture_lhs, ecapture_rhs, key) character(len=2*iso_name_length+1), intent(out) :: key key = trim(ecapture_lhs) // ' ' // trim(ecapture_rhs) end subroutine create_ecapture_dict_key - - + + subroutine create_weak_dict_key(weak_lhs, weak_rhs, key) character(len=iso_name_length), intent(in) :: weak_lhs, weak_rhs character(len=2*iso_name_length+1), intent(out) :: key key = trim(weak_lhs) // ' ' // trim(weak_rhs) end subroutine create_weak_dict_key - + integer function do_get_weak_rate_id(lhs, rhs) ! returns 0 if reaction not found use utils_lib - character (len=*), intent(in) :: lhs, rhs + character (len=*), intent(in) :: lhs, rhs integer :: ierr, i character(len=2*iso_name_length+1) :: key character (len=iso_name_length) :: lhs_name, rhs_name @@ -1227,7 +1227,7 @@ integer function do_get_weak_rate_id(lhs, rhs) ! returns 0 if reaction not found end if do_get_weak_rate_id = i end function do_get_weak_rate_id - + integer function do_get_weak_info_list_id(lhs, rhs) ! returns 0 if reaction not found ! value can be used to index weak_info_list_halflife and weak_info_list_Qneu @@ -1248,8 +1248,8 @@ integer function do_get_weak_info_list_id(lhs, rhs) ! returns 0 if reaction not end if do_get_weak_info_list_id = i end function do_get_weak_info_list_id - - + + integer function get_num_reaction_inputs(ir) integer, intent(in) :: ir integer :: j @@ -1261,7 +1261,7 @@ integer function get_num_reaction_inputs(ir) get_num_reaction_inputs = 2 else if (reaction_inputs(1,ir) /= 0) then get_num_reaction_inputs = 1 - else + else get_num_reaction_inputs = 0 end if return @@ -1274,8 +1274,8 @@ integer function get_num_reaction_inputs(ir) end if end do end function get_num_reaction_inputs - - + + integer function get_num_reaction_outputs(ir) integer, intent(in) :: ir integer :: j @@ -1286,7 +1286,7 @@ integer function get_num_reaction_outputs(ir) get_num_reaction_outputs = 2 else if (reaction_outputs(1,ir) /= 0) then get_num_reaction_outputs = 1 - else + else get_num_reaction_outputs = 0 end if return diff --git a/rates/public/rates_lib.f90 b/rates/public/rates_lib.f90 index 86e0f01aa..1a2fa5b42 100644 --- a/rates/public/rates_lib.f90 +++ b/rates/public/rates_lib.f90 @@ -24,19 +24,19 @@ ! *********************************************************************** module rates_lib - + use const_def, only: dp use utils_lib, only: mesa_error - + implicit none contains - - - ! call this routine to initialize the rates module. + + + ! call this routine to initialize the rates module. ! only needs to be done once at start of run. - + subroutine rates_init( & reactionlist_filename, jina_reaclib_filename, & rates_table_dir_in, & @@ -51,16 +51,16 @@ subroutine rates_init( & use load_weak, only: load_weak_data use load_ecapture, only: load_ecapture_data use rates_initialize, only: init_rates_info - + character (len=*), intent(in) :: reactionlist_filename, jina_reaclib_filename, rates_table_dir_in logical, intent(in) :: use_special_weak_rates, use_suzuki_weak_rates character (len=*), intent(in) :: special_weak_states_file, special_weak_transitions_file character (len=*), intent(in) :: cache_dir ! '' means use default - integer, intent(out) :: ierr ! 0 means AOK. - + integer, intent(out) :: ierr ! 0 means AOK. + logical, parameter :: dbg = .false. include 'formats' - + ierr = 0 rates_table_dir = rates_table_dir_in @@ -69,7 +69,7 @@ subroutine rates_init( & if (ierr /= 0) return use_suzuki_tables = use_suzuki_weak_rates - + if (dbg) write(*,*) 'call weaklib_init' call weaklib_init(ierr) if (ierr /= 0) return @@ -80,7 +80,7 @@ subroutine rates_init( & do_ecapture = use_special_weak_rates ecapture_states_file = special_weak_states_file ecapture_transitions_file = special_weak_transitions_file - + if (dbg) write(*,*) 'call ecapture_init' call ecapture_init(ierr) if (ierr /= 0) return @@ -92,16 +92,16 @@ subroutine rates_init( & if (dbg) write(*,*) 'call do_read_reaclib' call do_read_reaclib(ierr) if (ierr /= 0) return - + if (dbg) write(*,*) 'call init_rates_info' call init_rates_info(reactionlist_filename, ierr) if (ierr /= 0) return - + have_finished_initialization = .true. - + end subroutine rates_init - - + + subroutine rates_warning_init( & warn_rates_for_high_temp_in, max_safe_logT_for_rates_in) use rates_def @@ -109,13 +109,13 @@ subroutine rates_warning_init( & real(dp), intent(in) :: max_safe_logT_for_rates_in ! Setup warnings warn_rates_for_high_temp = warn_rates_for_high_temp_in - max_safe_logT_for_rates = max_safe_logT_for_rates_in + max_safe_logT_for_rates = max_safe_logT_for_rates_in end subroutine rates_warning_init - + subroutine read_raw_rates_records(ierr) use rates_initialize, only: init_raw_rates_records - integer, intent(out) :: ierr ! 0 means AOK. + integer, intent(out) :: ierr ! 0 means AOK. ierr = 0 call init_raw_rates_records(ierr) if (ierr /= 0) then @@ -153,9 +153,9 @@ subroutine read_rates_from_files(rate_names, filenames, ierr) end if end do - end subroutine read_rates_from_files + end subroutine read_rates_from_files + - subroutine rates_shutdown use rates_def @@ -165,17 +165,17 @@ subroutine rates_shutdown call integer_dict_free(skip_warnings_dict) call integer_dict_free(reaction_names_dict) - + call free_weak_info() call free_ecapture_info() call free_reaclib_data(reaclib) call free_reaction_data(reaclib_rates) call free_reaction_arrays() call free_raw_rates_records() - + end subroutine rates_shutdown - - + + subroutine add_reaction_from_reaclib(reaction_handle, reverse_handle, indx, ierr) use rates_initialize, only: do_add_reaction_from_reaclib character (len=*), intent(in) :: reaction_handle ! to be added @@ -184,8 +184,8 @@ subroutine add_reaction_from_reaclib(reaction_handle, reverse_handle, indx, ierr integer, intent(out) :: ierr call do_add_reaction_from_reaclib(reaction_handle, reverse_handle, indx, ierr) end subroutine add_reaction_from_reaclib - - + + subroutine add_reaction_for_handle(handle, ierr) use rates_initialize, only: do_add_reaction_for_handle character (len=*), intent(in) :: handle ! to be added @@ -196,7 +196,7 @@ end subroutine add_reaction_for_handle subroutine make_rate_tables( & num_reactions, cache_suffix, net_reaction_id, & - rattab, rattab_f1, nT8s, ttab, logttab, ierr) + rattab, rattab_f1, nT8s, ttab, logttab, ierr) use rates_support, only : do_make_rate_tables integer, intent(in) :: num_reactions, nT8s, net_reaction_id(:) character (len=*), intent(in) :: cache_suffix @@ -207,16 +207,16 @@ subroutine make_rate_tables( & num_reactions, cache_suffix, net_reaction_id, & rattab, rattab_f1, nT8s, ttab, logttab, ierr) end subroutine make_rate_tables - - - subroutine show_reaction_rates_from_cache(cache_filename, ierr) + + + subroutine show_reaction_rates_from_cache(cache_filename, ierr) use rates_support, only: do_show_reaction_from_cache character (len=*) :: cache_filename integer, intent(out) :: ierr - call do_show_reaction_from_cache(cache_filename, ierr) + call do_show_reaction_from_cache(cache_filename, ierr) end subroutine show_reaction_rates_from_cache - - + + subroutine extract_reaclib_rates(set,nuclides,rates,use_weaklib,ierr) use rates_def use chem_def, only: nuclide_set, nuclide_data @@ -228,7 +228,7 @@ subroutine extract_reaclib_rates(set,nuclides,rates,use_weaklib,ierr) integer, intent(out) :: ierr call do_extract_rates(set,nuclides,rates,use_weaklib,ierr) end subroutine extract_reaclib_rates - + subroutine output_reaclib_rates(unitno,rates,nuclides,format) use reaclib_print @@ -247,8 +247,8 @@ subroutine output_reaclib_rates(unitno,rates,nuclides,format) call print_short_format_reactions(unitno,rates,nuclides,err) end select end subroutine output_reaclib_rates - - + + subroutine reaclib_pretty_print_reaction(unitno, i, rates, nuclides, reverse, str, ierr) use reaclib_print, only: do_pretty_print_reaction use rates_def @@ -260,8 +260,8 @@ subroutine reaclib_pretty_print_reaction(unitno, i, rates, nuclides, reverse, st integer, intent(out) :: ierr call do_pretty_print_reaction(unitno, i, rates, nuclides, reverse, str, ierr) end subroutine reaclib_pretty_print_reaction - - + + subroutine eval_tfactors(tf, logT, temp) use rates_def, only : T_Factors use ratelib, only: tfactors @@ -269,7 +269,7 @@ subroutine eval_tfactors(tf, logT, temp) real(dp), intent(in) :: logT, temp call tfactors(tf, logT, temp) end subroutine eval_tfactors - + subroutine get_raw_rate(ir, temp, tf, raw_rate, ierr) use rates_def, only : T_Factors @@ -294,28 +294,28 @@ subroutine get_raw_rates(n, irs, temp, tf, rates, ierr) integer, intent(out) :: ierr call set_raw_rates(n, irs, temp, tf, rates, ierr) end subroutine get_raw_rates - + integer function rates_reaction_id(rname) use rates_def, only: get_rates_reaction_id - character (len=*), intent(in) :: rname ! reaction name such as 'rpp' + character (len=*), intent(in) :: rname ! reaction name such as 'rpp' ! returns id for the reaction if there is a matching entry in reaction_Name ! returns 0 otherwise. rates_reaction_id = get_rates_reaction_id(rname) end function rates_reaction_id - + integer function eval_num_reaction_inputs(ir) use rates_def, only: get_num_reaction_inputs integer, intent(in) :: ir eval_num_reaction_inputs = get_num_reaction_inputs(ir) end function eval_num_reaction_inputs - + integer function eval_num_reaction_outputs(ir) use rates_def, only: get_num_reaction_outputs integer, intent(in) :: ir eval_num_reaction_outputs = get_num_reaction_outputs(ir) end function eval_num_reaction_outputs - + subroutine rates_eval_reaclib_21( & ir, temp, den, rate_raw, reverse_rate_raw, ierr) use rates_support, only: do_eval_reaclib_21 @@ -327,7 +327,7 @@ subroutine rates_eval_reaclib_21( & ir, temp, den, rate_raw, reverse_rate_raw, ierr) end subroutine rates_eval_reaclib_21 - + subroutine rates_eval_reaclib_22( & ir, temp, den, rate_raw, reverse_rate_raw, ierr) use rates_support, only: do_eval_reaclib_22 @@ -338,8 +338,8 @@ subroutine rates_eval_reaclib_22( & call do_eval_reaclib_22( & ir, temp, den, rate_raw, reverse_rate_raw, ierr) end subroutine rates_eval_reaclib_22 - - + + subroutine rates_two_to_one_coeffs_for_reverse_factor( & Q, iso_A, iso_B, iso_C, a, b, ierr) use chem_def, only: chem_isos @@ -348,24 +348,24 @@ subroutine rates_two_to_one_coeffs_for_reverse_factor( & integer, intent(in) :: iso_A, iso_B, iso_C real(dp), intent(out) :: a, b integer, intent(out) :: ierr - real(dp) :: W_A, W_B, W_C, g_A, g_B, g_C + real(dp) :: W_A, W_B, W_C, g_A, g_B, g_C if (Q < 0) then ierr = -1 return end if - ierr = 0 + ierr = 0 W_A = chem_isos% W(iso_A) W_B = chem_isos% W(iso_B) W_C = chem_isos% W(iso_C) g_A = 2d0*chem_isos% spin(iso_A) + 1d0 g_B = 2d0*chem_isos% spin(iso_B) + 1d0 - g_C = 2d0*chem_isos% spin(iso_C) + 1d0 + g_C = 2d0*chem_isos% spin(iso_C) + 1d0 ! Arnett, Supernovae and Nucleosynthesis, eqn 3.136 a = 9.8678d9*(g_A*g_B/g_C)*pow(W_A*W_B/W_C,1.5d0) - b = -11.605d0*Q + b = -11.605d0*Q end subroutine rates_two_to_one_coeffs_for_reverse_factor - - + + ! note: assumes ground state spins and requires Q > 0. ! i.e., A + B -> C exothermic subroutine rates_two_to_one_reverse_factor( & @@ -374,13 +374,13 @@ subroutine rates_two_to_one_reverse_factor( & real(dp), intent(in) :: Q, T9, T932 integer, intent(in) :: iso_A, iso_B, iso_C real(dp), intent(out) :: rev, d_rev_dT - integer, intent(out) :: ierr - real(dp) :: a, b + integer, intent(out) :: ierr + real(dp) :: a, b call rates_two_to_one_coeffs_for_reverse_factor( & Q, iso_A, iso_B, iso_C, a, b, ierr) if (ierr /= 0) return rev = a*T932*exp(b/T9) - d_rev_dT = rev*(1.5d0*T9 - b)/(T9*T9*1d9) + d_rev_dT = rev*(1.5d0*T9 - b)/(T9*T9*1d9) end subroutine rates_two_to_one_reverse_factor @@ -396,7 +396,7 @@ subroutine rates_two_to_two_coeffs_for_reverse_factor( & ierr = -1 return end if - ierr = 0 + ierr = 0 W_A = chem_isos% W(iso_A) W_B = chem_isos% W(iso_B) W_C = chem_isos% W(iso_C) @@ -404,14 +404,14 @@ subroutine rates_two_to_two_coeffs_for_reverse_factor( & g_A = 2d0*chem_isos% spin(iso_A) + 1d0 g_B = 2d0*chem_isos% spin(iso_B) + 1d0 g_C = 2d0*chem_isos% spin(iso_C) + 1d0 - g_D = 2d0*chem_isos% spin(iso_D) + 0.5d0 + g_D = 2d0*chem_isos% spin(iso_D) + 0.5d0 ! Arnett, Supernovae and Nucleosynthesis, eqn 3.137 a1 = ((g_A*g_B)/(g_C*g_D))*((W_A*W_B)/(W_C*W_D)) a = a1*sqrt(a1) - b = -11.605d0*Q + b = -11.605d0*Q end subroutine rates_two_to_two_coeffs_for_reverse_factor - - + + ! note: assumes ground state spins and requires Q > 0. ! i.e., A + B -> C + D exothermic subroutine rates_two_to_two_reverse_factor( & @@ -420,7 +420,7 @@ subroutine rates_two_to_two_reverse_factor( & real(dp), intent(in) :: Q, T9 integer, intent(in) :: iso_A, iso_B, iso_C, iso_D real(dp), intent(out) :: rev, d_rev_dT - integer, intent(out) :: ierr + integer, intent(out) :: ierr real(dp) :: a, b call rates_two_to_two_coeffs_for_reverse_factor( & Q, iso_A, iso_B, iso_C, iso_D, a, b, ierr) @@ -428,8 +428,8 @@ subroutine rates_two_to_two_reverse_factor( & rev = a*exp(b/T9) d_rev_dT = -rev*b/(T9*T9*1d9) end subroutine rates_two_to_two_reverse_factor - - + + logical function is_weak_reaction(ir) ! not just weaklib. any weak reaction. use rates_def, only: weak_reaction_info, std_reaction_neuQs integer, intent(in) :: ir ! reaction index @@ -437,8 +437,8 @@ logical function is_weak_reaction(ir) ! not just weaklib. any weak reaction. (weak_reaction_info(1,ir) > 0 .and. weak_reaction_info(2,ir) > 0) .or. & (std_reaction_neuQs(ir) > 0) end function is_weak_reaction - - + + ! weaklib sources ! FFN: G.M. Fuller, W.A. Fowler, M.J. Newman, Ap. J. 293 (1985) ! OHMT: Oda, Hino, Muto, Takahara, and Sato. Atomic Data and Nuclear Data Tables, 1994. @@ -446,10 +446,10 @@ end function is_weak_reaction integer function get_weak_rate_id(lhs, rhs) ! returns 0 if reaction not found use rates_def, only: do_get_weak_rate_id - character (len=*), intent(in) :: lhs, rhs + character (len=*), intent(in) :: lhs, rhs get_weak_rate_id = do_get_weak_rate_id(lhs, rhs) end function get_weak_rate_id - + integer function get_weak_info_list_id(lhs, rhs) ! returns 0 if reaction not found ! value can be used to index weak_info_list_halflife and weak_info_list_Qneu use rates_def, only: do_get_weak_info_list_id @@ -463,7 +463,7 @@ end function get_weak_info_list_id integer function get_ecapture_rate_id(lhs, rhs) ! returns 0 if reaction not found use rates_def use utils_lib - character (len=*), intent(in) :: lhs, rhs + character (len=*), intent(in) :: lhs, rhs ! names of the nuclides as given in ecapturereactions.tables (e.g. 'p', 'n', 'ca42', etc.) integer :: ierr, i character (len=2*iso_name_length+1) :: key @@ -503,7 +503,7 @@ integer function get_ecapture_info_list_id(lhs, rhs) ! returns 0 if reaction not end function get_ecapture_info_list_id ! reaclib - + subroutine reaclib_parse_handle(handle, num_in, num_out, iso_ids, op, ierr) use reaclib_support, only: do_parse_reaction_handle character (len=*), intent(in) :: handle @@ -511,47 +511,47 @@ subroutine reaclib_parse_handle(handle, num_in, num_out, iso_ids, op, ierr) integer, intent(out) :: iso_ids(:) ! holds chem_ids for input and output species character (len=*), intent(out) :: op ! e.g., 'pg', 'wk', 'to', or ... integer, intent(out) :: ierr - call do_parse_reaction_handle(handle, num_in, num_out, iso_ids, op, ierr) + call do_parse_reaction_handle(handle, num_in, num_out, iso_ids, op, ierr) end subroutine reaclib_parse_handle - + subroutine reaclib_create_handle(num_in, num_out, iso_ids, handle) use reaclib_support, only: reaction_handle integer, intent(in) :: num_in, num_out integer, intent(in) :: iso_ids(:) ! holds chem_ids for input and output species character (len=*), intent(out) :: handle character (len=1), parameter :: reaction_flag = '-' - call reaction_handle(num_in, num_out, iso_ids, reaction_flag, handle) + call reaction_handle(num_in, num_out, iso_ids, reaction_flag, handle) end subroutine reaclib_create_handle - + subroutine reaclib_create_ec_handle(num_in, num_out, iso_ids, handle) use reaclib_support, only: reaction_handle integer, intent(in) :: num_in, num_out integer, intent(in) :: iso_ids(:) ! holds chem_ids for input and output species character (len=*), intent(out) :: handle character (len=1), parameter :: reaction_flag = 'e' - call reaction_handle(num_in, num_out, iso_ids, reaction_flag, handle) + call reaction_handle(num_in, num_out, iso_ids, reaction_flag, handle) end subroutine reaclib_create_ec_handle - + subroutine reaclib_create_wk_handle(num_in, num_out, iso_ids, handle) use reaclib_support, only: reaction_handle integer, intent(in) :: num_in, num_out integer, intent(in) :: iso_ids(:) ! holds chem_ids for input and output species character (len=*), intent(out) :: handle character (len=1), parameter :: reaction_flag = 'w' - call reaction_handle(num_in, num_out, iso_ids, reaction_flag, handle) + call reaction_handle(num_in, num_out, iso_ids, reaction_flag, handle) end subroutine reaclib_create_wk_handle - + subroutine reaclib_create_reverse_handle(num_in, num_out, iso_ids, handle) use reaclib_support, only: reverse_reaction_handle integer, intent(in) :: num_in, num_out integer, intent(in) :: iso_ids(:) ! holds chem_ids for input and output species character (len=*), intent(out) :: handle - call reverse_reaction_handle(num_in, num_out, iso_ids, handle) + call reverse_reaction_handle(num_in, num_out, iso_ids, handle) end subroutine reaclib_create_reverse_handle - - + + integer function reaclib_lookup(handle, rates_dict) result(indx) - ! returns first reaction index that matches handle. + ! returns first reaction index that matches handle. ! there may be several following that one having the same handle. ! returns 0 if handle doesn't match any of the reactions use rates_def @@ -560,7 +560,7 @@ integer function reaclib_lookup(handle, rates_dict) result(indx) type (integer_dict), pointer :: rates_dict ! from create_reaclib_rates_dict indx = do_reaclib_lookup(handle, rates_dict) end function reaclib_lookup - + subroutine create_reaction_handle( & num_in, num_out, pspecies, nuclides, reverse, reaction_flag, handle) use reaclib_support, only: get1_reaction_handle @@ -574,8 +574,8 @@ subroutine create_reaction_handle( & call get1_reaction_handle( & num_in, num_out, pspecies, nuclides, reverse, reaction_flag, handle) end subroutine create_reaction_handle - - + + subroutine reaclib_indices_for_reaction(handle, rates, lo, hi, ierr) use reaclib_eval, only: do_reaclib_indices_for_reaction use rates_def @@ -585,8 +585,8 @@ subroutine reaclib_indices_for_reaction(handle, rates, lo, hi, ierr) integer, intent(out) :: ierr call do_reaclib_indices_for_reaction(handle, rates, lo, hi, ierr) end subroutine reaclib_indices_for_reaction - - + + subroutine reaclib_reaction_rates( & lo, hi, T9, rates, nuclides, forward_only, & lambda, dlambda_dlnT, & @@ -608,10 +608,10 @@ subroutine reaclib_reaction_rates( & rlambda, drlambda_dlnT, & ierr) end subroutine reaclib_reaction_rates - - + + ! screen - + subroutine screen_init_AZ_info( & a1, z1, a2, z2, & zs13, zhat, zhat2, lzav, aznut, zs13inv, & @@ -624,7 +624,7 @@ subroutine screen_init_AZ_info( & call screen5_init_AZ_info( & zs13, zhat, zhat2, lzav, aznut, zs13inv, a1, z1, a2, z2, ierr) end subroutine screen_init_AZ_info - + integer function screening_option(which_screening_option, ierr) use rates_def use utils_lib, only: StrLowCase @@ -633,47 +633,47 @@ integer function screening_option(which_screening_option, ierr) character (len=64) :: option ierr = 0 - option = StrLowCase(which_screening_option) + option = StrLowCase(which_screening_option) if (associated(rates_other_screening)) then screening_option = other_screening else if (option == 'no_screening' .or. len_trim(option) == 0) then - screening_option = no_screening + screening_option = no_screening else if (option == 'extended') then - screening_option = extended_screening + screening_option = extended_screening else if (option == 'salpeter') then - screening_option = salpeter_screening + screening_option = salpeter_screening else if (option == 'chugunov') then - screening_option = chugunov_screening + screening_option = chugunov_screening else ierr = -1 screening_option = -1 - end if + end if end function screening_option - + subroutine screening_option_str(which_screening_option, screening_option, ierr) use rates_def integer, intent(in) :: which_screening_option character (len=*), intent(out) :: screening_option integer, intent(out) :: ierr - ierr = 0 - + ierr = 0 + if (which_screening_option == other_screening) then screening_option = 'other_screening' else if (which_screening_option == no_screening) then - screening_option = 'no_screening' + screening_option = 'no_screening' else if (which_screening_option == extended_screening) then - screening_option = 'extended' + screening_option = 'extended' else if (which_screening_option == salpeter_screening) then - screening_option = 'salpeter' + screening_option = 'salpeter' else if (which_screening_option == chugunov_screening) then - screening_option = 'chugunov' + screening_option = 'chugunov' else ierr = -1 screening_option = '' - end if + end if end subroutine screening_option_str - - + + ! note: if do_ecapture is true, then eval_weak_reaction_info calls this. subroutine eval_ecapture_reaction_info( & n, ids, cc, T9, YeRho, & @@ -684,7 +684,7 @@ subroutine eval_ecapture_reaction_info( & ierr) use rates_def, only: Coulomb_Info use eval_ecapture, only: do_eval_ecapture_reaction_info - integer, intent(in) :: n, ids(:) + integer, intent(in) :: n, ids(:) type(Coulomb_Info), intent(in) :: cc real(dp), intent(in) :: T9, YeRho, eta, d_eta_dlnT, d_eta_dlnRho ! lambda = combined rate (capture and decay) @@ -705,14 +705,14 @@ subroutine eval_ecapture_reaction_info( & Qneu, dQneu_dlnT, dQneu_dlnRho, & ierr) end subroutine eval_ecapture_reaction_info - - + + subroutine eval_salpeter_screening(sc, z1, z2, scor, scordt, scordd, ierr) ! weak screening only. following Salpeter (1954), ! with equations (4-215) and (4-221) of Clayton (1968). use rates_def use math_lib - type (Screen_Info) :: sc ! previously setup + type (Screen_Info) :: sc ! previously setup real(dp), intent(in) :: z1, z2 real(dp), intent(out) :: scor ! screening factor real(dp), intent(out) :: scordt ! partial wrt temperature @@ -762,7 +762,7 @@ subroutine eval_weak_reaction_info( & Qneu, dQneu_dlnT, dQneu_dlnRho, & ierr) if (ierr /= 0) return - if (.not. do_ecapture) return + if (.not. do_ecapture) return call eval_ecapture_reaction_info( & n, ids, cc, T9, YeRho, & eta, d_eta_dlnT, d_eta_dlnRho, & @@ -771,7 +771,7 @@ subroutine eval_weak_reaction_info( & Qneu, dQneu_dlnT, dQneu_dlnRho, & ierr) end subroutine eval_weak_reaction_info - + subroutine eval_using_rate_tables( & num_reactions, reaction_id, rattab, rattab_f1, nT8s, & ye, logtemp, btemp, bden, raw_rate_factor, logttab, & @@ -788,9 +788,9 @@ subroutine eval_using_rate_tables( & ye, logtemp, btemp, bden, raw_rate_factor, logttab, & rate_raw, rate_raw_dT, rate_raw_dRho, ierr) end subroutine eval_using_rate_tables - + ! call this once before calling screen_pair for each reaction - ! sets info that depends only on temp, den, and overall composition + ! sets info that depends only on temp, den, and overall composition subroutine screen_set_context( & sc, temp, den, logT, logRho, zbar, abar, z2bar, & screening_mode, num_isos, y, iso_z158) @@ -802,7 +802,7 @@ subroutine screen_set_context( & temp, den, logT, logRho, zbar, abar, z2bar, y(:), iso_z158(:) ! y(:) = x(:)/chem_A(chem_id(:)) ! iso_z(:) = chem_Z(chem_id(:))**1.58 - integer, intent(in) :: screening_mode + integer, intent(in) :: screening_mode call do_screen_set_context( & sc, temp, den, logT, logRho, zbar, abar, z2bar, & screening_mode, num_isos, y, iso_z158) @@ -811,7 +811,7 @@ end subroutine screen_set_context ! set jscr = 0 before 1st call. - ! make calls in exactly the same order as for screen_init_AZ_info + ! make calls in exactly the same order as for screen_init_AZ_info subroutine screen_pair( & sc, a1, z1, a2, z2, screening_mode, & zs13, zhat, zhat2, lzav, aznut, zs13inv, low_logT_lim, & @@ -819,8 +819,8 @@ subroutine screen_pair( & use rates_def use screen5, only: fxt_screen5 use screening_chugunov, only: eval_screen_chugunov - - type (Screen_Info) :: sc ! previously setup + + type (Screen_Info) :: sc ! previously setup real(dp), intent(in) :: a1, z1, a2, z2 integer, intent(in) :: screening_mode ! see screen_def. ! cached info @@ -831,7 +831,7 @@ subroutine screen_pair( & real(dp), intent(out) :: scordt ! partial wrt temperature real(dp), intent(out) :: scordd ! partial wrt density integer, intent(out) :: ierr - + if(sc% logT < low_logT_lim ) then scor = 0d0 scordt=0d0 @@ -863,39 +863,39 @@ subroutine eval_ecapnuc_rate(etakep,temp,rho,rpen,rnep,spen,snep) real(dp), intent(out) :: rpen,rnep,spen,snep ! given the electron degeneracy parameter etakep (chemical potential ! without the electron's rest mass divided by kt) and the temperature temp, - ! this routine calculates rates for + ! this routine calculates rates for ! electron capture on protons rpen (captures/sec/proton), - ! positron capture on neutrons rnep (captures/sec/neutron), - ! and their associated neutrino energy loss rates + ! positron capture on neutrons rnep (captures/sec/neutron), + ! and their associated neutrino energy loss rates ! spen (ergs/sec/proton) and snep (ergs/sec/neutron) call ecapnuc(etakep,temp,rho,rpen,rnep,spen,snep) end subroutine eval_ecapnuc_rate - subroutine eval_mazurek_rate(btemp,bden,y56,ye,rn56ec,sn56ec) + subroutine eval_mazurek_rate(btemp,bden,y56,ye,rn56ec,sn56ec) use ratelib, only: mazurek real(dp), intent(in) :: btemp,bden,y56,ye real(dp), intent(out) :: rn56ec,sn56ec call mazurek(btemp,bden,y56,ye,rn56ec,sn56ec) end subroutine eval_mazurek_rate - - subroutine eval_FL_epsnuc_3alf(T, Rho, Y, UE, eps_nuc, deps_nuc_dT, deps_nuc_dRho) + + subroutine eval_FL_epsnuc_3alf(T, Rho, Y, UE, eps_nuc, deps_nuc_dT, deps_nuc_dRho) ! based on analytic expressions in Fushiki and Lamb, Apj, 317, 368-388, 1987. - + ! Note: if you plot the results of this, you'll see abrupt changes in rate at - ! logRho about 9.74 and 10.25 -- these aren't bugs in the code. + ! logRho about 9.74 and 10.25 -- these aren't bugs in the code. ! They are discussed in F&L, and show up as step functions in their expressions. - + ! They provide expressions for both pyconuclear regime and strong screening regime. ! The transition between the regimes happens at U = 1, where U is defined below. ! Unfortunately, at U = 1, their expressions for pycnonuclear rate and ! strong screening rate disagree! - ! Bummer. For example, at logRho = 8.0, U = 1 for logT = 7.1955. + ! Bummer. For example, at logRho = 8.0, U = 1 for logT = 7.1955. ! For these values, and pure He, ! their strong screening expression is larger than their pycno expression ! by a factor of about 25. - + ! need to add transition region in U instead of having an abrupt change at U = 1 - + use pycno, only: FL_epsnuc_3alf real(dp), intent(in) :: T ! temperature real(dp), intent(in) :: Rho ! density @@ -906,7 +906,7 @@ subroutine eval_FL_epsnuc_3alf(T, Rho, Y, UE, eps_nuc, deps_nuc_dT, deps_nuc_dRh real(dp), intent(out) :: deps_nuc_dRho ! partial wrt density call FL_epsnuc_3alf(T, Rho, Y, UE, eps_nuc, deps_nuc_dT, deps_nuc_dRho) end subroutine eval_FL_epsnuc_3alf - + subroutine eval_n14_electron_capture_rate(T,Rho,UE,rate) use ratelib, only: n14_electron_capture_rate real(dp), intent(in) :: T ! temperature @@ -914,11 +914,11 @@ subroutine eval_n14_electron_capture_rate(T,Rho,UE,rate) real(dp), intent(in) :: UE ! electron molecular weight real(dp), intent(out) :: rate ! (s^-1) call n14_electron_capture_rate(T,Rho,UE,rate) - end subroutine eval_n14_electron_capture_rate + end subroutine eval_n14_electron_capture_rate ! call this once before calling eval_ecapture - ! sets info that depends only on temp, den, and overall composition + ! sets info that depends only on temp, den, and overall composition subroutine coulomb_set_context( & cc, temp, den, logT, logRho, zbar, abar, z2bar) use rates_def, only: Coulomb_Info diff --git a/rates/test/src/reaction_rate_from_cache.f90 b/rates/test/src/reaction_rate_from_cache.f90 index a740575b6..4f1e49c10 100644 --- a/rates/test/src/reaction_rate_from_cache.f90 +++ b/rates/test/src/reaction_rate_from_cache.f90 @@ -29,13 +29,13 @@ program show_rates use const_lib use math_lib use utils_lib, only: mesa_error - + implicit none - + character (len=256) :: cache_filename integer :: ierr, n character (len=32) :: my_mesa_dir - + n = COMMAND_ARGUMENT_COUNT() if (n /= 1) then write(*,*) 'please give full path name of cache file on command line' @@ -43,16 +43,16 @@ program show_rates end if call GET_COMMAND_ARGUMENT(1, cache_filename) write(*,'(a)') '# rates from ' // trim(cache_filename) - my_mesa_dir = '' - call const_init(my_mesa_dir,ierr) + my_mesa_dir = '' + call const_init(my_mesa_dir,ierr) if (ierr /= 0) then write(*,*) 'const_init failed' call mesa_error(__FILE__,__LINE__) - end if + end if call math_init() - + ierr = 0 - call show_reaction_rates_from_cache(cache_filename, ierr) + call show_reaction_rates_from_cache(cache_filename, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + end program show_rates diff --git a/rates/test/src/test_ecapture.f90 b/rates/test/src/test_ecapture.f90 index 9d9e9bbdd..9305e45a3 100644 --- a/rates/test/src/test_ecapture.f90 +++ b/rates/test/src/test_ecapture.f90 @@ -335,7 +335,7 @@ end subroutine Setup_eos - - + + end module test_ecapture diff --git a/rates/test/src/test_rates.f90 b/rates/test/src/test_rates.f90 index bb4b7670d..c07c5ad21 100644 --- a/rates/test/src/test_rates.f90 +++ b/rates/test/src/test_rates.f90 @@ -23,7 +23,7 @@ ! ! *********************************************************************** module test_rates_support - + use rates_def use rates_lib use chem_lib @@ -31,7 +31,7 @@ module test_rates_support use const_def, only: missing_value use math_lib use utils_lib, only: mesa_error - + implicit none @@ -40,23 +40,23 @@ module test_rates_support subroutine setup use chem_def - + integer :: ierr character (len=32) :: my_mesa_dir - + include 'formats' - + ierr = 0 - - my_mesa_dir = '../..' - call const_init(my_mesa_dir,ierr) + + my_mesa_dir = '../..' + call const_init(my_mesa_dir,ierr) if (ierr /= 0) then write(*,*) 'const_init failed' call mesa_error(__FILE__,__LINE__) - end if - + end if + call math_init() - + call chem_init('isotopes.data', ierr) if (ierr /= 0) then write(*,*) 'chem_init failed' @@ -64,18 +64,18 @@ subroutine setup end if ! use special weak reaction data in test directory - + call rates_init('reactions.list', '', 'rate_tables', & .true., & .true., 'test_special.states', 'test_special.transitions', & - '', ierr) + '', ierr) if (ierr /= 0) then write(*,*) 'rates_init failed' call mesa_error(__FILE__,__LINE__) end if - + call rates_warning_init(.true., 10d0) - + call read_raw_rates_records(ierr) if (ierr /= 0) then write(*,*) 'read_raw_rates_records failed' @@ -92,55 +92,55 @@ subroutine do_test_rates() type (T_Factors), pointer :: tf real(dp) :: logT, temp integer :: i, t - + integer :: nrates_to_eval integer, allocatable :: irs(:) real(dp), allocatable :: raw_rates(:) real(dp),dimension(9) :: temps - + logical, parameter :: dbg = .false. - + include 'formats' - + write(*,'(A)') - + temps = (/6.0d0,6.5d0,7.0d0,7.5d0,8.0d0,8.5d0,9.0d0,9.5d0,10.0d0/) - + tf => tf_rec - + if (dbg) then - + nrates_to_eval = 1 allocate(irs(nrates_to_eval),raw_rates(nrates_to_eval)) - + irs(1:nrates_to_eval) = (/ & ir_s32_ga_si28 & /) - + else - + nrates_to_eval = num_predefined_reactions allocate(irs(nrates_to_eval),raw_rates(nrates_to_eval)) do i=1, nrates_to_eval - irs(i) = i + irs(i) = i end do end if - + do t=1,size(temps) logT = temps(t) temp = exp10(logT) call eval_tfactors(tf, logT, temp) - write(*,1) 'logT', logT + write(*,1) 'logT', logT write(*,1) 'temp', temp write(*,'(A)') - + raw_rates = missing_value - + call get_raw_rates(nrates_to_eval, irs, temp, tf, raw_rates, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + do i=1,nrates_to_eval if (raw_rates(i) == missing_value) then write(*,*) 'missing value for ' // trim(reaction_Name(irs(i))) @@ -153,9 +153,9 @@ subroutine do_test_rates() write(*,*) 'done' write(*,'(A)') - - end subroutine do_test_rates - + + end subroutine do_test_rates + subroutine test1 integer :: ierr @@ -164,54 +164,54 @@ subroutine test1 real(dp) :: logT, temp, raw_rate, raw_rate1, raw_rate2 integer :: ir logical, parameter :: dbg = .false. - + include 'formats' - + write(*,'(A)') write(*,*) 'test1' - + tf => tf_rec - + temp = 3d9 logT = log10(temp) call eval_tfactors(tf, logT, temp) - - write(*,1) 'logT', logT + + write(*,1) 'logT', logT write(*,1) 'temp', temp write(*,'(A)') - + ir = rates_reaction_id('r_ni56_wk_co56') if (ir == 0) then write(*,*) 'failed to find rate id' call mesa_error(__FILE__,__LINE__) end if - - call run1 - raw_rate1 = raw_rate - + + call run1 + raw_rate1 = raw_rate + temp = 3.000000001d9 logT = log10(temp) call eval_tfactors(tf, logT, temp) - - write(*,1) 'logT', logT + + write(*,1) 'logT', logT write(*,1) 'temp', temp write(*,1) 'raw_rate1', raw_rate1 write(*,'(A)') - + stop - + ir = rates_reaction_id('r_s32_ga_si28') - call run1 + call run1 raw_rate2 = raw_rate - + write(*,1) 'raw_rate2', raw_rate2 write(*,1) 'raw_rate2-raw_rate1', raw_rate2-raw_rate1 write(*,*) 'done' write(*,'(A)') - + contains - + subroutine run1 include 'formats' call get_raw_rate(ir, temp, tf, raw_rate, ierr) @@ -219,9 +219,9 @@ subroutine run1 write(*,1) trim(reaction_Name(ir)), raw_rate write(*,'(A)') end subroutine run1 - - end subroutine test1 - + + end subroutine test1 + subroutine do_test_FL_epsnuc_3alf real(dp) :: T ! temperature real(dp) :: Rho ! density @@ -247,31 +247,31 @@ subroutine do_test_rate_table real(dp) :: logT, temp, raw_rate integer :: ir logical, parameter :: dbg = .false. - + include 'formats' - - + + write(*,'(A)') write(*,*) 'do_test_rate_table' - + tf => tf_rec - + temp = 9.0d8 logT = log10(temp) call eval_tfactors(tf, logT, temp) - - write(*,1) 'logT', logT + + write(*,1) 'logT', logT write(*,1) 'temp', temp write(*,'(A)') - + ir = rates_reaction_id('r3') - call run1 + call run1 write(*,*) 'done' write(*,'(A)') - + contains - + subroutine run1 include 'formats' call get_raw_rate(ir, temp, tf, raw_rate, ierr) @@ -279,9 +279,9 @@ subroutine run1 write(*,1) trim(reaction_Name(ir)), raw_rate write(*,'(A)') end subroutine run1 - + end subroutine do_test_rate_table - + subroutine do_test2_FL_epsnuc_3alf real(dp) :: T ! temperature real(dp) :: Rho ! density @@ -322,25 +322,25 @@ end module test_rates_support program test_rates - + use test_screen use test_weak use test_ecapture use test_rates_support - + implicit none call setup - + !call do_test_rates(rates_JR_if_available); stop !call test1; stop - + call do_test_screen - + call do_test_weak - + call do_test_ecapture - + call do_test_rates() call do_test_FL_epsnuc_3alf() call do_test_rate_table diff --git a/rates/test/src/test_screen.f90 b/rates/test/src/test_screen.f90 index cb880a7a2..4cee94dae 100644 --- a/rates/test/src/test_screen.f90 +++ b/rates/test/src/test_screen.f90 @@ -25,11 +25,11 @@ module test_screen - + use rates_lib use rates_def use utils_lib, only: mesa_error - + implicit none contains @@ -40,7 +40,7 @@ subroutine do_test_screen use chem_lib use const_lib use math_lib - + integer, parameter :: num_isos = 8, max_z_to_cache = 12 integer :: chem_id(num_isos), i1, i2, ierr integer, pointer :: net_iso(:) @@ -52,24 +52,24 @@ subroutine do_test_screen integer :: i integer :: h1, he3, he4, c12, n14, o16, ne20, mg24 character (len=32) :: my_mesa_dir - + include 'formats' - + ierr = 0 - my_mesa_dir = '../..' - call const_init(my_mesa_dir,ierr) + my_mesa_dir = '../..' + call const_init(my_mesa_dir,ierr) if (ierr /= 0) then write(*,*) 'const_init failed' call mesa_error(__FILE__,__LINE__) - end if + end if call math_init() - + call chem_init('isotopes.data', ierr) if (ierr /= 0) then write(*,*) 'chem_init failed' call mesa_error(__FILE__,__LINE__) end if - + h1 = 1 he3 = 2 he4 = 3 @@ -78,11 +78,11 @@ subroutine do_test_screen o16 = 6 ne20 = 7 mg24 = 8 - + allocate(net_iso(num_chem_isos)) - + net_iso = 0 - + net_iso(ih1)=h1; chem_id(h1) = ih1 net_iso(ihe3)=he3; chem_id(he3) = ihe3 net_iso(ihe4)=he4; chem_id(he4) = ihe4 @@ -91,7 +91,7 @@ subroutine do_test_screen net_iso(io16)=o16; chem_id(o16) = io16 net_iso(ine20)=ne20; chem_id(ne20) = ine20 net_iso(img24)=mg24; chem_id(mg24) = img24 - + logT = 7.7110722845770692D+00 logRho = 4.5306372623742392D+00 @@ -106,9 +106,9 @@ subroutine do_test_screen i1 = ihe4 i2 = ic12 - + if (.false.) then ! TESTING - + xin = 0 xin(net_iso(ih1))= 0.72d0 xin(net_iso(ihe4))= 0.26d0 @@ -116,43 +116,43 @@ subroutine do_test_screen i1 = ih1 i2 = in14 - + write(*,1) 'sum(xin)', sum(xin(:)) - + logT = 7d0 logRho = 1d0 - + end if - + call composition_info( & num_isos, chem_id, xin, xh, xhe, xz, abar, zbar, z2bar, z53bar, & ye, mass_correction, sumx, dabar_dx, dzbar_dx, dmc_dx) - + iso_z(:) = chem_isos% Z(chem_id(:)) - + do i=1,num_isos iso_z158(i) = pow(real(chem_isos% Z(chem_id(i)),kind=dp),1.58d0) end do y(:) = xin(:)/chem_isos% Z_plus_N(chem_id(:)) - + call do1(salpeter_screening, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call do1(extended_screening, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call do1(chugunov_screening, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call do1(no_screening, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + deallocate(net_iso) write(*,*) 'done' - + contains - + subroutine do1(sc_mode, ierr) use math_lib integer, intent(in) :: sc_mode @@ -162,10 +162,10 @@ subroutine do1(sc_mode, ierr) call screening_option_str(sc_mode, sc_str, ierr) if (ierr /= 0) return write(*,*) trim(sc_str) - + temp = exp10(logT) den = exp10(logRho) - + call screen_init_AZ_info( & chem_isos% W(i1), dble(chem_isos% Z(i1)), & chem_isos% W(i2), dble(chem_isos% Z(i2)), & @@ -200,8 +200,8 @@ subroutine do1(sc_mode, ierr) write(*,'(A)') end subroutine do1 - - end subroutine do_test_screen + + end subroutine do_test_screen end module test_screen diff --git a/rates/test/src/test_weak.f90 b/rates/test/src/test_weak.f90 index 39d69d1e0..cf56d67df 100644 --- a/rates/test/src/test_weak.f90 +++ b/rates/test/src/test_weak.f90 @@ -30,11 +30,11 @@ module test_weak use const_def use utils_lib, only: mesa_error use num_lib, only: dfridr - + implicit none - + contains - + subroutine do_test_weak use const_lib use chem_lib @@ -54,11 +54,11 @@ subroutine do_test_weak real(dp) :: dvardx, dvardx_0, dx_0, err, var_0, xdum logical :: doing_d_dlnd - + include 'formats' ierr = 0 - + write(*,*) 'check weak_info_list' weak_lhs = 'o14' weak_rhs = 'n14' @@ -72,10 +72,10 @@ subroutine do_test_weak write(*,1) 'halflife', weak_info_list_halflife(i) write(*,1) 'Qneu', weak_info_list_Qneu(i) write(*,'(A)') - + d_eta_dlnT = 0 d_eta_dlnRho = 0 - + if (.false.) then ! TESTING logT = 7.5904236599874348D+00 logRho = 1.0657946486820271D+00 @@ -108,7 +108,7 @@ subroutine do_test_weak Ye = 0.5d0 eta = 0d0 end if - + T = exp10(logT) T9 = T*1d-9 rho = exp10(logRho) @@ -122,7 +122,7 @@ subroutine do_test_weak write(*,1) 'T9', T9 write(*,1) 'lYeRho', log10(YeRho) write(*,'(A)') - + nr = num_weak_reactions allocate( & ids(nr), reaction_ids(nr), & @@ -135,11 +135,11 @@ subroutine do_test_weak ids(i) = i reaction_ids(i) = i end do - + write(*,'(A)') write(*,2) 'nr', nr write(*,'(A)') - + call eval_weak_reaction_info( & nr, ids, reaction_ids, cc, T9, YeRho, & eta, d_eta_dlnT, d_eta_dlnRho, & @@ -151,7 +151,7 @@ subroutine do_test_weak write(*,*) 'failed in eval_weak_reaction_info' call mesa_error(__FILE__,__LINE__) end if - + if (.true.) then write(*,'(30x,99a16)') & 'halflife', 'Qneu', 'Qtotal' @@ -183,7 +183,7 @@ subroutine do_test_weak Q(i), Qneu(i), lambda(i) end do write(*,'(A)') - + if (.false.) then write(*,'(a30,5a12,a20)') 'd_dT9', 'Q', 'Qneu', 'lambda' do i = 1, nr @@ -195,7 +195,7 @@ subroutine do_test_weak end do write(*,'(A)') end if - + if (.false.) then write(*,'(a30,5a12,a20)') 'd_d_rho', 'Q', 'Qneu', 'lambda' do i = 1, nr @@ -209,7 +209,7 @@ subroutine do_test_weak end if end if - + write(*,*) 'done' if (.false.) then ! dfridr tests for partials @@ -252,7 +252,7 @@ subroutine do_test_weak end if - + deallocate( & ids, reaction_ids, & lambda, dlambda_dlnT, dlambda_dlnRho, & diff --git a/sample/src/eos_correction.f90 b/sample/src/eos_correction.f90 index 2e4652d80..3d8def7ad 100644 --- a/sample/src/eos_correction.f90 +++ b/sample/src/eos_correction.f90 @@ -9,7 +9,7 @@ ! by the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! - ! MESA is distributed in the hope that it will be useful, + ! MESA is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU Library General Public License for more details. @@ -19,7 +19,7 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + program eos_correction use eos_def use eos_lib @@ -27,16 +27,16 @@ program eos_correction use chem_lib use const_lib use math_lib - + implicit none - + integer :: handle real(dp) :: X, Z, Y, abar, zbar, z2bar, z53bar, ye, WoA integer, parameter :: species = 2 integer, parameter :: h1 = 1, c12 = 2 integer, pointer, dimension(:) :: net_iso, chem_id real(dp) :: xa(species) - + integer, parameter :: num_lgRhos = 601 integer, parameter :: num_lgTs = 321 real(dp), parameter :: lg_Tmin = 6.0_dp, lg_Tmax = 9.2_dp, & @@ -46,9 +46,9 @@ program eos_correction real(dp), dimension(num_lgTs, num_lgRhos) :: tab,Ytab,Etab integer :: i character (len=256) :: my_mesa_dir - + call setup - + do i=1,num_lgts lg_Ts(i) = lg_Tmax + real(i-1)*(lg_Tmin-lg_Tmax)/real(num_lgTs-1) end do @@ -56,44 +56,44 @@ program eos_correction lg_Rhos(i) = lg_Rhomin + real(i-1)*(lg_Rhomax-lg_Rhomin)/real(num_lgRhos-1) end do call write_axes_to_file - + X = 0.0_dp; Y = 0.0_dp; Z = 1.0_dp call make_correction_table(X, Z, tab,Ytab,Etab) call write_correction_table('correction_C12.data',tab) call write_correction_table('Yfree_C12.data',Ytab) call write_correction_table('EoC2_C12.data',Etab) - + call shutdown - + contains - + subroutine setup() use math_lib integer :: ierr - + ierr = 0 my_mesa_dir = '..' ! if empty string, uses environment variable MESA_DIR - call const_init(my_mesa_dir,ierr) + call const_init(my_mesa_dir,ierr) if (ierr /= 0) then write(*,*) 'const_init failed' call mesa_error(__FILE__,__LINE__) - end if - + end if + call math_init() - + call chem_init('isotopes.data', ierr) if (ierr /= 0) then write(*,*) 'failed in chem_init' call mesa_error(__FILE__,__LINE__) end if - + ! allocate and initialize the eos tables call Setup_eos(handle) - + allocate(net_iso(num_chem_isos), chem_id(species), stat=ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'allocate failed') end subroutine setup - + subroutine make_correction_table(X,Z,Ecorr,Ytab,Etab) implicit none real(dp), intent(in) :: X, Z @@ -103,26 +103,26 @@ subroutine make_correction_table(X,Z,Ecorr,Ytab,Etab) real(dp), dimension(num_eos_d_dxa_results, species) :: d_dxa real(dp) :: Yplus, Yfree, Eoc2 integer :: i,j,ierr - + call Init_Composition(X,Z) - + do i = 1, num_lgRhos log10Rho = lg_Rhos(i) Rho = exp10(log10Rho) do j = 1, num_lgTs log10T = lg_Ts(j) T = exp10(log10T) - + call eosDT_get( & handle, & species, chem_id, net_iso, xa, & Rho, log10Rho, T, log10T, res, d_dlnd, d_dlnT, & d_dxa, ierr) - + Yfree = exp(res(i_lnfree_e)) Yplus = max(Yfree-ye,0.0_dp) Eoc2 = exp(res(i_lnE))/(clight*clight) - + Ecorr(j,i) = WoA + Yplus*me/amu + Eoc2 Ytab(j,i) = Yplus Etab(j,i) = Eoc2 @@ -135,41 +135,41 @@ subroutine make_correction_table(X,Z,Ecorr,Ytab,Etab) write (*,'(a16,"=",2f13.6)') 'E/c**2 min, max',minval(Etab(1:num_lgTs, 1:num_lgRhos)), & maxval(Etab(1:num_lgTs, 1:num_lgRhos)) end subroutine make_correction_table - - + + subroutine shutdown() ! deallocate the eos tables call Shutdown_eos(handle) - + deallocate(net_iso, chem_id) - + end subroutine shutdown - - + + subroutine Setup_eos(handle) ! allocate and load the eos tables integer, intent(out) :: handle - + integer :: ierr logical, parameter :: use_cache = .true. - + call eos_init('', use_cache, ierr) if (ierr /= 0) then write(*,*) 'eos_init failed in Setup_eos' call mesa_error(__FILE__,__LINE__) end if - + write(*,*) 'loading eos tables' - + handle = alloc_eos_handle(ierr) if (ierr /= 0) then write(*,*) 'failed trying to allocate eos handle' call mesa_error(__FILE__,__LINE__) end if - + end subroutine Setup_eos - - + + subroutine Shutdown_eos(handle) use eos_def use eos_lib @@ -177,72 +177,72 @@ subroutine Shutdown_eos(handle) call free_eos_handle(handle) call eos_shutdown end subroutine Shutdown_eos - - + + subroutine Init_Composition(X,Z) use chem_lib real(dp), intent(in) :: X, Z real(dp) :: dabar_dx(species), dzbar_dx(species), dmc_dx(species), sumx, xh, xhe, xz - + xa(h1) = X xa(c12) = Z - + net_iso(:) = 0 chem_id(h1) = ih1; net_iso(ih1) = h1 chem_id(c12) = ic12; net_iso(ic12) = c12 - + call composition_info( & & species, chem_id, xa, xh, xhe, xz, abar, zbar, z2bar, z53bar, ye, & & WoA, sumx, dabar_dx, dzbar_dx, dmc_dx) - + end subroutine Init_Composition - + subroutine write_axes_to_file() use utils_lib character(len=*), parameter :: form = '(f6.2)' integer :: iounit, ierr - + open(newunit=iounit, file='data/lgTs', iostat=ierr, action="write") if ( ierr /= 0 ) then write(*,*) "Error opening file data/lgTs" stop end if - + write(iounit,form) lg_Ts close(iounit) - + open(newunit=iounit, file='data/lgRhos', iostat=ierr, action="write") if ( ierr /= 0 ) then write(*,*) "Error opening file data/lgRhos" stop end if - + write(iounit,form) lg_Rhos close(iounit) - + end subroutine write_axes_to_file - + subroutine write_correction_table(filename, tab) use utils_lib character(len=*), intent(in) :: filename real(dp), dimension(num_lgTs,num_lgRhos), intent(in) :: tab integer :: iounit, ierr character(len=32) :: form - + open(newunit=iounit, file='data/'//trim(filename), iostat=ierr, action="write") if ( ierr /= 0 ) then write (*,*) "Error opening file data/Ecorrection.data" stop end if - + write(form,'("(",i0,"f11.6)")') num_lgRhos - + do i = 1, num_lgTs write(iounit,form) tab(i,:) end do - + close(iounit) end subroutine write_correction_table - + end program eos_correction - + diff --git a/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP2_TDC/src/run.f90 b/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP2_TDC/src/run.f90 index 0755aeea0..18fbdda1a 100644 --- a/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP2_TDC/src/run.f90 +++ b/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP2_TDC/src/run.f90 @@ -1,6 +1,6 @@ program run use run_star_extras, only: do_run_multi_stars - + call do_run_multi_stars - + end program diff --git a/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP2_TDC/src/run_star_extras.f90 b/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP2_TDC/src/run_star_extras.f90 index 7a1026781..85fe2c157 100644 --- a/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP2_TDC/src/run_star_extras.f90 +++ b/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP2_TDC/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,12 +27,12 @@ module run_star_extras use const_def use math_lib use run_star_support - + implicit none - + include 'test_suite_extras_def.inc' include 'multi_stars_extras_def.inc' - + contains include 'test_suite_extras.inc' @@ -49,8 +49,8 @@ integer function extras_start_step(id) call star_ptr(id, s, ierr) if (ierr /= 0) return end function extras_start_step - - + + ! returns either keep_going or terminate. integer function extras_finish_step(id) integer, intent(in) :: id @@ -88,8 +88,8 @@ integer function extras_finish_step(id) end do end if end function extras_finish_step - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -105,10 +105,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -118,15 +118,15 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (id == 1 .and. .not. s% RSP2_flag) then write(*,*) 'star id==1, but not RSP2_flag' call mesa_error(__FILE__,__LINE__,'extras_startup') end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -147,7 +147,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -160,8 +160,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 6 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -196,7 +196,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) vals(6) = s_other% rsp_num_periods end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -207,8 +207,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 38 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -233,48 +233,48 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end if call star_ptr(id_other, s_other, ierr) if (ierr /= 0) return - + i=1 names(i) = 'v_R'; i=i+1 names(i) = 'v_diff'; i=i+1 names(i) = 'v_drel'; i=i+1 - + names(i) = 'Y_face_R'; i=i+1 names(i) = 'Y_diff'; i=i+1 names(i) = 'Y_drel'; i=i+1 - + names(i) = 'vc_R'; i=i+1 names(i) = 'vc_diff'; i=i+1 names(i) = 'vc_drel'; i=i+1 - + names(i) = 'Lc_div_L_R'; i=i+1 names(i) = 'Lc_diff'; i=i+1 names(i) = 'Lc_drel'; i=i+1 - + names(i) = 'COUPL_R'; i=i+1 names(i) = 'CPL_diff'; i=i+1 names(i) = 'CPL_drel'; i=i+1 - + names(i) = 'SRC_R'; i=i+1 names(i) = 'SRC_diff'; i=i+1 names(i) = 'SRC_drel'; i=i+1 - + names(i) = 'DAMP_R'; i=i+1 names(i) = 'DAMP_diff'; i=i+1 names(i) = 'DAMP_drel'; i=i+1 - + names(i) = 'DAMPR_R'; i=i+1 names(i) = 'DAMPR_diff'; i=i+1 names(i) = 'DAMPR_drel'; i=i+1 - + names(i) = 'Eq_R'; i=i+1 names(i) = 'Eq_diff'; i=i+1 names(i) = 'Eq_drel'; i=i+1 - + names(i) = 'Uq_R'; i=i+1 names(i) = 'Uq_diff'; i=i+1 names(i) = 'Uq_drel'; i=i+1 - + names(i) = 'Pvsc_R'; i=i+1 names(i) = 'Pvsc_diff'; i=i+1 names(i) = 'Pvsc_drel'; i=i+1 @@ -291,16 +291,16 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(1:nz,:) = 0d0 else do k=1,nz - + i = 1 vals(k,i) = s_other% v(k)*1d-5; i=i+1 vals(k,i) = s_other% v(k) - s% v(k); i=i+1 vals(k,i) = rel_diff(s_other% v(k), s% v(k)); i=i+1 - + vals(k,i) = s_other% Y_face(k); i=i+1 vals(k,i) = s_other% Y_face(k) - s% Y_face(k); i=i+1 vals(k,i) = rel_diff(s_other% Y_face(k), s% Y_face(k)); i=i+1 - + if (s_other% RSP2_flag) then val = s_other% w(k)*sqrt_2_div_3 else @@ -315,36 +315,36 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call mesa_error(__FILE__,__LINE__,'data_for_extra_profile_columns') end if vals(k,i) = rel_diff(val, s% mlt_vc(k)); i=i+1 - + val = s_other% Lc(k)/s_other% L(k) vals(k,i) = val; i=i+1 vals(k,i) = val - s% Lc(k)/s% L(k); i=i+1 vals(k,i) = rel_diff(val, s% Lc(k)/s% L(k)); i=i+1 - + vals(k,i) = s_other% COUPL(k); i=i+1 vals(k,i) = s_other% COUPL(k) - s% COUPL(k); i=i+1 vals(k,i) = rel_diff(s_other% COUPL(k), s% COUPL(k)); i=i+1 - + vals(k,i) = s_other% SOURCE(k); i=i+1 vals(k,i) = s_other% SOURCE(k) - s% SOURCE(k); i=i+1 vals(k,i) = rel_diff(s_other% SOURCE(k), s% SOURCE(k)); i=i+1 - + vals(k,i) = s_other% DAMP(k); i=i+1 vals(k,i) = s_other% DAMP(k) - s% DAMP(k); i=i+1 vals(k,i) = rel_diff(s_other% DAMP(k), s% DAMP(k)); i=i+1 - + vals(k,i) = s_other% DAMPR(k); i=i+1 vals(k,i) = s_other% DAMPR(k) - s% DAMPR(k); i=i+1 vals(k,i) = rel_diff(s_other% DAMPR(k), s% DAMPR(k)); i=i+1 - + vals(k,i) = s_other% Eq(k); i=i+1 vals(k,i) = s_other% Eq(k) - s% Eq(k); i=i+1 vals(k,i) = rel_diff(s_other% Eq(k), s% Eq(k)); i=i+1 - + vals(k,i) = s_other% Uq(k); i=i+1 vals(k,i) = s_other% Uq(k) - s% Uq(k); i=i+1 vals(k,i) = rel_diff(s_other% Uq(k), s% Uq(k)); i=i+1 - + vals(k,i) = s_other% Pvsc(k); i=i+1 vals(k,i) = s_other% Pvsc(k) - s% Pvsc(k); i=i+1 vals(k,i) = rel_diff(s_other% Pvsc(k), s% Pvsc(k)); i=i+1 @@ -354,12 +354,12 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(k,i) = s_other% lnT(k)/ln10; i=i+1 vals(k,i) = s_other% lnd(k)/ln10; i=i+1 vals(k,i) = safe_log10(s_other% L(k)/Lsun); i=i+1 - + end do end if - + contains - + real(dp) function rel_diff(a, b, atol, rtol) result(d) real(dp), intent(in) :: a, b real(dp), intent(in), optional :: atol, rtol @@ -376,7 +376,7 @@ real(dp) function rel_diff(a, b, atol, rtol) result(d) end if d = (a - b)/(atl + rtl*max(abs(a),abs(b))) end function rel_diff - + real(dp) function fix_if_bad(v) use utils_lib, only: is_bad real(dp), intent(in) :: v @@ -386,8 +386,8 @@ real(dp) function fix_if_bad(v) fix_if_bad = v end if end function fix_if_bad - + end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_RSP2/src/run.f90 b/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_RSP2/src/run.f90 index 0755aeea0..18fbdda1a 100644 --- a/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_RSP2/src/run.f90 +++ b/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_RSP2/src/run.f90 @@ -1,6 +1,6 @@ program run use run_star_extras, only: do_run_multi_stars - + call do_run_multi_stars - + end program diff --git a/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_RSP2/src/run_star_extras.f90 b/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_RSP2/src/run_star_extras.f90 index 3ab6f279f..97e78f631 100644 --- a/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_RSP2/src/run_star_extras.f90 +++ b/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_RSP2/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,12 +27,12 @@ module run_star_extras use const_def use math_lib use run_star_support - + implicit none - + include 'test_suite_extras_def.inc' include 'multi_stars_extras_def.inc' - + contains include 'test_suite_extras.inc' @@ -49,8 +49,8 @@ integer function extras_start_step(id) call star_ptr(id, s, ierr) if (ierr /= 0) return end function extras_start_step - - + + ! returns either keep_going or terminate. integer function extras_finish_step(id) integer, intent(in) :: id @@ -88,8 +88,8 @@ integer function extras_finish_step(id) end do end if end function extras_finish_step - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -105,10 +105,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -118,15 +118,15 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (id == 1 .and. .not. s% RSP_flag) then write(*,*) 'star id==1, but not RSP_flag' call mesa_error(__FILE__,__LINE__,'extras_startup') end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -147,7 +147,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -160,8 +160,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 6 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -196,7 +196,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) vals(6) = s_other% rsp_num_periods end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -207,8 +207,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 38 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -233,48 +233,48 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end if call star_ptr(id_other, s_other, ierr) if (ierr /= 0) return - + i=1 names(i) = 'v_R'; i=i+1 names(i) = 'v_diff'; i=i+1 names(i) = 'v_drel'; i=i+1 - + names(i) = 'Y_face_R'; i=i+1 names(i) = 'Y_diff'; i=i+1 names(i) = 'Y_drel'; i=i+1 - + names(i) = 'w_R'; i=i+1 names(i) = 'w_diff'; i=i+1 names(i) = 'w_drel'; i=i+1 - + names(i) = 'Lc_div_L_R'; i=i+1 names(i) = 'Lc_diff'; i=i+1 names(i) = 'Lc_drel'; i=i+1 - + names(i) = 'COUPL_R'; i=i+1 names(i) = 'CPL_diff'; i=i+1 names(i) = 'CPL_drel'; i=i+1 - + names(i) = 'SRC_R'; i=i+1 names(i) = 'SRC_diff'; i=i+1 names(i) = 'SRC_drel'; i=i+1 - + names(i) = 'DAMP_R'; i=i+1 names(i) = 'DAMP_diff'; i=i+1 names(i) = 'DAMP_drel'; i=i+1 - + names(i) = 'DAMPR_R'; i=i+1 names(i) = 'DAMPR_diff'; i=i+1 names(i) = 'DAMPR_drel'; i=i+1 - + names(i) = 'Eq_R'; i=i+1 names(i) = 'Eq_diff'; i=i+1 names(i) = 'Eq_drel'; i=i+1 - + names(i) = 'Uq_R'; i=i+1 names(i) = 'Uq_diff'; i=i+1 names(i) = 'Uq_drel'; i=i+1 - + names(i) = 'Pvsc_R'; i=i+1 names(i) = 'Pvsc_diff'; i=i+1 names(i) = 'Pvsc_drel'; i=i+1 @@ -291,16 +291,16 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(1:nz,:) = 0d0 else do k=1,nz - + i = 1 vals(k,i) = s_other% v(k)*1d-5; i=i+1 vals(k,i) = s_other% v(k) - s% v(k); i=i+1 vals(k,i) = rel_diff(s_other% v(k), s% v(k)); i=i+1 - + vals(k,i) = s_other% Y_face(k); i=i+1 vals(k,i) = s_other% Y_face(k) - s% Y_face(k); i=i+1 vals(k,i) = rel_diff(s_other% Y_face(k), s% Y_face(k)); i=i+1 - + if (s_other% RSP2_flag) then val = s_other% w(k) else if (s_other% RSP_flag) then @@ -315,36 +315,36 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call mesa_error(__FILE__,__LINE__,'data_for_extra_profile_columns') end if vals(k,i) = rel_diff(val, s% w(k)); i=i+1 - + val = s_other% Lc(k)/s_other% L(k) vals(k,i) = val; i=i+1 vals(k,i) = val - s% Lc(k)/s% L(k); i=i+1 vals(k,i) = rel_diff(val, s% Lc(k)/s% L(k)); i=i+1 - + vals(k,i) = s_other% COUPL(k); i=i+1 vals(k,i) = s_other% COUPL(k) - s% COUPL(k); i=i+1 vals(k,i) = rel_diff(s_other% COUPL(k), s% COUPL(k)); i=i+1 - + vals(k,i) = s_other% SOURCE(k); i=i+1 vals(k,i) = s_other% SOURCE(k) - s% SOURCE(k); i=i+1 vals(k,i) = rel_diff(s_other% SOURCE(k), s% SOURCE(k)); i=i+1 - + vals(k,i) = s_other% DAMP(k); i=i+1 vals(k,i) = s_other% DAMP(k) - s% DAMP(k); i=i+1 vals(k,i) = rel_diff(s_other% DAMP(k), s% DAMP(k)); i=i+1 - + vals(k,i) = s_other% DAMPR(k); i=i+1 vals(k,i) = s_other% DAMPR(k) - s% DAMPR(k); i=i+1 vals(k,i) = rel_diff(s_other% DAMPR(k), s% DAMPR(k)); i=i+1 - + vals(k,i) = s_other% Eq(k); i=i+1 vals(k,i) = s_other% Eq(k) - s% Eq(k); i=i+1 vals(k,i) = rel_diff(s_other% Eq(k), s% Eq(k)); i=i+1 - + vals(k,i) = s_other% Uq(k); i=i+1 vals(k,i) = s_other% Uq(k) - s% Uq(k); i=i+1 vals(k,i) = rel_diff(s_other% Uq(k), s% Uq(k)); i=i+1 - + vals(k,i) = s_other% Pvsc(k); i=i+1 vals(k,i) = s_other% Pvsc(k) - s% Pvsc(k); i=i+1 vals(k,i) = rel_diff(s_other% Pvsc(k), s% Pvsc(k)); i=i+1 @@ -354,12 +354,12 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(k,i) = s_other% lnT(k)/ln10; i=i+1 vals(k,i) = s_other% lnd(k)/ln10; i=i+1 vals(k,i) = safe_log10(s_other% L(k)/Lsun); i=i+1 - + end do end if - + contains - + real(dp) function rel_diff(a, b, atol, rtol) result(d) real(dp), intent(in) :: a, b real(dp), intent(in), optional :: atol, rtol @@ -376,7 +376,7 @@ real(dp) function rel_diff(a, b, atol, rtol) result(d) end if d = (a - b)/(atl + rtl*max(abs(a),abs(b))) end function rel_diff - + real(dp) function fix_if_bad(v) use utils_lib, only: is_bad real(dp), intent(in) :: v @@ -386,8 +386,8 @@ real(dp) function fix_if_bad(v) fix_if_bad = v end if end function fix_if_bad - + end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_TDC/src/run.f90 b/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_TDC/src/run.f90 index 0755aeea0..18fbdda1a 100644 --- a/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_TDC/src/run.f90 +++ b/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_TDC/src/run.f90 @@ -1,6 +1,6 @@ program run use run_star_extras, only: do_run_multi_stars - + call do_run_multi_stars - + end program diff --git a/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_TDC/src/run_star_extras.f90 b/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_TDC/src/run_star_extras.f90 index 8bde2dc33..a4534ce2f 100644 --- a/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_TDC/src/run_star_extras.f90 +++ b/star/dev_cases_compare_pulses/dev_compare_Cepheid_RSP_TDC/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,12 +27,12 @@ module run_star_extras use const_def use math_lib use run_star_support - + implicit none - + include 'test_suite_extras_def.inc' include 'multi_stars_extras_def.inc' - + contains include 'test_suite_extras.inc' @@ -49,8 +49,8 @@ integer function extras_start_step(id) call star_ptr(id, s, ierr) if (ierr /= 0) return end function extras_start_step - - + + ! returns either keep_going or terminate. integer function extras_finish_step(id) integer, intent(in) :: id @@ -64,8 +64,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -81,10 +81,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -94,15 +94,15 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (id == 1 .and. .not. s% RSP_flag) then write(*,*) 'star id==1, but not RSP_flag' call mesa_error(__FILE__,__LINE__,'extras_startup') end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -123,7 +123,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -136,8 +136,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 6 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -172,7 +172,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) vals(6) = s_other% rsp_num_periods end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -183,8 +183,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 27 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -209,38 +209,38 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end if call star_ptr(id_other, s_other, ierr) if (ierr /= 0) return - + i=1 names(i) = 'v_R'; i=i+1 names(i) = 'v_drel'; i=i+1 - + names(i) = 'Y_face_R'; i=i+1 names(i) = 'Y_drel'; i=i+1 - + names(i) = 'w_R'; i=i+1 names(i) = 'w_drel'; i=i+1 - + names(i) = 'Lc_div_L_R'; i=i+1 names(i) = 'Lc_drel'; i=i+1 - + names(i) = 'COUPL_R'; i=i+1 names(i) = 'CPL_drel'; i=i+1 - + names(i) = 'SRC_R'; i=i+1 names(i) = 'SRC_drel'; i=i+1 - + names(i) = 'DAMP_R'; i=i+1 names(i) = 'DAMP_drel'; i=i+1 - + names(i) = 'DAMPR_R'; i=i+1 names(i) = 'DAMPR_drel'; i=i+1 - + names(i) = 'Eq_R'; i=i+1 names(i) = 'Eq_drel'; i=i+1 - + names(i) = 'Uq_R'; i=i+1 names(i) = 'Uq_drel'; i=i+1 - + names(i) = 'Pvsc_R'; i=i+1 names(i) = 'Pvsc_drel'; i=i+1 @@ -256,14 +256,14 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(1:nz,:) = 0d0 else do k=1,nz - + i = 1 vals(k,i) = s_other% v(k)*1d-5; i=i+1 vals(k,i) = rel_diff(s_other% v(k), s% v(k)); i=i+1 - + vals(k,i) = s_other% Y_face(k); i=i+1 vals(k,i) = rel_diff(s_other% Y_face(k), s% Y_face(k)); i=i+1 - + if (s_other% RSP2_flag) then val = s_other% w(k) else if (s_other% RSP_flag) then @@ -273,29 +273,29 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end if vals(k,i) = val; i=i+1 vals(k,i) = rel_diff(val, s% w(k)); i=i+1 - + val = s_other% Lc(k)/s_other% L(k) vals(k,i) = val; i=i+1 vals(k,i) = rel_diff(val, s% Lc(k)/s% L(k)); i=i+1 - + vals(k,i) = s_other% COUPL(k); i=i+1 vals(k,i) = rel_diff(s_other% COUPL(k), s% COUPL(k)); i=i+1 - + vals(k,i) = s_other% SOURCE(k); i=i+1 vals(k,i) = rel_diff(s_other% SOURCE(k), s% SOURCE(k)); i=i+1 - + vals(k,i) = s_other% DAMP(k); i=i+1 vals(k,i) = rel_diff(s_other% DAMP(k), s% DAMP(k)); i=i+1 - + vals(k,i) = s_other% DAMPR(k); i=i+1 vals(k,i) = rel_diff(s_other% DAMPR(k), s% DAMPR(k)); i=i+1 - + vals(k,i) = s_other% Eq(k); i=i+1 vals(k,i) = rel_diff(s_other% Eq(k), s% Eq(k)); i=i+1 - + vals(k,i) = s_other% Uq(k); i=i+1 vals(k,i) = rel_diff(s_other% Uq(k), s% Uq(k)); i=i+1 - + vals(k,i) = s_other% Pvsc(k); i=i+1 vals(k,i) = rel_diff(s_other% Pvsc(k), s% Pvsc(k)); i=i+1 @@ -304,12 +304,12 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(k,i) = s_other% lnT(k)/ln10; i=i+1 vals(k,i) = s_other% lnd(k)/ln10; i=i+1 vals(k,i) = safe_log10(s_other% L(k)/Lsun); i=i+1 - + end do end if - + contains - + real(dp) function rel_diff(b, a, atol, rtol) result(d) real(dp), intent(in) :: a, b real(dp), intent(in), optional :: atol, rtol @@ -326,7 +326,7 @@ real(dp) function rel_diff(b, a, atol, rtol) result(d) end if d = (a - b)/(atl + rtl*max(abs(a),abs(b))) end function rel_diff - + real(dp) function fix_if_bad(v) use utils_lib, only: is_bad real(dp), intent(in) :: v @@ -336,8 +336,8 @@ real(dp) function fix_if_bad(v) fix_if_bad = v end if end function fix_if_bad - + end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_BEP/src/run.f90 b/star/dev_cases_star_to_RSP2/dev_BEP/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_star_to_RSP2/dev_BEP/src/run.f90 +++ b/star/dev_cases_star_to_RSP2/dev_BEP/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_star_to_RSP2/dev_BEP/src/run_star_extras.f90 b/star/dev_cases_star_to_RSP2/dev_BEP/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_star_to_RSP2/dev_BEP/src/run_star_extras.f90 +++ b/star/dev_cases_star_to_RSP2/dev_BEP/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_BLAP/src/run.f90 b/star/dev_cases_star_to_RSP2/dev_BLAP/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_star_to_RSP2/dev_BLAP/src/run.f90 +++ b/star/dev_cases_star_to_RSP2/dev_BLAP/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_star_to_RSP2/dev_BLAP/src/run_star_extras.f90 b/star/dev_cases_star_to_RSP2/dev_BLAP/src/run_star_extras.f90 index 750a20597..cf5139ab0 100644 --- a/star/dev_cases_star_to_RSP2/dev_BLAP/src/run_star_extras.f90 +++ b/star/dev_cases_star_to_RSP2/dev_BLAP/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,15 +27,15 @@ module run_star_extras use const_def use math_lib use run_star_support - + implicit none - + include 'test_suite_extras_def.inc' include 'multi_stars_extras_def.inc' integer :: RSP2_num_periods real(dp) :: RSP2_period, time_started - + contains include 'test_suite_extras.inc' @@ -52,8 +52,8 @@ integer function extras_start_step(id) call star_ptr(id, s, ierr) if (ierr /= 0) return end function extras_start_step - - + + ! returns either keep_going or terminate. integer function extras_finish_step(id) integer, intent(in) :: id @@ -107,8 +107,8 @@ integer function extras_finish_step(id) write(*,'(A)') extras_finish_step = terminate end function extras_finish_step - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -124,7 +124,7 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -142,8 +142,8 @@ subroutine photo_read(id, iounit, ierr) ierr = 0 read(iounit, iostat=ierr) RSP2_num_periods, RSP2_period, time_started end subroutine photo_read - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -152,15 +152,15 @@ subroutine extras_startup(id, restart, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - call test_suite_startup(s, restart, ierr) - if (.not. restart) then + call test_suite_startup(s, restart, ierr) + if (.not. restart) then RSP2_num_periods = 0 RSP2_period = 0 time_started = 0 end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -181,7 +181,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -194,8 +194,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -206,7 +206,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) ierr = 0 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -217,8 +217,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -229,9 +229,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) type (star_info), pointer :: s integer :: k include 'formats' - ierr = 0 + ierr = 0 end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_BW_Vul/src/run.f90 b/star/dev_cases_star_to_RSP2/dev_BW_Vul/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_star_to_RSP2/dev_BW_Vul/src/run.f90 +++ b/star/dev_cases_star_to_RSP2/dev_BW_Vul/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_star_to_RSP2/dev_BW_Vul/src/run_star_extras.f90 b/star/dev_cases_star_to_RSP2/dev_BW_Vul/src/run_star_extras.f90 index 3631c0280..2808e90f9 100644 --- a/star/dev_cases_star_to_RSP2/dev_BW_Vul/src/run_star_extras.f90 +++ b/star/dev_cases_star_to_RSP2/dev_BW_Vul/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -37,7 +37,7 @@ module run_star_extras real(dp) :: period, time_started, period_r_min, period_max_vsurf_div_cs, best_G_div_P, & prev_period, prev_growth, prev_period_delta_r, prev_period_max_vsurf_div_cs, & best_growth, best_period - + !alpha_mlt_routine !alpha_H = s% x_ctrl(21) @@ -54,14 +54,14 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -69,7 +69,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -77,8 +77,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -137,7 +137,7 @@ subroutine photo_read(id, iounit, ierr) best_model_number, best_G_div_P, best_growth, best_period end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -148,7 +148,7 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) if (ierr /= 0) return - if (.not. restart) then + if (.not. restart) then num_periods = 0 period = 0 time_started = 0 @@ -174,11 +174,11 @@ subroutine extras_startup(id, restart, ierr) call gyre_set_constant('M_SUN', Msun) call gyre_set_constant('R_SUN', Rsun) call gyre_set_constant('L_SUN', Lsun) - call gyre_set_constant('GYRE_DIR', TRIM(mesa_dir)//'/gyre/gyre') + call gyre_set_constant('GYRE_DIR', TRIM(mesa_dir)//'/gyre/gyre') else call gyre_linear_analysis_and_set_velocities(s,restart,ierr) - end if - + end if + end subroutine extras_startup @@ -189,25 +189,25 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) type (star_info), pointer :: s logical, intent(in) :: restart integer, intent(out) :: ierr - + real(dp), allocatable :: global_data(:) real(dp), allocatable :: point_data(:,:) integer :: ipar(5), mode_l real(dp) :: rpar(1) - + integer, parameter :: modes = 3 integer :: npts(modes), nz, i, k, i_v real(dp), pointer :: vel(:) real(dp), allocatable, dimension(:,:) :: r, v real(dp) :: v_surf, v1, amix1, amix2, amixF, & period(modes) - + include 'formats' - + if (restart) return - + write(*,*) 'set gyre starting velocities' - + nz = s% nz allocate(r(modes,nz+10), v(modes,nz+10)) npts = 0 @@ -223,10 +223,10 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) call gyre_set_constant('L_SUN', Lsun) call gyre_set_constant('GYRE_DIR', TRIM(mesa_dir)//'/gyre/gyre') - + mode_l = 0 ! mode l (e.g. 0 for p modes, 1 for g modes) ! should match gyre.in mode l - + !write(*,*) 'call star_get_pulse_data' call star_get_pulse_data(s%id, 'GYRE', & .FALSE., .FALSE., .FALSE., global_data, point_data, ierr) @@ -234,7 +234,7 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) print *,'Failed when calling get_pulse_data' return end if - + !write(*,*) 'call star_write_pulse_data' call star_write_pulse_data(s%id, & 'GYRE', 'gyre.data', global_data, point_data, ierr) @@ -256,15 +256,15 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) !write(*,*) 'call gyre_get_modes' call gyre_get_modes(mode_l, process_mode_, ipar, rpar) - + amix1 = s% x_ctrl(4) ! s% RSP_fraction_1st_overtone amix2 = s% x_ctrl(5) ! s% RSP_fraction_2nd_overtone if((amix1+amix2) > 1d0) then - write(*,*) 'AMIX DO NOT ADD UP RIGHT' + write(*,*) 'AMIX DO NOT ADD UP RIGHT' call mesa_error(__FILE__,__LINE__,'set_gyre_linear_analysis') end if amixF = 1d0 - (amix1 + amix2) - + if (amixF > 0d0 .and. npts(1) /= nz-1) then write(*,3) 'amixF > 0d0 .and. npts(1) /= nz-1', npts(1) write(*,*) 'cannot use fundamental for setting starting velocities' @@ -273,7 +273,7 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) ierr = -1 return end if - + if (AMIX1 > 0d0 .and. npts(2) /= nz-1) then write(*,3) 'AMIX1 > 0d0 .and. npts(2) /= nz-1', npts(2) write(*,*) 'cannot use 1st overtone for setting starting velocities' @@ -282,7 +282,7 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) ierr = -1 return end if - + if (AMIX2 > 0d0 .and. npts(2) /= nz-1) then write(*,3) 'AMIX2 > 0d0 .and. npts(3) /= nz-1', npts(3) write(*,*) 'cannot use 2nd overtone for setting starting velocities' @@ -291,11 +291,11 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) ierr = -1 return end if - - v_surf = amixF*v(1,nz-1) + AMIX1*v(2,nz-1) + AMIX2*v(3,nz-1) + + v_surf = amixF*v(1,nz-1) + AMIX1*v(2,nz-1) + AMIX2*v(3,nz-1) v1 = 1d5/v_surf if (s% x_ctrl(6) > 0d0) v1 = v1*s% x_ctrl(6) - + if (s% v_flag) then vel => s% v i_v = s% i_v @@ -305,7 +305,7 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) else call mesa_error(__FILE__,__LINE__,'set_gyre_linear_analysis vel') end if - + do i=nz-1,1,-1 k = nz+1-i ! v(1) from gyre => vel(nz) in star vel(k) = v1*(amixF*v(1,i) + AMIX1*v(2,i) + AMIX2*v(3,i)) @@ -313,31 +313,31 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) end do vel(1) = vel(2) s% v_center = 0d0 - + do k=1,nz s% xh(i_v,k) = vel(k) end do - + write(*,'(A)') write(*,1) 'v_surf F 1 2', v_surf, v(1,nz-1), v(2,nz-1), v(3,nz-1) write(*,1) 'amixF amix1 amix2', amixF, amix1, amix2 write(*,'(A)') write(*,2) 'nz', nz - write(*,1) 'v(1)/1d5', vel(1)/1d5 - write(*,1) 'T(nz)', s% T(s%nz) - write(*,1) 'L_center/Lsun', s% L_center/Lsun - write(*,1) 'R_center/Rsun', s% R_center/Rsun - write(*,1) 'M_center/Msun', s% M_center/Msun - write(*,1) 'L(1)/Lsun', s% L(1)/Lsun - write(*,1) 'R(1)/Rsun', s% r(1)/Rsun - write(*,1) 'M(1)/Msun', s% m(1)/Msun - write(*,1) 'X(1)', s% X(1) - write(*,1) 'Y(1)', s% Y(1) - write(*,1) 'Z(1)', s% Z(1) - write(*,1) 'tau_factor', s% tau_factor - write(*,1) 'tau_base', s% tau_base + write(*,1) 'v(1)/1d5', vel(1)/1d5 + write(*,1) 'T(nz)', s% T(s%nz) + write(*,1) 'L_center/Lsun', s% L_center/Lsun + write(*,1) 'R_center/Rsun', s% R_center/Rsun + write(*,1) 'M_center/Msun', s% M_center/Msun + write(*,1) 'L(1)/Lsun', s% L(1)/Lsun + write(*,1) 'R(1)/Rsun', s% r(1)/Rsun + write(*,1) 'M(1)/Msun', s% m(1)/Msun + write(*,1) 'X(1)', s% X(1) + write(*,1) 'Y(1)', s% Y(1) + write(*,1) 'Z(1)', s% Z(1) + write(*,1) 'tau_factor', s% tau_factor + write(*,1) 'tau_base', s% tau_base write(*,1) 'Teff', s% Teff - write(*,*) + write(*,*) contains @@ -377,7 +377,7 @@ subroutine process_mode_ (md, ipar, rpar, retcode) write(*, 110) md%n_pg, freq, 1d0/freq, 1d0/(freq*60), 1d0/(freq*24*3600), 'stable' 110 format(I8,E16.4,F16.4,F14.4,F12.4,A16) end if - + if (md%n_pg > modes) return gr = md%grid() @@ -386,7 +386,7 @@ subroutine process_mode_ (md, ipar, rpar, retcode) npts(md%n_pg) = md%n_k do k = 1, md%n_k r(md%n_pg,k) = gr%pt(k)%x - v(md%n_pg,k) = md%xi_r(k) + v(md%n_pg,k) = md%xi_r(k) end do if (write_flag) then @@ -408,12 +408,12 @@ subroutine process_mode_ (md, ipar, rpar, retcode) retcode = 0 end subroutine process_mode_ - + end subroutine gyre_linear_analysis_and_set_velocities - + include 'gyre_in_mesa_extras_finish_step.inc' - + ! returns either keep_going, retry, or terminate. integer function extras_finish_step(id) @@ -491,7 +491,7 @@ integer function extras_finish_step(id) period = time_ended - time_started if (period/(24*3600) < 0.1d0*s% x_ctrl(7)) return ! reject as bogus if < 10% expected num_periods = num_periods + 1 - + period_delta_r = period_r_max - period_r_min if (period_delta_r > 0d0 .and. prev_period_delta_r > 0d0) then growth = period/log(period_delta_r/prev_period_delta_r) ! seconds @@ -540,8 +540,8 @@ integer function extras_finish_step(id) write(*,'(A)') extras_finish_step = terminate end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -553,7 +553,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call gyre_final() end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -563,7 +563,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -576,8 +576,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 5 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -611,8 +611,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 ! 6 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -624,8 +624,8 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer :: k ierr = 0 return - - + + call star_ptr(id, s, ierr) if (ierr /= 0) return @@ -636,17 +636,17 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) names(5) = 'xtra5' names(6) = 'xtra6' - do k=1,nz + do k=1,nz vals(k,1) = s% xtra1_array(k) vals(k,2) = s% xtra2_array(k) vals(k,3) = s% xtra3_array(k) vals(k,4) = s% xtra4_array(k) vals(k,5) = s% xtra5_array(k) - vals(k,6) = s% xtra6_array(k) + vals(k,6) = s% xtra6_array(k) end do - + end subroutine data_for_extra_profile_columns - + end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_BW_Vul/src/run_star_extras_stub.f90 b/star/dev_cases_star_to_RSP2/dev_BW_Vul/src/run_star_extras_stub.f90 index 8a41b1abf..af2513406 100644 --- a/star/dev_cases_star_to_RSP2/dev_BW_Vul/src/run_star_extras_stub.f90 +++ b/star/dev_cases_star_to_RSP2/dev_BW_Vul/src/run_star_extras_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,18 +19,18 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def - + implicit none - + ! these routines are called by the standard run_star check_model contains - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -38,13 +38,13 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + write(*,*) 'matched target' write(*,*) 'GYRE not installed, pretending to pass' write(*,*) 'this test was intentionally skipped' ierr = -1 - + end subroutine extras_controls end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_Cepheid/src/run.f90 b/star/dev_cases_star_to_RSP2/dev_Cepheid/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_star_to_RSP2/dev_Cepheid/src/run.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Cepheid/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_star_to_RSP2/dev_Cepheid/src/run_star_extras.f90 b/star/dev_cases_star_to_RSP2/dev_Cepheid/src/run_star_extras.f90 index 84b2a218a..d9a0b1b93 100644 --- a/star/dev_cases_star_to_RSP2/dev_Cepheid/src/run_star_extras.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Cepheid/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,11 +27,11 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' - + ! GYRE "best" info real(dp) :: best_period, best_cycles_to_double integer :: best_model_number, best_order @@ -62,14 +62,14 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -77,7 +77,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -85,8 +85,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -149,7 +149,7 @@ subroutine photo_read(id, iounit, ierr) best_period, best_model_number, best_order, best_cycles_to_double end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -160,7 +160,7 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) if (ierr /= 0) return - if (.not. restart) then + if (.not. restart) then num_periods = 0 run_num_steps_end_prev = 0 run_num_iters_end_prev = 0 @@ -185,9 +185,9 @@ subroutine extras_startup(id, restart, ierr) T_min = 0 T_max = 0 best_period = 0 - best_model_number = 0 + best_model_number = 0 best_order = 0 - best_cycles_to_double = 0 + best_cycles_to_double = 0 end if if (.not. s% x_logical_ctrl(5)) then call gyre_init('gyre.in') @@ -197,10 +197,10 @@ subroutine extras_startup(id, restart, ierr) call gyre_set_constant('M_SUN', Msun) call gyre_set_constant('R_SUN', Rsun) call gyre_set_constant('L_SUN', Lsun) - call gyre_set_constant('GYRE_DIR', TRIM(mesa_dir)//'/gyre/gyre') + call gyre_set_constant('GYRE_DIR', TRIM(mesa_dir)//'/gyre/gyre') else call gyre_linear_analysis_and_set_velocities(s,restart,ierr) - end if + end if end subroutine extras_startup @@ -213,13 +213,13 @@ integer function extras_finish_step(id) real(dp) :: target_period logical :: doing_pulses include 'formats' - + extras_finish_step = terminate ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return extras_finish_step = keep_going - + gyre_interval = s% x_integer_ctrl(1) if (gyre_interval > 0) then if (MOD(s% model_number, gyre_interval) == 0) & @@ -228,22 +228,22 @@ integer function extras_finish_step(id) s% termination_code = t_extras_finish_step if (extras_finish_step /= keep_going) return end if - + doing_pulses = s% x_logical_ctrl(7) if (.not. doing_pulses) return target_period = s% x_ctrl(7) if (target_period <= 0d0) return if (.not. get_period_info()) return - + test_period = s% x_integer_ctrl(7) if (num_periods < test_period .or. test_period <= 0) return - + ! have finished test run call report_test_results extras_finish_step = terminate - + contains - + subroutine get_gyre_info_for_this_step integer :: i extras_finish_step = gyre_in_mesa_extras_finish_step(id) @@ -268,14 +268,14 @@ subroutine get_gyre_info_for_this_step 'period(d)', best_period, 'cycles', best_cycles_to_double end if end subroutine get_gyre_info_for_this_step - + logical function get_period_info() real(dp) :: v_surf, v_surf_start, KE, KE_avg, min_period, time_ended, & delta_R, min_deltaR_for_periods, KE_growth_avg_frac_new, & min_period_div_target, cs include 'formats' get_period_info = .false. - + if (s% r(1) < R_min) R_min = s% r(1) if (s% r(1) > R_max) R_max = s% r(1) if (s% L(1) < L_min) L_min = s% L(1) @@ -285,7 +285,7 @@ logical function get_period_info() KE = s% total_radial_kinetic_energy_end if (KE > KE_max) KE_max = KE if (KE < KE_min) KE_min = KE - + if (s% v_flag) then v_surf = s% v(1) v_surf_start = s% v_start(1) @@ -297,10 +297,10 @@ logical function get_period_info() end if cs = s% csound(1) if (v_surf > v_div_cs_max*cs) v_div_cs_max = v_surf/cs - + ! period is completed when v_surf goes from positive to negative during step if (v_surf > 0d0 .or. v_surf_start < 0d0) return - + if (time_started == 0) then ! start of 1st cycle time_started = s% time run_num_steps_end_prev = s% model_number @@ -312,13 +312,13 @@ logical function get_period_info() s% model_number, s% time/(24*3600) return end if - + delta_R = R_max - R_min min_deltaR_for_periods = s% x_ctrl(8)*Rsun if (min_deltaR_for_periods > 0d0) then if (delta_R < min_deltaR_for_periods) return ! filter out glitches end if - + time_ended = s% time if (abs(v_surf - v_surf_start) > 1d-10) & ! tweak the end time to match when v_surf == 0 time_ended = s% time - v_surf*s% dt/(v_surf - v_surf_start) @@ -329,7 +329,7 @@ logical function get_period_info() period = time_ended - time_started num_periods = num_periods + 1 - + if (num_periods > 1) then KE_avg = 0.5d0*(KE_max + prev_KE_max) KE_growth = (KE_max - prev_KE_max)/KE_avg @@ -337,7 +337,7 @@ logical function get_period_info() KE_growth_avg = KE_growth_avg_frac_new*KE_growth + & (1d0 - KE_growth_avg_frac_new)*KE_growth_avg end if - + period_delta_Teff = T_max - T_min period_delta_R = R_max - R_min period_delta_logL = log10(L_max/L_min) @@ -365,7 +365,7 @@ logical function get_period_info() get_period_info = .true. end function get_period_info - + subroutine init_min_max_info v_div_cs_max = 0d0 KE_min = 1d99 @@ -377,7 +377,7 @@ subroutine init_min_max_info T_min = 1d99 T_max = -1d99 end subroutine init_min_max_info - + subroutine report_test_results real(dp) :: rel_run_E_err write(*,'(A)') @@ -399,13 +399,13 @@ subroutine report_test_results write(*,'(A)') write(*,'(A)') end subroutine report_test_results - + end function extras_finish_step - + include 'gyre_in_mesa_extras_finish_step.inc' - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -417,7 +417,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call gyre_final() end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -427,7 +427,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -440,8 +440,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 8 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -474,8 +474,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 ! 6 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -487,8 +487,8 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer :: k ierr = 0 return - - + + call star_ptr(id, s, ierr) if (ierr /= 0) return @@ -499,15 +499,15 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) names(5) = 'xtra5' names(6) = 'xtra6' - do k=1,nz + do k=1,nz vals(k,1) = s% xtra1_array(k) vals(k,2) = s% xtra2_array(k) vals(k,3) = s% xtra3_array(k) vals(k,4) = s% xtra4_array(k) vals(k,5) = s% xtra5_array(k) - vals(k,6) = s% xtra6_array(k) + vals(k,6) = s% xtra6_array(k) end do - + end subroutine data_for_extra_profile_columns @@ -518,25 +518,25 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) type (star_info), pointer :: s logical, intent(in) :: restart integer, intent(out) :: ierr - + real(dp), allocatable :: global_data(:) real(dp), allocatable :: point_data(:,:) integer :: ipar(5), mode_l real(dp) :: rpar(1) - + integer, parameter :: modes = 3 integer :: npts(modes), nz, i, k, i_v real(dp), pointer :: vel(:) real(dp), allocatable, dimension(:,:) :: r, v real(dp) :: v_surf, v1, amix1, amix2, amixF, & period(modes) - + include 'formats' - + if (restart) return - + write(*,*) 'set gyre starting velocities' - + nz = s% nz allocate(r(modes,nz+10), v(modes,nz+10)) npts = 0 @@ -552,10 +552,10 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) call gyre_set_constant('L_SUN', Lsun) call gyre_set_constant('GYRE_DIR', TRIM(mesa_dir)//'/gyre/gyre') - + mode_l = 0 ! mode l (e.g. 0 for p modes, 1 for g modes) ! should match gyre.in mode l - + !write(*,*) 'call star_get_pulse_data' call star_get_pulse_data(s%id, 'GYRE', & .FALSE., .FALSE., .FALSE., global_data, point_data, ierr) @@ -563,7 +563,7 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) print *,'Failed when calling get_pulse_data' return end if - + !write(*,*) 'call star_write_pulse_data' call star_write_pulse_data(s%id, & 'GYRE', 'gyre.data', global_data, point_data, ierr) @@ -584,15 +584,15 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) ipar(5) = 0 ! num_written call gyre_get_modes(mode_l, process_mode_, ipar, rpar) - + amix1 = s% x_ctrl(4) ! s% RSP_fraction_1st_overtone amix2 = s% x_ctrl(5) ! s% RSP_fraction_2nd_overtone if((amix1+amix2) > 1d0) then - write(*,*) 'AMIX DO NOT ADD UP RIGHT' + write(*,*) 'AMIX DO NOT ADD UP RIGHT' call mesa_error(__FILE__,__LINE__,'set_gyre_linear_analysis') end if amixF = 1d0 - (amix1 + amix2) - + if (amixF > 0d0 .and. npts(1) /= nz-1) then write(*,3) 'amixF > 0d0 .and. npts(1) /= nz-1', npts(1) write(*,*) 'cannot use fundamental for setting starting velocities' @@ -601,7 +601,7 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) ierr = -1 return end if - + if (AMIX1 > 0d0 .and. npts(2) /= nz-1) then write(*,3) 'AMIX1 > 0d0 .and. npts(2) /= nz-1', npts(2) write(*,*) 'cannot use 1st overtone for setting starting velocities' @@ -610,7 +610,7 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) ierr = -1 return end if - + if (AMIX2 > 0d0 .and. npts(2) /= nz-1) then write(*,3) 'AMIX2 > 0d0 .and. npts(3) /= nz-1', npts(3) write(*,*) 'cannot use 2nd overtone for setting starting velocities' @@ -619,11 +619,11 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) ierr = -1 return end if - - v_surf = amixF*v(1,nz-1) + AMIX1*v(2,nz-1) + AMIX2*v(3,nz-1) + + v_surf = amixF*v(1,nz-1) + AMIX1*v(2,nz-1) + AMIX2*v(3,nz-1) v1 = 1d5/v_surf if (s% x_ctrl(6) > 0d0) v1 = v1*s% x_ctrl(6) - + if (s% v_flag) then vel => s% v i_v = s% i_v @@ -633,7 +633,7 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) else call mesa_error(__FILE__,__LINE__,'set_gyre_linear_analysis vel') end if - + do i=nz-1,1,-1 k = nz+1-i ! v(1) from gyre => vel(nz) in star vel(k) = v1*(amixF*v(1,i) + AMIX1*v(2,i) + AMIX2*v(3,i)) @@ -641,31 +641,31 @@ subroutine gyre_linear_analysis_and_set_velocities(s,restart,ierr) end do vel(1) = vel(2) s% v_center = 0d0 - + do k=1,nz s% xh(i_v,k) = vel(k) end do - + write(*,'(A)') write(*,1) 'v_surf F 1 2', v_surf, v(1,nz-1), v(2,nz-1), v(3,nz-1) write(*,1) 'amixF amix1 amix2', amixF, amix1, amix2 write(*,'(A)') write(*,2) 'nz', nz - write(*,1) 'v(1)/1d5', vel(1)/1d5 - write(*,1) 'T(nz)', s% T(s%nz) - write(*,1) 'L_center/Lsun', s% L_center/Lsun - write(*,1) 'R_center/Rsun', s% R_center/Rsun - write(*,1) 'M_center/Msun', s% M_center/Msun - write(*,1) 'L(1)/Lsun', s% L(1)/Lsun - write(*,1) 'R(1)/Rsun', s% r(1)/Rsun - write(*,1) 'M(1)/Msun', s% m(1)/Msun - write(*,1) 'X(1)', s% X(1) - write(*,1) 'Y(1)', s% Y(1) - write(*,1) 'Z(1)', s% Z(1) - write(*,1) 'tau_factor', s% tau_factor - write(*,1) 'tau_base', s% tau_base + write(*,1) 'v(1)/1d5', vel(1)/1d5 + write(*,1) 'T(nz)', s% T(s%nz) + write(*,1) 'L_center/Lsun', s% L_center/Lsun + write(*,1) 'R_center/Rsun', s% R_center/Rsun + write(*,1) 'M_center/Msun', s% M_center/Msun + write(*,1) 'L(1)/Lsun', s% L(1)/Lsun + write(*,1) 'R(1)/Rsun', s% r(1)/Rsun + write(*,1) 'M(1)/Msun', s% m(1)/Msun + write(*,1) 'X(1)', s% X(1) + write(*,1) 'Y(1)', s% Y(1) + write(*,1) 'Z(1)', s% Z(1) + write(*,1) 'tau_factor', s% tau_factor + write(*,1) 'tau_base', s% tau_base write(*,1) 'Teff', s% Teff - write(*,*) + write(*,*) contains @@ -711,7 +711,7 @@ subroutine process_mode_ (md, ipar, rpar, retcode) freq, per, per/(24*3600), growth*(24*3600), 'stable' 110 format(I8,E20.4,2F20.4,E20.4,A20) end if - + if (md%n_pg > modes) return gr = md%grid() @@ -720,7 +720,7 @@ subroutine process_mode_ (md, ipar, rpar, retcode) npts(md%n_pg) = md%n_k do k = 1, md%n_k r(md%n_pg,k) = gr%pt(k)%x - v(md%n_pg,k) = md%xi_r(k) + v(md%n_pg,k) = md%xi_r(k) end do if (write_flag) then @@ -742,9 +742,9 @@ subroutine process_mode_ (md, ipar, rpar, retcode) retcode = 0 end subroutine process_mode_ - + end subroutine gyre_linear_analysis_and_set_velocities - + end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_Cepheid/src/run_star_extras_stub.f90 b/star/dev_cases_star_to_RSP2/dev_Cepheid/src/run_star_extras_stub.f90 index 8a41b1abf..af2513406 100644 --- a/star/dev_cases_star_to_RSP2/dev_Cepheid/src/run_star_extras_stub.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Cepheid/src/run_star_extras_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,18 +19,18 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def - + implicit none - + ! these routines are called by the standard run_star check_model contains - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -38,13 +38,13 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + write(*,*) 'matched target' write(*,*) 'GYRE not installed, pretending to pass' write(*,*) 'this test was intentionally skipped' ierr = -1 - + end subroutine extras_controls end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_Cepheid_6M/src/run.f90 b/star/dev_cases_star_to_RSP2/dev_Cepheid_6M/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_star_to_RSP2/dev_Cepheid_6M/src/run.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Cepheid_6M/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_star_to_RSP2/dev_Cepheid_6M/src/run_star_extras.f90 b/star/dev_cases_star_to_RSP2/dev_Cepheid_6M/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_star_to_RSP2/dev_Cepheid_6M/src/run_star_extras.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Cepheid_6M/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_Cepheid_6M/src/run_star_extras_stub.f90 b/star/dev_cases_star_to_RSP2/dev_Cepheid_6M/src/run_star_extras_stub.f90 index 8a41b1abf..af2513406 100644 --- a/star/dev_cases_star_to_RSP2/dev_Cepheid_6M/src/run_star_extras_stub.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Cepheid_6M/src/run_star_extras_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,18 +19,18 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def - + implicit none - + ! these routines are called by the standard run_star check_model contains - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -38,13 +38,13 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + write(*,*) 'matched target' write(*,*) 'GYRE not installed, pretending to pass' write(*,*) 'this test was intentionally skipped' ierr = -1 - + end subroutine extras_controls end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_Cepheid_9M/src/run.f90 b/star/dev_cases_star_to_RSP2/dev_Cepheid_9M/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_star_to_RSP2/dev_Cepheid_9M/src/run.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Cepheid_9M/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_star_to_RSP2/dev_Cepheid_9M/src/run_star_extras.f90 b/star/dev_cases_star_to_RSP2/dev_Cepheid_9M/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_star_to_RSP2/dev_Cepheid_9M/src/run_star_extras.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Cepheid_9M/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_Cepheid_9M/src/run_star_extras_stub.f90 b/star/dev_cases_star_to_RSP2/dev_Cepheid_9M/src/run_star_extras_stub.f90 index 8a41b1abf..af2513406 100644 --- a/star/dev_cases_star_to_RSP2/dev_Cepheid_9M/src/run_star_extras_stub.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Cepheid_9M/src/run_star_extras_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,18 +19,18 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def - + implicit none - + ! these routines are called by the standard run_star check_model contains - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -38,13 +38,13 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + write(*,*) 'matched target' write(*,*) 'GYRE not installed, pretending to pass' write(*,*) 'this test was intentionally skipped' ierr = -1 - + end subroutine extras_controls end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_Delta_Scuti/src/run.f90 b/star/dev_cases_star_to_RSP2/dev_Delta_Scuti/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_star_to_RSP2/dev_Delta_Scuti/src/run.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Delta_Scuti/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_star_to_RSP2/dev_Delta_Scuti/src/run_star_extras.f90 b/star/dev_cases_star_to_RSP2/dev_Delta_Scuti/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_star_to_RSP2/dev_Delta_Scuti/src/run_star_extras.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Delta_Scuti/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_Mira/src/run.f90 b/star/dev_cases_star_to_RSP2/dev_Mira/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_star_to_RSP2/dev_Mira/src/run.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Mira/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_star_to_RSP2/dev_Mira/src/run_star_extras.f90 b/star/dev_cases_star_to_RSP2/dev_Mira/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_star_to_RSP2/dev_Mira/src/run_star_extras.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Mira/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_RR_Lyrae/src/run.f90 b/star/dev_cases_star_to_RSP2/dev_RR_Lyrae/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_star_to_RSP2/dev_RR_Lyrae/src/run.f90 +++ b/star/dev_cases_star_to_RSP2/dev_RR_Lyrae/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_star_to_RSP2/dev_RR_Lyrae/src/run_star_extras.f90 b/star/dev_cases_star_to_RSP2/dev_RR_Lyrae/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_star_to_RSP2/dev_RR_Lyrae/src/run_star_extras.f90 +++ b/star/dev_cases_star_to_RSP2/dev_RR_Lyrae/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_RSG/src/run.f90 b/star/dev_cases_star_to_RSP2/dev_RSG/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_star_to_RSP2/dev_RSG/src/run.f90 +++ b/star/dev_cases_star_to_RSP2/dev_RSG/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_star_to_RSP2/dev_RSG/src/run_star_extras.f90 b/star/dev_cases_star_to_RSP2/dev_RSG/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_star_to_RSP2/dev_RSG/src/run_star_extras.f90 +++ b/star/dev_cases_star_to_RSP2/dev_RSG/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_RSG/src/run_star_extras_stub.f90 b/star/dev_cases_star_to_RSP2/dev_RSG/src/run_star_extras_stub.f90 index 8a41b1abf..af2513406 100644 --- a/star/dev_cases_star_to_RSP2/dev_RSG/src/run_star_extras_stub.f90 +++ b/star/dev_cases_star_to_RSP2/dev_RSG/src/run_star_extras_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,18 +19,18 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def - + implicit none - + ! these routines are called by the standard run_star check_model contains - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -38,13 +38,13 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + write(*,*) 'matched target' write(*,*) 'GYRE not installed, pretending to pass' write(*,*) 'this test was intentionally skipped' ierr = -1 - + end subroutine extras_controls end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_Type_II_Cepheid/src/run.f90 b/star/dev_cases_star_to_RSP2/dev_Type_II_Cepheid/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_star_to_RSP2/dev_Type_II_Cepheid/src/run.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Type_II_Cepheid/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_star_to_RSP2/dev_Type_II_Cepheid/src/run_star_extras.f90 b/star/dev_cases_star_to_RSP2/dev_Type_II_Cepheid/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_star_to_RSP2/dev_Type_II_Cepheid/src/run_star_extras.f90 +++ b/star/dev_cases_star_to_RSP2/dev_Type_II_Cepheid/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_star_to_RSP2/dev_beta_Cepheid/src/run.f90 b/star/dev_cases_star_to_RSP2/dev_beta_Cepheid/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_star_to_RSP2/dev_beta_Cepheid/src/run.f90 +++ b/star/dev_cases_star_to_RSP2/dev_beta_Cepheid/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_star_to_RSP2/dev_beta_Cepheid/src/run_star_extras.f90 b/star/dev_cases_star_to_RSP2/dev_beta_Cepheid/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_star_to_RSP2/dev_beta_Cepheid/src/run_star_extras.f90 +++ b/star/dev_cases_star_to_RSP2/dev_beta_Cepheid/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_test_RSP2/dev_rsp2_BEP/src/run.f90 b/star/dev_cases_test_RSP2/dev_rsp2_BEP/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_BEP/src/run.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_BEP/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_RSP2/dev_rsp2_BEP/src/run_star_extras.f90 b/star/dev_cases_test_RSP2/dev_rsp2_BEP/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_BEP/src/run_star_extras.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_BEP/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_test_RSP2/dev_rsp2_BLAP/src/run.f90 b/star/dev_cases_test_RSP2/dev_rsp2_BLAP/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_BLAP/src/run.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_BLAP/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_RSP2/dev_rsp2_BLAP/src/run_star_extras.f90 b/star/dev_cases_test_RSP2/dev_rsp2_BLAP/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_BLAP/src/run_star_extras.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_BLAP/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_test_RSP2/dev_rsp2_Cepheid/src/run.f90 b/star/dev_cases_test_RSP2/dev_rsp2_Cepheid/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_Cepheid/src/run.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_Cepheid/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_RSP2/dev_rsp2_Cepheid/src/run_star_extras.f90 b/star/dev_cases_test_RSP2/dev_rsp2_Cepheid/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_Cepheid/src/run_star_extras.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_Cepheid/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_test_RSP2/dev_rsp2_Cepheid_6M/src/run.f90 b/star/dev_cases_test_RSP2/dev_rsp2_Cepheid_6M/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_Cepheid_6M/src/run.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_Cepheid_6M/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_RSP2/dev_rsp2_Cepheid_6M/src/run_star_extras.f90 b/star/dev_cases_test_RSP2/dev_rsp2_Cepheid_6M/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_Cepheid_6M/src/run_star_extras.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_Cepheid_6M/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_test_RSP2/dev_rsp2_Delta_Scuti/src/run.f90 b/star/dev_cases_test_RSP2/dev_rsp2_Delta_Scuti/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_Delta_Scuti/src/run.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_Delta_Scuti/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_RSP2/dev_rsp2_Delta_Scuti/src/run_star_extras.f90 b/star/dev_cases_test_RSP2/dev_rsp2_Delta_Scuti/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_Delta_Scuti/src/run_star_extras.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_Delta_Scuti/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_test_RSP2/dev_rsp2_RR_Lyrae/src/run.f90 b/star/dev_cases_test_RSP2/dev_rsp2_RR_Lyrae/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_RR_Lyrae/src/run.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_RR_Lyrae/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_RSP2/dev_rsp2_RR_Lyrae/src/run_star_extras.f90 b/star/dev_cases_test_RSP2/dev_rsp2_RR_Lyrae/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_RR_Lyrae/src/run_star_extras.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_RR_Lyrae/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_test_RSP2/dev_rsp2_Type_II_Cepheid/src/run.f90 b/star/dev_cases_test_RSP2/dev_rsp2_Type_II_Cepheid/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_Type_II_Cepheid/src/run.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_Type_II_Cepheid/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_RSP2/dev_rsp2_Type_II_Cepheid/src/run_star_extras.f90 b/star/dev_cases_test_RSP2/dev_rsp2_Type_II_Cepheid/src/run_star_extras.f90 index cf7eb6925..67925f864 100644 --- a/star/dev_cases_test_RSP2/dev_rsp2_Type_II_Cepheid/src/run_star_extras.f90 +++ b/star/dev_cases_test_RSP2/dev_rsp2_Type_II_Cepheid/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use gyre_mesa_m - + implicit none include 'test_suite_extras_def.inc' @@ -49,15 +49,15 @@ module run_star_extras !x_integer_ctrl(4) = 1 ! order !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - - + + contains include 'test_suite_extras.inc' include '../../../rsp2_utils/run_star_extras_rsp2.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,8 +73,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine s% other_photo_write => photo_write s% other_photo_read => photo_read end subroutine extras_controls @@ -124,7 +124,7 @@ subroutine photo_read(id, iounit, ierr) call rsp2_photo_read(id, iounit, ierr) end subroutine photo_read - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -145,8 +145,8 @@ integer function extras_finish_step(id) extras_finish_step = rsp2_extras_finish_step(id) end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -158,7 +158,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) call rsp2_extras_after_evolve(id, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -168,16 +168,16 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = rsp2_how_many_extra_history_columns(id) end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,8 +185,8 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(out) :: ierr call rsp2_data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - - + + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = rsp2_how_many_extra_profile_columns(id) @@ -205,4 +205,4 @@ end subroutine data_for_extra_profile_columns end module run_star_extras - + diff --git a/star/dev_cases_test_TDC/dev_TDC_he_core_flash/src/run.f90 b/star/dev_cases_test_TDC/dev_TDC_he_core_flash/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_TDC/dev_TDC_he_core_flash/src/run.f90 +++ b/star/dev_cases_test_TDC/dev_TDC_he_core_flash/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_TDC/dev_TDC_he_core_flash/src/run_star_extras.f90 b/star/dev_cases_test_TDC/dev_TDC_he_core_flash/src/run_star_extras.f90 index 305dbda13..3a35b990f 100644 --- a/star/dev_cases_test_TDC/dev_TDC_he_core_flash/src/run_star_extras.f90 +++ b/star/dev_cases_test_TDC/dev_TDC_he_core_flash/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,28 +19,28 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def use math_lib - + implicit none include 'test_suite_extras_def.inc' include 'xtra_coeff_os/xtra_coeff_os_def.inc' - + ! these routines are called by the standard run_star check_model - + contains include 'test_suite_extras.inc' include 'xtra_coeff_os/xtra_coeff_os.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -49,7 +49,7 @@ subroutine extras_controls(id, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return include 'xtra_coeff_os/xtra_coeff_os_controls.inc' - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -57,10 +57,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -71,8 +71,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -83,7 +83,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -93,7 +93,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -106,8 +106,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -119,7 +119,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) call star_ptr(id, s, ierr) end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -130,8 +130,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 6 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -152,17 +152,17 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) names(5) = 'D0' names(6) = 'DR0' - do k=1,nz + do k=1,nz vals(k,1) = s% xtra1_array(k) vals(k,2) = s% xtra2_array(k) vals(k,3) = s% xtra3_array(k) vals(k,4) = s% xtra4_array(k) vals(k,5) = s% xtra5_array(k) - vals(k,6) = s% xtra6_array(k) + vals(k,6) = s% xtra6_array(k) end do - + end subroutine data_for_extra_profile_columns - + ! returns either keep_going, retry, or terminate. integer function extras_finish_step(id) @@ -175,7 +175,7 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - + end module run_star_extras - + diff --git a/star/dev_cases_test_TDC/dev_TDC_to_cc_12/src/run.f90 b/star/dev_cases_test_TDC/dev_TDC_to_cc_12/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_TDC/dev_TDC_to_cc_12/src/run.f90 +++ b/star/dev_cases_test_TDC/dev_TDC_to_cc_12/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_TDC/dev_TDC_to_cc_12/src/run_star_extras.f90 b/star/dev_cases_test_TDC/dev_TDC_to_cc_12/src/run_star_extras.f90 index 22df69a36..2fda3f937 100644 --- a/star/dev_cases_test_TDC/dev_TDC_to_cc_12/src/run_star_extras.f90 +++ b/star/dev_cases_test_TDC/dev_TDC_to_cc_12/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,9 +27,9 @@ module run_star_extras use const_def use math_lib use gyre_lib - + implicit none - + include "test_suite_extras_def.inc" ! here are the x controls used below @@ -50,12 +50,12 @@ module run_star_extras !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -70,8 +70,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine end subroutine extras_controls @@ -102,12 +102,12 @@ subroutine alpha_mlt_routine(id, ierr) else s% alpha_mlt(k) = alpha_other end if - !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), + !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), end do !stop end subroutine alpha_mlt_routine - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -117,9 +117,9 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (.not. s% x_logical_ctrl(37)) return - + ! Initialize GYRE call gyre_init('gyre.in') @@ -135,10 +135,10 @@ subroutine extras_startup(id, restart, ierr) call gyre_set_constant('L_SUN', Lsun) call gyre_set_constant('GYRE_DIR', TRIM(mesa_dir)//'/gyre/gyre') - + end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use num_lib, only: find0 integer, intent(in) :: id @@ -156,7 +156,7 @@ subroutine extras_after_evolve(id, ierr) if (.not. s% x_logical_ctrl(37)) return call gyre_final() end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -166,7 +166,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -179,8 +179,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -192,7 +192,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -203,8 +203,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 6 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -225,17 +225,17 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) names(5) = 'D0' names(6) = 'DR0' - do k=1,nz + do k=1,nz vals(k,1) = s% xtra1_array(k) vals(k,2) = s% xtra2_array(k) vals(k,3) = s% xtra3_array(k) vals(k,4) = s% xtra4_array(k) vals(k,5) = s% xtra5_array(k) - vals(k,6) = s% xtra6_array(k) + vals(k,6) = s% xtra6_array(k) end do - + end subroutine data_for_extra_profile_columns - + include 'gyre_in_mesa_extras_finish_step.inc' ! returns either keep_going or terminate. @@ -254,4 +254,4 @@ integer function extras_finish_step(id) end function extras_finish_step end module run_star_extras - + diff --git a/star/dev_cases_test_TDC/dev_TDC_to_cc_80/src/run.f90 b/star/dev_cases_test_TDC/dev_TDC_to_cc_80/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_TDC/dev_TDC_to_cc_80/src/run.f90 +++ b/star/dev_cases_test_TDC/dev_TDC_to_cc_80/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_TDC/dev_TDC_to_cc_80/src/run_star_extras.f90 b/star/dev_cases_test_TDC/dev_TDC_to_cc_80/src/run_star_extras.f90 index 22df69a36..2fda3f937 100644 --- a/star/dev_cases_test_TDC/dev_TDC_to_cc_80/src/run_star_extras.f90 +++ b/star/dev_cases_test_TDC/dev_TDC_to_cc_80/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,9 +27,9 @@ module run_star_extras use const_def use math_lib use gyre_lib - + implicit none - + include "test_suite_extras_def.inc" ! here are the x controls used below @@ -50,12 +50,12 @@ module run_star_extras !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -70,8 +70,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine end subroutine extras_controls @@ -102,12 +102,12 @@ subroutine alpha_mlt_routine(id, ierr) else s% alpha_mlt(k) = alpha_other end if - !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), + !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), end do !stop end subroutine alpha_mlt_routine - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -117,9 +117,9 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (.not. s% x_logical_ctrl(37)) return - + ! Initialize GYRE call gyre_init('gyre.in') @@ -135,10 +135,10 @@ subroutine extras_startup(id, restart, ierr) call gyre_set_constant('L_SUN', Lsun) call gyre_set_constant('GYRE_DIR', TRIM(mesa_dir)//'/gyre/gyre') - + end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use num_lib, only: find0 integer, intent(in) :: id @@ -156,7 +156,7 @@ subroutine extras_after_evolve(id, ierr) if (.not. s% x_logical_ctrl(37)) return call gyre_final() end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -166,7 +166,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -179,8 +179,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -192,7 +192,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -203,8 +203,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 6 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -225,17 +225,17 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) names(5) = 'D0' names(6) = 'DR0' - do k=1,nz + do k=1,nz vals(k,1) = s% xtra1_array(k) vals(k,2) = s% xtra2_array(k) vals(k,3) = s% xtra3_array(k) vals(k,4) = s% xtra4_array(k) vals(k,5) = s% xtra5_array(k) - vals(k,6) = s% xtra6_array(k) + vals(k,6) = s% xtra6_array(k) end do - + end subroutine data_for_extra_profile_columns - + include 'gyre_in_mesa_extras_finish_step.inc' ! returns either keep_going or terminate. @@ -254,4 +254,4 @@ integer function extras_finish_step(id) end function extras_finish_step end module run_star_extras - + diff --git a/star/dev_cases_test_TDC/dev_TDC_to_pisn_200/src/run.f90 b/star/dev_cases_test_TDC/dev_TDC_to_pisn_200/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_TDC/dev_TDC_to_pisn_200/src/run.f90 +++ b/star/dev_cases_test_TDC/dev_TDC_to_pisn_200/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_TDC/dev_TDC_to_pisn_200/src/run_star_extras.f90 b/star/dev_cases_test_TDC/dev_TDC_to_pisn_200/src/run_star_extras.f90 index 22df69a36..2fda3f937 100644 --- a/star/dev_cases_test_TDC/dev_TDC_to_pisn_200/src/run_star_extras.f90 +++ b/star/dev_cases_test_TDC/dev_TDC_to_pisn_200/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,9 +27,9 @@ module run_star_extras use const_def use math_lib use gyre_lib - + implicit none - + include "test_suite_extras_def.inc" ! here are the x controls used below @@ -50,12 +50,12 @@ module run_star_extras !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -70,8 +70,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine end subroutine extras_controls @@ -102,12 +102,12 @@ subroutine alpha_mlt_routine(id, ierr) else s% alpha_mlt(k) = alpha_other end if - !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), + !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), end do !stop end subroutine alpha_mlt_routine - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -117,9 +117,9 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (.not. s% x_logical_ctrl(37)) return - + ! Initialize GYRE call gyre_init('gyre.in') @@ -135,10 +135,10 @@ subroutine extras_startup(id, restart, ierr) call gyre_set_constant('L_SUN', Lsun) call gyre_set_constant('GYRE_DIR', TRIM(mesa_dir)//'/gyre/gyre') - + end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use num_lib, only: find0 integer, intent(in) :: id @@ -156,7 +156,7 @@ subroutine extras_after_evolve(id, ierr) if (.not. s% x_logical_ctrl(37)) return call gyre_final() end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -166,7 +166,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -179,8 +179,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -192,7 +192,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -203,8 +203,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 6 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -225,17 +225,17 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) names(5) = 'D0' names(6) = 'DR0' - do k=1,nz + do k=1,nz vals(k,1) = s% xtra1_array(k) vals(k,2) = s% xtra2_array(k) vals(k,3) = s% xtra3_array(k) vals(k,4) = s% xtra4_array(k) vals(k,5) = s% xtra5_array(k) - vals(k,6) = s% xtra6_array(k) + vals(k,6) = s% xtra6_array(k) end do - + end subroutine data_for_extra_profile_columns - + include 'gyre_in_mesa_extras_finish_step.inc' ! returns either keep_going or terminate. @@ -254,4 +254,4 @@ integer function extras_finish_step(id) end function extras_finish_step end module run_star_extras - + diff --git a/star/dev_cases_test_TDC/dev_TDC_to_ppisn_100/src/run.f90 b/star/dev_cases_test_TDC/dev_TDC_to_ppisn_100/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_TDC/dev_TDC_to_ppisn_100/src/run.f90 +++ b/star/dev_cases_test_TDC/dev_TDC_to_ppisn_100/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_TDC/dev_TDC_to_ppisn_100/src/run_star_extras.f90 b/star/dev_cases_test_TDC/dev_TDC_to_ppisn_100/src/run_star_extras.f90 index 22df69a36..2fda3f937 100644 --- a/star/dev_cases_test_TDC/dev_TDC_to_ppisn_100/src/run_star_extras.f90 +++ b/star/dev_cases_test_TDC/dev_TDC_to_ppisn_100/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,9 +27,9 @@ module run_star_extras use const_def use math_lib use gyre_lib - + implicit none - + include "test_suite_extras_def.inc" ! here are the x controls used below @@ -50,12 +50,12 @@ module run_star_extras !x_ctrl(1) = 0.158d-05 ! freq ~ this (Hz) !x_ctrl(2) = 0.33d+03 ! growth < this (days) - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -70,8 +70,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine end subroutine extras_controls @@ -102,12 +102,12 @@ subroutine alpha_mlt_routine(id, ierr) else s% alpha_mlt(k) = alpha_other end if - !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), + !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), end do !stop end subroutine alpha_mlt_routine - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -117,9 +117,9 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (.not. s% x_logical_ctrl(37)) return - + ! Initialize GYRE call gyre_init('gyre.in') @@ -135,10 +135,10 @@ subroutine extras_startup(id, restart, ierr) call gyre_set_constant('L_SUN', Lsun) call gyre_set_constant('GYRE_DIR', TRIM(mesa_dir)//'/gyre/gyre') - + end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use num_lib, only: find0 integer, intent(in) :: id @@ -156,7 +156,7 @@ subroutine extras_after_evolve(id, ierr) if (.not. s% x_logical_ctrl(37)) return call gyre_final() end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -166,7 +166,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -179,8 +179,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -192,7 +192,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -203,8 +203,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 6 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -225,17 +225,17 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) names(5) = 'D0' names(6) = 'DR0' - do k=1,nz + do k=1,nz vals(k,1) = s% xtra1_array(k) vals(k,2) = s% xtra2_array(k) vals(k,3) = s% xtra3_array(k) vals(k,4) = s% xtra4_array(k) vals(k,5) = s% xtra5_array(k) - vals(k,6) = s% xtra6_array(k) + vals(k,6) = s% xtra6_array(k) end do - + end subroutine data_for_extra_profile_columns - + include 'gyre_in_mesa_extras_finish_step.inc' ! returns either keep_going or terminate. @@ -254,4 +254,4 @@ integer function extras_finish_step(id) end function extras_finish_step end module run_star_extras - + diff --git a/star/dev_cases_test_TDC/dev_TDC_wd_nova_burst/src/run.f90 b/star/dev_cases_test_TDC/dev_TDC_wd_nova_burst/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/dev_cases_test_TDC/dev_TDC_wd_nova_burst/src/run.f90 +++ b/star/dev_cases_test_TDC/dev_TDC_wd_nova_burst/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/dev_cases_test_TDC/dev_TDC_wd_nova_burst/src/run_star_extras.f90 b/star/dev_cases_test_TDC/dev_TDC_wd_nova_burst/src/run_star_extras.f90 index 5fdf92820..088b93e57 100644 --- a/star/dev_cases_test_TDC/dev_TDC_wd_nova_burst/src/run_star_extras.f90 +++ b/star/dev_cases_test_TDC/dev_TDC_wd_nova_burst/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,23 +19,23 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def use math_lib - + implicit none - - include "test_suite_extras_def.inc" - + + include "test_suite_extras_def.inc" + integer :: num_bursts logical :: waiting_for_burst real(dp) :: L_burst = 1d4, L_between = 1d3 ! Lsun units - - + + contains include "test_suite_extras.inc" @@ -66,7 +66,7 @@ subroutine extras_controls(id, ierr) s% other_photo_read => extras_photo_read s% other_photo_write => extras_photo_write - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -74,10 +74,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -92,8 +92,8 @@ subroutine extras_startup(id, restart, ierr) waiting_for_burst = .true. end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -104,7 +104,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -142,8 +142,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -155,7 +155,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -166,8 +166,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 6 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -188,17 +188,17 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) names(5) = 'D0' names(6) = 'DR0' - do k=1,nz + do k=1,nz vals(k,1) = s% xtra1_array(k) vals(k,2) = s% xtra2_array(k) vals(k,3) = s% xtra3_array(k) vals(k,4) = s% xtra4_array(k) vals(k,5) = s% xtra5_array(k) - vals(k,6) = s% xtra6_array(k) + vals(k,6) = s% xtra6_array(k) end do - + end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -210,7 +210,7 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - + end module run_star_extras - + diff --git a/star/job/run_star.f90 b/star/job/run_star.f90 index d1606ce9a..2db6b2f01 100644 --- a/star/job/run_star.f90 +++ b/star/job/run_star.f90 @@ -1,9 +1,9 @@ - + module run_star implicit none - + contains - + subroutine do_run_star(inlist_fname_arg) use run_star_support, only: run1_star use run_star_extras, only: extras_controls @@ -28,4 +28,4 @@ subroutine do_run_star(inlist_fname_arg) end subroutine do_run_star end module run_star - + diff --git a/star/job/run_star_support.f90 b/star/job/run_star_support.f90 index b5d10038a..5b0b8df0a 100644 --- a/star/job/run_star_support.f90 +++ b/star/job/run_star_support.f90 @@ -22,7 +22,7 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module run_star_support use star_lib @@ -38,7 +38,7 @@ module run_star_support use other_extras implicit none - + integer :: id_from_read_star_job = 0 ! Set MESA_INLIST_RESOLVED to true when you no longer want the routine @@ -55,13 +55,13 @@ module run_star_support public :: id_from_read_star_job public :: MESA_INLIST_RESOLVED public :: do_star_job_controls_before, do_star_job_controls_after - + ! deprecated, but kept around for use by binary public :: before_evolve_loop, after_step_loop, before_step_loop, do_saves, & resolve_inlist_fname, terminate_normal_evolve_loop, null_binary_controls - - contains - + + contains + subroutine run1_star( & do_alloc_star, do_free_star, okay_to_restart, & @@ -69,30 +69,30 @@ subroutine run1_star( & extras_controls, & ierr, & inlist_fname_arg) - + logical, intent(in) :: do_alloc_star, do_free_star, okay_to_restart integer, intent(inout) :: id ! input if not do_alloc_star logical, intent(inout) :: restart ! input if not do_alloc_star character (len=*) :: inlist_fname_arg integer, intent(out) :: ierr optional inlist_fname_arg - + interface subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - end subroutine extras_controls - + end subroutine extras_controls + end interface - + logical :: continue_evolve_loop type (star_info), pointer :: s character (len=strlen) :: restart_filename - + logical, parameter :: pgstar_ok = .true. logical, parameter :: dbg = .false. - + 1 format(a35, 99(1pe26.16)) 2 format(a55, i7, 1pe26.16) 3 format(a15, 2x, f15.6) @@ -114,7 +114,7 @@ end subroutine extras_controls if (dbg) write(*,*) 'start evolve_loop' evolve_loop: do while(continue_evolve_loop) ! evolve one step per loop - + continue_evolve_loop = do_evolve_one_step(s, dbg, ierr) if (failed('do_evolve_one_step',ierr)) return @@ -123,14 +123,14 @@ end subroutine extras_controls call after_evolve_loop(s% id, do_free_star, ierr) if (failed('after_evolve_loop',ierr)) return - end subroutine run1_star - - + end subroutine run1_star + + subroutine start_run1_star( & do_alloc_star, do_free_star, okay_to_restart, & id, restart, restart_filename, pgstar_ok, dbg, & extras_controls, ierr, inlist_fname_arg) - + logical, intent(in) :: do_alloc_star, do_free_star, okay_to_restart integer, intent(inout) :: id ! input if not do_alloc_star logical, intent(inout) :: restart ! input if not do_alloc_star @@ -138,19 +138,19 @@ subroutine start_run1_star( & character (len=*) :: restart_filename, inlist_fname_arg optional inlist_fname_arg integer, intent(out) :: ierr - + interface subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - end subroutine extras_controls - + end subroutine extras_controls + end interface type (star_info), pointer :: s character (len=strlen) :: inlist_fname - + include 'formats' ierr = 0 @@ -175,19 +175,19 @@ end subroutine extras_controls s% job% time0_initial = 0 end subroutine start_run1_star - - + + logical function do_evolve_one_step(s, dbg, ierr) result(continue_evolve_loop) type (star_info), pointer :: s logical, intent(in) :: dbg integer, intent(out) :: ierr - + logical :: first_try integer :: id integer :: result, model_number - + include 'formats' - + ierr = 0 id = s% id continue_evolve_loop = .true. @@ -195,36 +195,36 @@ logical function do_evolve_one_step(s, dbg, ierr) result(continue_evolve_loop) call before_step_loop(s% id, ierr) if (failed('before_step_loop',ierr)) return - result = s% extras_start_step(id) + result = s% extras_start_step(id) if (result /= keep_going) then continue_evolve_loop = .false. - return - end if + return + end if first_try = .true. - + step_loop: do ! may need to repeat this loop - + if (stop_is_requested(s)) then continue_evolve_loop = .false. result = terminate - exit + exit step_loop end if - + result = star_evolve_step(id, first_try) if (result == keep_going) result = star_check_model(id) if (result == keep_going) result = s% extras_check_model(id) - if (result == keep_going) result = star_pick_next_timestep(id) + if (result == keep_going) result = star_pick_next_timestep(id) if (result == keep_going) exit step_loop - + model_number = get_model_number(id, ierr) if (failed('get_model_number',ierr)) return - + if (result == retry .and. s% job% report_retries) then write(*,'(i6,3x,a,/)') model_number, & 'retry reason ' // trim(result_reason_str(s% result_reason)) end if - + if (result == redo) then result = star_prepare_to_redo(id) end if @@ -236,16 +236,16 @@ logical function do_evolve_one_step(s, dbg, ierr) result(continue_evolve_loop) exit step_loop end if first_try = .false. - + end do step_loop - + ! once we get here, the only options are keep_going or terminate. ! redo or retry must be done inside the step_loop - + call after_step_loop(s% id, s% inlist_fname, & dbg, result, ierr) if (failed('after_step_loop',ierr)) return - + if (result /= keep_going) then if (result /= terminate) then write(*,2) 'ERROR in result value in run_star_extras: model', & @@ -253,7 +253,7 @@ logical function do_evolve_one_step(s, dbg, ierr) result(continue_evolve_loop) write(*,2) 'extras_finish_step must return keep_going or terminate' write(*,2) 'result', result continue_evolve_loop = .false. - return + return end if if (s% result_reason == result_reason_normal) then call terminate_normal_evolve_loop(s% id, & @@ -261,9 +261,9 @@ logical function do_evolve_one_step(s, dbg, ierr) result(continue_evolve_loop) if (failed('terminate_normal_evolve_loop',ierr)) return end if continue_evolve_loop = .false. - return + return end if - + call do_saves(id, ierr) if (failed('do_saves',ierr)) return @@ -275,9 +275,9 @@ logical function do_evolve_one_step(s, dbg, ierr) result(continue_evolve_loop) s% job% check_after_step_timing = s% job% check_after_step_timing + & (s% job% check_time_end - s% job% check_time_start) end if - + end function do_evolve_one_step - + subroutine null_binary_controls(id, binary_id, ierr) integer, intent(in) :: id, binary_id @@ -300,11 +300,11 @@ subroutine before_evolve_loop( & subroutine binary_controls(id, binary_id, ierr) integer, intent(in) :: id, binary_id integer, intent(out) :: ierr - end subroutine binary_controls + end subroutine binary_controls subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - end subroutine extras_controls + end subroutine extras_controls end interface integer :: id_from_read_star_job character (len=*) :: inlist_fname, restart_filename @@ -317,8 +317,8 @@ end subroutine extras_controls id_from_read_star_job, inlist_fname, restart_filename, & dbg, binary_id, id, ierr) end subroutine before_evolve_loop - - + + subroutine do_before_evolve_loop( & do_alloc_star, okay_to_restart, restart, pgstar_ok, & binary_controls, extras_controls, & @@ -330,11 +330,11 @@ subroutine do_before_evolve_loop( & subroutine binary_controls(id, binary_id, ierr) integer, intent(in) :: id, binary_id integer, intent(out) :: ierr - end subroutine binary_controls + end subroutine binary_controls subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - end subroutine extras_controls + end subroutine extras_controls end interface integer :: id_from_read_star_job character (len=*) :: inlist_fname, restart_filename @@ -343,19 +343,19 @@ end subroutine extras_controls integer, intent(in) :: binary_id integer, intent(out) :: id, ierr - type (star_info), pointer :: s - + type (star_info), pointer :: s + include 'formats' - - if (do_alloc_star) then - if (id_from_read_star_job /= 0) then + + if (do_alloc_star) then + if (id_from_read_star_job /= 0) then ! already allocated by read_star_job id = id_from_read_star_job id_from_read_star_job = 0 else call alloc_star(id, ierr) if (failed('alloc_star',ierr)) return - end if + end if call star_ptr(id, s, ierr) if (failed('star_ptr',ierr)) return else @@ -364,32 +364,32 @@ end subroutine extras_controls call init_starting_star_data(s, ierr) if (failed('init_starting_star_data',ierr)) return end if - + s% inlist_fname = inlist_fname - + if (dbg) write(*,*) 'call starlib_init' call starlib_init(s, ierr) ! okay to do extra calls on this if (failed('star_init',ierr)) return - + if (dbg) write(*,*) 'call star_set_kap_and_eos_handles' call star_set_kap_and_eos_handles(id, ierr) if (failed('set_star_kap_and_eos_handles',ierr)) return - + if (dbg) write(*,*) 'call star_setup' call star_setup(id, inlist_fname, ierr) if (failed('star_setup',ierr)) return - + if(dbg) write(*,*) 'call add_fpe_checks' call add_fpe_checks(id, s, ierr) if (failed('add_fpe_checks',ierr)) return - + if(dbg) write(*,*) 'call multiply_tolerances' call multiply_tolerances(id, s, ierr) if (failed('multiply_tolerances',ierr)) return if(dbg) write(*,*) 'call pgstar_env_check' call pgstar_env_check(id, s, ierr) - if (failed('pgstar_env_check',ierr)) return + if (failed('pgstar_env_check',ierr)) return ! testing module-level (atm/eos/kap/net) partials requires single-threaded execution if (s% solver_test_atm_partials .or. s% solver_test_eos_partials .or. & @@ -399,14 +399,14 @@ end subroutine extras_controls call omp_set_num_threads(1) end if end if - + if (len_trim(s% op_mono_data_path) == 0) & call get_environment_variable( & "MESA_OP_MONO_DATA_PATH", s% op_mono_data_path) - + if (len_trim(s% op_mono_data_cache_filename) == 0) & call get_environment_variable( & - "MESA_OP_MONO_DATA_CACHE_FILENAME", s% op_mono_data_cache_filename) + "MESA_OP_MONO_DATA_CACHE_FILENAME", s% op_mono_data_cache_filename) if (len_trim(s% emesh_data_for_op_mono_path) == 0) & call get_environment_variable( & @@ -436,7 +436,7 @@ end subroutine extras_controls else restart = .false. end if - + if (s% job% show_log_description_at_start .and. .not. restart) then write(*,'(A)') call show_log_description(id, ierr) @@ -446,7 +446,7 @@ end subroutine extras_controls if (dbg) write(*,*) 'call binary_controls' call binary_controls(id, binary_id, ierr) if (ierr /= 0) return - + if (dbg) write(*,*) 'call do_star_job_controls_before' call do_star_job_controls_before(id, s, restart, ierr) if (ierr /= 0) return @@ -454,14 +454,14 @@ end subroutine extras_controls if (dbg) write(*,*) 'call do_load1_star' call do_load1_star(id, s, restart, restart_filename, ierr) if (failed('do_load1_star',ierr)) return - + if (dbg) write(*,*) 'call do_star_job_controls_after' call do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) if (failed('do_star_job_controls_after',ierr)) return write(*,'(A)') write(*,'(A)') - + if (.not. restart) then if (dbg) write(*,*) 'call before_evolve' call before_evolve(id, ierr) @@ -470,7 +470,7 @@ end subroutine extras_controls call show_terminal_header(id, ierr) if (failed('show_terminal_header',ierr)) return end if - + if (dbg) write(*,*) 'call extras_startup' call s% extras_startup(id, restart, ierr) if (failed('extras_startup',ierr)) return @@ -478,7 +478,7 @@ end subroutine extras_controls if (s% job% profile_starting_model .and. .not. restart) then call star_set_vars(id, 0d0, ierr) if (failed('star_set_vars',ierr)) return - write(*, '(a, i12)') 'save profile for model number ', s% model_number + write(*, '(a, i12)') 'save profile for model number ', s% model_number call save_profile(id,3,ierr) if (failed('save_profile',ierr)) return end if @@ -486,12 +486,12 @@ end subroutine extras_controls if (s% model_number == s% job% save_model_number) then call star_set_vars(id, 0d0, ierr) if (failed('star_set_vars',ierr)) return - write(*, '(a, i12)') 'write initial model ', s% model_number + write(*, '(a, i12)') 'write initial model ', s% model_number call star_write_model(id, 'initial.mod', ierr) if (failed('star_write_model',ierr)) return write(*, *) 'saved to ' // 'initial.mod' ! trim(s% job% save_model_filename) end if - + if (len_trim(s% job% echo_at_start) > 0) then write(*,'(A)') write(*,'(a)') trim(s% job% echo_at_start) @@ -503,11 +503,11 @@ end subroutine do_before_evolve_loop subroutine before_step_loop(id, ierr) integer, intent(in) :: id - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(out) :: ierr integer :: model_number, j integer :: num_DT, num_FreeEOS - + 1 format(a35, 99(1pe26.16)) 2 format(a35, i7, 1pe26.16) 3 format(a15, 2x, f15.6) @@ -519,7 +519,7 @@ subroutine before_step_loop(id, ierr) if (ierr/=0) return s% result_reason = result_reason_normal - + if (s% job% first_model_for_timing >= 0 .and. & s% model_number >= s% job% first_model_for_timing .and. & .not. s% doing_timing) then @@ -532,12 +532,12 @@ subroutine before_step_loop(id, ierr) s% job% after_step_timing = 0 s% job% before_step_timing = 0 end if - + if (s% doing_timing) then call system_clock(s% job% time0_extra,s% job% clock_rate) s% job% check_time_start = eval_total_times(s% id, ierr) end if - + if(s% job% num_steps_for_garbage_collection > 0 .and. s% model_number > 1) then if(mod(s% model_number, s% job% num_steps_for_garbage_collection) == 0)then if (s% job% report_garbage_collection) then @@ -549,7 +549,7 @@ subroutine before_step_loop(id, ierr) call star_do_garbage_collection(s% id,ierr) if (failed('star_do_garbage_collection',ierr)) return end if - + ! If reporting, we want to look at the step and the next step (to see the difference) if(mod(s% model_number-1, s% job% num_steps_for_garbage_collection) == 0 & .and. s% job% report_garbage_collection)then @@ -559,7 +559,7 @@ subroutine before_step_loop(id, ierr) "num FreeEOS",num_FreeEOS end if end if - + if (s% job% enable_adaptive_network) then call star_adjust_net(s% id, & s% job% min_x_for_keep, & @@ -571,12 +571,12 @@ subroutine before_step_loop(id, ierr) ierr) if (failed('star_adjust_net',ierr)) return end if - + if (s% job% auto_extend_net) then call extend_net(s, ierr) if (failed('extend_net',ierr)) return end if - + if (s% use_other_remove_surface) then call s% other_remove_surface(id, ierr, j) if (failed('other_remove_surface',ierr)) return @@ -588,24 +588,24 @@ subroutine before_step_loop(id, ierr) call do_remove_surface(id, s, ierr) if (failed('do_remove_surface',ierr)) return end if - + if (s% job% remove_fallback_at_each_step) then call star_remove_fallback(id,ierr) if (failed('star_remove_fallback',ierr)) return end if - + if (s% job% limit_center_logP_at_each_step > -1d90) then call star_limit_center_logP( & id, s% job% limit_center_logP_at_each_step, ierr) if (failed('star_limit_center_logP',ierr)) return end if - + if (s% job% remove_center_logRho_limit > -1d90) then call star_remove_center_by_logRho( & id, s% job% remove_center_logRho_limit, ierr) if (failed('star_remove_center_by_logRho',ierr)) return end if - + if (s% center_ye <= s% job% center_ye_limit_for_v_flag & .and. (.not. s% v_flag) .and. (.not. s% u_flag)) then write(*,1) 'have reached center ye limit', & @@ -615,33 +615,33 @@ subroutine before_step_loop(id, ierr) if (failed('star_set_v_flag',ierr)) return if (ierr /= 0) return end if - + if (s% job% change_RSP2_flag_at_model_number == s% model_number) then write(*,*) 'have reached model number for new_RSP2_flag', & s% model_number, s% job% new_RSP2_flag call star_set_RSP2_flag(id, s% job% new_RSP2_flag, ierr) if (failed('star_set_RSP2_flag',ierr)) return end if - + if (s% job% report_mass_not_fe56) call do_report_mass_not_fe56(s) if (s% job% report_cell_for_xm > 0) call do_report_cell_for_xm(s) - + model_number = get_model_number(id, ierr) if (failed('get_model_number',ierr)) return - + if (s% star_age < s% job% set_cumulative_energy_error_each_step_if_age_less_than) then if (mod(model_number, s% terminal_interval) == 0) & write(*,1) 'cumulative_energy_error reset to', s% job% new_cumulative_energy_error s% cumulative_energy_error = s% job% new_cumulative_energy_error end if - + if (s% doing_timing) then - + call system_clock(s% job% time1_extra, s% job% clock_rate) s% job% before_step_timing = & s% job% before_step_timing + & dble(s% job% time1_extra - s% job% time0_extra) / s% job% clock_rate - + s% job% check_time_end = eval_total_times(s% id, ierr) s% job% check_before_step_timing = & s% job% check_before_step_timing + & @@ -657,7 +657,7 @@ end subroutine before_step_loop subroutine after_step_loop(id, inlist_fname, dbg, result, ierr) integer, intent(in) :: id - type (star_info), pointer :: s + type (star_info), pointer :: s character (len=*) :: inlist_fname logical, intent(in) :: dbg integer, intent(out) :: ierr @@ -665,28 +665,28 @@ subroutine after_step_loop(id, inlist_fname, dbg, result, ierr) logical :: will_read_pgstar_inlist real(dp) :: tmp - + include 'formats' call star_ptr(id, s, ierr) if (ierr/=0) return - if (s% doing_timing) then + if (s% doing_timing) then call system_clock(s% job% time1_extra,s% job% clock_rate) s% job% step_loop_timing = s% job% step_loop_timing + & - dble(s% job% time1_extra - s% job% time0_extra) / s% job% clock_rate + dble(s% job% time1_extra - s% job% time0_extra) / s% job% clock_rate s% job% check_time_end = eval_total_times(s% id, ierr) s% job% check_step_loop_timing = s% job% check_step_loop_timing + & (s% job% check_time_end - s% job% check_time_start) s% job% time0_extra = s% job% time1_extra - s% job% check_time_start = s% job% check_time_end + s% job% check_time_start = s% job% check_time_end end if - + if (s% model_number == s% job% set_cumulative_energy_error_at_step) then write(*,1) 'set_cumulative_energy_error', s% job% new_cumulative_energy_error s% cumulative_energy_error = s% job% new_cumulative_energy_error end if - + if (is_bad(s% total_energy_end)) then ierr = 1 return @@ -699,7 +699,7 @@ subroutine after_step_loop(id, inlist_fname, dbg, result, ierr) s% model_number, abs(s% cumulative_energy_error/s% total_energy_end) end if end if - + if (.not. (s% rotation_flag .or. s% u_flag .or. s% use_mass_corrections & .or. s% v_flag .or. s% m_center > 0 .or. s% star_mdot /= 0d0)) then tmp = abs(1d0 + s% total_gravitational_energy_end/s% virial_thm_P_avg) @@ -709,8 +709,8 @@ subroutine after_step_loop(id, inlist_fname, dbg, result, ierr) abs(s% total_gravitational_energy_end), s% virial_thm_P_avg end if end if - - if (result == keep_going) then + + if (result == keep_going) then if (s% job% pgstar_flag) then will_read_pgstar_inlist = .false. if (s% pg% pgstar_interval <= 0) then @@ -719,43 +719,43 @@ subroutine after_step_loop(id, inlist_fname, dbg, result, ierr) will_read_pgstar_inlist = .true. end if if(will_read_pgstar_inlist) then - call read_pgstar_inlist(s, inlist_fname, ierr) + call read_pgstar_inlist(s, inlist_fname, ierr) if (failed('read_pgstar_controls',ierr)) return end if end if end if - + if (result == keep_going) then - result = s% extras_finish_step(id) - else if (result == terminate) then + result = s% extras_finish_step(id) + else if (result == terminate) then ! call extras_finish_step one last time before terminate - result = s% extras_finish_step(id) + result = s% extras_finish_step(id) result = terminate end if - + if (result == keep_going) then if (dbg) write(*,*) 'call star_finish_step' result = star_finish_step(id, ierr) if (failed('star_finish_step',ierr)) return end if - + if (result == keep_going .and. s% job% pgstar_flag) then if (dbg) write(*,*) 'call update_pgstar_plots' call update_pgstar_plots(s, .false., ierr) if (failed('update_pgstar_plots',ierr)) return end if - - if (result == keep_going) then + + if (result == keep_going) then call adjust_tau_factor(s) if (s% L_nuc_burn_total/s% L_phot >= s% Lnuc_div_L_zams_limit & - .and. .not. s% rotation_flag) then + .and. .not. s% rotation_flag) then call do_rotation_near_zams(s,ierr) if (ierr /= 0) return - end if - if (s% rotation_flag) then + end if + if (s% rotation_flag) then call do_rotation(s,ierr) if (ierr /= 0) return - end if + end if end if end subroutine after_step_loop @@ -764,7 +764,7 @@ end subroutine after_step_loop subroutine terminate_normal_evolve_loop(id, & dbg, result, ierr) integer, intent(in) :: id - type (star_info), pointer :: s + type (star_info), pointer :: s logical, intent(in) :: dbg integer, intent(out) :: result, ierr integer :: i @@ -774,18 +774,18 @@ subroutine terminate_normal_evolve_loop(id, & if (ierr/=0) return if (dbg) write(*,*) 'call star_pick_next_timestep' - result = star_pick_next_timestep(id) ! for saved model if any + result = star_pick_next_timestep(id) ! for saved model if any if (dbg) write(*,*) 'call save_profile' call save_profile(id, 3, ierr) s% need_to_save_profiles_now = .false. s% need_to_update_history_now = .true. if (dbg) write(*,*) 'call star_finish_step' result = star_finish_step(id, ierr) - if (failed('star_finish_step',ierr)) return + if (failed('star_finish_step',ierr)) return if (s% job% save_photo_when_terminate .and. termination_code_string_okay()) & s% job% save_photo_number = s% model_number if (s% job% save_model_when_terminate .and. termination_code_string_okay()) & - s% job% save_model_number = s% model_number + s% job% save_model_number = s% model_number if (s% job% save_pulse_data_when_terminate) & s% job% save_pulse_data_for_model_number = s% model_number if (s% job% write_profile_when_terminate) then @@ -796,7 +796,7 @@ subroutine terminate_normal_evolve_loop(id, & if (failed('star_write_profile_info',ierr)) return else write(*,*) "filename_for_profile_when_terminate must be non empty" - ierr = -1 + ierr = -1 return end if end if @@ -818,9 +818,9 @@ subroutine terminate_normal_evolve_loop(id, & end if call do_saves(id, ierr) if (failed('do_saves terminate_normal_evolve_loop',ierr)) return - + contains - + logical function termination_code_string_okay() integer :: j, n termination_code_string_okay = .true. @@ -844,7 +844,7 @@ end subroutine terminate_normal_evolve_loop subroutine after_evolve_loop(id, & do_free_star, ierr) integer, intent(in) :: id - type (star_info), pointer :: s + type (star_info), pointer :: s logical, intent(in) :: do_free_star integer, intent(out) :: ierr @@ -857,17 +857,17 @@ subroutine after_evolve_loop(id, & dble(s% job% time1 - s% job% time0_initial) / s% job% clock_rate call show_times(id,s) end if - + if (s% result_reason /= result_reason_normal) then write(*, '(a)') 'terminated evolution: ' // & trim(result_reason_str(s% result_reason)) end if - + if (s% termination_code > 0 .and. s% termination_code <= num_termination_codes) then write(*, '(a)') 'termination code: ' // & trim(termination_code_str(s% termination_code)) end if - + if (s% job% pause_before_terminate) then write(*,'(a)') 'pause_before_terminate: hit RETURN to continue' read(*,*) @@ -877,7 +877,7 @@ subroutine after_evolve_loop(id, & if (failed('after_evolve_extras',ierr)) return if (s% result_reason == result_reason_normal) then - + if (s% job% pgstar_flag) & call update_pgstar_plots( & s, s% job% save_pgstar_files_when_terminate, & @@ -886,37 +886,37 @@ subroutine after_evolve_loop(id, & call show_terminal_header(id, ierr) if (failed('show_terminal_header',ierr)) return - + call write_terminal_summary(id, ierr) if (failed('write_terminal_summary',ierr)) return - + end if - + if (len_trim(s% job% echo_at_end) > 0) then write(*,'(A)') write(*,'(a)') trim(s% job% echo_at_end) write(*,'(A)') end if - + if (do_free_star) then call free_star(id, ierr) if (failed('free_star',ierr)) return end if end subroutine after_evolve_loop - - + + subroutine adjust_tau_factor(s) - type (star_info), pointer :: s + type (star_info), pointer :: s include 'formats' - + if (s% job% adjust_tau_factor_to_surf_density .and. & s% job% base_for_adjust_tau_factor_to_surf_density > 0d0) then s% tau_factor = s% rho(1)/s% job% base_for_adjust_tau_factor_to_surf_density !write(*,1) 'adjust_tau_factor_to_surf_density', s% tau_factor s% need_to_setvars = .true. end if - + if (s% job% set_tau_factor_after_core_He_burn > 0 .and. & abs(s% tau_factor - s% job% set_to_this_tau_factor) > & 1d-6*max(s% tau_factor, s% job% set_to_this_tau_factor)) then @@ -926,7 +926,7 @@ subroutine adjust_tau_factor(s) s% need_to_setvars = .true. end if end if - + if (s% job% set_tau_factor_after_core_C_burn > 0 .and. & abs(s% tau_factor - s% job% set_to_this_tau_factor) > & 1d-6*max(s% tau_factor, s% job% set_to_this_tau_factor)) then @@ -936,14 +936,14 @@ subroutine adjust_tau_factor(s) s% need_to_setvars = .true. end if end if - + if (s% job% relax_tau_factor_after_core_He_burn > 0 .and. & abs(s% tau_factor - s% job% relax_to_this_tau_factor) > & 1d-6*max(s% tau_factor, s% job% relax_to_this_tau_factor)) then if (check_for_after_He_burn(s, s% job% relax_tau_factor_after_core_He_burn)) & call relax_tau_factor(s) end if - + if (s% job% relax_tau_factor_after_core_C_burn > 0 .and. & abs(s% tau_factor - s% job% relax_to_this_tau_factor) > & 1d-6*max(s% tau_factor, s% job% relax_to_this_tau_factor)) then @@ -954,26 +954,26 @@ subroutine adjust_tau_factor(s) end subroutine adjust_tau_factor - + subroutine do_rotation(s,ierr) - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(out) :: ierr include 'formats' ierr = 0 - + if (s% model_number <= s% job% set_surf_rotation_v_step_limit) then s% job% new_omega = s% job% new_surface_rotation_v*1d5/(s% photosphere_r*Rsun) write(*,2) 'surface_rotation_v', s% model_number, s% job% new_surface_rotation_v write(*,2) 'omega', s% model_number, s% job% new_omega call star_set_uniform_omega(s% id, s% job% new_omega, ierr) if (failed('star_set_uniform_omega',ierr)) return - + else if (s% model_number <= s% job% set_omega_step_limit) then write(*,2) 'omega', s% model_number, s% job% new_omega if (failed('star_surface_omega_crit',ierr)) return call star_set_uniform_omega(s% id, s% job% new_omega, ierr) if (failed('star_set_uniform_omega',ierr)) return - + else if (s% model_number <= s% job% set_omega_div_omega_crit_step_limit) then s% job% new_omega = & s% job% new_omega_div_omega_crit*star_surface_omega_crit(s% id, ierr) @@ -983,16 +983,16 @@ subroutine do_rotation(s,ierr) if (failed('star_surface_omega_crit',ierr)) return call star_set_uniform_omega(s% id, s% job% new_omega, ierr) if (failed('star_set_uniform_omega',ierr)) return - end if - end subroutine do_rotation - - + end if + end subroutine do_rotation + + subroutine do_rotation_near_zams(s,ierr) - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(out) :: ierr include 'formats' ierr = 0 - + if (s% job% set_near_zams_surface_rotation_v_steps > 0 .and. & s% job% new_surface_rotation_v /= 0d0) then s% job% new_rotation_flag = .true. @@ -1059,12 +1059,12 @@ subroutine do_rotation_near_zams(s,ierr) s% job% relax_omega_max_yrs_dt, ierr) if (failed('star_relax_uniform_omega',ierr)) return - end if - end subroutine do_rotation_near_zams + end if + end subroutine do_rotation_near_zams + - subroutine relax_tau_factor(s) - type (star_info), pointer :: s + type (star_info), pointer :: s real(dp) :: next include 'formats' write(*,*) 'relax_to_this_tau_factor < s% tau_factor', & @@ -1087,9 +1087,9 @@ subroutine relax_tau_factor(s) end if end subroutine relax_tau_factor - + subroutine relax_Tsurf_factor(s) - type (star_info), pointer :: s + type (star_info), pointer :: s real(dp) :: next include 'formats' write(*,*) 'relax_to_this_Tsurf_factor < s% Tsurf_factor', & @@ -1109,10 +1109,10 @@ subroutine relax_Tsurf_factor(s) write(*,1) 'relax_Tsurf_factor', next, s% job% relax_to_this_Tsurf_factor end subroutine relax_Tsurf_factor - + subroutine check_if_want_to_stop_warnings(s) use utils_lib - type (star_info), pointer :: s + type (star_info), pointer :: s character (len=200) :: fname integer :: iounit, ierr ierr = 0 @@ -1127,11 +1127,11 @@ subroutine check_if_want_to_stop_warnings(s) end if end if ierr = 0 - end subroutine check_if_want_to_stop_warnings - - + end subroutine check_if_want_to_stop_warnings + + logical function stop_is_requested(s) - type (star_info), pointer :: s + type (star_info), pointer :: s logical :: file_exists stop_is_requested = .false. if (mod(s% model_number,100) /= 0) return @@ -1142,28 +1142,28 @@ logical function stop_is_requested(s) trim(s% job% stop_if_this_file_exists) stop_is_requested = .true. end function stop_is_requested - - + + logical function failed(str,ierr) character (len=*), intent(in) :: str integer, intent(in) :: ierr failed = (ierr /= 0) if (failed) write(*, *) trim(str) // ' ierr', ierr end function failed - - + + subroutine show_times(id, s) use utils_lib, only: utils_OMP_GET_MAX_THREADS use num_lib, only: qsort - + integer, intent(in) :: id type (star_info), pointer :: s integer, parameter :: max_num_items = 50 character(len=60) :: item_names(max_num_items) real(dp) :: item_values(max_num_items) - integer, target :: index_arry(max_num_items) - integer, pointer :: index(:) + integer, target :: index_arry(max_num_items) + integer, pointer :: index(:) integer :: ierr, omp_num_threads, item_num, num_items, i, j real(dp) :: total, tmp include 'formats' @@ -1171,7 +1171,7 @@ subroutine show_times(id, s) omp_num_threads = utils_OMP_GET_MAX_THREADS() s% time_total = s% job% check_before_step_timing + & s% job% check_step_loop_timing + s% job% check_after_step_timing - + write(*,'(A)') write(*,'(a50,i18)') 'nz', s% nz write(*,'(a50,i18)') 'nvar_total', s% nvar_total @@ -1207,11 +1207,11 @@ subroutine show_times(id, s) call save1('run1_star', s% job% elapsed_time - total, total) tmp = 0 call save1('total', total, tmp) - + num_items = item_num index(1:num_items) => index_arry(1:num_items) call qsort(index, num_items, item_values) - + write(*,'(A)') write(*,'(A)') do i=1,num_items @@ -1221,7 +1221,7 @@ subroutine show_times(id, s) item_values(j), item_values(j)/total if (j == num_items) write(*,*) end do - + if (s% job% step_loop_timing/s% job% elapsed_time < 0.9d0) then write(*,'(A)') write(*,'(A)') @@ -1232,11 +1232,11 @@ subroutine show_times(id, s) end if write(*,'(A)') write(*,'(A)') - - + + contains - - + + subroutine save1(name, value, total) use utils_lib, only: is_bad_num character (len=*), intent(in) :: name @@ -1248,34 +1248,34 @@ subroutine save1(name, value, total) item_values(item_num) = value total = total + value end subroutine save1 - + end subroutine show_times - - + + subroutine do_saves(id, ierr) integer, intent(in) :: id type (star_info), pointer :: s integer :: ierr ierr = 0 - + call star_ptr(id, s, ierr) - if (ierr/=0) return - + if (ierr/=0) return + if (s% model_number == s% job% save_model_number) then call star_write_model(id, s% job% save_model_filename, ierr) if (failed('star_write_model',ierr)) return write(*, *) 'model saved to ' // trim(s% job% save_model_filename) end if - + if (s% model_number == s% job% save_photo_number) then call star_write_photo(id, s% job% save_photo_filename, ierr) if (failed('star_write_photo',ierr)) return if (len_trim(s% job% save_photo_filename) > 0) & write(*, *) 'photo saved to ' // trim(s% job% save_photo_filename) end if - + if (s% model_number == s% job% save_pulse_data_for_model_number) then call star_export_pulse_data(id, s%pulse_data_format, s%job%save_pulse_data_filename, & s%add_center_point_to_pulse_data, s%keep_surface_point_for_pulse_data, & @@ -1284,16 +1284,16 @@ subroutine do_saves(id, ierr) write(*, *) 'pulsation data saved to ' // & trim(s% job% save_pulse_data_filename) end if - + if (s% model_number == s% job% profile_model_number) then write(*, '(a, i7)') 'save profile for model number', s% model_number call save_profile(id, 3, ierr) if (failed('save_profile',ierr)) return end if - + end subroutine do_saves - + subroutine write_colors_info(id, s, ierr) use colors_lib use colors_def @@ -1301,7 +1301,7 @@ subroutine write_colors_info(id, s, ierr) integer, intent(in) :: id type (star_info), pointer :: s integer, intent(out) :: ierr - + integer :: io, i, j character (len=strlen) :: fname real(dp) :: log_Teff ! log10 of surface temp @@ -1311,18 +1311,18 @@ subroutine write_colors_info(id, s, ierr) ! output real(dp),dimension(bc_total_num_colors) :: results real(dp) :: log_g - + character(len=strlen),dimension(bc_total_num_colors) :: names - + ierr = 0 - + call get_all_bc_names(names,ierr) - if (ierr /= 0) then + if (ierr /= 0) then ierr=-1 call cleanup return end if - + fname = 'colors.log' !if (s% doing_first_model_of_run) then if (.false.) then @@ -1354,7 +1354,7 @@ subroutine write_colors_info(id, s, ierr) call cleanup return end if - + log_Teff = log10(s% Teff) log_L = s% log_surface_luminosity mass = s% star_mass @@ -1365,14 +1365,14 @@ subroutine write_colors_info(id, s, ierr) call cleanup return end if - + call get_bcs_all(log_Teff, log_g, Fe_H, results, ierr) if (ierr /= 0) then write(*,*) 'failed in colors_get' call cleanup return end if - + 1 format(1x,f24.12) write(io,fmt='(i10)',advance='no') s% model_number write(io,fmt=1,advance='no') log_Teff @@ -1383,36 +1383,36 @@ subroutine write_colors_info(id, s, ierr) write(io,fmt=1,advance='no') results(i) end do write(io,1) log_g - + call cleanup - + contains - + subroutine cleanup close(io) end subroutine cleanup - + end subroutine write_colors_info - - + + subroutine read_masses(filename, masses, nmasses, ierr) character (len=*), intent(in) :: filename real(dp), pointer, intent(inout) :: masses(:) integer, intent(out) :: nmasses, ierr call read_items(filename, masses, nmasses, 'masses', ierr) end subroutine read_masses - - + + subroutine read_items(filename, items, nitems, name, ierr) use utils_lib use utils_def character (len=*), intent(in) :: filename, name real(dp), pointer, intent(inout) :: items(:) integer, intent(out) :: nitems, ierr - + integer :: iounit, n, i, t, capacity character (len=strlen) :: buffer, string - + nitems = 0 if (.not. associated(items)) then capacity = 10 @@ -1420,7 +1420,7 @@ subroutine read_items(filename, items, nitems, name, ierr) else capacity = size(items,dim=1) end if - + ierr = 0 open(newunit=iounit, file=trim(filename), action='read', status='old', iostat=ierr) @@ -1428,10 +1428,10 @@ subroutine read_items(filename, items, nitems, name, ierr) write(*,*) 'failed to open file ' // trim(filename) return end if - + n = 0 i = 0 - + do t = token(iounit, n, i, buffer, string) select case(t) @@ -1449,21 +1449,21 @@ subroutine read_items(filename, items, nitems, name, ierr) case default call error; return end select - + end do - + close(iounit) - + contains - - + + subroutine error ierr = -1 write(*,*) 'error in reading file' // trim(filename) close(iounit) end subroutine error - - + + subroutine do_read_items(ierr) integer, intent(out) :: ierr real(dp) :: mass @@ -1497,11 +1497,11 @@ subroutine do_read_items(ierr) end if end do mass_loop end subroutine do_read_items - - + + end subroutine read_items - - + + subroutine do_report_mass_not_fe56(s) use const_def type (star_info), pointer :: s @@ -1527,8 +1527,8 @@ subroutine do_report_mass_not_fe56(s) end if end do end subroutine do_report_mass_not_fe56 - - + + subroutine do_report_cell_for_xm(s) use const_def type (star_info), pointer :: s @@ -1557,7 +1557,7 @@ subroutine do_report_cell_for_xm(s) end do write(*,2) 'total mass in cells from 1 to nz', s% nz, s% xmstar end subroutine do_report_cell_for_xm - + subroutine set_rate_factors(id, ierr) use net_lib, only: get_net_reaction_table_ptr use rates_lib, only: rates_reaction_id @@ -1565,16 +1565,16 @@ subroutine set_rate_factors(id, ierr) integer, intent(out) :: ierr type (star_info), pointer :: s integer :: j, i, ir - integer, pointer :: net_reaction_ptr(:) + integer, pointer :: net_reaction_ptr(:) logical :: error - + include 'formats' - + ierr = 0 error = .false. call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% rate_factors(:) = 1 if (s% job% num_special_rate_factors <= 0) return @@ -1585,10 +1585,10 @@ subroutine set_rate_factors(id, ierr) return end if - + call get_net_reaction_table_ptr(s% net_handle, net_reaction_ptr, ierr) if (ierr /= 0) return - + do i=1,s% job% num_special_rate_factors if (len_trim(s% job% reaction_for_special_factor(i)) == 0) cycle ir = rates_reaction_id(s% job% reaction_for_special_factor(i)) @@ -1608,7 +1608,7 @@ subroutine set_rate_factors(id, ierr) end do if(error) call mesa_error(__FILE__,__LINE__) - + end subroutine set_rate_factors @@ -1623,11 +1623,11 @@ subroutine do_star_job_controls_before(id, s, restart, ierr) integer, intent(out) :: ierr logical, parameter :: kap_use_cache = .true. include 'formats' - + ierr = 0 s% set_rate_factors => set_rate_factors ! will be called after net is defined - + call get_atm_tau_base(s, s% tau_base, ierr) if (failed('atm_tau_base',ierr)) return @@ -1636,42 +1636,42 @@ subroutine do_star_job_controls_before(id, s, restart, ierr) end subroutine do_star_job_controls_before - + subroutine do_read_star_job_and_return_id(filename, id, ierr) character(*), intent(in) :: filename - integer, intent(out) :: id - integer, intent(out) :: ierr + integer, intent(out) :: id + integer, intent(out) :: ierr type (star_info), pointer :: s character(len=strlen) :: inlist_fname - + include 'formats' - ierr = 0 + ierr = 0 if (id_from_read_star_job /= 0) then write(*,2) 'id_from_read_star_job', id_from_read_star_job ierr = -1 return end if - + call alloc_star(id, ierr) if (ierr /= 0) then write(*,*) 'do_read_star_job failed in alloc_star' return end if - + call star_ptr(id, s, ierr) if (ierr /= 0) then write(*,*) 'do_read_star_job failed in star_ptr' return end if - + call resolve_inlist_fname(inlist_fname,filename) call read_star_job(s, inlist_fname, ierr) if (ierr /= 0) then write(*,*) 'ierr from read_star_job ' // trim(inlist_fname) return end if - + id_from_read_star_job = id if (s% job% save_star_job_namelist) then @@ -1682,27 +1682,27 @@ subroutine do_read_star_job_and_return_id(filename, id, ierr) return end if end if - + end subroutine do_read_star_job_and_return_id - + ! in a perfect world, we'd pass s as an arg to this routine. ! but for backward compatibility for a large number of users ! we do it this strange way instead. subroutine do_read_star_job(filename, ierr) character(*), intent(in) :: filename - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: id call do_read_star_job_and_return_id(filename, id, ierr) end subroutine do_read_star_job - - + + subroutine do_load1_star(id, s, restart, restart_filename, ierr) integer, intent(in) :: id type (star_info), pointer :: s logical, intent(in) :: restart character (len=*), intent(in) :: restart_filename integer, intent(out) :: ierr - + if (restart) then call star_load_restart_photo(id, restart_filename, ierr) if (failed('star_load_restart_photo',ierr)) return @@ -1880,9 +1880,9 @@ subroutine create_merger_model(s, ierr) s% job% change_mass_years_for_dt, ierr) deallocate(xq,xa) if (failed('star_relax_mass_scale',ierr)) return - + end subroutine create_merger_model - + subroutine extend_net(s, ierr) use net_def @@ -1890,15 +1890,15 @@ subroutine extend_net(s, ierr) type (star_info), pointer :: s integer, intent(out) :: ierr real(dp), parameter :: tiny = 1d-10, small = 1d-2 - + real(dp) :: cntr_h, cntr_he - + include 'formats' - + ierr = 0 - + !write(*,2) 'extend_net: current net ' // trim(s% net_name), s% model_number - + if (s% net_name == s% job% adv_net) return if (s% net_name == s% job% co_net) then @@ -1911,7 +1911,7 @@ subroutine extend_net(s, ierr) end if return end if - + if (s% net_name == s% job% h_he_net) then cntr_h = current_abundance_at_point(s% id, ih1, s% nz, ierr) !write(*,2) 'cntr_h', s% model_number, cntr_h, tiny @@ -1929,17 +1929,17 @@ subroutine extend_net(s, ierr) s% id, s% job% profile_columns_file, .true., ierr) end if end if - - + + contains - - + + subroutine change_net(net_name) use const_def character (len=*), intent(in) :: net_name - + include 'formats' - + call star_change_to_new_net( & s% id, s% job% adjust_abundances_for_new_isos, net_name, ierr) if (ierr /= 0) then @@ -1947,7 +1947,7 @@ subroutine change_net(net_name) call mesa_error(__FILE__,__LINE__,'change_net') return end if - + if (net_name /= s% net_name) then write(*,*) ' new net_name ', trim(net_name) write(*,*) 'old s% net_name ', trim(s% net_name) @@ -1964,17 +1964,17 @@ subroutine change_net(net_name) !write(*,1) 'reduce timestep', log10(s% dt_next/secyer) write(*,'(A)') end subroutine change_net - - - end subroutine extend_net + + + end subroutine extend_net subroutine before_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr ierr = 0 - end subroutine before_evolve - + end subroutine before_evolve + subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) use const_def @@ -1986,20 +1986,20 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) type (star_info), pointer :: s logical, intent(in) :: restart, pgstar_ok integer, intent(out) :: ierr - + real(dp) :: log_m, log_lifetime, max_dt, max_timestep integer :: i, j, nzlo, nzhi, chem_id, chem_id1, chem_id2 logical :: change_v, change_u include 'formats' - - if (s% job% change_net .or. (s% job% change_initial_net .and. .not. restart)) then + + if (s% job% change_net .or. (s% job% change_initial_net .and. .not. restart)) then call star_change_to_new_net( & id, s% job% adjust_abundances_for_new_isos, s% job% new_net_name, ierr) if (failed('star_change_to_new_net',ierr)) return end if if (s% job% change_small_net .or. & - (s% job% change_initial_small_net .and. .not. restart)) then + (s% job% change_initial_small_net .and. .not. restart)) then write(*,*) 'change small net to ' // trim(s% job% new_small_net_name) call star_change_to_new_small_net( & id, s% job% adjust_abundances_for_new_isos, s% job% new_small_net_name, ierr) @@ -2012,12 +2012,12 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) write(*,*) 'read ' // trim(s% job% history_columns_file) call star_set_history_columns(id, s% job% history_columns_file, .true., ierr) if (failed('star_set_history_columns',ierr)) return - + if (len_trim(s% job% profile_columns_file) > 0) & write(*,*) 'read ' // trim(s% job% profile_columns_file) call star_set_profile_columns(id, s% job% profile_columns_file, .true., ierr) if (failed('star_set_profile_columns',ierr)) return - + if (pgstar_ok) then if (s% job% clear_pgstar_history .or. & (s% job% clear_initial_pgstar_history .and. .not. restart)) then @@ -2028,19 +2028,19 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) if (failed('restart_run_for_pgstar',ierr)) return end if end if - + if (s% job% set_tau_factor .or. & (s% job% set_initial_tau_factor .and. .not. restart)) then write(*,1) 'set_tau_factor', s% job% set_to_this_tau_factor s% tau_factor = s% job% set_to_this_tau_factor end if - + if (s% job% set_Tsurf_factor .or. & (s% job% set_initial_Tsurf_factor .and. .not. restart)) then write(*,1) 'set_Tsurf_factor', s% job% set_to_this_Tsurf_factor s% Tsurf_factor = s% job% set_to_this_Tsurf_factor end if - + if (s% job% set_initial_age .and. .not. restart) then write(*,1) 'set_initial_age', s% job% initial_age ! in years call star_set_age(id, s% job% initial_age, ierr) @@ -2106,27 +2106,27 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) write(*,2) 'steps_before_start_timing', & s% job% steps_before_start_timing end if - + if (abs(s% job% T9_weaklib_full_off - T9_weaklib_full_off) > 1d-6) then write(*,1) 'set T9_weaklib_full_off', s% job% T9_weaklib_full_off T9_weaklib_full_off = s% job% T9_weaklib_full_off end if - + if (abs(s% job% T9_weaklib_full_on - T9_weaklib_full_on) > 1d-6) then write(*,1) 'set T9_weaklib_full_on', s% job% T9_weaklib_full_on T9_weaklib_full_on = s% job% T9_weaklib_full_on end if - + if (s% job% weaklib_blend_hi_Z /= weaklib_blend_hi_Z) then write(*,1) 'set weaklib_blend_hi_Z', s% job% weaklib_blend_hi_Z weaklib_blend_hi_Z = s% job% weaklib_blend_hi_Z end if - + if (abs(s% job% T9_weaklib_full_off_hi_Z - T9_weaklib_full_off_hi_Z) > 1d-6) then write(*,1) 'set T9_weaklib_full_off_hi_Z', s% job% T9_weaklib_full_off_hi_Z T9_weaklib_full_off_hi_Z = s% job% T9_weaklib_full_off_hi_Z end if - + if (abs(s% job% T9_weaklib_full_on_hi_Z - T9_weaklib_full_on_hi_Z) > 1d-6) then write(*,1) 'set T9_weaklib_full_on_hi_Z', s% job% T9_weaklib_full_on_hi_Z T9_weaklib_full_on_hi_Z = s% job% T9_weaklib_full_on_hi_Z @@ -2135,7 +2135,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) ! set up coulomb corrections for the special weak rates which_mui_coulomb = get_mui_value(s% job% ion_coulomb_corrections) which_vs_coulomb = get_vs_value(s% job% electron_coulomb_corrections) - + change_v = s% job% change_v_flag .or. & (s% job% change_initial_v_flag .and. .not. restart) change_u = s% job% change_u_flag .or. & @@ -2170,7 +2170,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) call star_set_RTI_flag(id, s% job% new_RTI_flag, ierr) if (failed('star_set_RTI_flag',ierr)) return end if - + if (s% job% change_RSP2_flag .or. & (s% job% change_initial_RSP2_flag .and. .not. restart)) then write(*,*) 'new_RSP2_flag', s% job% new_RSP2_flag @@ -2267,17 +2267,17 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) call star_set_uniform_omega(id, s% job% new_omega, ierr) if (failed('star_set_uniform_omega',ierr)) return end if - + if (s% job% set_to_xa_for_accretion .or. & (s% job% set_initial_to_xa_for_accretion .and. .not. restart)) then write(*,*) 'set_to_xa_for_accretion' call change_to_xa_for_accretion(id, s% job% set_nzlo, s% job% set_nzhi, ierr) if (failed('set_to_xa_for_accretion',ierr)) return end if - + if (s% job% first_model_for_timing > 0) & write(*,2) 'first_model_for_timing', s% job% first_model_for_timing - + if (s% job% set_uniform_initial_composition .and. .not. restart) then write(*,'(A)') write(*,1) 'set_uniform_initial_composition' @@ -2315,12 +2315,12 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) s% job% dump_missing_metals_into_heaviest, ierr) if (failed('set_uniform_initial_composition',ierr)) return end if - + if (s% job% relax_initial_composition .and. .not. restart) then call do_relax_initial_composition(ierr) if (failed('do_relax_initial_composition',ierr)) return end if - + if (s% job% relax_initial_to_xaccrete .and. .not. restart) then call star_relax_to_xaccrete(id, s% job% num_steps_to_relax_composition, ierr) if (failed('star_relax_to_xaccrete',ierr)) return @@ -2330,17 +2330,17 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) call star_uniform_xa_from_file(id, s% job% file_for_uniform_xa, ierr) if (failed('star_uniform_xa_from_file',ierr)) return end if - + if (s% job% relax_initial_angular_momentum .and. .not. restart) then call do_relax_initial_angular_momentum(ierr) if (failed('do_relax_initial_angular_momentum',ierr)) return end if - + if (s% job% relax_initial_entropy .and. .not. restart) then call do_relax_initial_entropy(ierr) if (failed('do_relax_initial_entropy',ierr)) return end if - + if (s% job% mix_section .or. & (s% job% mix_initial_section .and. .not. restart)) then write(*,*) 'mix_section' @@ -2368,7 +2368,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) call star_uniform_xa_from_file(id, s% job% file_for_uniform_xa, ierr) if (failed('star_uniform_xa_from_file',ierr)) return end if - + ! do change Z before change Y since changing Z can change Y if (s% job% change_Z) then call star_set_z(id, s% job% new_Z, ierr) @@ -2403,7 +2403,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) if (nzhi <= 0) nzhi = s% nz if (nzlo <= 0) nzlo = 1 write(*, *) 'set_abundance of ', & - trim(s% job% chem_name), s% job% new_frac, nzlo, nzhi + trim(s% job% chem_name), s% job% new_frac, nzlo, nzhi chem_id = get_nuclide_index(s% job% chem_name) if (chem_id <= 0) then write(*,*) 'failed to find ' // trim(s% job% chem_name) @@ -2412,7 +2412,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) call set_abundance_in_section(id, chem_id, s% job% new_frac, nzlo, nzhi, ierr) if (failed('set_abundance_in_section',ierr)) return end if - + if (s% job% replace_element .or. & (s% job% replace_initial_element .and. .not. restart)) then write(*, *) 'replace_element ', & @@ -2443,19 +2443,19 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) s% irradiation_flux = s% job% set_to_this_irrad_flux s% column_depth_for_irradiation = s% job% irrad_col_depth end if - + if (s% job% do_special_test) then write(*, *) 'do_special_test' call star_special_test(id, ierr) if (failed('star_special_test',ierr)) return end if - + if (s% job% set_v_center .or. & (s% job% set_initial_v_center .and. .not. restart)) then write(*, 1) 'set_v_center', s% job% new_v_center s% v_center = s% job% new_v_center end if - + if (s% job% set_L_center .or. & (s% job% set_initial_L_center .and. .not. restart)) then write(*, 1) 'set_L_center', s% job% new_L_center @@ -2463,7 +2463,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) end if ! do "set" before "relax" - + ! must do relax Z before relax Y since relax Z can change Y ! (Warrick Ball pointed out this requirement) if (s% job% relax_initial_Z .and. .not. restart) then @@ -2581,7 +2581,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) call do_remove_center(id, s, restart, ierr) if (ierr /= 0) return - + if (s% job% relax_M_center .or. & (s% job% relax_initial_M_center .and. .not. restart)) then write(*, 1) 'relax_M_center', s% job% new_mass @@ -2589,7 +2589,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) id, s% job% new_mass, s% job% dlgm_per_step, s% job% relax_M_center_dt, ierr) if (failed('star_relax_M_center',ierr)) return end if - + if (s% job% relax_R_center .or. & (s% job% relax_initial_R_center .and. .not. restart)) then write(*, 1) 'relax_R_center', s% job% new_R_center @@ -2597,7 +2597,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) id, s% job% new_R_center, s% job% dlgR_per_step, s% job% relax_R_center_dt, ierr) if (failed('star_relax_R_center',ierr)) return end if - + if (s% job% relax_v_center .or. & (s% job% relax_initial_v_center .and. .not. restart)) then write(*, 1) 'relax_v_center', s% job% new_v_center @@ -2605,7 +2605,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) id, s% job% new_v_center, s% job% dv_per_step, s% job% relax_v_center_dt, ierr) if (failed('star_relax_v_center',ierr)) return end if - + if (s% job% relax_L_center .or. & (s% job% relax_initial_L_center .and. .not. restart)) then write(*, 1) 'relax_L_center', s% job% new_L_center @@ -2613,7 +2613,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) id, s% job% new_L_center, s% job% dlgL_per_step, s% job% relax_L_center_dt, ierr) if (failed('star_relax_L_center',ierr)) return end if - + if (s% job% relax_Tsurf_factor .or. & (s% job% relax_initial_Tsurf_factor .and. .not. restart)) then write(*,1) 'relax_Tsurf_factor', s% job% relax_to_this_Tsurf_factor @@ -2621,7 +2621,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) id, s% job% relax_to_this_Tsurf_factor, s% job% dlogTsurf_factor, ierr) if (failed('star_relax_Tsurf_factor',ierr)) return end if - + if (s% job% relax_tau_factor .or. & (s% job% relax_initial_tau_factor .and. .not. restart)) then write(*,1) 'relax_tau_factor', s% job% relax_to_this_tau_factor @@ -2629,7 +2629,7 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) id, s% job% relax_to_this_tau_factor, s% job% dlogtau_factor, ierr) if (failed('star_relax_tau_factor',ierr)) return end if - + if (s% job% relax_opacity_factor .or. & (s% job% relax_initial_opacity_factor .and. .not. restart)) then write(*,1) 'relax_opacity_factor', s% job% relax_to_this_opacity_factor @@ -2666,10 +2666,10 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) s% job% relax_mass_change_max_yrs_dt, ierr) if (failed('star_relax_mass_change',ierr)) return end if - + call do_remove_initial_surface(id, s, restart, ierr) if (ierr /= 0) return - + call do_remove_surface(id, s, ierr) if (ierr /= 0) return @@ -2751,56 +2751,56 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) log10(s% max_timestep/secyer) end if end if - + ! print out info about selected non-standard parameter settings - + write(*,*) 'net name ' // trim(s% net_name) if (s% do_element_diffusion) & write(*,*) 'do_element_diffusion', s% do_element_diffusion - + if (s% RSP_flag) & write(*,*) 'RSP_flag', s% RSP_flag - + if (s% v_flag) & write(*,*) 'v_flag', s% v_flag - + if (s% u_flag) & write(*,*) 'u_flag', s% u_flag - + if (s% rotation_flag) & write(*,*) 'rotation_flag', s% rotation_flag - + if (s% w_div_wc_flag) & write(*,*) 'w_div_wc_flag', s% w_div_wc_flag - + if (s% j_rot_flag) & write(*,*) 'j_rot_flag', s% j_rot_flag - + if (s% mix_factor /= 1d0) & write(*,1) 'mix_factor', s% mix_factor - + if (abs(s% tau_base - 2d0/3d0) > 1d-4) & write(*,1) 'tau_base', s% tau_base - + if (abs(s% tau_factor - 1) > 1d-4) & write(*,1) 'tau_factor', s% tau_factor - + if (s% eps_grav_factor /= 1) & write(*,1) 'eps_grav_factor', s% eps_grav_factor - + if (s% eps_mdot_factor /= 1) & write(*,1) 'eps_mdot_factor', s% eps_mdot_factor if (s% dxdt_nuc_factor /= 1) & write(*,1) 'dxdt_nuc_factor', s% dxdt_nuc_factor - + if (.NOT. ( & s% atm_option == 'T_tau' .AND. & s% atm_T_tau_relation == 'Eddington' .AND. & s% atm_T_tau_opacity == 'fixed')) & write(*,1) 'atm_option: ' // trim(s% atm_option) - + if (s% M_center /= 0) then write(*,1) 'xmstar/mstar', s% xmstar/s% mstar write(*,1) 'xmstar (g)', s% xmstar @@ -2808,44 +2808,44 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) write(*,1) 'xmstar/Msun', s% xmstar/Msun write(*,1) 'M_center/Msun', s% M_center/Msun end if - + if (s% v_flag .or. s% u_flag) then if (s% v_center /= 0) & write(*,1) 'v_center (cm/s)', s% v_center end if - + if (s% R_center /= 0) then write(*,1) 'R_center (cm)', s% R_center write(*,1) 'R_center/Rsun', s% R_center/Rsun write(*,1) 'core density', & s% M_center/(4*pi/3*s% R_center*s% R_center*s% R_center) end if - + if (s% L_center /= 0) & write(*,1) 'L_center/Lsun', s% L_center/Lsun - + if (s% opacity_max > 0) & write(*,1) 'opacity_max', s% opacity_max - + if (s% job% show_net_reactions_info) then write(*,'(a)') ' net reactions ' call show_net_reactions_and_info(s% net_handle, 6, ierr) if (failed('show_net_reactions_and_info',ierr)) return end if - + if (s% job% list_net_reactions) then write(*,'(a)') ' net reactions ' call show_net_reactions(s% net_handle, 6, ierr) if (failed('show_net_reactions',ierr)) return end if - + if (s% job% set_cumulative_energy_error .or. & (s% job% set_initial_cumulative_energy_error .and. .not. restart) .or. & (s% model_number == s% job% set_cumulative_energy_error_at_step)) then write(*,1) 'set_cumulative_energy_error', s% job% new_cumulative_energy_error s% cumulative_energy_error = s% job% new_cumulative_energy_error end if - + if (s% job% show_net_species_info) then write(*,'(a)') ' species' do j=1,s% species @@ -2853,21 +2853,21 @@ subroutine do_star_job_controls_after(id, s, restart, pgstar_ok, ierr) end do write(*,'(A)') end if - + if (s% job% show_eqns_and_vars_names) then do i=1,s% nvar_total write(*,*) i, s% nameofvar(i), s% nameofequ(i) end do write(*,'(A)') - end if - + end if + write(*,*) 'kap_option ' // trim(kap_option_str(s% kap_rq% kap_option)) write(*,*) 'kap_CO_option ' // trim(kap_CO_option_str(s% kap_rq% kap_CO_option)) write(*,*) 'kap_lowT_option ' // trim(kap_lowT_option_str(s% kap_rq% kap_lowT_option)) write(*,2) 'OMP_NUM_THREADS', utils_omp_get_max_threads() - + call check_if_want_to_stop_warnings(s) - + contains subroutine do_relax_initial_composition(ierr) @@ -2876,7 +2876,7 @@ subroutine do_relax_initial_composition(ierr) real(dp), pointer :: xq(:), xa(:,:) integer :: num_pts, num_species, i, iounit include 'formats' - + write(*,'(A)') write(*,1) 'relax_initial_composition' @@ -2917,20 +2917,20 @@ subroutine do_relax_initial_composition(ierr) end if end do close(iounit) - + call star_relax_composition( & id, s% job% num_steps_to_relax_composition, num_pts, num_species, xa, xq, ierr) deallocate(xq,xa) - + end subroutine do_relax_initial_composition - + subroutine do_relax_initial_angular_momentum(ierr) use utils_lib integer, intent(out) :: ierr real(dp), pointer :: xq(:), angular_momentum(:) integer :: num_pts, i, iounit include 'formats' - + write(*,'(A)') write(*,1) 'relax_initial_angular_momentum' @@ -2967,7 +2967,7 @@ subroutine do_relax_initial_angular_momentum(ierr) num_pts, angular_momentum, xq, ierr) deallocate(xq,angular_momentum) end subroutine do_relax_initial_angular_momentum - + subroutine do_relax_initial_entropy(ierr) use utils_lib use eos_def @@ -2991,7 +2991,7 @@ subroutine do_relax_initial_entropy(ierr) real(dp), parameter :: logT_tol = 1d-8, logE_tol = 1d-8 integer, parameter :: MAX_ITERS = 20 include 'formats' - + write(*,'(A)') write(*,1) 'relax_initial_entropy' @@ -3089,7 +3089,7 @@ subroutine do_relax_initial_entropy(ierr) end subroutine do_relax_initial_entropy end subroutine do_star_job_controls_after - + subroutine do_remove_center(id, s, restart, ierr) integer, intent(in) :: id @@ -3097,14 +3097,14 @@ subroutine do_remove_center(id, s, restart, ierr) logical, intent(in) :: restart integer, intent(out) :: ierr include 'formats' - + if (s% job% remove_center_by_temperature > 0) then write(*, 1) 'remove_center_by_temperature', s% job% remove_center_by_temperature call star_remove_center_by_temperature( & id, s% job% remove_center_by_temperature, ierr) if (failed('star_remove_center_by_temperature',ierr)) return end if - + if (s% job% remove_initial_center_by_temperature > 0 .and. .not. restart) then write(*, 1) 'remove_initial_center_by_temperature', & s% job% remove_initial_center_by_temperature @@ -3112,7 +3112,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_initial_center_by_temperature, ierr) if (failed('star_remove_center_by_temperature',ierr)) return end if - + if (s% job% remove_center_by_radius_cm > s% R_center .and. & s% job% remove_center_by_radius_cm < s% r(1)) then write(*, 1) 'remove_center_by_radius_cm', & @@ -3121,7 +3121,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_center_by_radius_cm, ierr) if (failed('star_remove_center_by_radius_cm',ierr)) return end if - + if (s% job% remove_initial_center_by_radius_cm > s% R_center .and. & s% job% remove_initial_center_by_radius_cm < s% r(1) .and. .not. restart) then write(*, 1) 'remove_initial_center_by_radius_cm', & @@ -3130,7 +3130,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_initial_center_by_radius_cm, ierr) if (failed('star_remove_center_by_radius_cm',ierr)) return end if - + if (s% job% remove_initial_center_by_he4 > 0d0 .and. & s% job% remove_initial_center_by_he4 < 1d0 & .and. .not. restart) then @@ -3140,7 +3140,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_initial_center_by_he4, ierr) if (failed('star_remove_initial_center_by_he4',ierr)) return end if - + if (s% job% remove_center_by_he4 > 0d0 .and. & s% job% remove_center_by_he4 < 1d0) then write(*, 1) 'remove_center_by_he4', & @@ -3149,7 +3149,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_center_by_he4, ierr) if (failed('star_remove_center_by_he4',ierr)) return end if - + if (s% job% remove_initial_center_by_c12_o16 > 0d0 .and. & s% job% remove_initial_center_by_c12_o16 < 1d0 & .and. .not. restart) then @@ -3159,7 +3159,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_initial_center_by_c12_o16, ierr) if (failed('star_remove_initial_center_by_c12_o16',ierr)) return end if - + if (s% job% remove_center_by_c12_o16 > 0d0 .and. & s% job% remove_center_by_c12_o16 < 1d0) then write(*, 1) 'remove_center_by_c12_o16', & @@ -3168,7 +3168,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_center_by_c12_o16, ierr) if (failed('star_remove_center_by_c12_o16',ierr)) return end if - + if (s% job% remove_initial_center_by_si28 > 0d0 .and. & s% job% remove_initial_center_by_si28 < 1d0 & .and. .not. restart) then @@ -3178,7 +3178,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_initial_center_by_si28, ierr) if (failed('star_remove_initial_center_by_si28',ierr)) return end if - + if (s% job% remove_center_by_si28 > 0d0 .and. & s% job% remove_center_by_si28 < 1d0) then write(*, 1) 'remove_center_by_si28', & @@ -3187,7 +3187,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_center_by_si28, ierr) if (failed('star_remove_center_by_si28',ierr)) return end if - + if (s% job% remove_initial_center_to_reduce_co56_ni56 > 0d0 & .and. .not. restart) then write(*, 1) 'remove_initial_center_to_reduce_co56_ni56', & @@ -3196,7 +3196,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_initial_center_to_reduce_co56_ni56, ierr) if (failed('star_remove_initial_center_to_reduce_co56_ni56',ierr)) return end if - + if (s% job% remove_center_to_reduce_co56_ni56 > 0d0) then write(*, 1) 'remove_center_to_reduce_co56_ni56', & s% job% remove_center_to_reduce_co56_ni56 @@ -3204,7 +3204,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_center_to_reduce_co56_ni56, ierr) if (failed('star_remove_center_to_reduce_co56_ni56',ierr)) return end if - + if (s% job% remove_initial_center_by_ye > 0d0 .and. & s% job% remove_initial_center_by_ye < 1d0 & .and. .not. restart) then @@ -3214,7 +3214,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_initial_center_by_ye, ierr) if (failed('star_remove_initial_center_by_ye',ierr)) return end if - + if (s% job% remove_center_by_ye > 0d0 .and. & s% job% remove_center_by_ye < 1d0) then write(*, 1) 'remove_center_by_ye', & @@ -3223,7 +3223,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_center_by_ye, ierr) if (failed('star_remove_center_by_ye',ierr)) return end if - + if (s% job% remove_initial_center_by_entropy > 0d0 & .and. .not. restart) then write(*, 1) 'remove_initial_center_by_entropy', & @@ -3232,7 +3232,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_initial_center_by_entropy, ierr) if (failed('star_remove_initial_center_by_entropy',ierr)) return end if - + if (s% job% remove_center_by_entropy > 0d0) then write(*, 1) 'remove_center_by_entropy', & s% job% remove_center_by_entropy @@ -3240,7 +3240,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_center_by_entropy, ierr) if (failed('star_remove_center_by_entropy',ierr)) return end if - + if (s% job% remove_initial_center_by_infall_kms /= 0d0 & .and. .not. restart) then write(*, 1) 'remove_initial_center_by_infall_kms', & @@ -3249,7 +3249,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_initial_center_by_infall_kms, ierr) if (failed('star_remove_initial_center_by_infall_kms',ierr)) return end if - + if (s% job% remove_center_by_infall_kms /= 0d0) then write(*, 1) 'remove_center_by_infall_kms', & s% job% remove_center_by_infall_kms @@ -3257,32 +3257,32 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_center_by_infall_kms, ierr) if (failed('star_remove_center_by_infall_kms',ierr)) return end if - + if (s% job% remove_initial_center_at_inner_max_abs_v & .and. .not. restart) then write(*, 1) 'remove_initial_center_at_inner_max_abs_v' call star_remove_center_at_inner_max_abs_v(id, ierr) if (failed('remove_center_at_inner_max_abs_v',ierr)) return end if - + if (s% job% remove_center_at_inner_max_abs_v) then write(*, 1) 'remove_initial_center_at_inner_max_abs_v' call star_remove_center_at_inner_max_abs_v(id, ierr) if (failed('remove_center_at_inner_max_abs_v',ierr)) return end if - + if (s% job% remove_initial_fe_core .and. .not. restart) then write(*, 1) 'remove_initial_fe_core' call star_remove_fe_core(id, ierr) if (failed('remove_fe_core',ierr)) return end if - + if (s% job% remove_fe_core) then write(*, 1) 'remove_initial_fe_core' call star_remove_fe_core(id, ierr) if (failed('remove_fe_core',ierr)) return end if - + if (s% job% remove_initial_center_by_mass_fraction_q > 0d0 .and. & s% job% remove_initial_center_by_mass_fraction_q < 1d0 & .and. .not. restart) then @@ -3292,7 +3292,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_initial_center_by_mass_fraction_q, ierr) if (failed('star_remove_initial_center_by_mass_fraction_q',ierr)) return end if - + if (s% job% remove_center_by_mass_fraction_q > 0d0 .and. & s% job% remove_center_by_mass_fraction_q < 1d0) then write(*, 1) 'remove_center_by_mass_fraction_q', & @@ -3301,7 +3301,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_center_by_mass_fraction_q, ierr) if (failed('star_remove_center_by_mass_fraction_q',ierr)) return end if - + if (s% job% remove_center_by_delta_mass_gm > 0) then write(*, 1) 'remove_center_by_delta_mass_gm', & s% job% remove_center_by_delta_mass_gm @@ -3309,7 +3309,7 @@ subroutine do_remove_center(id, s, restart, ierr) s% M_center + s% job% remove_center_by_delta_mass_gm, ierr) if (failed('star_remove_center_by_mass',ierr)) return end if - + if (s% job% remove_initial_center_by_delta_mass_gm > 0 .and. & .not. restart) then write(*, 1) 'remove_initial_center_by_delta_mass_gm', & @@ -3318,7 +3318,7 @@ subroutine do_remove_center(id, s, restart, ierr) s% M_center + s% job% remove_initial_center_by_delta_mass_gm, ierr) if (failed('star_remove_center_by_mass',ierr)) return end if - + if (s% job% remove_center_by_delta_mass_Msun > 0) then write(*, 1) 'remove_center_by_delta_mass_Msun', & s% job% remove_center_by_delta_mass_Msun @@ -3326,7 +3326,7 @@ subroutine do_remove_center(id, s, restart, ierr) s% M_center + s% job% remove_center_by_delta_mass_Msun*Msun, ierr) if (failed('star_remove_center_by_mass',ierr)) return end if - + if (s% job% remove_initial_center_by_delta_mass_Msun > 0 .and. & .not. restart) then write(*, 1) 'remove_initial_center_by_delta_mass_Msun', & @@ -3335,7 +3335,7 @@ subroutine do_remove_center(id, s, restart, ierr) s% M_center + s% job% remove_initial_center_by_delta_mass_Msun*Msun, ierr) if (failed('star_remove_center_by_mass',ierr)) return end if - + if (s% job% remove_center_by_mass_gm > s% M_center .and. & s% job% remove_center_by_mass_gm < s% m(1)) then write(*, 1) 'remove_center_by_mass_gm', & @@ -3344,7 +3344,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_center_by_mass_gm, ierr) if (failed('star_remove_center_by_mass_gm',ierr)) return end if - + if (s% job% remove_initial_center_by_mass_gm > s% M_center .and. & s% job% remove_initial_center_by_mass_gm < s% m(1) .and. .not. restart) then write(*, 1) 'remove_initial_center_by_mass_gm', & @@ -3353,7 +3353,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_initial_center_by_mass_gm, ierr) if (failed('star_remove_center_by_mass_gm',ierr)) return end if - + if (s% job% remove_center_by_mass_Msun > s% M_center/Msun .and. & s% job% remove_center_by_mass_Msun < s% m(1)/Msun) then write(*, 1) 'remove_center_by_mass_Msun', & @@ -3362,7 +3362,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_center_by_mass_Msun*Msun, ierr) if (failed('star_remove_center_by_mass_Msun',ierr)) return end if - + if (s% job% remove_initial_center_by_mass_Msun > s% M_center/Msun .and. & s% job% remove_initial_center_by_mass_Msun < s% m(1)/Msun .and. & .not. restart) then @@ -3372,7 +3372,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_initial_center_by_mass_Msun*Msun, ierr) if (failed('star_remove_center_by_mass_Msun',ierr)) return end if - + if (s% job% remove_center_by_radius_Rsun > s% R_center/Rsun .and. & s% job% remove_center_by_radius_Rsun < s% r(1)/Rsun) then write(*, 1) 'remove_center_by_radius_Rsun', & @@ -3381,7 +3381,7 @@ subroutine do_remove_center(id, s, restart, ierr) id, s% job% remove_center_by_radius_Rsun*Rsun, ierr) if (failed('star_remove_center_by_radius_Rsun',ierr)) return end if - + if (s% job% remove_initial_center_by_radius_Rsun > s% R_center/Rsun .and. & s% job% remove_initial_center_by_radius_Rsun < s% r(1)/Rsun .and. & .not. restart) then @@ -3406,9 +3406,9 @@ subroutine do_remove_center(id, s, restart, ierr) call star_remove_center_at_cell_k(id, s% job% remove_center_at_cell_k, ierr) if (failed('star_remove_center_at_cell_k',ierr)) return end if - + end subroutine do_remove_center - + subroutine do_remove_initial_surface(id,s,restart,ierr) integer, intent(in) :: id @@ -3417,7 +3417,7 @@ subroutine do_remove_initial_surface(id,s,restart,ierr) integer, intent(out) :: ierr include 'formats' - + ierr = 0 if (s% job% remove_initial_surface_at_he_core_boundary > 0 .and. .not. restart) then @@ -3435,7 +3435,7 @@ subroutine do_remove_initial_surface(id,s,restart,ierr) id, s% job% remove_initial_surface_by_optical_depth, ierr) if (failed('star_remove_surface_by_optical_depth',ierr)) return end if - + if (s% job% remove_initial_surface_by_density > 0 .and. .not. restart) then write(*, 1) 'remove_initial_surface_by_density', & s% job% remove_initial_surface_by_density @@ -3443,7 +3443,7 @@ subroutine do_remove_initial_surface(id,s,restart,ierr) id, s% job% remove_initial_surface_by_density, ierr) if (failed('star_remove_surface_by_density',ierr)) return end if - + if (s% job% remove_initial_surface_by_pressure > 0 .and. .not. restart) then write(*, 1) 'remove_initial_surface_by_pressure', & s% job% remove_initial_surface_by_pressure @@ -3451,7 +3451,7 @@ subroutine do_remove_initial_surface(id,s,restart,ierr) id, s% job% remove_initial_surface_by_pressure, ierr) if (failed('star_remove_surface_by_pressure',ierr)) return end if - + if (s% job% remove_initial_surface_by_radius_cm > s% R_center .and. & s% job% remove_initial_surface_by_radius_cm < s% r(1) .and. .not. restart) then write(*, 1) 'remove_initial_surface_by_radius_cm', & @@ -3460,7 +3460,7 @@ subroutine do_remove_initial_surface(id,s,restart,ierr) id, s% job% remove_initial_surface_by_radius_cm, ierr) if (failed('star_remove_surface_by_radius_cm',ierr)) return end if - + if (s% job% remove_initial_surface_by_mass_fraction_q > 0d0 .and. & s% job% remove_initial_surface_by_mass_fraction_q < 1d0 & .and. .not. restart) then @@ -3470,7 +3470,7 @@ subroutine do_remove_initial_surface(id,s,restart,ierr) id, s% job% remove_initial_surface_by_mass_fraction_q, ierr) if (failed('star_remove_initial_surface_by_mass_fraction_q',ierr)) return end if - + if (s% job% remove_initial_surface_by_mass_gm > s% M_center .and. & s% job% remove_initial_surface_by_mass_gm < s% m(1) .and. .not. restart) then write(*, 1) 'remove_initial_surface_by_mass_gm', & @@ -3479,7 +3479,7 @@ subroutine do_remove_initial_surface(id,s,restart,ierr) id, s% job% remove_initial_surface_by_mass_gm, ierr) if (failed('star_remove_surface_by_mass_gm',ierr)) return end if - + if (s% job% remove_initial_surface_by_radius_Rsun > s% R_center/Rsun .and. & s% job% remove_initial_surface_by_radius_Rsun < s% r(1)/Rsun .and. & .not. restart) then @@ -3489,7 +3489,7 @@ subroutine do_remove_initial_surface(id,s,restart,ierr) id, s% job% remove_initial_surface_by_radius_Rsun*Rsun, ierr) if (failed('star_remove_surface_by_radius_Rsun',ierr)) return end if - + if (s% job% remove_initial_surface_by_mass_Msun > s% M_center/Msun .and. & s% job% remove_initial_surface_by_mass_Msun < s% m(1)/Msun .and. & .not. restart) then @@ -3533,7 +3533,7 @@ subroutine do_remove_initial_surface(id,s,restart,ierr) end if end subroutine do_remove_initial_surface - + subroutine do_remove_surface(id,s,ierr) integer, intent(in) :: id @@ -3541,7 +3541,7 @@ subroutine do_remove_surface(id,s,ierr) integer, intent(out) :: ierr include 'formats' - + ierr = 0 if (s% job% remove_surface_at_he_core_boundary > 0) then @@ -3557,21 +3557,21 @@ subroutine do_remove_surface(id,s,ierr) id, s% job% remove_surface_by_optical_depth, ierr) if (failed('star_remove_surface_by_optical_depth',ierr)) return end if - + if (s% job% remove_surface_by_density > 0) then !write(*, 1) 'remove_surface_by_density', s% job% remove_surface_by_density call star_remove_surface_by_density( & id, s% job% remove_surface_by_density, ierr) if (failed('star_remove_surface_by_density',ierr)) return end if - + if (s% job% remove_surface_by_pressure > 0) then !write(*, 1) 'remove_surface_by_pressure', s% job% remove_surface_by_pressure call star_remove_surface_by_pressure( & id, s% job% remove_surface_by_pressure, ierr) if (failed('star_remove_surface_by_pressure',ierr)) return end if - + if (s% job% remove_surface_by_radius_cm > s% R_center .and. & s% job% remove_surface_by_radius_cm < s% r(1)) then !write(*, 1) 'remove_surface_by_radius_cm', s% job% remove_surface_by_radius_cm @@ -3579,7 +3579,7 @@ subroutine do_remove_surface(id,s,ierr) id, s% job% remove_surface_by_radius_cm, ierr) if (failed('star_remove_surface_by_radius_cm',ierr)) return end if - + if (s% job% remove_surface_by_mass_fraction_q > 0d0 .and. & s% job% remove_surface_by_mass_fraction_q < 1d0) then !write(*, 1) 'remove_surface_by_mass_fraction_q', & @@ -3588,7 +3588,7 @@ subroutine do_remove_surface(id,s,ierr) id, s% job% remove_surface_by_mass_fraction_q, ierr) if (failed('star_remove_surface_by_mass_fraction_q',ierr)) return end if - + if (s% job% remove_surface_by_mass_gm > s% M_center .and. & s% job% remove_surface_by_mass_gm < s% m(1)) then !write(*, 1) 'remove_surface_by_mass_gm', & @@ -3597,7 +3597,7 @@ subroutine do_remove_surface(id,s,ierr) id, s% job% remove_surface_by_mass_gm, ierr) if (failed('star_remove_surface_by_mass_gm',ierr)) return end if - + if (s% job% remove_surface_by_radius_Rsun > s% R_center/Rsun .and. & s% job% remove_surface_by_radius_Rsun < s% r(1)/Rsun) then !write(*, 1) 'remove_surface_by_radius_Rsun', & @@ -3606,7 +3606,7 @@ subroutine do_remove_surface(id,s,ierr) id, s% job% remove_surface_by_radius_Rsun*Rsun, ierr) if (failed('star_remove_surface_by_radius_Rsun',ierr)) return end if - + if (s% job% remove_surface_by_mass_Msun > s% M_center/Msun .and. & s% job% remove_surface_by_mass_Msun < s% m(1)/Msun) then !write(*, 1) 'remove_surface_by_mass_Msun', & @@ -3689,8 +3689,8 @@ subroutine resolve_inlist_fname(inlist_out,inlist_opt) return end subroutine resolve_inlist_fname - - + + subroutine add_fpe_checks(id, s, ierr) integer, intent(in) :: id type (star_info), pointer :: s @@ -3712,26 +3712,26 @@ subroutine add_fpe_checks(id, s, ierr) end if end subroutine add_fpe_checks - - - + + + subroutine multiply_tolerances(id, s, ierr) integer, intent(in) :: id type (star_info), pointer :: s integer, intent(out) :: ierr integer :: status - + real(dp) :: test_suite_res_factor = 1 character(len=20) :: test_suite_resolution_factor_str - + include 'formats' - + ierr = 0 call GET_ENVIRONMENT_VARIABLE('MESA_TEST_SUITE_RESOLUTION_FACTOR', & test_suite_resolution_factor_str, STATUS=status) if (status /= 0) return - - if (test_suite_resolution_factor_str .ne. "") then + + if (test_suite_resolution_factor_str .ne. "") then read(test_suite_resolution_factor_str, *) test_suite_res_factor write(*,*) "" write(*,*) "***" @@ -3756,10 +3756,10 @@ subroutine multiply_tolerances(id, s, ierr) write(*,*) " new max_model_number = ", s% max_model_number write(*,*) "" end if - + end subroutine multiply_tolerances - - + + subroutine pgstar_env_check(id, s, ierr) integer, intent(in) :: id type (star_info), pointer :: s @@ -3780,13 +3780,13 @@ subroutine pgstar_env_check(id, s, ierr) s% job% pgstar_flag = .true. case ("FALSE", "false") write(*,*) "PGSTAR forced off" - s% job% pgstar_flag = .false. + s% job% pgstar_flag = .false. end select end subroutine pgstar_env_check end module run_star_support - - - - + + + + diff --git a/star/private/adjust_mass.f90 b/star/private/adjust_mass.f90 index 42365ac4b..8ea94e7da 100644 --- a/star/private/adjust_mass.f90 +++ b/star/private/adjust_mass.f90 @@ -62,17 +62,17 @@ real(dp) function compute_delta_m(s) result(delta_m) end if delta_m = s% dt*s% mstar_dot - + if (is_bad(s% dt)) then write(*,1) 's% dt', s% dt call mesa_error(__FILE__,__LINE__,'compute_delta_m') end if - + if (is_bad(s% mstar_dot)) then write(*,1) 's% mstar_dot', s% mstar_dot call mesa_error(__FILE__,__LINE__,'compute_delta_m') end if - + if (is_bad(delta_m)) then write(*,1) 'delta_m', delta_m call mesa_error(__FILE__,__LINE__,'compute_delta_m') @@ -85,7 +85,7 @@ subroutine save_for_eps_mdot(s) type (star_info), pointer :: s integer :: j - + call eval_deltaM_total_energy_integrals( & s, 1, s% nz, s% mstar, .true., & s% total_energy_profile_before_adjust_mass, & @@ -169,7 +169,7 @@ subroutine update_radius(s) call store_r_in_xh(s, j, r_new) call get_r_and_lnR_from_xh(s, j, s% r(j), s% lnR(j)) s% xh_start(s% i_lnR,j) = s% xh(s% i_lnR,j) - + end do end subroutine update_radius @@ -215,7 +215,7 @@ subroutine do_adjust_mass(s, species, ierr) nz = s% nz dt = s% dt - + s% k_const_mass = 1 @@ -232,7 +232,7 @@ subroutine do_adjust_mass(s, species, ierr) end if delta_m = compute_delta_m(s) - + if (delta_m == 0) then return end if @@ -246,7 +246,7 @@ subroutine do_adjust_mass(s, species, ierr) new_mstar = old_mstar + delta_m new_xmstar = old_xmstar + delta_m - + if (is_bad(new_xmstar)) then write(*,1) 'new_xmstar', new_xmstar call mesa_error(__FILE__,__LINE__,'do_adjust_mass') @@ -374,7 +374,7 @@ subroutine do_adjust_mass(s, species, ierr) end if end do end if - + k_below_just_added = s% k_below_just_added k_newval = 1 @@ -517,12 +517,12 @@ subroutine do_adjust_mass(s, species, ierr) end do end if - + call update_radius(s) - + call dealloc - + if (s% doing_timing) call update_time(s, time0, total, s% time_adjust_mass) @@ -583,7 +583,7 @@ real(dp) function eval_total_angular_momentum(s,cell_mass,nz_last) result(J) J = J + dm*s% j_rot(k) end do end function eval_total_angular_momentum - + subroutine do_alloc(ierr) integer, intent(out) :: ierr allocate(rxm_old(nz), rxm_new(nz), old_cell_mass(nz), new_cell_mass(nz), & @@ -636,7 +636,7 @@ subroutine revise_q_and_dq( & ierr = 0 dbg = .false. flag = .false. - + if (is_bad(old_xmstar)) then write(*,1) 'old_xmstar', old_xmstar call mesa_error(__FILE__,__LINE__,'revise_q_and_dq') @@ -653,13 +653,13 @@ subroutine revise_q_and_dq( & end if - + okay_to_move_kB_inward = .false. lnTlim_A = ln10*s% max_logT_for_k_below_const_q lnTlim_B = ln10*s% max_logT_for_k_const_mass - + q1 = old_xmstar q2 = new_xmstar mold_o_mnew_qp = q1/q2 @@ -690,11 +690,11 @@ subroutine revise_q_and_dq( & do k = 2, nz xq(k) = xq(k-1) + s% dq(k-1) end do - + k = maxloc(s% xh(s% i_lnT,1:nz),dim=1) lnTmax = get_lnT_from_xh(s, k) lnT_A = min(lnTmax, lnTlim_A) - + if (is_bad(s% max_q_for_k_below_const_q)) then write(*,*) 's% max_q_for_k_below_const_q', s% max_q_for_k_below_const_q call mesa_error(__FILE__,__LINE__,'revise_q_and_dq') @@ -703,7 +703,7 @@ subroutine revise_q_and_dq( & write(*,*) 's% min_q_for_k_below_const_q', s% min_q_for_k_below_const_q call mesa_error(__FILE__,__LINE__,'revise_q_and_dq') end if - + kA = min_kA do k = min_kA, nz-1 kA = k @@ -714,7 +714,7 @@ subroutine revise_q_and_dq( & xqA = xq(kA) lnT_B = min(lnTmax, lnTlim_B) - + if (is_bad(s% max_q_for_k_const_mass)) then write(*,*) 's% max_q_for_k_const_mass', s% max_q_for_k_const_mass call mesa_error(__FILE__,__LINE__,'revise_q_and_dq') @@ -780,7 +780,7 @@ subroutine revise_q_and_dq( & call mesa_error(__FILE__,__LINE__,'revise_q_and_dq') end if s% dq(kB:nz) = s% dq(kB:nz)*frac - + adjust_mass_outer_frac = 1d0 adjust_mass_mid_frac = qfrac_qp adjust_mass_inner_frac = frac_qp @@ -814,7 +814,7 @@ subroutine revise_q_and_dq( & do k = 1, nz s% dq(k) = s% dq(k) * frac end do - + s% adjust_mass_outer_frac_sub1 = frac_qp*adjust_mass_outer_frac*new_xmstar / old_xmstar - 1.0_qp s% adjust_mass_mid_frac_sub1 = frac_qp*adjust_mass_mid_frac*new_xmstar / old_xmstar - 1.0_qp s% adjust_mass_inner_frac_sub1 = frac_qp*adjust_mass_inner_frac*new_xmstar / old_xmstar - 1.0_qp @@ -1614,7 +1614,7 @@ subroutine set_D_omega( & newloc(k) = rxm_new(k) oldval(k) = D_omega(k) end do - + call interpolate_vector( & n, oldloc, n, newloc, oldval, newval, interp_pm, nwork, work, & 'adjust_mass set_D_omega', ierr) diff --git a/star/private/adjust_mesh.f90 b/star/private/adjust_mesh.f90 index b143cfb4d..2a95f1348 100644 --- a/star/private/adjust_mesh.f90 +++ b/star/private/adjust_mesh.f90 @@ -411,7 +411,7 @@ integer function remesh(s) call set_dm_bar(s, s% nz, s% dm, s% dm_bar) if (dbg_remesh) write(*,*) 'call do_mesh_adjust' - + call do_mesh_adjust( & s, nz, nz_old, prv% xh, prv% xa, & prv% energy, prv% eta, prv% lnd, prv% lnPgas, & @@ -611,8 +611,8 @@ subroutine do_dealloc1 call return_integer_work_array(s, which_gval) call do_work_arrays1(.false., ierr) end subroutine do_dealloc1 - - + + subroutine do_work_arrays1(alloc_flag, ierr) logical, intent(in) :: alloc_flag integer, intent(out) :: ierr @@ -653,8 +653,8 @@ subroutine do_dealloc2 if (ierr /= 0) return call return_logical_work_array(s, do_not_split) end subroutine do_dealloc2 - - + + subroutine do_work_arrays2(alloc_flag, ierr) logical, intent(in) :: alloc_flag integer, intent(out) :: ierr diff --git a/star/private/adjust_mesh_split_merge.f90 b/star/private/adjust_mesh_split_merge.f90 index 9b97c0e3d..c22c7eaa6 100644 --- a/star/private/adjust_mesh_split_merge.f90 +++ b/star/private/adjust_mesh_split_merge.f90 @@ -47,7 +47,7 @@ integer function remesh_split_merge(s) integer :: ierr include 'formats' - + if (s% RSP2_flag) then call mesa_error(__FILE__,__LINE__,'need to add mlt_vc and Hp_face to remesh_split_merge') end if @@ -179,9 +179,9 @@ subroutine amr(s,ierr) end do end if if (s% model_number == -6918) call mesa_error(__FILE__,__LINE__,'amr') - + contains - + subroutine split1 ! ratio of desired/actual is too large include 'formats' if (s% trace_split_merge_amr) then @@ -198,7 +198,7 @@ subroutine split1 ! ratio of desired/actual is too large !write(*,*) end if end subroutine split1 - + subroutine merge1 ! ratio of actual/desired is too large include 'formats' if (s% trace_split_merge_amr) then @@ -214,7 +214,7 @@ subroutine merge1 ! ratio of actual/desired is too large !write(*,*) end if end subroutine merge1 - + end subroutine amr @@ -263,7 +263,7 @@ subroutine biggest_smallest( & real(dp), pointer :: v(:), r_for_v(:) include 'formats' - + nz = s% nz hydrid_zoning = s% split_merge_amr_hybrid_zoning flipped_hydrid_zoning = s% split_merge_amr_flipped_hybrid_zoning @@ -295,7 +295,7 @@ subroutine biggest_smallest( & else nullify(v,r_for_v) end if - + if (hydrid_zoning) then target_dr_core = (r_core_cm - s% R_center)/nz_r_core target_dlnR_envelope = & @@ -308,7 +308,7 @@ subroutine biggest_smallest( & xmin = log(tau_center) xmax = log(s% tau(1)) inner_dx_baseline = (xmin - xmax)/nz_baseline ! keep it > 0 - outer_dx_baseline = inner_dx_baseline + outer_dx_baseline = inner_dx_baseline else if (log_zoning) then xmin = log(max(1d0,s% R_center)) xmax = s% lnR(1) @@ -321,14 +321,14 @@ subroutine biggest_smallest( & outer_dx_baseline = inner_dx_baseline end if dx_baseline = outer_dx_baseline - + TooBig = 0d0 TooSmall = 0d0 iTooBig = -1 iTooSmall = -1 xR = xmin ! start at center do k = nz, 1, -1 - + xL = xR dx_baseline = inner_dx_baseline if (hydrid_zoning) then @@ -374,13 +374,13 @@ subroutine biggest_smallest( & else xR = s% r(k) end if - + if (s% split_merge_amr_avoid_repeated_remesh .and. & (s% split_merge_amr_avoid_repeated_remesh .and. & s% amr_split_merge_has_undergone_remesh(k))) cycle dx_actual = xR - xL if (logtau_zoning) dx_actual = -dx_actual ! make dx_actual > 0 - + ! first check for cells that are too big and need to be split oversize_ratio = dx_actual/dx_baseline if (TooBig < oversize_ratio .and. s% dq(k) > 5d0*dq_min) then @@ -390,7 +390,7 @@ subroutine biggest_smallest( & end if end if end if - + ! next check for cells that are too small and need to be merged if (s% merge_amr_ignore_surface_cells .and. & @@ -401,18 +401,18 @@ subroutine biggest_smallest( & else undersize_ratio = dq_min/s% dq(k) end if - + if (s% merge_amr_max_abs_du_div_cs >= 0d0) then call check_merge_limits else if (TooSmall < undersize_ratio .and. s% dq(k) < dq_max/5d0) then TooSmall = undersize_ratio; iTooSmall = k end if - + end do - - + + contains - + subroutine check_merge_limits ! Pablo's additions to modify when merge ! merge_amr_max_abs_du_div_cs @@ -437,7 +437,7 @@ subroutine check_merge_limits end if if (du_div_cs_limit_flag .and. associated(v)) then - if (k == 1) then + if (k == 1) then abs_du_div_cs = abs(v(k) - v(k+1))/s% csound(k) else if (k == nz) then abs_du_div_cs = abs(v(nz-1) - v(nz))/s% csound(nz) @@ -448,9 +448,9 @@ subroutine check_merge_limits else abs_du_div_cs = 0d0 end if - + if (du_div_cs_limit_flag) then - if (s% merge_amr_inhibit_at_jumps) then + if (s% merge_amr_inhibit_at_jumps) then ! reduce undersize_ratio for large jumps ! i.e. large jumps inhibit merges but don't prohibit completely if (abs_du_div_cs > s% merge_amr_max_abs_du_div_cs) & @@ -470,8 +470,8 @@ subroutine check_merge_limits end if end if end subroutine check_merge_limits - - + + end subroutine biggest_smallest @@ -529,7 +529,7 @@ subroutine do_merge(s, i_merge, species, new_xa, ierr) s% amr_split_merge_has_undergone_remesh(ip))) then s% amr_split_merge_has_undergone_remesh(i) = .true. s% amr_split_merge_has_undergone_remesh(ip) = .true. - + return end if @@ -607,7 +607,7 @@ subroutine do_merge(s, i_merge, species, new_xa, ierr) cell_ie = IE_i + IE_ip s% energy(i) = cell_ie/dm - + if (s% RSP2_flag) then cell_etrb = Etrb_i + Etrb_ip s% w(i) = sqrt(cell_etrb/dm) @@ -663,15 +663,15 @@ subroutine do_merge(s, i_merge, species, new_xa, ierr) nz = nz - 1 s% nz = nz - + if (s% u_flag) then s% xh(s% i_u,i) = s% u(i) else if (s% v_flag) then s% xh(s% i_v,i) = s% v(i) end if - + if (s% RTI_flag) s% xh(s% i_alpha_RTI,i) = s% alpha_RTI(i) - + if (s% RSP2_flag) then s% xh(s% i_w,i) = s% w(i) s% xh(s% i_Hp,i) = s% Hp_face(i) @@ -680,7 +680,7 @@ subroutine do_merge(s, i_merge, species, new_xa, ierr) ! do this after move cells since need new r(ip) to calc new rho(i). call update_xh_eos_and_kap(s,i,species,new_xa,ierr) if (ierr /= 0) return ! call mesa_error(__FILE__,__LINE__,'update_xh_eos_and_kap failed in do_merge') - + s% rmid_start(i) = -1 call set_rmid(s, i, i, ierr) if (ierr /= 0) return ! call mesa_error(__FILE__,__LINE__,'update_xh_eos_and_kap failed in do_merge') @@ -689,8 +689,8 @@ subroutine do_merge(s, i_merge, species, new_xa, ierr) call revise_star_radius(s, star_PE0, star_PE1) end subroutine do_merge - - + + subroutine revise_star_radius(s, star_PE0, star_PE1) use star_utils, only: store_r_in_xh, get_lnR_from_xh type (star_info), pointer :: s @@ -712,7 +712,7 @@ subroutine revise_star_radius(s, star_PE0, star_PE1) s% r_center = frac*s% r_center end subroutine revise_star_radius - + real(dp) function get_star_PE(s) result(totPE) type (star_info), pointer :: s integer :: k @@ -872,7 +872,7 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) mlt_vcL = s% mlt_vc(ip) tauL = s% tau(ip) end if - + tauR = s% tau(i) if (i == nz) then tauL = tau_center @@ -887,7 +887,7 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) call mesa_error(__FILE__,__LINE__,'do_split') !$omp end critical (adjust_mesh_split_merge_crit1) end if - + dr = rR - rL dr_old = dr rC = 0.5d0*(rR + rL) ! split at center by radius @@ -898,7 +898,7 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) dm = s% dm(i) rho = dm/dV - + if (s% u_flag) then v = s% u(i) v2 = v*v @@ -906,7 +906,7 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) v = 0 v2 = 0 end if - + energy = s% energy(i) if (s% RSP2_flag) etrb = pow2(s% w(i)) @@ -924,16 +924,16 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) iC = nz_old-1 iL = nz_old end if - + energy_R = s% energy(iR) rho_R = s% dm(iR)/get_dV(s,iR) - + energy_C = s% energy(iC) rho_C = s% dm(iC)/get_dV(s,iC) - + energy_L = s% energy(iL) rho_L = s% dm(iL)/get_dV(s,iL) - + ! get gradients before move cell contents if (iL == nz_old) then @@ -959,17 +959,17 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) end if grad_energy = get1_grad(energy_L, energy_C, energy_R, dLeft, dCntr, dRght) - + if (s% RTI_flag) grad_alpha = get1_grad( & s% alpha_RTI(iL), s% alpha_RTI(iC), s% alpha_RTI(iR), dLeft, dCntr, dRght) - + if (s% RSP2_flag) then etrb_R = pow2(s% w(iR)) etrb_C = pow2(s% w(iC)) etrb_L = pow2(s% w(iL)) grad_etrb = get1_grad(etrb_L, etrb_C, etrb_R, dLeft, dCntr, dRght) end if - + if (s% u_flag) then v_R = s% u(iR) v2_R = v_R*v_R @@ -1043,7 +1043,7 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) end if s% amr_split_merge_has_undergone_remesh(i) = .true. s% amr_split_merge_has_undergone_remesh(ip) = .true. - + dM = rho*dV if (.not. use_new_grad_rho) then ! do it the old way @@ -1070,12 +1070,12 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) end if dMR = dM - dML end if - + else - + ! at this point, rho_R is the density of the cell iR ! we are about to redefine it as the density of the right 1/2 of the split - ! similarly for rho_L + ! similarly for rho_L rho_iR = rho_R dR = -(dRght/4 + (s% r(iR) - s% r(iC))/2) rho_R = rho_iR + grad_rho*dR @@ -1107,9 +1107,9 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) call mesa_error(__FILE__,__LINE__,'failed in do_split extrapolation of density from above') !$omp end critical (adjust_mesh_split_merge_crit2) end if - + end if - + min_dm = s% split_merge_amr_dq_min*s% xmstar if (dML < min_dm .or. dMR < min_dm) then rho_R = rho @@ -1125,10 +1125,10 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) energy_R = energy energy_L = energy end if - + s% energy(i) = energy_R s% energy(ip) = energy_L - + if (s% RSP2_flag) then etrb_R = etrb + grad_etrb*dr/4 etrb_L = (dm*etrb - dmR*etrb_R)/dmL @@ -1153,10 +1153,10 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) s% u(i) = -s% u(i) s% u(ip) = -s% u(ip) end if - else if (s% v_flag) then ! just make a rough approximation. + else if (s% v_flag) then ! just make a rough approximation. s% v(ip) = sqrt(0.5d0*(v2_L + v2_R)) end if - + if (s% RTI_flag) then ! set new alpha if (i == 1) then s% alpha_RTI(ip) = s% alpha_RTI(i) @@ -1169,13 +1169,13 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) end if s% dPdr_dRhodr_info(ip) = s% dPdr_dRhodr_info(i) end if - + if (i == 1) then s% mlt_vc(ip) = s% mlt_vc(i) else s% mlt_vc(ip) = (mlt_vcL*dML + mlt_vcR*dMR)/dM end if - + s% tau(ip) = tauR + (tauL - tauR)*dMR/dM if (is_bad(s% tau(ip))) then write(*,2) 'tau', ip, s% tau(ip), tauL, tauR, dMR/dM @@ -1216,7 +1216,7 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) s% xa(q,ip) = s% xa(q,ip)/sumxp end do end if - + if (s% u_flag) s% u_face_ad(ip)%val = 0.5d0*(s% u(i) + s% u(ip)) ! just for setting u_face_start so don't need partials @@ -1284,7 +1284,7 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) 0.5d0*(s% xh(s% i_lum,i) + s% L_center) end if end if - + call store_r_in_xh(s, ip, s% r(ip)) if (s% u_flag) then s% xh(s% i_u,i) = s% u(i) @@ -1303,7 +1303,7 @@ subroutine do_split(s, i_split, species, tau_center, grad_xa, new_xa, ierr) call update_xh_eos_and_kap(s,ip,species,new_xa,ierr) if (ierr /= 0) return ! call mesa_error(__FILE__,__LINE__,'update_xh_eos_and_kap failed in do_split') - + s% rmid_start(i) = -1 s% rmid_start(ip) = -1 call set_rmid(s, i, ip, ierr) @@ -1444,10 +1444,10 @@ subroutine report_energies(s, str) character (len=*), intent(in) :: str real(dp) :: KE, IE, PE, Etot include 'formats' - + return - - + + KE = total_KE(s) IE = total_IE(s) PE = total_PE(s) diff --git a/star/private/adjust_mesh_support.f90 b/star/private/adjust_mesh_support.f90 index 6f94bbf5e..a91418258 100644 --- a/star/private/adjust_mesh_support.f90 +++ b/star/private/adjust_mesh_support.f90 @@ -78,12 +78,12 @@ subroutine get_gval_info( & s, num_gvals, gval_names, & gval_is_xa_function, gval_is_logT_function, gvals1, ierr) if (ierr /= 0) return - + allocate(src(nz)) call set_delta_gval_max(src, ierr) if (ierr /= 0) return - + call smooth_gvals(nz,src,num_gvals,gvals) @@ -98,7 +98,7 @@ subroutine set_delta_gval_max(src, ierr) logical, parameter :: dbg = .false. include 'formats' - + ierr = 0 delta_gval_max(1:nz) = 1d0 @@ -109,7 +109,7 @@ subroutine set_delta_gval_max(src, ierr) delta_gval_max(k) = delta_gval_max(k)*pow(beta,P_exp) end do end if - + if (s% use_other_mesh_delta_coeff_factor) then do k=1,nz s% mesh_delta_coeff_factor(k) = delta_gval_max(k) @@ -156,7 +156,7 @@ subroutine set_delta_gval_max(src, ierr) call do1_dlog_eps_dlogP_coef(s% mesh_dlog_other_dlogP_extra, iother) if (s% mesh_delta_coeff_factor_smooth_iters > 0) then ! smooth delta_gval_max - + do k=1,nz src(k) = delta_gval_max(k) end do @@ -175,7 +175,7 @@ subroutine set_delta_gval_max(src, ierr) end do src(nz) = (2*delta_gval_max(nz) + delta_gval_max(nz-1))/3 end do - + end if end subroutine set_delta_gval_max diff --git a/star/private/adjust_xyz.f90 b/star/private/adjust_xyz.f90 index 7929e8981..fca30f7b7 100644 --- a/star/private/adjust_xyz.f90 +++ b/star/private/adjust_xyz.f90 @@ -100,7 +100,7 @@ subroutine do_composition_fixup( & nz = max(s% nz, s% prev_mesh_nz) chem_id => s% chem_id num_reactions = s% num_reactions - + write(*,*) 'change to "' // trim(new_net_name)//'"' write(*,*) 'number of species', s% species @@ -131,7 +131,7 @@ subroutine do_composition_fixup( & if (associated(s% d_eos_dxa)) deallocate(s% d_eos_dxa) allocate(s% d_eos_dxa(num_eos_d_dxa_results, species, nz + nz_alloc_extra), stat=ierr) if (ierr /= 0) return - + call realloc(s% xa_sub_xa_start); if (ierr /= 0) return call realloc(s% xa_start); if (ierr /= 0) return call realloc(s% prev_mesh_xa); if (ierr /= 0) return @@ -139,13 +139,13 @@ subroutine do_composition_fixup( & if (s% generations > 1) call do_xa(s% nz_old, s% xh_old, s% xa_old) call realloc_reactions(s% raw_rate) - if(ierr/=0) return + if(ierr/=0) return call realloc_reactions(s% screened_rate) - if(ierr/=0) return + if(ierr/=0) return call realloc_reactions(s% eps_nuc_rate) - if(ierr/=0) return + if(ierr/=0) return call realloc_reactions(s% eps_neu_rate) - if(ierr/=0) return + if(ierr/=0) return s% need_to_setvars = .true. s% prev_mesh_species_or_nvar_hydro_changed = .true. @@ -668,7 +668,7 @@ subroutine set_y(s, y, nzlo, nzhi, ierr) end if call set_abundance_ratio(s% id, ih1, ihe4, ratio, nzlo, nzhi, ierr) - + end subroutine set_y diff --git a/star/private/alloc.f90 b/star/private/alloc.f90 index 93ef72e0c..dc112b606 100644 --- a/star/private/alloc.f90 +++ b/star/private/alloc.f90 @@ -84,7 +84,7 @@ module alloc contains - + subroutine init_alloc integer :: i num_calls=0; num_returns=0 @@ -268,7 +268,7 @@ subroutine free_arrays(s) deallocate(s%op_mono_factors) nullify(s%op_mono_factors) end if - + call dealloc_extras(s) call free_other(s) @@ -282,15 +282,15 @@ subroutine free_arrays(s) deallocate(s%other_star_info) endif - + call dealloc_history(s) - + if (ASSOCIATED(s%bcyclic_odd_storage)) call clear_storage(s) ! Free the star handle itself call free_star(s) - + end subroutine free_arrays @@ -371,7 +371,7 @@ subroutine star_info_old_arrays(s, action, ierr) integer, intent(out) :: ierr integer :: nz, species, nvar_hydro - + include 'formats' nz = s% nz_old @@ -476,8 +476,8 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) ierr = 0 null_str = '' ! avoid bogus compiler warnings 'array subscript 1 is above array bounds' - - + + species = s% species num_reactions = s% num_reactions nvar = s% nvar_total @@ -505,7 +505,7 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) do ! just so can exit on failure if (action /= do_fill_arrays_with_NaNs) then - ! these arrays must not be filled with NaNs + ! these arrays must not be filled with NaNs ! because they contain the inputs to the step call do2(s% xh, c% xh, nvar_hydro, 'xh') if (failed('xh')) exit @@ -530,7 +530,7 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) call do1(s% conv_vel, c% conv_vel) if (failed('conv_vel')) exit end if - + call do1(s% q, c% q) if (failed('q')) exit call do1(s% m, c% m) @@ -538,8 +538,8 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) call do1(s% dm, c% dm) if (failed('dm')) exit call do1(s% dm_bar, c% dm_bar) - if (failed('dm_bar')) exit - + if (failed('dm_bar')) exit + call do1(s% am_nu_rot, c% am_nu_rot) if (failed('am_nu_rot')) exit call do1(s% D_omega, c% D_omega) @@ -567,7 +567,7 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) call do2(s% xh_start, c% xh_start, nvar_hydro, 'xh_start') if (failed('xh_start')) exit - + call do1(s% r_polar, c% r_polar) if (failed('r_polar')) exit call do1(s% r_equatorial, c% r_equatorial) @@ -595,7 +595,7 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) if (failed('w_start')) exit call do1(s% Hp_face_start, c% Hp_face_start) if (failed('Hp_face_start')) exit - + call do1(s% dxh_lnR, c% dxh_lnR) if (failed('dxh_lnR')) exit call do1(s% dxh_lnd, c% dxh_lnd) @@ -749,10 +749,10 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) if (failed('csound')) exit call do1(s% csound_face, c% csound_face) if (failed('csound_face')) exit - + call do1(s% rho_face, c% rho_face) if (failed('rho_face')) exit - + call do1(s% scale_height, c% scale_height) if (failed('scale_height')) exit call do1(s% v_div_csound, c% v_div_csound) @@ -938,7 +938,7 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) if (failed('eps_heat')) exit call do1(s% irradiation_heat, c% irradiation_heat) if (failed('irradiation_heat')) exit - + call do1_ad(s% extra_heat, c% extra_heat) if (failed('extra_heat')) exit call do1_ad(s% extra_grav, c% extra_grav) @@ -1035,7 +1035,7 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) call do1_logical(s% fixed_gradr_for_rest_of_solver_iters, c% fixed_gradr_for_rest_of_solver_iters) if (failed('fixed_gradr_for_rest_of_solver_iters')) exit - + call do1(s% mlt_Gamma, c% mlt_Gamma) if (failed('mlt_Gamma')) exit call do1(s% L_conv, c% L_conv) @@ -1065,7 +1065,7 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) if (failed('mixing_type')) exit call do1(s% cz_bdy_dq, c% cz_bdy_dq) if (failed('cz_bdy_dq')) exit - + call do1_ad(s% gradT_ad, c% gradT_ad) if (failed('gradT_ad')) exit call do1_ad(s% gradr_ad, c% gradr_ad) @@ -1086,7 +1086,7 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) if (failed('mlt_D_ad')) exit call do1_ad(s% mlt_Gamma_ad, c% mlt_Gamma_ad) if (failed('mlt_Gamma_ad')) exit - + call do1_ad(s% PII_ad, c% PII_ad) if (failed('PII_ad')) exit call do1_ad(s% Chi_ad, c% Chi_ad) @@ -1135,7 +1135,7 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) if (failed('unsmoothed_brunt_B')) exit call do1(s% smoothed_brunt_B, c% smoothed_brunt_B) if (failed('smoothed_brunt_B')) exit - + call do1(s% RTI_du_diffusion_kick, c% RTI_du_diffusion_kick) if (failed('RTI_du_diffusion_kick')) exit @@ -1317,7 +1317,7 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) call do1(s% Y_face, c% Y_face); if (failed('Y_face')) exit call do1(s% Y_face_start, c% Y_face_start); if (failed('Y_face_start')) exit - + call do1(s% PII, c% PII); if (failed('PII')) exit call do1(s% Chi, c% Chi); if (failed('Chi')) exit @@ -1328,7 +1328,7 @@ subroutine star_info_arrays(s, c_in, action_in, ierr) call do1(s% Lc_start, c% Lc_start); if (failed('Lc_start')) exit call do1(s% Lt, c% Lt); if (failed('Lt')) exit call do1(s% Lt_start, c% Lt_start); if (failed('Lt_start')) exit - + call do1(s% Fr, c% Fr); if (failed('Fr')) exit call do1(s% Fr_start, c% Fr_start); if (failed('Fr_start')) exit call do1(s% Pvsc, c% Pvsc); if (failed('Pvsc')) exit @@ -1640,8 +1640,8 @@ end function failed end subroutine star_info_arrays - - + + subroutine fill_ad_with_NaNs(ptr, klo, khi_in) type(auto_diff_real_star_order1), dimension(:), pointer :: ptr integer, intent(in) :: klo, khi_in @@ -1656,8 +1656,8 @@ subroutine fill_ad_with_NaNs(ptr, klo, khi_in) call fill_with_NaNs(ptr(k)% d1Array) end do end subroutine fill_ad_with_NaNs - - + + subroutine fill_ad_with_zeros(ptr, klo, khi_in) type(auto_diff_real_star_order1), dimension(:), pointer :: ptr integer, intent(in) :: klo, khi_in @@ -2301,23 +2301,23 @@ subroutine set_var_info(s, ierr) integer, intent(out) :: ierr integer :: i - + include 'formats' ierr = 0 i = 0 - + ! first assign variable numbers i = i+1; s% i_lnd = i i = i+1; s% i_lnT = i i = i+1; s% i_lnR = i - + if (.not. s% RSP_flag) then i = i+1; s% i_lum = i else s% i_lum = 0 end if - + if (s% v_flag) then i = i+1; s% i_v = i else @@ -2345,11 +2345,11 @@ subroutine set_var_info(s, ierr) s% i_erad_RSP = 0 s% i_Fr_RSP = 0 end if - + if (s% RSP2_flag) then i = i+1; s% i_w = i i = i+1; s% i_Hp = i - else + else s% i_w = 0 s% i_Hp = 0 end if @@ -2365,7 +2365,7 @@ subroutine set_var_info(s, ierr) else s% i_j_rot = 0 end if - + ! now assign equation numbers if (s% i_v /= 0 .or. s% i_u /= 0) then s% i_dlnd_dt = s% i_lnd @@ -2382,7 +2382,7 @@ subroutine set_var_info(s, ierr) s% i_dlnR_dt = 0 s% i_du_dt = 0 end if - + s% i_detrb_dt = s% i_w s% i_equ_Hp = s% i_Hp s% i_dalpha_RTI_dt = s% i_alpha_RTI @@ -2409,7 +2409,7 @@ subroutine set_var_info(s, ierr) if (s% i_Fr_RSP /= 0) s% nameofvar(s% i_Fr_RSP) = 'Fr_RSP' if (s% i_w_div_wc /= 0) s% nameofvar(s% i_w_div_wc) = 'w_div_wc' if (s% i_j_rot /= 0) s% nameofvar(s% i_j_rot) = 'j_rot' - if (s% i_u /= 0) s% nameofvar(s% i_u) = 'u' + if (s% i_u /= 0) s% nameofvar(s% i_u) = 'u' ! Names of the equations if (s% i_dv_dt /= 0) s% nameofequ(s% i_dv_dt) = 'dv_dt' @@ -2428,7 +2428,7 @@ subroutine set_var_info(s, ierr) if (s% i_du_dt /= 0) s% nameofequ(s% i_du_dt) = 'du_dt' ! chem names are done later by set_chem_names when have set up the net - + s% need_to_setvars = .true. @@ -3071,14 +3071,14 @@ end function return1 end subroutine return_logical_work_array - + subroutine shutdown_alloc () call free_work_arrays() end subroutine shutdown_alloc - + subroutine free_work_arrays () integer :: i @@ -3161,12 +3161,12 @@ integer function get_size_l(i) end function get_size_l end subroutine size_work_arrays - + ! Cleans array used by history.f90, cant think of better place? subroutine dealloc_history(s) use utils_lib, only: integer_dict_free type(star_info), pointer :: s - + if (associated(s% history_values)) then deallocate(s% history_values) nullify(s% history_values) diff --git a/star/private/atm_support.f90 b/star/private/atm_support.f90 index 68e68c9a8..392dfddce 100644 --- a/star/private/atm_support.f90 +++ b/star/private/atm_support.f90 @@ -73,7 +73,7 @@ subroutine get_atm_PT( & integer, intent(out) :: ierr real(dp) :: kap - + if (is_bad(tau_surf)) then write(*,*) 'tau_surf', tau_surf ierr = -1 @@ -106,7 +106,7 @@ subroutine get_atm_PT( & ierr) case ('irradiated_grey') - + call get_irradiated( & s, s% atm_irradiated_opacity, skip_partials, L, R, M, cgrav, & Teff, & @@ -228,7 +228,7 @@ subroutine get_atm_tau_base(s, tau_base, ierr) ! All other options use this tau_base = 2._dp/3._dp - + end select ! Finish @@ -302,7 +302,7 @@ subroutine get_T_tau( & select case (T_tau_opacity) case ('fixed') - + ! ok to use s% opacity(1) for fixed call atm_eval_T_tau_uniform( & tau_surf, L, R, M, cgrav, s% opacity(1), s% Pextra_factor, & @@ -321,7 +321,7 @@ subroutine get_T_tau( & if (s% report_ierr) write(*, *) s% retry_message return endif - + ! need to start iterations from same kap each time, so use opacity_start if (s% solver_iter > 0) then kap_guess = s% opacity_start(1) @@ -358,7 +358,7 @@ subroutine get_T_tau( & kap = 0._dp ! This value is not used case default - + write(*,*) 'Unknown value for atm_T_tau_opacity: ' // trim(T_tau_opacity) call mesa_error(__FILE__,__LINE__,'Please amend your inlist file to correct this problem') @@ -383,7 +383,7 @@ subroutine eos_proc_for_get_T_tau( & real(dp), intent(out) :: dres_dlnT(:) integer, intent(out) :: ierr include 'formats' - + call eos_proc( & s, lnP, lnT, & lnRho, res, dres_dlnRho, dres_dlnT, & @@ -408,14 +408,14 @@ subroutine kap_proc_for_get_T_tau( & real(dp), intent(out) :: dlnkap_dlnT integer, intent(out) :: ierr include 'formats' - + call kap_proc( & s, lnRho, lnT, res, dres_dlnRho, dres_dlnT, & kap, dlnkap_dlnRho, dlnkap_dlnT, & ierr) end subroutine kap_proc_for_get_T_tau - + end subroutine get_T_tau !**** @@ -427,7 +427,7 @@ subroutine get_T_tau_id (T_tau_relation, T_tau_id, ierr) ATM_T_TAU_SOLAR_HOPF, & ATM_T_TAU_KRISHNA_SWAMY, & ATM_T_TAU_TRAMPEDACH_SOLAR - + character(*), intent(in) :: T_tau_relation integer, intent(out) :: T_tau_id integer, intent(out) :: ierr @@ -556,7 +556,7 @@ subroutine get_table( & if (s% report_ierr) write(*, *) s% retry_message return endif - + ! If completely off the table, may need to reset tau_base to the ! T_Tau value to get the expected off-table behavior. if(beta == 0._dp) then @@ -596,7 +596,7 @@ subroutine get_table( & s% tau_base = tau_base end if end if - + ! Evaluate temperature and pressure from the table if (beta /= 0._dp) then @@ -626,7 +626,7 @@ subroutine get_table( & dlnP_dlnR_b = 0._dp dlnP_dlnM_b = 0._dp dlnP_dlnkap_b = 0._dp - + endif ! Evaluate temperature and pressure from the backup atmosphere @@ -661,7 +661,7 @@ subroutine get_table( & write(*,*) 'Unknown value for atm_off_table_option: ' // trim(s% atm_off_table_option) call mesa_error(__FILE__,__LINE__,'Please amend your inlist file to correct this problem') - + end select else @@ -677,7 +677,7 @@ subroutine get_table( & dlnP_dlnR_a = 0._dp dlnP_dlnM_a = 0._dp dlnP_dlnkap_a = 0._dp - + end if ! Blend the results together @@ -686,12 +686,12 @@ subroutine get_table( & lnP = alfa*lnP_a + beta*lnP_b if (.not. skip_partials) then - + dlnT_dL = alfa*dlnT_dL_a + beta*dlnT_dL_b dlnT_dlnR = alfa*dlnT_dlnR_a + beta*dlnT_dlnR_b dlnT_dlnM = alfa*dlnT_dlnM_a + beta*dlnT_dlnM_b dlnT_dlnkap = alfa*dlnT_dlnkap_a + beta*dlnT_dlnkap_b - + dlnP_dL = alfa*dlnP_dL_a + beta*dlnP_dL_b dlnP_dlnR = alfa*dlnP_dlnR_a + beta*dlnP_dlnR_b dlnP_dlnM = alfa*dlnP_dlnM_a + beta*dlnP_dlnM_b @@ -769,7 +769,7 @@ subroutine get_table_id (table_name, table_id, ierr) end subroutine get_table_id !**** - + subroutine get_irradiated( & s, irradiated_opacity, skip_partials, L, R, M, cgrav, & Teff, & @@ -802,7 +802,7 @@ subroutine get_irradiated( & real(dp) :: tau_surf include 'formats' - + if (s% solver_iter > 0) then kap_for_atm = s% opacity_start(1) else @@ -854,7 +854,7 @@ subroutine get_irradiated( & Teff, kap, tau_surf, & lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, & ierr) - + case default write(*,*) 'Unknown value for atm_irradiated_opacity: ' // trim(irradiated_opacity) @@ -874,7 +874,7 @@ subroutine get_irradiated( & ! Update tau_factor s% tau_factor = tau_surf/s% tau_base - + ! Finish return @@ -893,7 +893,7 @@ subroutine eos_proc_for_get_irradiated( & real(dp), intent(out) :: dres_dlnRho(:) real(dp), intent(out) :: dres_dlnT(:) integer, intent(out) :: ierr - + call eos_proc( & s, lnP, lnT, & lnRho, res, dres_dlnRho, dres_dlnT, & @@ -917,14 +917,14 @@ subroutine kap_proc_for_get_irradiated( & real(dp), intent(out) :: dlnkap_dlnRho real(dp), intent(out) :: dlnkap_dlnT integer, intent(out) :: ierr - + call kap_proc( & s, lnRho, lnT, res, dres_dlnRho, dres_dlnT, & kap, dlnkap_dlnRho, dlnkap_dlnT, & ierr) end subroutine kap_proc_for_get_irradiated - + end subroutine get_irradiated !**** @@ -1024,7 +1024,7 @@ subroutine get_legacy (s, ierr) write(*,*) ' atm_irradiated_opacity = ''varying'' (if atm_grey_irradiated_simple_kap_th = .false.)' case default - + write(*,*) 'Unknown value for atm_option: ' // trim(s% atm_option) end select @@ -1048,7 +1048,7 @@ subroutine build_atm( & type(star_info), pointer :: s real(dp), intent(in) :: L, R, Teff, M, cgrav integer, intent(out) :: ierr - + ! Create the atmosphere structure by dispatching to the ! appropriate internal routine @@ -1083,7 +1083,7 @@ subroutine build_T_tau( & use atm_lib, only: & atm_build_T_tau_uniform, & atm_build_T_tau_varying - + type(star_info), pointer :: s real(dp), intent(in) :: tau_surf, L, R, Teff, M, cgrav character(*), intent(in) :: T_tau_relation @@ -1164,7 +1164,7 @@ subroutine build_T_tau( & end if case default - + write(*,*) 'Unknown value for atm_T_tau_opacity: ' // trim(T_tau_opacity) call mesa_error(__FILE__,__LINE__,'Please amend your inlist file to correct this problem') @@ -1188,7 +1188,7 @@ subroutine eos_proc_for_build_T_tau( & real(dp), intent(out) :: dres_dlnRho(:) real(dp), intent(out) :: dres_dlnT(:) integer, intent(out) :: ierr - + call eos_proc( & s, lnP, lnT, & lnRho, res, dres_dlnRho, dres_dlnT, & @@ -1212,16 +1212,16 @@ subroutine kap_proc_for_build_T_tau( & real(dp), intent(out) :: dlnkap_dlnRho real(dp), intent(out) :: dlnkap_dlnT integer, intent(out) :: ierr - + call kap_proc( & s, lnRho, lnT, res, dres_dlnRho, dres_dlnT, & kap, dlnkap_dlnRho, dlnkap_dlnT, & ierr) end subroutine kap_proc_for_build_T_tau - + end subroutine build_T_tau - + !**** subroutine eos_proc( & @@ -1258,7 +1258,7 @@ subroutine eos_proc( & Prad = radiation_pressure(T) Pgas = MAX(1.E-99_dp, P - Prad) - + gamma = 5d0/3d0 call eos_gamma_PT_get_rho_energy( & s% abar(1), P, T, gamma, rho, energy, ierr) @@ -1266,7 +1266,7 @@ subroutine eos_proc( & s% retry_message = 'Call to eos_gamma_PT_get_rho_energy failed in eos_proc' if (s% report_ierr) write(*, *) trim(s% retry_message) end if - + logRho_guess = log10(rho) call solve_eos_given_PgasT( & @@ -1282,7 +1282,7 @@ subroutine eos_proc( & lnRho = logRho*ln10 ! Finish - + return @@ -1311,7 +1311,7 @@ subroutine kap_proc( & integer, intent(out) :: ierr real(dp) :: kap_fracs(num_kap_fracs) - + include 'formats' call get_kap( & @@ -1326,7 +1326,7 @@ subroutine kap_proc( & end if ! Finish - + if (kap <= 0d0 .or. is_bad(kap)) then write(*,1) 'bad kap', kap write(*,1) 's% zbar(1)', s% zbar(1) diff --git a/star/private/auto_diff_support.f90 b/star/private/auto_diff_support.f90 index a6e685e72..1ef4b6fdb 100644 --- a/star/private/auto_diff_support.f90 +++ b/star/private/auto_diff_support.f90 @@ -30,7 +30,7 @@ module auto_diff_support use auto_diff implicit none - + ! current use of xtra's ! xtra1 is w_div_wc @@ -180,7 +180,7 @@ end subroutine wrap ! The following routines turn regular star variables into auto_diff_real_star_order1 variables. ! For independent variables this is a straightforward wrapping. For dependent variables like eos and kap ! outputs we also pull in information about their partials from the relevant module. - + !---------------------------------------------------------------------------------------------------- ! ! We begin with quantities defined on cells (T, rho, e_turb, kap, pressure, energy, entropy). @@ -193,7 +193,7 @@ function wrap_T_m1(s, k) result(T_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: T_m1 integer, intent(in) :: k - T_m1 = 0d0 + T_m1 = 0d0 if (k > 1) then T_m1 % val = s%T(k-1) T_m1 % d1Array(i_lnT_m1) = s%T(k-1) @@ -204,7 +204,7 @@ function wrap_T_00(s, k) result(T_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: T_00 integer, intent(in) :: k - T_00 = 0d0 + T_00 = 0d0 T_00 % val = s%T(k) T_00 % d1Array(i_lnT_00) = s%T(k) end function wrap_T_00 @@ -213,7 +213,7 @@ function wrap_T_p1(s, k) result(T_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: T_p1 integer, intent(in) :: k - T_p1 = 0d0 + T_p1 = 0d0 if (k < s%nz) then T_p1 % val = s%T(k+1) T_p1 % d1Array(i_lnT_p1) = s%T(k+1) @@ -224,7 +224,7 @@ function wrap_lnT_m1(s, k) result(lnT_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: lnT_m1 integer, intent(in) :: k - lnT_m1 = 0d0 + lnT_m1 = 0d0 if (k > 1) then lnT_m1 % val = s%lnT(k-1) lnT_m1 % d1Array(i_lnT_m1) = 1d0 @@ -235,7 +235,7 @@ function wrap_lnT_00(s, k) result(lnT_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: lnT_00 integer, intent(in) :: k - lnT_00 = 0d0 + lnT_00 = 0d0 lnT_00 % val = s%lnT(k) lnT_00 % d1Array(i_lnT_00) = 1d0 end function wrap_lnT_00 @@ -244,7 +244,7 @@ function wrap_lnT_p1(s, k) result(lnT_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: lnT_p1 integer, intent(in) :: k - lnT_p1 = 0d0 + lnT_p1 = 0d0 if (k < s%nz) then lnT_p1 % val = s%lnT(k+1) lnT_p1 % d1Array(i_lnT_p1) = 1d0 @@ -255,7 +255,7 @@ function wrap_dxh_lnT(s, k) result(dxh_lnT) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: dxh_lnT integer, intent(in) :: k - dxh_lnT = 0d0 + dxh_lnT = 0d0 dxh_lnT % val = s%dxh_lnT(k) dxh_lnT % d1Array(i_lnT_00) = 1d0 end function wrap_dxh_lnT @@ -264,7 +264,7 @@ function wrap_d_m1(s, k) result(d_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: d_m1 integer, intent(in) :: k - d_m1 = 0d0 + d_m1 = 0d0 if (k > 1) then d_m1 % val = s%rho(k-1) d_m1 % d1Array(i_lnd_m1) = s%rho(k-1) @@ -275,7 +275,7 @@ function wrap_d_00(s, k) result(d_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: d_00 integer, intent(in) :: k - d_00 = 0d0 + d_00 = 0d0 d_00 % val = s%rho(k) d_00 % d1Array(i_lnd_00) = s%rho(k) end function wrap_d_00 @@ -284,7 +284,7 @@ function wrap_d_p1(s, k) result(d_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: d_p1 integer, intent(in) :: k - d_p1 = 0d0 + d_p1 = 0d0 if (k < s%nz) then d_p1 % val = s%rho(k+1) d_p1 % d1Array(i_lnd_p1) = s%rho(k+1) @@ -295,7 +295,7 @@ function wrap_lnd_m1(s, k) result(lnd_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: lnd_m1 integer, intent(in) :: k - lnd_m1 = 0d0 + lnd_m1 = 0d0 if (k > 1) then lnd_m1 % val = s%lnd(k-1) lnd_m1 % d1Array(i_lnd_m1) = 1d0 @@ -306,7 +306,7 @@ function wrap_lnd_00(s, k) result(lnd_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: lnd_00 integer, intent(in) :: k - lnd_00 = 0d0 + lnd_00 = 0d0 lnd_00 % val = s%lnd(k) lnd_00 % d1Array(i_lnd_00) = 1d0 end function wrap_lnd_00 @@ -315,7 +315,7 @@ function wrap_lnd_p1(s, k) result(lnd_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: lnd_p1 integer, intent(in) :: k - lnd_p1 = 0d0 + lnd_p1 = 0d0 if (k < s%nz) then lnd_p1 % val = s%lnd(k+1) lnd_p1 % d1Array(i_lnd_p1) = 1d0 @@ -326,7 +326,7 @@ function wrap_dxh_lnd(s, k) result(dxh_lnd) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: dxh_lnd integer, intent(in) :: k - dxh_lnd = 0d0 + dxh_lnd = 0d0 dxh_lnd % val = s%dxh_lnd(k) dxh_lnd % d1Array(i_lnd_00) = 1d0 end function wrap_dxh_lnd @@ -335,7 +335,7 @@ function wrap_w_m1(s, k) result(w_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: w_m1 integer, intent(in) :: k - w_m1 = 0d0 + w_m1 = 0d0 if (k > 1) then w_m1 % val = s%w(k-1) w_m1 % d1Array(i_w_m1) = 1d0 @@ -346,7 +346,7 @@ function wrap_w_00(s, k) result(w_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: w_00 integer, intent(in) :: k - w_00 = 0d0 + w_00 = 0d0 w_00 % val = s%w(k) w_00 % d1Array(i_w_00) = 1d0 end function wrap_w_00 @@ -355,25 +355,25 @@ function wrap_w_p1(s, k) result(w_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: w_p1 integer, intent(in) :: k - w_p1 = 0d0 + w_p1 = 0d0 if (k < s%nz) then w_p1 % val = s%w(k+1) w_p1 % d1Array(i_w_p1) = 1d0 end if end function wrap_w_p1 - + real(dp) function get_etrb(s,k) type (star_info), pointer :: s integer, intent(in) :: k get_etrb = pow2(s% w(k)) end function get_etrb - + real(dp) function get_etrb_start(s,k) type (star_info), pointer :: s integer, intent(in) :: k get_etrb_start = pow2(s% w_start(k)) end function get_etrb_start - + real(dp) function get_RSP2_conv_velocity(s,k) result (cv) ! at face k type (star_info), pointer :: s integer, intent(in) :: k @@ -386,13 +386,13 @@ real(dp) function get_RSP2_conv_velocity(s,k) result (cv) ! at face k cv = sqrt_2_div_3*(alfa*s% w(k) + beta*s% w(k-1)) end if end function get_RSP2_conv_velocity - + real(dp) function get_w(s,k) type (star_info), pointer :: s integer, intent(in) :: k get_w = s% w(k) end function get_w - + real(dp) function get_w_start(s,k) type (star_info), pointer :: s integer, intent(in) :: k @@ -403,28 +403,28 @@ function wrap_etrb_m1(s, k) result(etrb_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: etrb_m1 integer, intent(in) :: k - etrb_m1 = pow2(wrap_w_m1(s,k)) + etrb_m1 = pow2(wrap_w_m1(s,k)) end function wrap_etrb_m1 function wrap_etrb_00(s, k) result(etrb_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: etrb_00 integer, intent(in) :: k - etrb_00 = pow2(wrap_w_00(s,k)) + etrb_00 = pow2(wrap_w_00(s,k)) end function wrap_etrb_00 function wrap_etrb_p1(s, k) result(etrb_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: etrb_p1 integer, intent(in) :: k - etrb_p1 = pow2(wrap_w_p1(s,k)) + etrb_p1 = pow2(wrap_w_p1(s,k)) end function wrap_etrb_p1 function wrap_kap_m1(s, k) result(kap_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: kap_m1 integer, intent(in) :: k - kap_m1 = 0d0 + kap_m1 = 0d0 if (k > 1) then kap_m1 % val = s%opacity(k-1) kap_m1 % d1Array(i_lnd_m1) = s%d_opacity_dlnd(k-1) @@ -436,7 +436,7 @@ function wrap_kap_00(s, k) result(kap_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: kap_00 integer, intent(in) :: k - kap_00 = 0d0 + kap_00 = 0d0 kap_00 % val = s%opacity(k) kap_00 % d1Array(i_lnd_00) = s%d_opacity_dlnd(k) kap_00 % d1Array(i_lnT_00) = s%d_opacity_dlnT(k) @@ -446,7 +446,7 @@ function wrap_kap_p1(s, k) result(kap_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: kap_p1 integer, intent(in) :: k - kap_p1 = 0d0 + kap_p1 = 0d0 if (k < s%nz) then kap_p1 % val = s%opacity(k+1) kap_p1 % d1Array(i_lnd_p1) = s%d_opacity_dlnd(k+1)/s% rho(k+1) @@ -458,19 +458,19 @@ function wrap_s_m1(s, k) result(s_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: s_m1 integer, intent(in) :: k - s_m1 = 0d0 + s_m1 = 0d0 if (k > 1) then s_m1%val = s% entropy(k-1) s_m1%d1Array(i_lnd_m1) = s% dS_dRho_for_partials(k-1)*s% rho(k-1) s_m1%d1Array(i_lnT_m1) = s% dS_dT_for_partials(k-1)*s% T(k-1) - end if + end if end function wrap_s_m1 function wrap_s_00(s, k) result(s_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: s_00 integer, intent(in) :: k - s_00 = 0d0 + s_00 = 0d0 s_00%val = s% entropy(k) s_00%d1Array(i_lnd_00) = s% dS_dRho_for_partials(k)*s% rho(k) s_00%d1Array(i_lnT_00) = s% dS_dT_for_partials(k)*s% T(k) @@ -480,7 +480,7 @@ function wrap_s_p1(s, k) result(s_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: s_p1 integer, intent(in) :: k - s_p1 = 0d0 + s_p1 = 0d0 if (k < s%nz) then s_p1%val = s% entropy(k+1) s_p1%d1Array(i_lnd_p1) = s% dS_dRho_for_partials(k+1)*s% rho(k+1) @@ -492,19 +492,19 @@ function wrap_e_m1(s, k) result(e_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: e_m1 integer, intent(in) :: k - e_m1 = 0d0 + e_m1 = 0d0 if (k > 1) then e_m1%val = s% energy(k-1) e_m1%d1Array(i_lnd_m1) = s% dE_dRho_for_partials(k-1)*s% rho(k-1) e_m1%d1Array(i_lnT_m1) = s% Cv_for_partials(k-1)*s% T(k-1) - end if + end if end function wrap_e_m1 function wrap_e_00(s, k) result(e_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: e_00 integer, intent(in) :: k - e_00 = 0d0 + e_00 = 0d0 e_00%val = s% energy(k) e_00%d1Array(i_lnd_00) = s% dE_dRho_for_partials(k)*s% rho(k) e_00%d1Array(i_lnT_00) = s% Cv_for_partials(k)*s% T(k) @@ -514,7 +514,7 @@ function wrap_e_p1(s, k) result(e_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: e_p1 integer, intent(in) :: k - e_p1 = 0d0 + e_p1 = 0d0 if (k < s%nz) then e_p1%val = s% energy(k+1) e_p1%d1Array(i_lnd_p1) = s% dE_dRho_for_partials(k+1)*s% rho(k+1) @@ -526,19 +526,19 @@ function wrap_Peos_m1(s, k) result(Peos_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: Peos_m1 integer, intent(in) :: k - Peos_m1 = 0d0 + Peos_m1 = 0d0 if (k > 1) then Peos_m1%val = s% Peos(k-1) Peos_m1%d1Array(i_lnd_m1) = s%Peos(k-1) * s% chiRho_for_partials(k-1) Peos_m1%d1Array(i_lnT_m1) = s%Peos(k-1) * s% chiT_for_partials(k-1) - end if + end if end function wrap_Peos_m1 function wrap_Peos_00(s, k) result(Peos_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: Peos_00 integer, intent(in) :: k - Peos_00 = 0d0 + Peos_00 = 0d0 Peos_00%val = s% Peos(k) Peos_00%d1Array(i_lnd_00) = s%Peos(k) * s% chiRho_for_partials(k) Peos_00%d1Array(i_lnT_00) = s%Peos(k) * s% chiT_for_partials(k) @@ -548,31 +548,31 @@ function wrap_Peos_p1(s, k) result(Peos_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: Peos_p1 integer, intent(in) :: k - Peos_p1 = 0d0 + Peos_p1 = 0d0 if (k < s%nz) then Peos_p1%val = s% Peos(k+1) Peos_p1%d1Array(i_lnd_p1) = s%Peos(k+1) * s% chiRho_for_partials(k+1) Peos_p1%d1Array(i_lnT_p1) = s%Peos(k+1) * s% chiT_for_partials(k+1) - end if + end if end function wrap_Peos_p1 function wrap_lnPeos_m1(s, k) result(lnPeos_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: lnPeos_m1 integer, intent(in) :: k - lnPeos_m1 = 0d0 + lnPeos_m1 = 0d0 if (k > 1) then lnPeos_m1%val = s% lnPeos(k-1) lnPeos_m1%d1Array(i_lnd_m1) = s% chiRho_for_partials(k-1) lnPeos_m1%d1Array(i_lnT_m1) = s% chiT_for_partials(k-1) - end if + end if end function wrap_lnPeos_m1 function wrap_lnPeos_00(s, k) result(lnPeos_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: lnPeos_00 integer, intent(in) :: k - lnPeos_00 = 0d0 + lnPeos_00 = 0d0 lnPeos_00%val = s% lnPeos(k) lnPeos_00%d1Array(i_lnd_00) = s% chiRho_for_partials(k) lnPeos_00%d1Array(i_lnT_00) = s% chiT_for_partials(k) @@ -582,12 +582,12 @@ function wrap_lnPeos_p1(s, k) result(lnPeos_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: lnPeos_p1 integer, intent(in) :: k - lnPeos_p1 = 0d0 + lnPeos_p1 = 0d0 if (k < s%nz) then lnPeos_p1%val = s% lnPeos(k+1) lnPeos_p1%d1Array(i_lnd_p1) = s% chiRho_for_partials(k+1) lnPeos_p1%d1Array(i_lnT_p1) = s% chiT_for_partials(k+1) - end if + end if end function wrap_lnPeos_p1 function wrap_ChiRho_m1(s, k) result(ChiRho_m1) @@ -595,7 +595,7 @@ function wrap_ChiRho_m1(s, k) result(ChiRho_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: ChiRho_m1 integer, intent(in) :: k - ChiRho_m1 = 0d0 + ChiRho_m1 = 0d0 if (k > 1) then ChiRho_m1%val = s% ChiRho(k-1) ChiRho_m1%d1Array(i_lnd_m1) = s% d_eos_dlnd(i_ChiRho,k-1) @@ -608,7 +608,7 @@ function wrap_ChiRho_00(s, k) result(ChiRho_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: ChiRho_00 integer, intent(in) :: k - ChiRho_00 = 0d0 + ChiRho_00 = 0d0 ChiRho_00%val = s% ChiRho(k) ChiRho_00%d1Array(i_lnd_00) = s% d_eos_dlnd(i_ChiRho,k) ChiRho_00%d1Array(i_lnT_00) = s% d_eos_dlnT(i_ChiRho,k) @@ -619,7 +619,7 @@ function wrap_ChiRho_p1(s, k) result(ChiRho_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: ChiRho_p1 integer, intent(in) :: k - ChiRho_p1 = 0d0 + ChiRho_p1 = 0d0 if (k < s% nz) then ChiRho_p1%val = s% ChiRho(k+1) ChiRho_p1%d1Array(i_lnd_p1) = s% d_eos_dlnd(i_ChiRho,k+1) @@ -632,7 +632,7 @@ function wrap_ChiT_m1(s, k) result(ChiT_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: ChiT_m1 integer, intent(in) :: k - ChiT_m1 = 0d0 + ChiT_m1 = 0d0 if (k > 1) then ChiT_m1%val = s% ChiT(k-1) ChiT_m1%d1Array(i_lnd_m1) = s% d_eos_dlnd(i_ChiT,k-1) @@ -645,7 +645,7 @@ function wrap_ChiT_00(s, k) result(ChiT_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: ChiT_00 integer, intent(in) :: k - ChiT_00 = 0d0 + ChiT_00 = 0d0 ChiT_00%val = s% ChiT(k) ChiT_00%d1Array(i_lnd_00) = s% d_eos_dlnd(i_ChiT,k) ChiT_00%d1Array(i_lnT_00) = s% d_eos_dlnT(i_ChiT,k) @@ -656,7 +656,7 @@ function wrap_ChiT_p1(s, k) result(ChiT_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: ChiT_p1 integer, intent(in) :: k - ChiT_p1 = 0d0 + ChiT_p1 = 0d0 if (k < s% nz) then ChiT_p1%val = s% ChiT(k+1) ChiT_p1%d1Array(i_lnd_p1) = s% d_eos_dlnd(i_ChiT,k+1) @@ -669,12 +669,12 @@ function wrap_Cp_m1(s, k) result(Cp_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: Cp_m1 integer, intent(in) :: k - Cp_m1 = 0d0 + Cp_m1 = 0d0 if (k > 1) then Cp_m1%val = s% Cp(k-1) Cp_m1%d1Array(i_lnd_m1) = s% d_eos_dlnd(i_Cp,k-1) Cp_m1%d1Array(i_lnT_m1) = s% d_eos_dlnT(i_Cp,k-1) - end if + end if end function wrap_Cp_m1 function wrap_Cp_00(s, k) result(Cp_00) @@ -682,7 +682,7 @@ function wrap_Cp_00(s, k) result(Cp_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: Cp_00 integer, intent(in) :: k - Cp_00 = 0d0 + Cp_00 = 0d0 Cp_00%val = s% Cp(k) Cp_00%d1Array(i_lnd_00) = s% d_eos_dlnd(i_Cp,k) Cp_00%d1Array(i_lnT_00) = s% d_eos_dlnT(i_Cp,k) @@ -693,12 +693,12 @@ function wrap_Cp_p1(s, k) result(Cp_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: Cp_p1 integer, intent(in) :: k - Cp_p1 = 0d0 + Cp_p1 = 0d0 if (k < s% nz) then Cp_p1%val = s% Cp(k+1) Cp_p1%d1Array(i_lnd_p1) = s% d_eos_dlnd(i_Cp,k+1) Cp_p1%d1Array(i_lnT_p1) = s% d_eos_dlnT(i_Cp,k+1) - end if + end if end function wrap_Cp_p1 function wrap_grad_ad_m1(s, k) result(grad_ad_m1) @@ -706,12 +706,12 @@ function wrap_grad_ad_m1(s, k) result(grad_ad_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: grad_ad_m1 integer, intent(in) :: k - grad_ad_m1 = 0d0 + grad_ad_m1 = 0d0 if (k > 1) then grad_ad_m1%val = s% grada(k-1) grad_ad_m1%d1Array(i_lnd_m1) = s% d_eos_dlnd(i_grad_ad,k-1) grad_ad_m1%d1Array(i_lnT_m1) = s% d_eos_dlnT(i_grad_ad,k-1) - end if + end if end function wrap_grad_ad_m1 function wrap_grad_ad_00(s, k) result(grad_ad_00) @@ -719,7 +719,7 @@ function wrap_grad_ad_00(s, k) result(grad_ad_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: grad_ad_00 integer, intent(in) :: k - grad_ad_00 = 0d0 + grad_ad_00 = 0d0 grad_ad_00%val = s% grada(k) grad_ad_00%d1Array(i_lnd_00) = s% d_eos_dlnd(i_grad_ad,k) grad_ad_00%d1Array(i_lnT_00) = s% d_eos_dlnT(i_grad_ad,k) @@ -730,12 +730,12 @@ function wrap_grad_ad_p1(s, k) result(grad_ad_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: grad_ad_p1 integer, intent(in) :: k - grad_ad_p1 = 0d0 + grad_ad_p1 = 0d0 if (k < s% nz) then grad_ad_p1%val = s% grada(k+1) grad_ad_p1%d1Array(i_lnd_p1) = s% d_eos_dlnd(i_grad_ad,k+1) grad_ad_p1%d1Array(i_lnT_p1) = s% d_eos_dlnT(i_grad_ad,k+1) - end if + end if end function wrap_grad_ad_p1 function wrap_gamma1_m1(s, k) result(gamma1_m1) @@ -743,12 +743,12 @@ function wrap_gamma1_m1(s, k) result(gamma1_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: gamma1_m1 integer, intent(in) :: k - gamma1_m1 = 0d0 + gamma1_m1 = 0d0 if (k > 1) then gamma1_m1%val = s% gamma1(k-1) gamma1_m1%d1Array(i_lnd_m1) = s% d_eos_dlnd(i_gamma1,k-1) gamma1_m1%d1Array(i_lnT_m1) = s% d_eos_dlnT(i_gamma1,k-1) - end if + end if end function wrap_gamma1_m1 function wrap_gamma1_00(s, k) result(gamma1_00) @@ -756,7 +756,7 @@ function wrap_gamma1_00(s, k) result(gamma1_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: gamma1_00 integer, intent(in) :: k - gamma1_00 = 0d0 + gamma1_00 = 0d0 gamma1_00%val = s% gamma1(k) gamma1_00%d1Array(i_lnd_00) = s% d_eos_dlnd(i_gamma1,k) gamma1_00%d1Array(i_lnT_00) = s% d_eos_dlnT(i_gamma1,k) @@ -767,12 +767,12 @@ function wrap_gamma1_p1(s, k) result(gamma1_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: gamma1_p1 integer, intent(in) :: k - gamma1_p1 = 0d0 + gamma1_p1 = 0d0 if (k < s% nz) then gamma1_p1%val = s% gamma1(k+1) gamma1_p1%d1Array(i_lnd_p1) = s% d_eos_dlnd(i_gamma1,k+1) gamma1_p1%d1Array(i_lnT_p1) = s% d_eos_dlnT(i_gamma1,k+1) - end if + end if end function wrap_gamma1_p1 function wrap_latent_ddlnT_m1(s, k) result(latent_ddlnT_m1) @@ -853,7 +853,7 @@ function wrap_L_m1(s, k) result(L_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: L_m1 integer, intent(in) :: k - L_m1 = 0d0 + L_m1 = 0d0 if (k > 1) then L_m1 % val = s%L(k-1) L_m1 % d1Array(i_L_m1) = 1d0 @@ -864,7 +864,7 @@ function wrap_L_00(s, k) result(L_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: L_00 integer, intent(in) :: k - L_00 = 0d0 + L_00 = 0d0 L_00 % val = s%L(k) L_00 % d1Array(i_L_00) = 1d0 end function wrap_L_00 @@ -873,7 +873,7 @@ function wrap_L_p1(s, k) result(L_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: L_p1 integer, intent(in) :: k - L_p1 = 0d0 + L_p1 = 0d0 if (k < s%nz) then L_p1 % val = s%L(k+1) L_p1 % d1Array(i_L_p1) = 1d0 @@ -887,7 +887,7 @@ function wrap_r_m1(s, k) result(r_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: r_m1 integer, intent(in) :: k - r_m1 = 0d0 + r_m1 = 0d0 if (k > 1) then r_m1 % val = s%r(k-1) r_m1 % d1Array(i_lnR_m1) = s%r(k-1) @@ -898,7 +898,7 @@ function wrap_r_00(s, k) result(r_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: r_00 integer, intent(in) :: k - r_00 = 0d0 + r_00 = 0d0 r_00 % val = s%r(k) r_00 % d1Array(i_lnR_00) = s%r(k) end function wrap_r_00 @@ -907,7 +907,7 @@ function wrap_r_p1(s, k) result(r_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: r_p1 integer, intent(in) :: k - r_p1 = 0d0 + r_p1 = 0d0 if (k < s%nz) then r_p1 % val = s%r(k+1) r_p1 % d1Array(i_lnR_p1) = s%r(k+1) @@ -920,7 +920,7 @@ function wrap_lnR_m1(s, k) result(lnR_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: lnR_m1 integer, intent(in) :: k - lnR_m1 = 0d0 + lnR_m1 = 0d0 if (k > 1) then lnR_m1 % val = s%lnR(k-1) lnR_m1 % d1Array(i_lnR_m1) = 1d0 @@ -931,7 +931,7 @@ function wrap_lnR_00(s, k) result(lnR_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: lnR_00 integer, intent(in) :: k - lnR_00 = 0d0 + lnR_00 = 0d0 lnR_00 % val = s%lnR(k) lnR_00 % d1Array(i_lnR_00) = 1d0 end function wrap_lnR_00 @@ -940,7 +940,7 @@ function wrap_lnR_p1(s, k) result(lnR_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: lnR_p1 integer, intent(in) :: k - lnR_p1 = 0d0 + lnR_p1 = 0d0 if (k < s%nz) then lnR_p1 % val = s%lnR(k+1) lnR_p1 % d1Array(i_lnR_p1) = 1d0 @@ -953,8 +953,8 @@ function wrap_dxh_lnR(s, k) result(dxh_lnR) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: dxh_lnR integer, intent(in) :: k - dxh_lnR = 0d0 - dxh_lnR % val = s%dxh_lnR(k) + dxh_lnR = 0d0 + dxh_lnR % val = s%dxh_lnR(k) dxh_lnR % d1Array(i_lnR_00) = 1d0 end function wrap_dxh_lnR @@ -989,7 +989,7 @@ function wrap_v_m1(s, k) result(v_m1) v_m1 = wrap_u_face_m1(s,k) return end if - v_m1 = 0d0 + v_m1 = 0d0 if (k > 1) then v_m1 % val = s%v(k-1) v_m1 % d1Array(i_v_m1) = 1d0 @@ -1004,7 +1004,7 @@ function wrap_v_00(s, k) result(v_00) v_00 = wrap_u_face_00(s,k) return end if - v_00 = 0d0 + v_00 = 0d0 v_00 % val = s%v(k) v_00 % d1Array(i_v_00) = 1d0 end function wrap_v_00 @@ -1017,7 +1017,7 @@ function wrap_v_p1(s, k) result(v_p1) v_p1 = wrap_u_face_p1(s,k) return end if - v_p1 = 0d0 + v_p1 = 0d0 if (k < s%nz) then v_p1 % val = s%v(k+1) v_p1 % d1Array(i_v_p1) = 1d0 @@ -1026,7 +1026,7 @@ function wrap_v_p1(s, k) result(v_p1) ! v_center is a constant end if end function wrap_v_p1 - + function wrap_opt_time_center_r_m1(s, k) result(r_tc) type (star_info), pointer :: s integer, intent(in) :: k @@ -1036,7 +1036,7 @@ function wrap_opt_time_center_r_m1(s, k) result(r_tc) if (k > 1) r_tc = 0.5d0*(r_tc + s% r_start(k-1)) end if end function wrap_opt_time_center_r_m1 - + function wrap_opt_time_center_r_00(s, k) result(r_tc) type (star_info), pointer :: s integer, intent(in) :: k @@ -1045,7 +1045,7 @@ function wrap_opt_time_center_r_00(s, k) result(r_tc) if (s% using_velocity_time_centering) & r_tc = 0.5d0*(r_tc + s% r_start(k)) end function wrap_opt_time_center_r_00 - + function wrap_opt_time_center_r_p1(s, k) result(r_tc) type (star_info), pointer :: s integer, intent(in) :: k @@ -1059,7 +1059,7 @@ function wrap_opt_time_center_r_p1(s, k) result(r_tc) end if end if end function wrap_opt_time_center_r_p1 - + function wrap_opt_time_center_v_m1(s, k) result(v_tc) type (star_info), pointer :: s integer, intent(in) :: k @@ -1067,7 +1067,7 @@ function wrap_opt_time_center_v_m1(s, k) result(v_tc) v_tc = 0 if (k == 1) return if (s% v_flag) then - v_tc = wrap_v_m1(s,k) + v_tc = wrap_v_m1(s,k) if (s% using_velocity_time_centering) & v_tc = 0.5d0*(v_tc + s% v_start(k-1)) else if (s% u_flag) then @@ -1076,7 +1076,7 @@ function wrap_opt_time_center_v_m1(s, k) result(v_tc) v_tc = 0.5d0*(v_tc + s% u_face_start(k-1)) end if end function wrap_opt_time_center_v_m1 - + function wrap_opt_time_center_v_00(s, k) result(v_tc) type (star_info), pointer :: s integer, intent(in) :: k @@ -1092,7 +1092,7 @@ function wrap_opt_time_center_v_00(s, k) result(v_tc) v_tc = 0.5d0*(v_tc + s% u_face_start(k)) end if end function wrap_opt_time_center_v_00 - + function wrap_opt_time_center_v_p1(s, k) result(v_tc) type (star_info), pointer :: s integer, intent(in) :: k @@ -1100,7 +1100,7 @@ function wrap_opt_time_center_v_p1(s, k) result(v_tc) v_tc = 0 if (k == s% nz) return if (s% v_flag) then - v_tc = wrap_v_p1(s,k) + v_tc = wrap_v_p1(s,k) if (s% using_velocity_time_centering) & v_tc = 0.5d0*(v_tc + s% v_start(k+1)) else if (s% u_flag) then @@ -1114,7 +1114,7 @@ function wrap_u_m1(s, k) result(v_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: v_m1 integer, intent(in) :: k - v_m1 = 0d0 + v_m1 = 0d0 if (k > 1) then v_m1 % val = s%u(k-1) v_m1 % d1Array(i_v_m1) = 1d0 @@ -1125,7 +1125,7 @@ function wrap_u_00(s, k) result(v_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: v_00 integer, intent(in) :: k - v_00 = 0d0 + v_00 = 0d0 v_00 % val = s%u(k) v_00 % d1Array(i_v_00) = 1d0 end function wrap_u_00 @@ -1134,7 +1134,7 @@ function wrap_u_p1(s, k) result(v_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: v_p1 integer, intent(in) :: k - v_p1 = 0d0 + v_p1 = 0d0 if (k < s%nz) then v_p1 % val = s%u(k+1) v_p1 % d1Array(i_v_p1) = 1d0 @@ -1148,7 +1148,7 @@ function wrap_Hp_m1(s, k) result(Hp_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: Hp_m1 integer, intent(in) :: k - Hp_m1 = 0d0 + Hp_m1 = 0d0 if (k > 1) then Hp_m1 % val = s%Hp_face(k-1) Hp_m1 % d1Array(i_Hp_m1) = 1d0 @@ -1159,7 +1159,7 @@ function wrap_Hp_00(s, k) result(Hp_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: Hp_00 integer, intent(in) :: k - Hp_00 = 0d0 + Hp_00 = 0d0 Hp_00 % val = s%Hp_face(k) Hp_00 % d1Array(i_Hp_00) = 1d0 end function wrap_Hp_00 @@ -1168,7 +1168,7 @@ function wrap_Hp_p1(s, k) result(Hp_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: Hp_p1 integer, intent(in) :: k - Hp_p1 = 0d0 + Hp_p1 = 0d0 if (k < s%nz) then Hp_p1 % val = s%Hp_face(k+1) Hp_p1 % d1Array(i_Hp_p1) = 1d0 @@ -1180,7 +1180,7 @@ function wrap_w_div_wc_m1(s, k) result(w_div_wc_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: w_div_wc_m1 integer, intent(in) :: k - w_div_wc_m1 = 0d0 + w_div_wc_m1 = 0d0 if (k > 1) then w_div_wc_m1 % val = s% w_div_w_crit_roche(k-1) w_div_wc_m1 % d1Array(i_w_div_wc_m1) = 1d0 @@ -1191,7 +1191,7 @@ function wrap_w_div_wc_00(s, k) result(w_div_wc_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: w_div_wc_00 integer, intent(in) :: k - w_div_wc_00 = 0d0 + w_div_wc_00 = 0d0 w_div_wc_00 % val = s% w_div_w_crit_roche(k) w_div_wc_00 % d1Array(i_w_div_wc_00) = 1d0 end function wrap_w_div_wc_00 @@ -1200,7 +1200,7 @@ function wrap_w_div_wc_p1(s, k) result(w_div_wc_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: w_div_wc_p1 integer, intent(in) :: k - w_div_wc_p1 = 0d0 + w_div_wc_p1 = 0d0 if (k < s%nz) then w_div_wc_p1 % val = s% w_div_w_crit_roche(k+1) w_div_wc_p1 % d1Array(i_w_div_wc_p1) = 1d0 @@ -1212,7 +1212,7 @@ function wrap_jrot_m1(s, k) result(jrot_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: jrot_m1 integer, intent(in) :: k - jrot_m1 = 0d0 + jrot_m1 = 0d0 if (k > 1) then jrot_m1 % val = s% j_rot(k-1) jrot_m1 % d1Array(i_jrot_m1) = 1d0 @@ -1223,7 +1223,7 @@ function wrap_jrot_00(s, k) result(jrot_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: jrot_00 integer, intent(in) :: k - jrot_00 = 0d0 + jrot_00 = 0d0 jrot_00 % val = s% j_rot(k) jrot_00 % d1Array(i_jrot_00) = 1d0 end function wrap_jrot_00 @@ -1232,7 +1232,7 @@ function wrap_jrot_p1(s, k) result(jrot_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: jrot_p1 integer, intent(in) :: k - jrot_p1 = 0d0 + jrot_p1 = 0d0 if (k < s%nz) then jrot_p1 % val = s% j_rot(k+1) jrot_p1 % d1Array(i_jrot_p1) = 1d0 @@ -1263,7 +1263,7 @@ function wrap_omega_p1(s, k) result(omega_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: omega_p1, jrot_p1 integer, intent(in) :: k - omega_p1 = 0d0 + omega_p1 = 0d0 jrot_p1 = wrap_jrot_p1(s,k) if (k < s%nz) then omega_p1 = jrot_p1/shift_p1(s% i_rot(k+1)) @@ -1275,7 +1275,7 @@ function wrap_xtra1_m1(s, k) result(xtra1_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: xtra1_m1 integer, intent(in) :: k - xtra1_m1 = 0d0 + xtra1_m1 = 0d0 if (k > 1) then xtra1_m1 % val = 0d0 xtra1_m1 % d1Array(i_xtra1_m1) = 1d0 @@ -1286,8 +1286,8 @@ function wrap_xtra1_00(s, k) result(xtra1_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: xtra1_00 integer, intent(in) :: k - xtra1_00 = 0d0 - xtra1_00 % val = 0d0 + xtra1_00 = 0d0 + xtra1_00 % val = 0d0 xtra1_00 % d1Array(i_xtra1_00) = 1d0 end function wrap_xtra1_00 @@ -1295,9 +1295,9 @@ function wrap_xtra1_p1(s, k) result(xtra1_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: xtra1_p1 integer, intent(in) :: k - xtra1_p1 = 0d0 + xtra1_p1 = 0d0 if (k < s%nz) then - xtra1_p1 % val = 0d0 + xtra1_p1 % val = 0d0 xtra1_p1 % d1Array(i_xtra1_p1) = 1d0 end if end function wrap_xtra1_p1 @@ -1307,7 +1307,7 @@ function wrap_xtra2_m1(s, k) result(xtra2_m1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: xtra2_m1 integer, intent(in) :: k - xtra2_m1 = 0d0 + xtra2_m1 = 0d0 if (k > 1) then xtra2_m1 % val = 0d0 xtra2_m1 % d1Array(i_xtra2_m1) = 1d0 @@ -1318,7 +1318,7 @@ function wrap_xtra2_00(s, k) result(xtra2_00) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: xtra2_00 integer, intent(in) :: k - xtra2_00 = 0d0 + xtra2_00 = 0d0 xtra2_00 % val = 0d0 xtra2_00 % d1Array(i_xtra2_00) = 1d0 end function wrap_xtra2_00 @@ -1327,7 +1327,7 @@ function wrap_xtra2_p1(s, k) result(xtra2_p1) type (star_info), pointer :: s type(auto_diff_real_star_order1) :: xtra2_p1 integer, intent(in) :: k - xtra2_p1 = 0d0 + xtra2_p1 = 0d0 if (k < s%nz) then xtra2_p1 % val = 0d0 xtra2_p1 % d1Array(i_xtra2_p1) = 1d0 diff --git a/star/private/brunt.f90 b/star/private/brunt.f90 index 7bf3233ca..2af4acdd1 100644 --- a/star/private/brunt.f90 +++ b/star/private/brunt.f90 @@ -56,7 +56,7 @@ subroutine do_brunt_B(s,nzlo,nzhi,ierr) ierr = 0 nz = s% nz - + if (.not. s% calculate_Brunt_B) then call set_nan(s% brunt_B(1:nz)) call set_nan(s% unsmoothed_brunt_B(1:nz)) @@ -233,7 +233,7 @@ subroutine do_brunt_B_MHM_form(s, nzlo, nzhi, ierr) !$OMP END PARALLEL DO end subroutine do_brunt_B_MHM_form - + subroutine get_brunt_B(s, species, nz, k, T_face, rho_face, chiT_face, chiRho_face, ierr) use eos_def, only: num_eos_basic_results, num_eos_d_dxa_results, i_lnPgas diff --git a/star/private/conv_premix.f90 b/star/private/conv_premix.f90 index 4b3baa8ba..037494528 100644 --- a/star/private/conv_premix.f90 +++ b/star/private/conv_premix.f90 @@ -197,11 +197,11 @@ subroutine do_conv_premix (s, ierr) s% need_to_setvars = .true. if (s% doing_timing) call update_time(s, time0, total, s% time_conv_premix) - + return end subroutine do_conv_premix - + !**** subroutine advance_bdy_ (s, update_mode, zi, i_bdy, t_bdy, sd, j_it) @@ -250,7 +250,7 @@ subroutine advance_bdy_ (s, update_mode, zi, i_bdy, t_bdy, sd, j_it) elseif (.NOT. t_bdy .AND. zi(i_bdy)%kc_b == s%nz) then zi(i_bdy)%sel_b = .FALSE. endif - + ! Check whether the advancing face is still selected if ((t_bdy .AND. .NOT. zi(i_bdy)%sel_t) .OR. & @@ -361,7 +361,7 @@ subroutine advance_bdy_by_one_cell_ (s, update_mode, zi, i_bdy, t_bdy, sd) if (t_bdy) then if (zi(i_bdy)%dt_t + delta_dt > dt_limit) then - + zi(i_bdy)%sel_t = .FALSE. if (TRACE_MIX_CELL) then @@ -476,7 +476,7 @@ subroutine advance_bdy_by_one_cell_ (s, update_mode, zi, i_bdy, t_bdy, sd) ! subcells m_zone = SUM(s%dm(kc_t:kc_b)) - + do l = 1, s%species avg_xa(l) = (SUM(s%dm(kc_t:kc_b)*s%xa(l,kc_t:kc_b)) + & SUM(m_sub*xa_sub(l,1:kc_sub))) / (m_zone + m_sub*kc_sub) @@ -517,7 +517,7 @@ subroutine advance_bdy_by_one_cell_ (s, update_mode, zi, i_bdy, t_bdy, sd) ! advancing boundary) has_split = .TRUE. - + if (t_bdy) then search_down_loop : do kf = kf_t+1, kf_b-1 @@ -539,7 +539,7 @@ subroutine advance_bdy_by_one_cell_ (s, update_mode, zi, i_bdy, t_bdy, sd) kc_t = kf kf_t = kc_t - + if (TRACE_MIX_SUBCELL) then write(*,*) ' Moved upper boundary to', kc_t end if @@ -621,7 +621,7 @@ subroutine advance_bdy_by_one_cell_ (s, update_mode, zi, i_bdy, t_bdy, sd) ! Determine whether the face just inside the advancing boundary ! has become/remained convective; if not, revert back to the ! starting model and return - + if (t_bdy) then if (s%mlt_mixing_type(kf_t+1) /= convective_mixing) then @@ -639,7 +639,7 @@ subroutine advance_bdy_by_one_cell_ (s, update_mode, zi, i_bdy, t_bdy, sd) endif else - + if (s%mlt_mixing_type(kf_b-1) /= convective_mixing) then call restore_model_(s, update_mode, sd) @@ -852,7 +852,7 @@ subroutine update_zone_info_ (s, i_bdy, t_bdy, has_split, zi) write(*,*) 'Truncated zone above to', zi(i_bdy+1)%kc_b, zi(i_bdy+1)%vc_b, & s%mlt_mixing_type(zi(i_bdy+1)%kc_b), zi(i_bdy+1)%kc_b-zi(i_bdy+1)%kc_t+1 endif - + else ! Delete the zone @@ -876,18 +876,18 @@ subroutine update_zone_info_ (s, i_bdy, t_bdy, has_split, zi) if (zi(i_bdy-1)%kc_b-zi(i_bdy-1)%kc_t > 1) then ! Truncate the zone - + zi(i_bdy-1)%kc_t = zi(i_bdy-1)%kc_t + 1 zi(i_bdy-1)%vc_t = s%mlt_vc(zi(i_bdy-1)%kc_t+1) if (TRACE_UPDATE_ZONE) then write(*,*) 'Truncated zone below to', zi(i_bdy-1)%kc_t endif - + else ! Delete the zone - + zi = [zi(:i_bdy-2),zi(i_bdy:)] i_bdy = i_bdy - 1 @@ -928,7 +928,7 @@ subroutine update_zone_info_ (s, i_bdy, t_bdy, has_split, zi) zi_new(i)%sel_t = .FALSE. endif endif - + if (zi_new(i)%kc_b == zi(i_bdy)%kc_b) then zi_new(i)%dt_b = zi(i_bdy)%dt_b zi_new(i)%sel_b = zi(i_bdy)%sel_b @@ -950,7 +950,7 @@ subroutine update_zone_info_ (s, i_bdy, t_bdy, has_split, zi) call set_burn_data_(s, zi_new(i)) - ! Initial abundances + ! Initial abundances zi_new(i)%avg_xa = zi(i_bdy)%avg_xa zi_new(i)%davg_xa_dt = zi(i_bdy)%davg_xa_dt @@ -1072,7 +1072,7 @@ subroutine set_burn_data_ (s, zi) integer :: kc ! Set burning data for the zone info - + iso_h1 = s%net_iso(chem_get_iso_id('h1')) iso_he4 = s%net_iso(chem_get_iso_id('he4')) iso_c12 = s%net_iso(chem_get_iso_id('c12')) @@ -1097,7 +1097,7 @@ subroutine set_burn_data_ (s, zi) s%eps_nuc_categories(icno, kc) eps_he_max = s%eps_nuc_categories(i3alf, kc) + & s%eps_nuc_categories(i_burn_c, kc) - + endif end do cell_loop @@ -1169,7 +1169,7 @@ subroutine set_abund_data_ (s, zi) integer :: l ! Set abundance data for the zone info - + allocate(zi%avg_xa(s%species)) allocate(zi%davg_xa_dt(s%species)) @@ -1248,7 +1248,7 @@ subroutine validate_zone_info_ (s, zi) ! (iv) Overlapping zone (cells inside previous/next zone) if (i > 1) then - if (zi(i)%kc_b >= zi(max(1,i-1))%kc_t) then + if (zi(i)%kc_b >= zi(max(1,i-1))%kc_t) then ! bp: max(1,i-1) to prevent bogus warning from gfortran write(*,*) 'conv_premix: Zone bottom inside previous zone' valid = .FALSE. @@ -1440,7 +1440,7 @@ subroutine dump_snapshot_ (s, filename) write(*,*) 'conv_premix: error from call to set_grads' stop end if - + ! Dump the snapshot open(NEWUNIT=unit, FILE=filename, STATUS='REPLACE') @@ -1530,7 +1530,7 @@ subroutine save_model_ (s, update_mode, kc_t, kc_b, sd) end if sd%update_mode(kc_t:kc_b) = update_mode(kc_t:kc_b) - + sd%xa(:,kc_t:kc_b) = s%xa(:,kc_t:kc_b) sd%lnd(kc_t:kc_b) = s%lnd(kc_t:kc_b) @@ -1548,7 +1548,7 @@ subroutine save_model_ (s, update_mode, kc_t, kc_b, sd) write(*,*) ' kf_t:', kf_t write(*,*) ' kf_b:', kf_b end if - + sd%gradL_composition_term(kf_t+1:kf_b-1) = s%gradL_composition_term(kf_t+1:kf_b-1) ! Store indices (used when we call restore_model_) @@ -1594,12 +1594,12 @@ subroutine restore_model_ (s, update_mode, sd) end if update_mode(kc_t:kc_b) = sd%update_mode(kc_t:kc_b) - + s%xa(:,kc_t:kc_b) = sd%xa(:,kc_t:kc_b) - + s%lnd(kc_t:kc_b) = sd%lnd(kc_t:kc_b) s%rho(kc_t:kc_b) = sd%rho(kc_t:kc_b) - + s%lnPgas(kc_t:kc_b) = sd%lnPgas(kc_t:kc_b) s%Pgas(kc_t:kc_b) = sd%Pgas(kc_t:kc_b) @@ -1612,7 +1612,7 @@ subroutine restore_model_ (s, update_mode, sd) write(*,*) ' kf_t:', kf_t write(*,*) ' kf_b:', kf_b end if - + s%gradL_composition_term(kf_t+1:kf_b-1) = sd%gradL_composition_term(kf_t+1:kf_b-1) ! Update the model set those quantities that are not stored diff --git a/star/private/create_initial_model.f90 b/star/private/create_initial_model.f90 index d281067cb..f5aded2dd 100644 --- a/star/private/create_initial_model.f90 +++ b/star/private/create_initial_model.f90 @@ -444,7 +444,7 @@ subroutine get_kap_from_rhoT(cs,logrho,logT,kap) ! this ignores lnfree and eta lnfree_e=0; d_lnfree_e_dlnRho=0; d_lnfree_e_dlnT=0 eta=0; d_eta_dlnRho=0; d_eta_dlnT=0 - + call kap_get( & kap_handle, species, chem_id, net_iso, xa, & logRho, logT, & diff --git a/star/private/ctrls_io.f90 b/star/private/ctrls_io.f90 index 3e566b4a0..ab6bba215 100644 --- a/star/private/ctrls_io.f90 +++ b/star/private/ctrls_io.f90 @@ -39,14 +39,14 @@ module ctrls_io character (len=strlen) :: controls_namelist_name namelist /controls/ & - + ! where to start initial_mass, initial_z, initial_y, initial_he3, & - + ! definition of core boundaries he_core_boundary_h1_fraction, co_core_boundary_he4_fraction, one_core_boundary_he4_c12_fraction, & fe_core_boundary_si28_fraction, neutron_rich_core_boundary_Ye_max, min_boundary_fraction, & - + ! when to stop max_model_number, relax_max_number_retries, max_number_retries, max_age, max_age_in_seconds, max_age_in_days, & num_adjusted_dt_steps_before_max_age, dt_years_for_steps_before_max_age, max_abs_rel_run_E_err, & @@ -83,14 +83,14 @@ module ctrls_io log_g_upper_limit, log_g_lower_limit, power_nuc_burn_upper_limit, power_h_burn_upper_limit, & power_he_burn_upper_limit, power_z_burn_upper_limit, power_nuc_burn_lower_limit, & power_h_burn_lower_limit, power_he_burn_lower_limit, power_z_burn_lower_limit, & - + ! max timesteps max_timestep, max_years_for_timestep, & hi_T_max_years_for_timestep, max_timestep_hi_T_limit, & - + ! output of "snapshots" for restarts photo_interval, photo_digits, photo_directory, & - + ! output of logs and profiles do_history_file, history_interval, write_header_frequency, terminal_interval, & terminal_show_age_units, terminal_show_timestep_units, terminal_show_log_dt, terminal_show_log_age, & @@ -112,16 +112,16 @@ module ctrls_io min_q_for_inner_mach1_location, max_q_for_outer_mach1_location, & conv_core_gap_dq_limit, & alpha_TDC_DAMP, alpha_TDC_DAMPR, alpha_TDC_PtdVdt, & - + ! burn zone eps definitions for use in logs and profiles burn_min1, burn_min2, & max_conv_vel_div_csound_maxq, width_for_limit_conv_vel, max_q_for_limit_conv_vel, & max_mass_in_gm_for_limit_conv_vel, max_r_in_cm_for_limit_conv_vel, & - + ! for reported surface/center abundances surface_avg_abundance_dq, center_avg_value_dq, & - - ! mixing parameters + + ! mixing parameters min_convective_gap, min_thermohaline_gap, min_semiconvection_gap, min_thermohaline_dropout, & max_dropout_gradL_sub_grada, remove_embedded_semiconvection, recalc_mix_info_after_evolve, remove_mixing_glitches, & okay_to_remove_mixing_singleton, prune_bad_cz_min_Hp_height, prune_bad_cz_min_log_eps_nuc, & @@ -192,12 +192,12 @@ module ctrls_io Nieuwenhuijzen_scaling_factor, Vink_scaling_factor, & Dutch_scaling_factor, Bjorklund_scaling_factor, Dutch_wind_lowT_scheme, wind_He_layer_limit, & wind_H_envelope_limit, wind_H_He_envelope_limit, hot_wind_full_on_T, cool_wind_full_on_T, & - + ! composition of added mass accrete_same_as_surface, & accrete_given_mass_fractions, num_accretion_species, accretion_species_id, accretion_species_xa, & accretion_h1, accretion_h2, accretion_he3, accretion_he4, accretion_zfracs, accretion_dump_missing_metals_into_heaviest, & - + ! special list of z fractions z_fraction_li, z_fraction_be, z_fraction_b, z_fraction_c, z_fraction_n,& z_fraction_o, z_fraction_f, z_fraction_ne, z_fraction_na, z_fraction_mg, z_fraction_al, & @@ -205,16 +205,16 @@ module ctrls_io z_fraction_ca, z_fraction_sc, z_fraction_ti, z_fraction_v, z_fraction_cr, z_fraction_mn, & z_fraction_fe, z_fraction_co, z_fraction_ni, z_fraction_cu, z_fraction_zn, & lgT_lo_for_set_new_abundances, lgT_hi_for_set_new_abundances, & - + ! automatic stops for mass loss/gain max_star_mass_for_gain, min_star_mass_for_loss, max_T_center_for_any_mass_loss, max_T_center_for_full_mass_loss, & - + ! extra power source extra_power_source, & - + ! relaxation parameters relax_dlnZ, relax_dY, & - + ! mesh adjustment show_mesh_changes, okay_to_remesh, restore_mesh_on_retry, num_steps_to_hold_mesh_after_retry, & max_rel_delta_IE_for_mesh_total_energy_balance, & @@ -286,7 +286,7 @@ module ctrls_io min_D_mix, min_center_Ye_for_min_D_mix, & smooth_outer_xa_big, smooth_outer_xa_small, nonlocal_NiCo_kap_gamma, nonlocal_NiCo_decay_heat, & dtau_gamma_NiCo_decay_heat, max_logT_for_net, reaction_neuQs_factor, & - + ! element diffusion parameters diffusion_use_iben_macdonald, diffusion_use_paquette, diffusion_use_caplan, diffusion_use_cgs_solver, & diffusion_use_full_net, do_WD_sedimentation_heating, min_xa_for_WD_sedimentation_heating, & @@ -318,7 +318,7 @@ module ctrls_io do_phase_separation_heating, & phase_separation_mixing_use_brunt, & phase_separation_no_diffusion, & - + ! eos controls fix_d_eos_dxa_partials, & @@ -326,13 +326,13 @@ module ctrls_io use_simple_es_for_kap, use_starting_composition_for_kap, & min_kap_for_dPrad_dm_eqn, low_logT_op_mono_full_off, low_logT_op_mono_full_on, high_logT_op_mono_full_off, & high_logT_op_mono_full_on, op_mono_min_X_to_include, use_op_mono_alt_get_kap, & - - + + include_L_in_correction_limits, include_v_in_correction_limits, include_u_in_correction_limits, include_w_in_correction_limits, & - + ! asteroseismology controls get_delta_nu_from_scaled_solar, nu_max_sun, delta_nu_sun, astero_Teff_sun, delta_Pg_mode_freq, & - + ! hydro parameters energy_eqn_option, & opacity_factor, opacity_max, min_logT_for_opacity_factor_off, min_logT_for_opacity_factor_on, & @@ -411,8 +411,8 @@ module ctrls_io RSP2_T_anchor, RSP2_dq_1_factor, RSP2_nz, RSP2_nz_outer, RSP2_nz_div_IBOTOM, RSP2_report_adjust_w, & RSP2_w_min_for_damping, RSP2_source_seed, RSP2_w_fix_if_neg, max_X_for_conv_timescale, min_X_for_conv_timescale, & max_q_for_conv_timescale, min_q_for_conv_timescale, max_q_for_QHSE_timescale, min_q_for_QHSE_timescale, & - - + + ! timestep time_delta_coeff, min_timestep_factor, max_timestep_factor, timestep_factor_for_retries, retry_hold, & neg_mass_fraction_hold, timestep_dt_factor, use_dt_low_pass_controller, & @@ -487,31 +487,31 @@ module ctrls_io use_compression_outer_BC, use_momentum_outer_BC, Tsurf_factor, use_zero_Pgas_outer_BC, & fixed_Psurf, use_fixed_Psurf_outer_BC, fixed_vsurf, use_fixed_vsurf_outer_BC, & - + atm_build_tau_outer, atm_build_dlogtau, atm_build_errtol, & use_T_tau_gradr_factor, & ! starspots do_starspots, fspot, xspot, & - + ! extra heat near surface to model irradiation irradiation_flux, column_depth_for_irradiation, & - + ! uniform extra heat inject_uniform_extra_heat, min_q_for_uniform_extra_heat, max_q_for_uniform_extra_heat, & inject_extra_ergs_sec, base_of_inject_extra_ergs_sec, total_mass_for_inject_extra_ergs_sec, & start_time_for_inject_extra_ergs_sec, duration_for_inject_extra_ergs_sec, & inject_until_reach_model_with_total_energy, & - + ! mass gain or loss no_wind_if_no_rotation, max_logT_for_k_below_const_q, & max_q_for_k_below_const_q, min_q_for_k_below_const_q, max_logT_for_k_const_mass, & min_q_for_k_const_mass, max_q_for_k_const_mass, & - + ! info for debugging stop_for_bad_nums, report_ierr, report_bad_negative_xa, diffusion_dump_call_number, & - + ! controls for the evolve routine trace_evolve, & @@ -528,7 +528,7 @@ module ctrls_io use_other_before_struct_burn_mix, use_other_astero_freq_corr, use_other_timestep_limit, use_other_set_pgstar_controls, & use_other_screening, use_other_rate_get, use_other_net_derivs, use_other_split_burn, use_other_close_gaps, & x_ctrl, x_integer_ctrl, x_logical_ctrl, x_character_ctrl, & - + ! extra files read_extra_controls_inlist, extra_controls_inlist_name, & save_controls_namelist, controls_namelist_name @@ -540,10 +540,10 @@ module ctrls_io subroutine write_controls(s, fname, ierr) type (star_info), pointer :: s character (len=*), intent(in) :: fname - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: iounit character (len=256) :: filename - + ierr = 0 filename = fname @@ -555,7 +555,7 @@ subroutine write_controls(s, fname, ierr) write(*,*) 'failed to open ' // trim(filename) return endif - + call set_controls_for_writing(s, ierr) if (ierr /= 0) then close(iounit) @@ -563,9 +563,9 @@ subroutine write_controls(s, fname, ierr) end if write(iounit, nml=controls, iostat=ierr) - + write(*,*) 'write controls namelist values to "' // trim(filename)//'"' - + close(iounit) end subroutine write_controls @@ -682,7 +682,7 @@ recursive subroutine read_controls_file(s, filename, level, ierr) read_extra_controls_inlist(i) = .false. extra(i) = extra_controls_inlist_name(i) extra_controls_inlist_name(i) = 'undefined' - + if (read_extra(i)) then write(*,*) 'read ' // trim(extra(i)) call read_controls_file(s, extra(i), level+1, ierr) @@ -692,7 +692,7 @@ recursive subroutine read_controls_file(s, filename, level, ierr) end subroutine read_controls_file - + subroutine set_default_controls @@ -868,12 +868,12 @@ subroutine store_controls(s, ierr) s% star_mass_min_limit = star_mass_min_limit s% ejecta_mass_max_limit = ejecta_mass_max_limit s% remnant_mass_min_limit = remnant_mass_min_limit - + s% star_species_mass_min_limit = star_species_mass_min_limit s% star_species_mass_min_limit_iso = star_species_mass_min_limit_iso s% star_species_mass_max_limit = star_species_mass_max_limit s% star_species_mass_max_limit_iso = star_species_mass_max_limit_iso - + s% xmstar_min_limit = xmstar_min_limit s% xmstar_max_limit = xmstar_max_limit s% envelope_mass_limit = envelope_mass_limit @@ -993,7 +993,7 @@ subroutine store_controls(s, ierr) s% min_tau_for_max_abs_v_location = min_tau_for_max_abs_v_location s% min_q_for_inner_mach1_location = min_q_for_inner_mach1_location s% max_q_for_outer_mach1_location = max_q_for_outer_mach1_location - + s% conv_core_gap_dq_limit = conv_core_gap_dq_limit ! burn zone eps definitions for use in logs and profiles @@ -1059,7 +1059,7 @@ subroutine store_controls(s, ierr) s% superad_reduction_gamma_inv_scale = superad_reduction_gamma_inv_scale s% superad_reduction_diff_grads_limit = superad_reduction_diff_grads_limit s% superad_reduction_limit = superad_reduction_limit - + s% max_logT_for_mlt = max_logT_for_mlt s% mlt_make_surface_no_mixing = mlt_make_surface_no_mixing s% do_normalize_dqs_as_part_of_set_qs = do_normalize_dqs_as_part_of_set_qs @@ -1084,7 +1084,7 @@ subroutine store_controls(s, ierr) s% burn_h_mix_region_logT = burn_h_mix_region_logT s% max_Y_for_burn_z_mix_region = max_Y_for_burn_z_mix_region s% max_X_for_burn_he_mix_region = max_X_for_burn_he_mix_region - + s% limit_overshoot_Hp_using_size_of_convection_zone = limit_overshoot_Hp_using_size_of_convection_zone s% predictive_mix = predictive_mix @@ -1341,7 +1341,7 @@ subroutine store_controls(s, ierr) s% wind_boost_full_on_L_div_Ledd = wind_boost_full_on_L_div_Ledd s% super_eddington_wind_max_boost = super_eddington_wind_max_boost s% trace_super_eddington_wind_boost = trace_super_eddington_wind_boost - + s% max_tries_for_implicit_wind = max_tries_for_implicit_wind s% iwind_tolerance = iwind_tolerance s% iwind_lambda = iwind_lambda @@ -1533,7 +1533,7 @@ subroutine store_controls(s, ierr) s% mesh_dlog_pnhe4_dlogP_extra = mesh_dlog_pnhe4_dlogP_extra s% mesh_dlog_photo_dlogP_extra = mesh_dlog_photo_dlogP_extra s% mesh_dlog_other_dlogP_extra = mesh_dlog_other_dlogP_extra - + s% mesh_delta_coeff_factor_smooth_iters = mesh_delta_coeff_factor_smooth_iters s% T_function1_weight = T_function1_weight @@ -1565,7 +1565,7 @@ subroutine store_controls(s, ierr) s% xa_function_weight = xa_function_weight s% xa_function_param = xa_function_param s% xa_mesh_delta_coeff = xa_mesh_delta_coeff - + s% use_split_merge_amr = use_split_merge_amr s% split_merge_amr_nz_baseline = split_merge_amr_nz_baseline s% split_merge_amr_nz_r_core = split_merge_amr_nz_r_core @@ -1804,7 +1804,7 @@ subroutine store_controls(s, ierr) s% high_logT_op_mono_full_on = high_logT_op_mono_full_on s% op_mono_min_X_to_include = op_mono_min_X_to_include s% use_op_mono_alt_get_kap = use_op_mono_alt_get_kap - + s% include_L_in_correction_limits = include_L_in_correction_limits s% include_v_in_correction_limits = include_v_in_correction_limits s% include_u_in_correction_limits = include_u_in_correction_limits @@ -1864,7 +1864,7 @@ subroutine store_controls(s, ierr) s% RTI_energy_floor = RTI_energy_floor s% RTI_D_mix_floor = RTI_D_mix_floor s% RTI_min_m_for_D_mix_floor = RTI_min_m_for_D_mix_floor - s% RTI_log_max_boost = RTI_log_max_boost + s% RTI_log_max_boost = RTI_log_max_boost s% RTI_m_full_boost = RTI_m_full_boost s% RTI_m_no_boost = RTI_m_no_boost @@ -1897,7 +1897,7 @@ subroutine store_controls(s, ierr) s% tol_correction_extreme_T_limit = tol_correction_extreme_T_limit s% tol_correction_norm_extreme_T = tol_correction_norm_extreme_T s% tol_max_correction_extreme_T = tol_max_correction_extreme_T - + s% tol_bad_max_correction = tol_bad_max_correction s% bad_max_correction_series_limit = bad_max_correction_series_limit @@ -1909,7 +1909,7 @@ subroutine store_controls(s, ierr) s% tol_max_residual3 = tol_max_residual3 s% warning_limit_for_max_residual = warning_limit_for_max_residual s% trace_solver_damping = trace_solver_damping - + s% relax_use_gold_tolerances = relax_use_gold_tolerances s% relax_tol_correction_norm = relax_tol_correction_norm s% relax_tol_max_correction = relax_tol_max_correction @@ -1923,9 +1923,9 @@ subroutine store_controls(s, ierr) s% relax_tol_residual_norm3 = relax_tol_residual_norm3 s% relax_tol_max_residual3 = relax_tol_max_residual3 s% relax_maxT_for_gold_tolerances = relax_maxT_for_gold_tolerances - + s% use_gold_tolerances = use_gold_tolerances - s% gold_solver_iters_timestep_limit = gold_solver_iters_timestep_limit + s% gold_solver_iters_timestep_limit = gold_solver_iters_timestep_limit s% maxT_for_gold_tolerances = maxT_for_gold_tolerances s% gold_tol_residual_norm1 = gold_tol_residual_norm1 s% gold_tol_max_residual1 = gold_tol_max_residual1 @@ -1936,9 +1936,9 @@ subroutine store_controls(s, ierr) s% gold_tol_residual_norm3 = gold_tol_residual_norm3 s% gold_tol_max_residual3 = gold_tol_max_residual3 s% steps_before_use_gold_tolerances = steps_before_use_gold_tolerances - + s% use_gold2_tolerances = use_gold2_tolerances - s% gold2_solver_iters_timestep_limit = gold2_solver_iters_timestep_limit + s% gold2_solver_iters_timestep_limit = gold2_solver_iters_timestep_limit s% gold2_tol_residual_norm1 = gold2_tol_residual_norm1 s% gold2_tol_max_residual1 = gold2_tol_max_residual1 s% gold2_iter_for_resid_tol2 = gold2_iter_for_resid_tol2 @@ -1948,7 +1948,7 @@ subroutine store_controls(s, ierr) s% gold2_tol_residual_norm3 = gold2_tol_residual_norm3 s% gold2_tol_max_residual3 = gold2_tol_max_residual3 s% steps_before_use_gold2_tolerances = steps_before_use_gold2_tolerances - + s% include_rotation_in_total_energy = include_rotation_in_total_energy s% convergence_ignore_equL_residuals = convergence_ignore_equL_residuals @@ -1970,11 +1970,11 @@ subroutine store_controls(s, ierr) s% hydro_mtx_max_allowed_logRho = hydro_mtx_max_allowed_logRho s% hydro_mtx_min_allowed_logT = hydro_mtx_min_allowed_logT s% hydro_mtx_min_allowed_logRho = hydro_mtx_min_allowed_logRho - + s% use_DGESVX_in_bcyclic = use_DGESVX_in_bcyclic s% use_equilibration_in_DGESVX = use_equilibration_in_DGESVX s% report_min_rcond_from_DGESXV = report_min_rcond_from_DGESXV - + s% op_split_burn = op_split_burn s% op_split_burn_min_T = op_split_burn_min_T s% op_split_burn_eps = op_split_burn_eps @@ -2065,7 +2065,7 @@ subroutine store_controls(s, ierr) s% RSP2_alfap = RSP2_alfap s% RSP2_alfad = RSP2_alfad - s% RSP2_alfat = RSP2_alfat + s% RSP2_alfat = RSP2_alfat s% RSP2_alfam = RSP2_alfam s% RSP2_alfar = RSP2_alfar s% RSP2_min_Lt_div_L_for_overshooting_mixing_type = RSP2_min_Lt_div_L_for_overshooting_mixing_type @@ -2102,7 +2102,7 @@ subroutine store_controls(s, ierr) s% RSP2_w_min_for_damping = RSP2_w_min_for_damping s% RSP2_source_seed = RSP2_source_seed s% RSP2_w_fix_if_neg = RSP2_w_fix_if_neg - + s% max_X_for_conv_timescale = max_X_for_conv_timescale s% min_X_for_conv_timescale = min_X_for_conv_timescale s% max_q_for_conv_timescale = max_q_for_conv_timescale @@ -2127,7 +2127,7 @@ subroutine store_controls(s, ierr) s% neg_mass_fraction_hold = neg_mass_fraction_hold s% timestep_dt_factor = timestep_dt_factor s% use_dt_low_pass_controller = use_dt_low_pass_controller - + s% force_timestep_min = force_timestep_min s% force_timestep_min_years = force_timestep_min_years s% force_timestep_min_factor = force_timestep_min_factor @@ -2153,7 +2153,7 @@ subroutine store_controls(s, ierr) s% dt_div_dt_cell_collapse_hard_limit = dt_div_dt_cell_collapse_hard_limit s% dt_div_min_dr_div_cs_limit = dt_div_min_dr_div_cs_limit s% dt_div_min_dr_div_cs_hard_limit = dt_div_min_dr_div_cs_hard_limit - + s% min_abs_du_div_cs_for_dt_div_min_dr_div_cs_limit = min_abs_du_div_cs_for_dt_div_min_dr_div_cs_limit s% min_abs_u_div_cs_for_dt_div_min_dr_div_cs_limit = min_abs_u_div_cs_for_dt_div_min_dr_div_cs_limit s% min_k_for_dt_div_min_dr_div_cs_limit = min_k_for_dt_div_min_dr_div_cs_limit @@ -2173,7 +2173,7 @@ subroutine store_controls(s, ierr) s% dX_div_X_at_high_T_limit = dX_div_X_at_high_T_limit s% dX_div_X_at_high_T_hard_limit = dX_div_X_at_high_T_hard_limit s% dX_div_X_at_high_T_limit_lgT_min = dX_div_X_at_high_T_limit_lgT_min - + s% dX_decreases_only = dX_decreases_only s% dX_nuc_drop_min_X_limit = dX_nuc_drop_min_X_limit @@ -2245,7 +2245,7 @@ subroutine store_controls(s, ierr) s% delta_lgL_nuc_at_high_T_limit = delta_lgL_nuc_at_high_T_limit s% delta_lgL_nuc_at_high_T_hard_limit = delta_lgL_nuc_at_high_T_hard_limit s% delta_lgL_nuc_at_high_T_limit_lgT_min = delta_lgL_nuc_at_high_T_limit_lgT_min - + s% max_lgT_for_lgL_nuc_limit = max_lgT_for_lgL_nuc_limit s% lgL_nuc_burn_min = lgL_nuc_burn_min s% lgL_nuc_drop_factor = lgL_nuc_drop_factor @@ -2560,7 +2560,7 @@ subroutine set_controls_for_writing(s, ierr) star_mass_min_limit = s% star_mass_min_limit ejecta_mass_max_limit = s% ejecta_mass_max_limit remnant_mass_min_limit = s% remnant_mass_min_limit - + star_species_mass_min_limit = s% star_species_mass_min_limit star_species_mass_min_limit_iso = s% star_species_mass_min_limit_iso star_species_mass_max_limit = s% star_species_mass_max_limit @@ -2670,7 +2670,7 @@ subroutine set_controls_for_writing(s, ierr) fgong_header = s% fgong_header fgong_ivers = s% fgong_ivers - + max_num_gyre_points = s% max_num_gyre_points format_for_OSC_data = s% format_for_OSC_data fgong_zero_A_inside_r = s% fgong_zero_A_inside_r @@ -2687,7 +2687,7 @@ subroutine set_controls_for_writing(s, ierr) min_tau_for_max_abs_v_location = s% min_tau_for_max_abs_v_location min_q_for_inner_mach1_location = s% min_q_for_inner_mach1_location max_q_for_outer_mach1_location = s% max_q_for_outer_mach1_location - + conv_core_gap_dq_limit = s% conv_core_gap_dq_limit ! burn zone eps definitions for use in logs and profiles @@ -2739,7 +2739,7 @@ subroutine set_controls_for_writing(s, ierr) gradT_excess_beta2 = s% gradT_excess_beta2 gradT_excess_dlambda = s% gradT_excess_dlambda gradT_excess_dbeta = s% gradT_excess_dbeta - + D_mix_zero_region_bottom_q = s% D_mix_zero_region_bottom_q D_mix_zero_region_top_q = s% D_mix_zero_region_top_q dq_D_mix_zero_at_H_He_crossover = s% dq_D_mix_zero_at_H_He_crossover @@ -2751,7 +2751,7 @@ subroutine set_controls_for_writing(s, ierr) superad_reduction_gamma_inv_scale = s% superad_reduction_gamma_inv_scale superad_reduction_diff_grads_limit = s% superad_reduction_diff_grads_limit superad_reduction_limit = s% superad_reduction_limit - + max_logT_for_mlt = s% max_logT_for_mlt mlt_make_surface_no_mixing = s% mlt_make_surface_no_mixing do_normalize_dqs_as_part_of_set_qs = s% do_normalize_dqs_as_part_of_set_qs @@ -2776,7 +2776,7 @@ subroutine set_controls_for_writing(s, ierr) burn_h_mix_region_logT = s% burn_h_mix_region_logT max_Y_for_burn_z_mix_region = s% max_Y_for_burn_z_mix_region max_X_for_burn_he_mix_region = s% max_X_for_burn_he_mix_region - + limit_overshoot_Hp_using_size_of_convection_zone = s% limit_overshoot_Hp_using_size_of_convection_zone predictive_mix = s% predictive_mix @@ -2824,7 +2824,7 @@ subroutine set_controls_for_writing(s, ierr) min_overshoot_q = s% min_overshoot_q overshoot_alpha = s% overshoot_alpha - + RSP_max_num_periods = s% RSP_max_num_periods RSP_target_steps_per_cycle = s% RSP_target_steps_per_cycle RSP_min_max_R_for_periods = s% RSP_min_max_R_for_periods @@ -2976,7 +2976,7 @@ subroutine set_controls_for_writing(s, ierr) atm_build_tau_outer = s% atm_build_tau_outer atm_build_dlogtau = s% atm_build_dlogtau atm_build_errtol = s% atm_build_errtol - + use_T_tau_gradr_factor = s% use_T_tau_gradr_factor ! starspots @@ -3016,7 +3016,7 @@ subroutine set_controls_for_writing(s, ierr) nu_omega_mixing_rate = s% nu_omega_mixing_rate nu_omega_mixing_across_convection_boundary = s% nu_omega_mixing_across_convection_boundary max_q_for_nu_omega_zero_in_convection_region = s% max_q_for_nu_omega_zero_in_convection_region - + mdot_omega_power = s% mdot_omega_power max_rotational_mdot_boost = s% max_rotational_mdot_boost max_mdot_jump_for_rotation = s% max_mdot_jump_for_rotation @@ -3032,7 +3032,7 @@ subroutine set_controls_for_writing(s, ierr) wind_boost_full_on_L_div_Ledd = s% wind_boost_full_on_L_div_Ledd super_eddington_wind_max_boost = s% super_eddington_wind_max_boost trace_super_eddington_wind_boost = s% trace_super_eddington_wind_boost - + max_tries_for_implicit_wind = s% max_tries_for_implicit_wind iwind_tolerance = s% iwind_tolerance iwind_lambda = s% iwind_lambda @@ -3218,7 +3218,7 @@ subroutine set_controls_for_writing(s, ierr) mesh_dlog_pnhe4_dlogP_extra = s% mesh_dlog_pnhe4_dlogP_extra mesh_dlog_photo_dlogP_extra = s% mesh_dlog_photo_dlogP_extra mesh_dlog_other_dlogP_extra = s% mesh_dlog_other_dlogP_extra - + mesh_delta_coeff_factor_smooth_iters = s% mesh_delta_coeff_factor_smooth_iters T_function1_weight = s% T_function1_weight @@ -3250,7 +3250,7 @@ subroutine set_controls_for_writing(s, ierr) xa_function_weight = s% xa_function_weight xa_function_param = s% xa_function_param xa_mesh_delta_coeff = s% xa_mesh_delta_coeff - + use_split_merge_amr = s% use_split_merge_amr split_merge_amr_nz_baseline = s% split_merge_amr_nz_baseline split_merge_amr_nz_r_core = s% split_merge_amr_nz_r_core @@ -3475,7 +3475,7 @@ subroutine set_controls_for_writing(s, ierr) ! eos controls fix_d_eos_dxa_partials = s% fix_d_eos_dxa_partials - + ! opacity controls use_simple_es_for_kap = s% use_simple_es_for_kap use_starting_composition_for_kap = s% use_starting_composition_for_kap @@ -3545,7 +3545,7 @@ subroutine set_controls_for_writing(s, ierr) RTI_energy_floor = s% RTI_energy_floor RTI_D_mix_floor = s% RTI_D_mix_floor RTI_min_m_for_D_mix_floor = s% RTI_min_m_for_D_mix_floor - RTI_log_max_boost = s% RTI_log_max_boost + RTI_log_max_boost = s% RTI_log_max_boost RTI_m_full_boost = s% RTI_m_full_boost RTI_m_no_boost = s% RTI_m_no_boost @@ -3577,7 +3577,7 @@ subroutine set_controls_for_writing(s, ierr) tol_correction_extreme_T_limit = s% tol_correction_extreme_T_limit tol_correction_norm_extreme_T = s% tol_correction_norm_extreme_T tol_max_correction_extreme_T = s% tol_max_correction_extreme_T - + tol_bad_max_correction = s% tol_bad_max_correction bad_max_correction_series_limit = s% bad_max_correction_series_limit @@ -3589,7 +3589,7 @@ subroutine set_controls_for_writing(s, ierr) tol_max_residual3 = s% tol_max_residual3 warning_limit_for_max_residual = s% warning_limit_for_max_residual trace_solver_damping = s% trace_solver_damping - + relax_use_gold_tolerances = s% relax_use_gold_tolerances relax_tol_correction_norm = s% relax_tol_correction_norm relax_tol_max_correction = s% relax_tol_max_correction @@ -3603,9 +3603,9 @@ subroutine set_controls_for_writing(s, ierr) relax_tol_residual_norm3 = s% relax_tol_residual_norm3 relax_tol_max_residual3 = s% relax_tol_max_residual3 relax_maxT_for_gold_tolerances = s% relax_maxT_for_gold_tolerances - + use_gold_tolerances = s% use_gold_tolerances - gold_solver_iters_timestep_limit = s% gold_solver_iters_timestep_limit + gold_solver_iters_timestep_limit = s% gold_solver_iters_timestep_limit maxT_for_gold_tolerances = s% maxT_for_gold_tolerances gold_tol_residual_norm1 = s% gold_tol_residual_norm1 gold_tol_max_residual1 = s% gold_tol_max_residual1 @@ -3616,9 +3616,9 @@ subroutine set_controls_for_writing(s, ierr) gold_tol_residual_norm3 = s% gold_tol_residual_norm3 gold_tol_max_residual3 = s% gold_tol_max_residual3 steps_before_use_gold_tolerances = s% steps_before_use_gold_tolerances - + use_gold2_tolerances = s% use_gold2_tolerances - gold2_solver_iters_timestep_limit = s% gold2_solver_iters_timestep_limit + gold2_solver_iters_timestep_limit = s% gold2_solver_iters_timestep_limit gold2_tol_residual_norm1 = s% gold2_tol_residual_norm1 gold2_tol_max_residual1 = s% gold2_tol_max_residual1 gold2_iter_for_resid_tol2 = s% gold2_iter_for_resid_tol2 @@ -3628,7 +3628,7 @@ subroutine set_controls_for_writing(s, ierr) gold2_tol_residual_norm3 = s% gold2_tol_residual_norm3 gold2_tol_max_residual3 = s% gold2_tol_max_residual3 steps_before_use_gold2_tolerances = s% steps_before_use_gold2_tolerances - + include_rotation_in_total_energy = s% include_rotation_in_total_energy convergence_ignore_equL_residuals = s% convergence_ignore_equL_residuals @@ -3650,11 +3650,11 @@ subroutine set_controls_for_writing(s, ierr) hydro_mtx_max_allowed_logRho = s% hydro_mtx_max_allowed_logRho hydro_mtx_min_allowed_logT = s% hydro_mtx_min_allowed_logT hydro_mtx_min_allowed_logRho = s% hydro_mtx_min_allowed_logRho - + use_DGESVX_in_bcyclic = s% use_DGESVX_in_bcyclic use_equilibration_in_DGESVX = s% use_equilibration_in_DGESVX report_min_rcond_from_DGESXV = s% report_min_rcond_from_DGESXV - + op_split_burn = s% op_split_burn op_split_burn_min_T = s% op_split_burn_min_T op_split_burn_eps = s% op_split_burn_eps @@ -3745,7 +3745,7 @@ subroutine set_controls_for_writing(s, ierr) RSP2_alfap= s% RSP2_alfap RSP2_alfad = s% RSP2_alfad - RSP2_alfat= s% RSP2_alfat + RSP2_alfat= s% RSP2_alfat RSP2_alfam= s% RSP2_alfam RSP2_alfar= s% RSP2_alfar RSP2_min_Lt_div_L_for_overshooting_mixing_type = s% RSP2_min_Lt_div_L_for_overshooting_mixing_type @@ -3807,7 +3807,7 @@ subroutine set_controls_for_writing(s, ierr) neg_mass_fraction_hold = s% neg_mass_fraction_hold timestep_dt_factor = s% timestep_dt_factor use_dt_low_pass_controller = s% use_dt_low_pass_controller - + force_timestep_min = s% force_timestep_min force_timestep_min_years = s% force_timestep_min_years force_timestep_min_factor = s% force_timestep_min_factor @@ -3833,7 +3833,7 @@ subroutine set_controls_for_writing(s, ierr) dt_div_dt_cell_collapse_hard_limit = s% dt_div_dt_cell_collapse_hard_limit dt_div_min_dr_div_cs_limit = s% dt_div_min_dr_div_cs_limit dt_div_min_dr_div_cs_hard_limit = s% dt_div_min_dr_div_cs_hard_limit - + min_abs_du_div_cs_for_dt_div_min_dr_div_cs_limit = s% min_abs_du_div_cs_for_dt_div_min_dr_div_cs_limit min_abs_u_div_cs_for_dt_div_min_dr_div_cs_limit = s% min_abs_u_div_cs_for_dt_div_min_dr_div_cs_limit min_k_for_dt_div_min_dr_div_cs_limit = s% min_k_for_dt_div_min_dr_div_cs_limit @@ -3923,7 +3923,7 @@ subroutine set_controls_for_writing(s, ierr) delta_lgL_nuc_at_high_T_limit = s% delta_lgL_nuc_at_high_T_limit delta_lgL_nuc_at_high_T_hard_limit = s% delta_lgL_nuc_at_high_T_hard_limit delta_lgL_nuc_at_high_T_limit_lgT_min = s% delta_lgL_nuc_at_high_T_limit_lgT_min - + max_lgT_for_lgL_nuc_limit = s% max_lgT_for_lgL_nuc_limit lgL_nuc_burn_min = s% lgL_nuc_burn_min lgL_nuc_drop_factor = s% lgL_nuc_drop_factor @@ -4121,7 +4121,7 @@ subroutine set_controls_for_writing(s, ierr) num_cells_for_smooth_brunt_B = s% num_cells_for_smooth_brunt_B steps_before_start_stress_test = s% steps_before_start_stress_test stress_test_relax = s% stress_test_relax - + end subroutine set_controls_for_writing @@ -4151,7 +4151,7 @@ subroutine get_control(s, name, val, ierr) upper_name = trim(StrUpCase(name))//'=' val = '' ! Search for name inside namelist - do + do read(iounit,'(A)',iostat=iostat) str ind = index(trim(str),trim(upper_name)) if( ind /= 0 ) then diff --git a/star/private/diffusion_procs.f90 b/star/private/diffusion_procs.f90 index 6821910b1..79e64fc2e 100644 --- a/star/private/diffusion_procs.f90 +++ b/star/private/diffusion_procs.f90 @@ -248,7 +248,7 @@ subroutine fix_negative_masses( & fix1: do j=1,nc - if (mass(j,k) >= 0d0) cycle + if (mass(j,k) >= 0d0) cycle fix1 if (mass(j,k) >= -1d-13*cell_dm(k)) then mass(j,k) = 0d0 cycle fix1 diff --git a/star/private/diffusion_support.f90 b/star/private/diffusion_support.f90 index f1474696d..ae8329391 100644 --- a/star/private/diffusion_support.f90 +++ b/star/private/diffusion_support.f90 @@ -33,7 +33,7 @@ module diffusion_support implicit none - + real(dp), parameter :: Xlim = 1d-14 real(dp), parameter :: tiny_mass = 1d3 ! a kilogram real(dp), parameter :: tinyX = 1d-50 @@ -55,7 +55,7 @@ subroutine get_matrix_coeffs( & g_ap, g_at, g_ar, g_ax, g_field_face, & v_advection_face, v_total_face, vlnP_face, vlnT_face, v_rad_face, & GT_face, D_self_face, AD_face, SIG_face, sigma_lnC, ierr) - + type (star_info), pointer :: s integer, intent(in) :: & nz, nc, m, nzlo, nzhi, ih1, ihe4 @@ -78,7 +78,7 @@ subroutine get_matrix_coeffs( & vlnP_face, vlnT_face, v_rad_face, GT_face, e_ax, g_ax, D_self_face real(dp), dimension(:,:,:), intent(out) :: SIG_face, sigma_lnC integer, intent(out) :: ierr - + integer :: i, j, k, op_err real(dp) :: tmp, tinyX, dlamch, sfmin, & AD_dm_full_on, AD_dm_full_off, AD_boost_factor, sum_dm, & @@ -87,12 +87,12 @@ subroutine get_matrix_coeffs( & real(dp), dimension(m) :: C_face, Z_face, dC_dr_face real(dp), dimension(nc) :: total_diffusion_factor real(dp) :: dlnne_dr_face - + include 'formats' - + ierr = 0 - sfmin = dlamch('S') - + sfmin = dlamch('S') + tinyX = 1d-50 do k=nzlo,nzhi do j=1,nc @@ -104,14 +104,14 @@ subroutine get_matrix_coeffs( & C(j,k) = X(j,k)*C_div_X(j,k) end do C(m,k) = 1d0 - X(m,k) = A(m)/dot_product(A(1:nc),C(1:nc,k)) + X(m,k) = A(m)/dot_product(A(1:nc),C(1:nc,k)) end do - + Vlimit_dm_full_on = s% diffusion_Vlimit_dm_full_on*Msun Vlimit_dm_full_off = s% diffusion_Vlimit_dm_full_off*Msun Vlimit = s% diffusion_Vlimit - + !$OMP PARALLEL DO PRIVATE(k, j, i, total_diffusion_factor, op_err, C_face, Z_face, dC_dr_face, dlnne_dr_face, tmp) SCHEDULE(dynamic,2) do k = nzlo+1, nzhi @@ -126,12 +126,12 @@ subroutine get_matrix_coeffs( & else total_diffusion_factor(1:nc) = diffusion_factor(1:nc) end if - + call get1_CXZn_face( & k, nz, nc, m, nzlo, nzhi, C, X, Z, A, alfa_face, tiny_C, & four_pi_r2_rho_face(k)/dm_bar(k), dlnRho_dr_face(k), & C_face, X_face, Z_face, C_div_X_face, dC_dr_face, dlnne_dr_face) - + op_err = 0 call get1_coeffs_face( & s, k, nz, nc, m, nzlo, nzhi, ih1, ihe4, pure_Coulomb, & @@ -191,21 +191,21 @@ subroutine get_matrix_coeffs( & v_total_face(i,k) = v_total_face(i,k) - sigma_lnC(i,j,k)*dC_dr_face(j)/C_face(j) end do end do - + end do !$OMP END PARALLEL DO if (ierr /= 0) return sum_dm = cell_dm(nzlo) - + AD_dm_full_on = s% diffusion_AD_dm_full_on*Msun AD_dm_full_off = s% diffusion_AD_dm_full_off*Msun AD_boost_factor = s% diffusion_AD_boost_factor - + SIG_factor = s% diffusion_SIG_factor GT_factor = s% diffusion_GT_factor - + !write(*,1) 'GT_factor SIG_factor', GT_factor, SIG_factor do k = nzlo+1, nzhi @@ -230,7 +230,7 @@ subroutine get_matrix_coeffs( & end if sum_dm = sum_dm + cell_dm(k) end do - + do j=1,nc ! not used, but copy just for sake of plotting D_self_face(j,nzlo) = D_self_face(j,nzlo+1) v_advection_face(j,nzlo) = v_advection_face(j,nzlo+1) @@ -243,10 +243,10 @@ subroutine get_matrix_coeffs( & SIG_face(i,j,nzlo) = SIG_face(i,j,nzlo+1) end do end do - + end subroutine get_matrix_coeffs - - + + subroutine get1_coeffs_face( & s, k, nz, nc, m, nzlo, nzhi, ih1, ihe4, pure_Coulomb, & rho_face, T_face, gamma_T_limit_coeff_face, & @@ -261,7 +261,7 @@ subroutine get1_coeffs_face( & e_ap, e_at, e_ar, e_ax, & g_ap, g_at, g_ar, g_ax, & sigma_lnC, ierr) - + type (star_info), pointer :: s integer, intent(in) :: k, nz, nc, m, nzlo, nzhi, ih1, ihe4 logical, intent(in) :: pure_Coulomb @@ -273,7 +273,7 @@ subroutine get1_coeffs_face( & dlnRho_dr_face, grav, dlnne_dr_face real(dp), intent(in), dimension(:) :: & A, X_face, Z_face, C_face, C_div_X_face, & - rad_accel_face, diffusion_factor + rad_accel_face, diffusion_factor logical, intent(in) :: use_cgs_solver, rad real(dp), intent(in) :: eta, eta_on, eta_off real(dp), intent(inout), dimension(:) :: & @@ -282,19 +282,19 @@ subroutine get1_coeffs_face( & real(dp), intent(inout) :: e_ax(:), g_ax(:) ! (m) real(dp), intent(inout) :: sigma_lnC(:,:) ! (nc,nc) integer, intent(out) :: ierr - + real(dp), dimension(m) :: AP, AT, AR real(dp), dimension(m,m) :: kappa_st, Zdiff, Zdiff1, Zdiff2, AX - + include 'formats' - + ierr = 0 - + call get1_burgers_coeffs( & s, k, nc, m, A, Z_face, X_face, C_face, & rho_face, T_face, pure_Coulomb, & kappa_st, Zdiff, Zdiff1, Zdiff2) - + call get1_gradient_coeffs( & k, m, sfmin, A, Z_face, X_face, C_face, rho_face, T_face, & use_cgs_solver, eta, eta_on, eta_off, & @@ -304,7 +304,7 @@ subroutine get1_coeffs_face( & g_ap, g_at, g_ar, g_ax, & ierr) if (ierr /= 0) return - + call get1_diffusion_velocities( & k, nc, m, nzlo, nzhi, AP, AT, AR, AX, rho_face, T_face, & dlnP_dr_face, dlnT_dr_face, dlnRho_dr_face, & @@ -312,11 +312,11 @@ subroutine get1_coeffs_face( & Vlimit_dm_full_on, Vlimit_dm_full_off, Vlimit, xm_face, r_mid, s% dt, & gamma_T_limit_coeff_face, v_advection_max, diffusion_factor, & use_cgs_solver, & - v_advection_face, vlnP_face, vlnT_face, v_rad_face, sigma_lnC) - + v_advection_face, vlnP_face, vlnT_face, v_rad_face, sigma_lnC) + end subroutine get1_coeffs_face - + subroutine get1_CXZn_face( & k, nz, nc, m, nzlo, nzhi, C, X, Z, A, alfa_face, tiny_C, & d_dr_factor, dlnRho_dr_face, C_face, X_face, Z_face, C_div_X_face, & @@ -366,14 +366,14 @@ subroutine get1_CXZn_face( & dlnne_dr_face = dlnRho_dr_face + dlntmp_dr_face end subroutine get1_CXZn_face - - + + subroutine get1_burgers_coeffs( & s, k, nc, m, A, Z, X, C, rho, T, pure_Coulomb, & kappa_st, Zdiff, Zdiff1, Zdiff2) - + use paquette_coeffs, only: paquette_coefficients - + type (star_info), pointer :: s integer, intent(in) :: k, nc, m real(dp), intent(in) :: rho, T @@ -388,22 +388,22 @@ subroutine get1_burgers_coeffs( & real(dp), dimension(m,m) :: cl, Ath, Ddiff, Kdiff, Kdiff2 real(dp) :: Gamma, kappa_SM real(dp) :: Ddiff_Caplan(nc) - + do i = 1, nc charge(i) = max(1d0, Z(i)) ! assume some ionization end do charge(m) = Z(m) - + if (.not. pure_Coulomb) then ! use Paquette coeffs ! Get number densities (per cm^3) do i = 1, nc - na(i) = rho*X(i)/(A(i)*amu) + na(i) = rho*X(i)/(A(i)*amu) end do na(m) = 0.d0 do i = 1, nc na(m) = na(m) + charge(i)*na(i) end do - ! Compute resistance coefficients from Paquette&al (1986) + ! Compute resistance coefficients from Paquette&al (1986) call paquette_coefficients( & rho, T, m, A, charge, na, Ddiff, Kdiff, Zdiff, Zdiff1, Zdiff2, Ath) @@ -438,22 +438,22 @@ subroutine get1_burgers_coeffs( & ! Unit conversion conveniently applies to both Paquette and Stanton&Murillo kappa_st(:,:) = Kdiff(:,:)/(1.41D-25*pow(T,-1.5D0)*na(m)*na(m)) - ! = kappa_st of eq 37, Thoul&al 1994 + ! = kappa_st of eq 37, Thoul&al 1994 return end if - + ! calculate density of electrons (ne) from mass density (rho): ac=0.d0 do i=1, m ac=ac+a(i)*c(i) - end do - ne=rho/(mp*ac) - ! calculate interionic distance (ao): + end do + ne=rho/(mp*ac) + ! calculate interionic distance (ao): ni=0.d0 do i=1, nc ni=ni+c(i)*ne end do - ao=pow(0.23873d0/ni,one_third) + ao=pow(0.23873d0/ni,one_third) ! calculate debye length (lambdad): cz=0.d0 do i=1, m @@ -481,7 +481,7 @@ subroutine get1_burgers_coeffs( & c(i)*c(j)*charge(i)*charge(i)*charge(j)*charge(j) end do end do - + end subroutine get1_burgers_coeffs @@ -504,7 +504,7 @@ subroutine get1_gradient_coeffs( & real(dp), intent(inout) :: e_ap, e_at, e_ar, e_ax(:) ! (m) real(dp), intent(inout) :: g_ap, g_at, g_ar, g_ax(:) ! (m) integer, intent(out) :: ierr - + integer :: i, j real(dp) :: charge(m), nd(m), Kdiff(m,m), alfa, beta @@ -513,11 +513,11 @@ subroutine get1_gradient_coeffs( & real(dp) :: e_ap1, e_at1, e_ar1, e_ax1(m) real(dp) :: AP2(m), AT2(m), AR2(m), AX2(m,m) real(dp) :: e_ap2, e_at2, e_ar2, e_ax2(m) - + include 'formats' - + ierr = 0 - + do i=1,m-1 charge(i) = max(1d0, Z(i)) end do @@ -530,7 +530,7 @@ subroutine get1_gradient_coeffs( & nd(i) = rho*X(i)/(A(i)*amu) nd(m) = nd(m) + nd(i)*charge(i) ! Electron Number Density satisfies charge neutrality end do - + Kdiff(:,:) = kappa_st(:,:)*(1.41D-25*pow(T,-1.5D0)*nd(m)*nd(m)) if(eta < eta_on) then @@ -546,7 +546,7 @@ subroutine get1_gradient_coeffs( & ! Call both and do a linear blend of all coefficients. alfa = (eta - eta_on)/(eta_off - eta_on) ! alfa = 1 means no thermal diffusion. beta = 1d0 - alfa ! beta = 1 means full thermal diffusion. - + call solve_burgers_cgs_no_thermal(m+1,m,A,charge,nd,rad_accel,rad, & Kdiff,AP1,AT1,AR1,AX1, & e_ap1,e_at1,e_ar1,e_ax1,ierr) @@ -570,7 +570,7 @@ subroutine get1_gradient_coeffs( & ! print *, "Thermal diffusion changing temperature coefficient by more than factor of two." ! print *, "Relative difference: ", abs((AT1(3) - AT2(3))/AT1(3)) ! end if - + ! Blending between the two solutions. do i = 1,m AP(i) = alfa*AP1(i) + beta*AP2(i) @@ -592,7 +592,7 @@ subroutine get1_gradient_coeffs( & g_at = 0d0 g_ar = 0d0 g_ax(1:m) = 0d0 - + if (ierr /= 0) then !return write(*,2) 'solve_burgers_cgs failed', k @@ -620,10 +620,10 @@ subroutine get1_gradient_coeffs( & end if end if - + end subroutine get1_gradient_coeffs - - + + subroutine get1_diffusion_velocities( & k, nc, m, nzlo, nzhi, AP, AT, AR, AX, rho, T, & dlnP_dr, dlnT_dr, dlnRho_dr, grav, dlnne_dr, X_face, & @@ -641,14 +641,14 @@ subroutine get1_diffusion_velocities( & logical, intent(in) :: use_cgs_solver real(dp), intent(inout), dimension(:) :: vgt, vlnP, vlnT, vrad real(dp), intent(inout) :: sigma_lnC(:,:) ! (nc,nc) - + integer :: i, j, im real(dp) :: coef, coef_vrad, dv_im, dr, T2pt5, & vcross, vmax, vmax_limit, frac, alfa, beta real(dp) :: tau0 ! = 6d13*secyer, solar diffusion time (seconds) real(dp), parameter :: rho_unit = 1d2 real(dp), parameter :: T_unit = 1d7 - + include 'formats' if (limit_coeff <= 0) then @@ -656,7 +656,7 @@ subroutine get1_diffusion_velocities( & sigma_lnC(:,:) = 0 return end if - + dr = r_mid(k-1) - r_mid(k) vcross = dr/dt if (xm_face >= Vlimit_dm_full_off .or. Vlimit <= 0d0) then @@ -673,7 +673,7 @@ subroutine get1_diffusion_velocities( & beta = 1d0 - alfa ! fraction of normal v when it is > vmax vmax_limit = vcross*Vlimit/alfa ! Want to scale to no limit at alfa = 0 end if - + if(use_cgs_solver) then ! Converts coefficients to velocities ! assuming cgs routine. do i=1,nc @@ -685,14 +685,14 @@ subroutine get1_diffusion_velocities( & vrad(i) = AR(i)*diffusion_factor(i)*limit_coeff ! AR already contains all constants. vgt(i) = vlnP(i) + vlnT(i) + vrad(i) end do - + do i = 1,nc ! Converting from Iben/MacDonald notation to Thoul ! notation using electron number density gradient. vgt(i) = vgt(i) - dlnne_dr*sum(sigma_lnC(i,1:nc)) if (X_face(i) < 1d-15) vgt(i) = 0d0 end do - + else ! converts coefficients to velocities assuming Thoul. tau0 = 6d13*secyer T2pt5 = pow(T/T_unit,2.5d0) @@ -716,12 +716,12 @@ subroutine get1_diffusion_velocities( & if (X_face(i) < 1d-15) vgt(i) = 0d0 end do end if - + ! final fixup for vgt of most abundant so it gives baryon conservation. im = maxloc(X_face(1:nc),dim=1) dv_im = -dot_product(X_face(1:nc), vgt(1:nc))/X_face(im) vgt(im) = vgt(im) + dv_im - + vmax = maxval(abs(vgt(1:nc))) if (vmax > v_advection_max) then frac = v_advection_max/vmax @@ -749,10 +749,10 @@ subroutine get1_diffusion_velocities( & end do end do end if - + end subroutine get1_diffusion_velocities - - + + subroutine get1_flow_coeffs( & k, nc, m, & v_advection_face, v_advection_max, SIG_factor, GT_factor, & @@ -767,21 +767,21 @@ subroutine get1_flow_coeffs( & real(dp), intent(inout) :: GT_face(:) ! (nc) real(dp), intent(inout) :: D_self_face(:) ! (nc) real(dp), intent(inout) :: SIG_face(:,:) ! (nc,nc) - + integer :: i, j real(dp) :: c - + include 'formats' c = SIG_factor*four_pi_r2_rho_face*four_pi_r2_rho_face/dm_bar do i = 1, nc GT_face(i) = GT_factor*four_pi_r2_rho_face*v_advection_face(i) - D_self_face(i) = sigma_lnC_face(i,i) + D_self_face(i) = sigma_lnC_face(i,i) do j = 1, nc SIG_face(i,j) = c*sigma_lnC_face(i,j)/C_div_X_face(j) end do end do - + end subroutine get1_flow_coeffs @@ -794,10 +794,10 @@ end subroutine get1_flow_coeffs !************************************************************* ! This routine inverses the burgers equations. ! -! The system contains N equations with N unknowns. -! The equations are: the M momentum equations, -! the M energy equations, -! two constraints: the current neutrality +! The system contains N equations with N unknowns. +! The equations are: the M momentum equations, +! the M energy equations, +! two constraints: the current neutrality ! the zero fluid velocity. ! The unknowns are: the M diffusion velocities, ! the M heat fluxes, @@ -812,7 +812,7 @@ end subroutine get1_flow_coeffs ! if alpha is the r.h.s., we obtain the coefficient A_p ! if nu ---------------------------------------- A_T ! if gamma(i,j) ----------------------------------- A_Cj - ! + ! ! If I=1, we obtain the hydrogen diffusion velocity ! If I=2, ------------- helium ------------------ ! If I=3,M-1, --------- heavy element ------------- @@ -834,14 +834,14 @@ subroutine do1_solve_thoul_hu( & ! the parameter m is the number of fluids considered (ions+electrons) ! the parameter n is the number of equations (2*m+2). ! - ! the vectors a,z and x contain the atomic mass numbers, + ! the vectors a,z and x contain the atomic mass numbers, ! the charges (ionization), and the mass fractions, of the elements. ! note: since m is the electron fluid, its mass and charge must be ! a(m)=m_e/m_u ! z(m)=-1. ! ! the array cl contains the values of the coulomb logarithms. - ! the vector ap, at, and array ax contains the results for the diffusion + ! the vector ap, at, and array ax contains the results for the diffusion ! coefficients. integer, intent(in) :: m,n @@ -867,20 +867,20 @@ subroutine do1_solve_thoul_hu( & ! the vector c contains the concentrations ! cc is the total concentration: cc=sum(c_s) ! ac is proportional to the mass density: ac=sum(a_s c_s) - ! the arrays xx,y,yy and k are various parameters which appear in + ! the arrays xx,y,yy and k are various parameters which appear in ! burgers equations. ! the vectors and arrays alpha, nu, gamma, delta, and ga represent - ! the "right- and left-hand-sides" of burgers equations, and later + ! the "right- and left-hand-sides" of burgers equations, and later ! the diffusion coefficients. - + ! initialize: ierr = 0 - ko = 2d0 + ko = 2d0 indx(1:n) = 0 ! calculate cc and ac: - + cc=sum(c(1:m)) ac=dot_product(a(1:m),c(1:m)) @@ -896,7 +896,7 @@ subroutine do1_solve_thoul_hu( & end do ! write the burgers equations and the two constraints as - ! alpha_s dp + nu_s dt + sum_t(not ihe or m) gamma_st dc_t + ! alpha_s dp + nu_s dt + sum_t(not ihe or m) gamma_st dc_t ! = sum_t delta_st w_t do i=1,m @@ -904,7 +904,7 @@ subroutine do1_solve_thoul_hu( & nu(i)=0d0 gamma(i,1:n)=0d0 if (rad) then - beta(i) = -(amu/boltzm)*alpha(i)*a(i)*rad_accel(i) + beta(i) = -(amu/boltzm)*alpha(i)*a(i)*rad_accel(i) else beta(i) = 0d0 end if @@ -916,28 +916,28 @@ subroutine do1_solve_thoul_hu( & end if end do end do - + do i=m+1,n-2 alpha(i)=0d0 nu(i)=2.5d0*c(i-m)/cc beta(i) = 0d0 gamma(i,1:n)=0d0 end do - + alpha(n-1)=0d0 nu(n-1)=0d0 beta(n-1)=0d0 gamma(n-1,1:n)=0d0 - + alpha(n)=0d0 nu(n)=0d0 beta(n)=0d0 gamma(n,1:n)=0d0 - + delta(1:n,1:n) = 0d0 - + do i=1,m - + do j=1,m if (j == i) then do l=1,m @@ -949,7 +949,7 @@ subroutine do1_solve_thoul_hu( & delta(i,j)=k(i,j) end if end do - + do j=m+1,n-2 if (j-m == i) then do l=1,m @@ -960,15 +960,15 @@ subroutine do1_solve_thoul_hu( & delta(i,j) = -Zdiff(i,j-m)*y(i,j-m)*k(i,j-m) end if end do - + delta(i,n-1)=c(i)*z(i) - + delta(i,n)=-c(i)*a(i) - + end do - + do i=m+1,n-2 - + do j=1,m if (j == i-m) then do l=1,m @@ -979,7 +979,7 @@ subroutine do1_solve_thoul_hu( & delta(i,j) = -(2.5d0*Zdiff(i-m,j))*xx(i-m,j)*k(i-m,j) end if end do - + do j=m+1,n-2 if (j-m == i-m) then do l=1,m @@ -992,35 +992,35 @@ subroutine do1_solve_thoul_hu( & (3D0 + Zdiff1(i-m,j-m) - 0.8D0*Zdiff2(i-m,j-m)) end if end do - + delta(i,n-1:n)=0d0 - + end do - + do j=1,m delta(n-1,j) = c(j)*z(j) end do delta(n-1,m+1:n) = 0d0 - + do j=1,m delta(n,j) = c(j)*a(j) end do delta(n,m+1:n) = 0d0 - + call dgetrf(n, n, delta, n, indx, ierr) if (ierr /= 0) return - + call dgetrs( 'n', n, 1, delta, n, indx, alpha, n, ierr ) if (ierr /= 0) return - + call dgetrs( 'n', n, 1, delta, n, indx, nu, n, ierr ) if (ierr /= 0) return - + if (rad) then call dgetrs( 'n', n, 1, delta, n, indx, beta, n, ierr ) if (ierr /= 0) return end if - + do j=1,n do i=1,n ga(i)=gamma(i,j) @@ -1031,7 +1031,7 @@ subroutine do1_solve_thoul_hu( & gamma(i,j)=ga(i) end do end do - + f = ko*ac*cc do j=1,m ap(j)=alpha(j)*f @@ -1041,7 +1041,7 @@ subroutine do1_solve_thoul_hu( & ax(i,j)=gamma(i,j)*f end do end do - + e_ap=alpha(n-1)*f g_ap=alpha(n)*f @@ -1050,7 +1050,7 @@ subroutine do1_solve_thoul_hu( & e_ar=beta(n-1)*f g_ar=beta(n)*f - + do i=1,m e_ax(i)=gamma(n-1,i)*f g_ax(i)=gamma(n,i)*f @@ -1065,7 +1065,7 @@ subroutine solve_burgers_cgs_no_thermal( & n, m, A, Z, nd, rad_accel, rad, & Kdiff, ap, at, ar, ax, & e_ap, e_at, e_ar, e_ax, ierr) - + ! nd = array of number densities ! m = # of species including electrons ! n = m+1 without thermal diffusion @@ -1074,7 +1074,7 @@ subroutine solve_burgers_cgs_no_thermal( & ! 2 conservation equations. ! Thermal diffusion on: 2m diffusion equations (maybe 2*m-1) ! 2 conservation equations. - + integer, intent(in) :: m,n real(dp), intent(in), dimension(:) :: A, Z, nd, rad_accel ! (m) logical, intent(in) :: rad @@ -1104,7 +1104,7 @@ subroutine solve_burgers_cgs_no_thermal( & e_at = 0d0 e_ar = 0d0 e_ax(1:m) = 0d0 - + ! Assign the RHS Matrix multiplying the unkown quantities. ! Right now this is for thermal diffusion off, assuming gravity ! is a known, so there are m uknown diffusion velocities and @@ -1161,7 +1161,7 @@ subroutine solve_burgers_cgs_no_thermal( & ! print *, "Factoring failed!" return end if - + call dgetrs('N',n,1,delta,n,indx,alpha,n,ierr) if( ierr /= 0 ) then ! print *, "solve failed on alpha" @@ -1183,7 +1183,7 @@ subroutine solve_burgers_cgs_no_thermal( & else beta(1:n) = 0d0 end if - + do j=1,n do i=1,n ga(i) = gamm(i,j) @@ -1197,10 +1197,10 @@ subroutine solve_burgers_cgs_no_thermal( & gamm(i,j) = ga(i) end do end do - + ! Assign the results of the matrix solve to the output ! arrays/matrix. - + do j = 1,m ap(j) = alpha(j) at(j) = nu(j) @@ -1209,14 +1209,14 @@ subroutine solve_burgers_cgs_no_thermal( & ax(i,j) = gamm(i,j) end do end do - + e_ap = alpha(n) e_at = nu(n) e_ar = beta(n) do i=1,m e_ax(i) = gamm(n,i) end do - + end subroutine solve_burgers_cgs_no_thermal @@ -1225,7 +1225,7 @@ subroutine solve_burgers_cgs_with_thermal( & Kdiff, zdiff, zdiff1, zdiff2, & ap, at, ar, ax, & e_ap, e_at, e_ar, e_ax, ierr) - + ! nd = array of number densities ! m = # of species including electrons ! n = 2*m+1 with thermal diffusion @@ -1240,7 +1240,7 @@ subroutine solve_burgers_cgs_with_thermal( & ! there is degeneracy. Having it in this form makes it easier to transition ! between ideal gas (where this solver is valid) and solve_burgers_cgs ! (which is much better when things are degenerate). - + integer, intent(in) :: m,n real(dp), intent(in), dimension(:) :: A, Z, nd, rad_accel ! (m) logical, intent(in) :: rad @@ -1275,7 +1275,7 @@ subroutine solve_burgers_cgs_with_thermal( & ! by making block matrices and then shifting them into the proper position. ! This makes the comparisons for checking the subdiagonals easier, as well ! as indexing of the coefficients. - rightshift = m + rightshift = m downshift = m-1 ! Because electron momentum equation dropped. ! Assign the RHS Matrix multiplying the unkown quantities. @@ -1300,7 +1300,7 @@ subroutine solve_burgers_cgs_with_thermal( & end if end do - ! Terms that multiply the heat flow vectors. + ! Terms that multiply the heat flow vectors. do j = 1,m if (j == i) then do l = 1,m @@ -1320,7 +1320,7 @@ subroutine solve_burgers_cgs_with_thermal( & ! Terms corresponding to the energy equations. do i = 1,m ! All these entries get shifted lower into the i+downshift position. - + ! Terms that multiply the diffusion velocities. do j = 1,m if (j == i) then @@ -1355,7 +1355,7 @@ subroutine solve_burgers_cgs_with_thermal( & A(i)*A(j)/pow2(A(i)+A(j)) end if end do - + ! Term multiplying the electric field. (doesn't appear in energy equations) delta(i+downshift,n) = 0d0 end do @@ -1400,7 +1400,7 @@ subroutine solve_burgers_cgs_with_thermal( & ! print *, "Factoring failed!" return end if - + call dgetrs('N',n,1,delta,n,indx,alpha,n,ierr) if( ierr /= 0 ) then ! print *, "solve failed on alpha" @@ -1436,11 +1436,11 @@ subroutine solve_burgers_cgs_with_thermal( & gamm(i,j) = ga(i) end do end do - + ! Assign the results of the matrix solve from the diffusion ! velocity part of the arrays to the solution vectors. - + do j = 1,m ap(j) = alpha(j) at(j) = nu(j) @@ -1458,11 +1458,11 @@ subroutine solve_burgers_cgs_with_thermal( & do i=1,m e_ax(i) = gamm(n,i) end do - + end subroutine solve_burgers_cgs_with_thermal - + ! Calculate coefficients given in Appendix C.3 of Stanton & Murillo, PR E 93, 043203 (2016) subroutine get_SM_coeffs(nc,m,rho,T,A,Z,nd,Kdiff,zdiff,zdiff1,zdiff2,kappa) integer, intent(in) :: nc, m @@ -1624,7 +1624,7 @@ subroutine get_SM_coeffs(nc,m,rho,T,A,Z,nd,Kdiff,zdiff,zdiff1,zdiff2,kappa) ! touched the electron entries. They exit this routine unchanged, so they ! either need to be initialized before this routine is called or somehow ! calculated later. - + end subroutine get_SM_coeffs ! Screening Length according to Stanton & Murillo @@ -1699,15 +1699,15 @@ subroutine get_CBF_coeffs(nc,m,rho,T,A,Z,nd,Gamma,Ddiff,Kdiff) do j = 1,nc Zp6bar = Zp6bar + pow(Z(j),0.6d0)*nd(j)/ni_sum end do - + ! Set kappa as input for Dstar calculation, ! also sets omegap, ai, lam_e for converting to cgs units later. call kappa_CBF(nc,m,rho,T,Abar,Zbar,nd,omegap,ai,lam_e,kappa) - + ! Calculate Dstar using fit of Eqn (5) call get_Dstar_OCP(Gamma,kappa,DstarOCP) Docp = DstarOCP*ai*ai*omegap ! convert from dimensionless to cgs units - + ! Eqn (11) do j = 1,nc Ddiff(j) = Docp*pow(Z(j)/Zbar,-0.6d0) @@ -1722,7 +1722,7 @@ subroutine get_CBF_coeffs(nc,m,rho,T,A,Z,nd,Gamma,Ddiff,Kdiff) end do end subroutine get_CBF_coeffs - + subroutine get_Dstar_OCP(Gamma,kappa,DstarOCP) real(dp), intent(in) :: Gamma, kappa real(dp), intent(out) :: DstarOCP @@ -1733,16 +1733,16 @@ subroutine get_Dstar_OCP(Gamma,kappa,DstarOCP) a0 = 1.55973d0 a1 = 1.10941d0 a2 = 1.36909d0 - + b0 = 0.0070782d0 b1 = 0.80499d0 b2 = 4.53523d0 - + c0 = 2.20689d0 c1 = 1.351594d0 c2 = 1.57138d0 c3 = 3.34187d0 - + Ak = sqrt(pi/3d0)*(a0 + a1*pow(kappa,a2)) Bk = b0*exp(-b1*pow(kappa,b2)) Ck = c0 + c1*bitsafe_erf_fit(c2*pow(kappa,c3)) @@ -1751,7 +1751,7 @@ subroutine get_Dstar_OCP(Gamma,kappa,DstarOCP) DstarOCP = sqrt(pi/3d0)*Ak*pow(Gamma,-2.5d0)*exp(-Bk*Gamma)/log(1d0 + Ck*pow(Gamma,-1.5d0)/sqrt(3d0)) end subroutine get_Dstar_OCP - + ! Screening Length for CBF diffusion coefficients. ! Only electron screening, accounts for potentially relativistic electron degeneracy. subroutine kappa_CBF(nc,m,rho,T,Abar,Zbar,nd,omegap,ai,lam_e,kappa) @@ -1806,6 +1806,6 @@ real(dp) function bitsafe_erf_fit(x) bitsafe_erf_fit = 1d0 - (a1*t + a2*t*t + a3*t*t*t)*exp(-x*x) end function bitsafe_erf_fit - + end module diffusion_support diff --git a/star/private/do_one_utils.f90 b/star/private/do_one_utils.f90 index 782f3540b..cb35b9c3c 100644 --- a/star/private/do_one_utils.f90 +++ b/star/private/do_one_utils.f90 @@ -24,27 +24,27 @@ ! *********************************************************************** module do_one_utils - + use star_private_def use const_def use utils_lib, only: is_bad implicit none - + private public :: do_one_check_model, & write_terminal_header, do_bare_bones_check_model, do_check_limits, & do_show_log_description, do_show_terminal_header, do_terminal_summary - + ! model log priorities integer, parameter :: delta_priority = 1 integer, parameter :: phase_priority = 2 - - + + contains - - + + logical function model_is_okay(s) type (star_info), pointer :: s ! for now, just check for valid number in the final dynamic timescale @@ -58,8 +58,8 @@ subroutine set_save_profiles_info(s, model_priority) s% need_to_save_profiles_now = .true. s% save_profiles_model_priority = model_priority end subroutine set_save_profiles_info - - + + subroutine write_terminal_header(s) type (star_info), pointer :: s if (s% model_number <= s% recent_log_header) return @@ -68,8 +68,8 @@ subroutine write_terminal_header(s) call do_show_terminal_header(s) s% just_wrote_terminal_header = .true. end subroutine write_terminal_header - - + + subroutine do_show_log_description(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -116,8 +116,8 @@ subroutine do_show_log_description(id, ierr) write(*,'(A)') write(*,'(a)') " All this and more are saved in the LOGS directory during the run." end subroutine do_show_log_description - - + + subroutine do_show_terminal_header(s) type (star_info), pointer :: s integer :: ierr, io @@ -135,17 +135,17 @@ subroutine do_show_terminal_header(s) end if end if end subroutine do_show_terminal_header - - + + subroutine output_terminal_header(s,io) use chem_def, only: isi28 type (star_info), pointer :: s integer, intent(in) :: io character (len=5) :: iters iters = 'iters' - + include 'formats' - + write(io,'(a)') & '_______________________________________________________________________' // & '___________________________________________________________________________' @@ -153,7 +153,7 @@ subroutine output_terminal_header(s,io) write(io,'(a)') & ' step lg_Tmax Teff lg_LH lg_Lnuc Mass ' // & 'H_rich H_cntr N_cntr Y_surf eta_cntr zones retry' - + ! note that if the age is in days, then the timestep is automatically in seconds. if (trim(s% terminal_show_timestep_units) == 'seconds' .or. & trim(s% terminal_show_timestep_units) == 'secs') then @@ -163,14 +163,14 @@ subroutine output_terminal_header(s,io) write(io,'(a)',advance='no') ' dt_sec' end if else if (trim(s% terminal_show_timestep_units) == 'days') then - if (s% terminal_show_log_dt) then + if (s% terminal_show_log_dt) then write(io,'(a)',advance='no') ' lg_dt_days' else write(io,'(a)',advance='no') ' dt_days' end if else if (trim(s% terminal_show_timestep_units) == 'years' .or. & trim(s% terminal_show_timestep_units) == 'yrs') then - if (s% terminal_show_log_dt) then + if (s% terminal_show_log_dt) then write(io,'(a)',advance='no') ' lg_dt_yrs' else write(io,'(a)',advance='no') ' dt_yrs' @@ -179,7 +179,7 @@ subroutine output_terminal_header(s,io) write(*,*) 'unrecognized option for terminal_show_timestep_units ' // trim(s% terminal_show_timestep_units) return end if - + if (s% initial_z >= 1d-5) then write(io,'(a)') & ' lg_Tcntr lg_R lg_L3a lg_Lneu lg_Mdot ' // & @@ -214,7 +214,7 @@ subroutine output_terminal_header(s,io) write(*,*) 'unrecognized option for terminal_show_age_units ' // trim(s% terminal_show_age_units) return end if - + if (s% net_iso(isi28) == 0) then write(io,'(a)') & ' lg_Dcntr lg_L lg_LZ lg_Lphoto lg_Dsurf ' // & @@ -228,10 +228,10 @@ subroutine output_terminal_header(s,io) '_______________________________________________________________________' // & '___________________________________________________________________________' write(io,'(A)') - + end subroutine output_terminal_header - - + + subroutine do_terminal_summary(s) type (star_info), pointer :: s integer :: ierr, io @@ -249,8 +249,8 @@ subroutine do_terminal_summary(s) end if end if end subroutine do_terminal_summary - - + + subroutine output_terminal_summary(s,io) use num_def, only:banded_matrix_type use const_def, only:secyer @@ -259,24 +259,24 @@ subroutine output_terminal_summary(s,io) use star_utils, only:eval_current_y, eval_current_z type (star_info), pointer :: s integer, intent(in) :: io - + real(dp) :: time_step, age, dt, Xmax, v, vsurf_div_csound, tmp, & sum_Lnuc, sum_LH, sum_LHe, sum_Lz, sum_Lphoto integer :: model, ierr, nz, iters character (len=3) :: id_str character (len=32) :: why character (len=90) :: fmt, fmt1, fmt2, fmt3, fmt4, fmt5 - + include 'formats' - - age = s% star_age ! in years + + age = s% star_age ! in years if (trim(s% terminal_show_age_units) == 'seconds' .or. & trim(s% terminal_show_age_units) == 'secs') then age = age*secyer else if (trim(s% terminal_show_age_units) == 'days') then age = age*dayyer end if - + time_step = s% time_step ! in years if (trim(s% terminal_show_timestep_units) == 'seconds' .or. & trim(s% terminal_show_timestep_units) == 'secs') then @@ -284,17 +284,17 @@ subroutine output_terminal_summary(s,io) else if (trim(s% terminal_show_timestep_units) == 'days') then time_step = time_step*dayyer end if - + if (s% terminal_show_log_age) age = safe_log10(age) if (s% terminal_show_log_dt) time_step = safe_log10(time_step) model = s% model_number nz = s% nz - ierr = 0 - + ierr = 0 + Xmax = dot_product(s% dq(1:nz), s% xa(s% species,1:nz)) - + if (s% u_flag) then v = s% u(1) else if (s% v_flag) then @@ -305,40 +305,40 @@ subroutine output_terminal_summary(s,io) vsurf_div_csound = v / s% csound(1) dt = s% time_step*secyer - + sum_Lnuc = s% power_nuc_burn sum_LH = s% power_h_burn sum_LHe = s% power_he_burn sum_Lphoto = abs(s% power_photo) - sum_Lz = s% power_z_burn - + sum_Lz = s% power_z_burn + if (how_many_allocated_star_ids() == 1) then id_str = '' else write(id_str,'(i3)') s% id end if - + fmt1 = '(a3,i8,f11.6,' - + if (s% Teff < 1d4) then fmt2 = 'f11.3,' else fmt2 = '1pe11.3,0p,' end if - + if (s% star_mass >= 1d2) then fmt3 = '2f11.6,2(1pe11.3),0p,' else fmt3 = '4f11.6,' end if - + if (s% eta(s% nz) >= 1d3) then fmt4 = '3f11.6,e11.3,' else fmt4 = '3f11.6,f11.6,' end if fmt5 = '2i7)' - + fmt = trim(fmt1) // trim(fmt2) // trim(fmt3) // trim(fmt4) // trim(fmt5) !write(*,*) 'fmt line1 ' // trim(fmt) write(io,fmt=fmt) & @@ -347,7 +347,7 @@ subroutine output_terminal_summary(s,io) s% Teff, & ! fmt2 safe_log10(sum_LH), & ! fmt3 safe_log10(sum_Lnuc), & - s% star_mass, & + s% star_mass, & s% star_mass - max(s% he_core_mass, s% co_core_mass), & s% center_h1, & ! fmt4 s% center_n14, & @@ -355,7 +355,7 @@ subroutine output_terminal_summary(s,io) s% eta(s% nz), & s% nz, & ! fmt5 s% num_retries - + tmp = max(0d0, min(1d0, 1 - (s% surface_h1 + s% surface_he3 + s% surface_he4))) if (s% initial_z >= 1d-5) then fmt1 = '(1pe11.4, 0p, 9f11.6, ' @@ -389,7 +389,7 @@ subroutine output_terminal_summary(s,io) if (s% why_Tlim < 0) then why = '' else if (s% why_Tlim == 0) then - why = 'initial dt' + why = 'initial dt' else why = dt_why_str(min(numTlim,s% why_Tlim)) if (s% why_Tlim == Tlim_dX .and. s% Tlim_dX_species > 0 & @@ -404,16 +404,16 @@ subroutine output_terminal_summary(s,io) .and. s% dX_nuc_drop_max_j <= s% species) then why = trim(dt_why_str(s% why_Tlim)) // ' ' // & trim(chem_isos% name(s% chem_id(s% dX_nuc_drop_max_j))) - else if (s% why_Tlim == Tlim_dlgL_nuc_cat) then + else if (s% why_Tlim == Tlim_dlgL_nuc_cat) then if (s% Tlim_dlgL_nuc_category > 0 & .and. s% Tlim_dlgL_nuc_category <= num_categories ) then why = trim(category_name(s% Tlim_dlgL_nuc_category)) else why = '???' end if - end if - end if - + end if + end if + if (s% net_iso(isi28) == 0) then tmp = 1 - (s% center_h1 + s% center_he3 + s% center_he4) fmt = '(1pe11.4, 0p, 5f11.6, 0p4f11.6, 0p, e11.3, a14)' @@ -449,16 +449,16 @@ subroutine output_terminal_summary(s,io) vsurf_div_csound, & trim(why) end if - + call show_trace_history_values(max(0, s% num_trace_history_values)) write(io,'(A)') - + s% just_wrote_terminal_header = .false. - - + + contains - + subroutine show_trace_history_values(num) use history, only: do_get_data_for_history_columns, & get_history_specs, get_history_values, get1_hist_value @@ -483,7 +483,7 @@ subroutine show_trace_history_values(num) cycle end if values(i) = val - if (is_bad(values(i))) then + if (is_bad(values(i))) then call mesa_error(__FILE__,__LINE__,'show_trace_history_values bad from get1_hist_value') end if else if (is_int_value(i)) then @@ -498,7 +498,7 @@ subroutine show_trace_history_values(num) else write(io,'(a40,99(1pd26.16))') & trim(s% trace_history_value_name(i)), values(i) - if (is_bad(values(i))) then + if (is_bad(values(i))) then call mesa_error(__FILE__,__LINE__,'show_trace_history_values') end if end if @@ -507,13 +507,13 @@ end subroutine show_trace_history_values end subroutine output_terminal_summary - - + + logical function get_history_info(s, do_write) type (star_info), pointer :: s - logical, intent(in) :: do_write + logical, intent(in) :: do_write integer :: model - logical :: write_history, write_terminal + logical :: write_history, write_terminal include 'formats' model = s% model_number if (s% history_interval > 0) then @@ -526,7 +526,7 @@ logical function get_history_info(s, do_write) else write_terminal = .false. end if - get_history_info = write_history .or. write_terminal + get_history_info = write_history .or. write_terminal if (.not. get_history_info) return if (s% write_header_frequency*s% terminal_interval > 0) then if ( mod(model, s% write_header_frequency*s% terminal_interval) == 0 & @@ -534,13 +534,13 @@ logical function get_history_info(s, do_write) write(*,'(A)') call write_terminal_header(s) endif - end if - if (write_terminal) call do_terminal_summary(s) - if (write_history) s% need_to_update_history_now = .true. - + end if + if (write_terminal) call do_terminal_summary(s) + if (write_history) s% need_to_update_history_now = .true. + end function get_history_info - - + + integer function do_bare_bones_check_model(id) integer, intent(in) :: id integer :: ierr @@ -554,8 +554,8 @@ integer function do_bare_bones_check_model(id) logged = get_history_info( s, .false. ) do_bare_bones_check_model = keep_going end function do_bare_bones_check_model - - + + subroutine save_profile(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -566,7 +566,7 @@ subroutine save_profile(id, ierr) call set_save_profiles_info(s, phase_priority) end subroutine save_profile - + integer function do_check_limits(id) use rates_def use chem_def @@ -583,16 +583,16 @@ integer function do_check_limits(id) peak_burn_vconv_div_cs, min_pgas_div_p, v_surf_div_v_kh, GREKM_avg_abs, & max_omega_div_omega_crit, omega_div_omega_crit, log_Teff, Lnuc_div_L, max_abs_vel, & species_mass_for_min_limit, species_mass_for_max_limit, center_gamma - + include 'formats' - + ierr = 0 call get_star_ptr(id, s, ierr) if (ierr /= 0) then do_check_limits = terminate return end if - + if (s% RSP_flag) then max_period_number = s% RSP_max_num_periods period_number = s% RSP_num_periods @@ -605,7 +605,7 @@ integer function do_check_limits(id) nz = s% nz do_check_limits = keep_going - + species_mass_for_min_limit = get_species_mass(s% star_species_mass_min_limit_iso) species_mass_for_max_limit = get_species_mass(s% star_species_mass_max_limit_iso) @@ -620,10 +620,10 @@ integer function do_check_limits(id) v_surf = 0d0 v_div_csound_max = 0d0 end if - + remnant_mass = get_remnant_mass(s)/Msun ejecta_mass = get_ejecta_mass(s)/Msun - + if(s%u_flag) then max_abs_vel_loc = maxloc(abs(s%u(1:nz)),dim=1) max_abs_vel = s%u(max_abs_vel_loc) @@ -634,8 +634,8 @@ integer function do_check_limits(id) max_abs_vel_loc = -1 max_abs_vel = 0d0 end if - - + + if (s% photosphere_r > 0d0) then v_surf_div_v_kh = abs(v_surf)*s% kh_timescale/s% photosphere_r if (s% cgrav(1) <= 0d0) then @@ -647,7 +647,7 @@ integer function do_check_limits(id) v_surf_div_v_kh = 0d0 v_surf_div_v_esc = 0d0 end if - + log_surface_gravity = safe_log10(s%grav(1)) log_surface_temperature = s% lnT(1) / ln10 log_surface_density = s% lnd(1)/ln10 ! log10(density at surface) @@ -673,21 +673,21 @@ integer function do_check_limits(id) Lnuc_div_L = 0d0 delta_nu = 0d0 end if - + if (s% dxdt_nuc_factor > 0d0) then k = maxloc(s% eps_nuc(1:nz), dim=1) peak_burn_vconv_div_cs = s% conv_vel(k)/s% csound(k) else peak_burn_vconv_div_cs = 0d0 end if - + if (s% initial_mass > s% he_core_mass) then envelope_fraction_left = & (s% star_mass - s% he_core_mass)/(s% initial_mass - s% he_core_mass) else envelope_fraction_left = 1 end if - + max_logQ = -99 min_logQ = 100 do k = 1, s% nz @@ -697,24 +697,24 @@ integer function do_check_limits(id) end if if (logQ < min_logQ) min_logQ = logQ end do - + min_pgas_div_p = 1d99 do k = s% nz, 1, -1 if (s% q(k) > s% Pgas_div_P_limit_max_q) exit if (s% pgas(k)/s% Peos(k) < min_pgas_div_p) min_pgas_div_p = s% pgas(k)/s% Peos(k) end do - + max_omega_div_omega_crit = 0; k_omega = 0 if (s% rotation_flag .and. s% omega_div_omega_crit_limit > 0) then do k = 1, s% nz - omega_div_omega_crit = abs(s% omega(k))/omega_crit(s,k) + omega_div_omega_crit = abs(s% omega(k))/omega_crit(s,k) if (omega_div_omega_crit > max_omega_div_omega_crit) then k_omega = k max_omega_div_omega_crit = omega_div_omega_crit end if end do end if - + if(s% max_abs_rel_run_E_err > 0d0) then if (abs(s% cumulative_energy_error/s% total_energy) > s% max_abs_rel_run_E_err & .and. .not. s% doing_relax) then @@ -727,9 +727,9 @@ integer function do_check_limits(id) return end if end if - + if (max_abs_vel > clight) then - if (s% retry_for_v_above_clight) then + if (s% retry_for_v_above_clight) then write(*, '(/,a,/, I5,1X,2e20.10)') & 'retry because maximum velocity exceeds speed of light ',max_abs_vel_loc,max_abs_vel,max_abs_vel/clight do_check_limits = retry @@ -748,21 +748,21 @@ integer function do_check_limits(id) write(*,2) 'maxloc eps_nuc', k, s% conv_vel(k), s% csound(k), s% eps_nuc(k) call mesa_error(__FILE__,__LINE__,'test do_one_utils') end if - + if (s% fe_core_infall < s% fe_core_infall_limit .and. & s% fe_core_infall > 0.99d0*s% fe_core_infall_limit) & write(*,1) 'nearing fe_core_infall limit', & s% fe_core_infall, s% fe_core_infall_limit - + if (s% non_fe_core_infall < s% non_fe_core_infall_limit .and. & s% non_fe_core_infall > 0.99d0*s% non_fe_core_infall_limit) & write(*,1) 'nearing non_fe_core_infall limit', & s% non_fe_core_infall, s% non_fe_core_infall_limit - + if (s% non_fe_core_rebound > 0.99d0*s% non_fe_core_rebound_limit) & write(*,1) 'nearing non_fe_core_rebound limit', & s% non_fe_core_rebound, s% non_fe_core_rebound_limit - + if (max_omega_div_omega_crit > 0.75d0*s% omega_div_omega_crit_limit .and. & s% omega_div_omega_crit_limit > 0 .and. k_omega > 0) & write(*,2) 'omega_div_omega_crit', k_omega, & @@ -770,340 +770,340 @@ integer function do_check_limits(id) s% m(k_omega)/Msun, s% r_equatorial(k_omega)/Rsun, & s% omega(k_omega), & sqrt(s% cgrav(k_omega)*s% m(k_omega)/ pow3(s% r_equatorial(k_omega))) - - if (s% star_age >= s% max_age .and. s% max_age > 0) then + + if (s% star_age >= s% max_age .and. s% max_age > 0) then call compare_to_target('star_age >= max_age', s% star_age, s% max_age, & t_max_age) - + else if (s% time >= s% max_age_in_days*secday .and. s% max_age_in_days > 0) then call compare_to_target('time >= max_age_in_days', & s% time/secday, s% max_age_in_days, t_max_age) - - else if (s% time >= s% max_age_in_seconds .and. s% max_age_in_seconds > 0) then + + else if (s% time >= s% max_age_in_seconds .and. s% max_age_in_seconds > 0) then call compare_to_target('time >= max_age_in_seconds', & s% time, s% max_age_in_seconds, t_max_age) - + else if (max_omega_div_omega_crit >= s% omega_div_omega_crit_limit .and. & - s% omega_div_omega_crit_limit > 0) then + s% omega_div_omega_crit_limit > 0) then write(*, '(/,a,/, 2e20.10)') & 'stop max_omega_div_omega_crit >= omega_div_omega_crit_limit', & max_omega_div_omega_crit, s% omega_div_omega_crit_limit do_check_limits = terminate s% termination_code = t_max_omega_div_omega_crit s% result_reason = result_reason_normal - - else if (peak_burn_vconv_div_cs >= s% peak_burn_vconv_div_cs_limit) then + + else if (peak_burn_vconv_div_cs >= s% peak_burn_vconv_div_cs_limit) then write(*, '(/,a,/, 2e20.10)') & 'stop peak_burn_vconv_div_cs >= peak_burn_vconv_div_cs_limit', & peak_burn_vconv_div_cs, s% peak_burn_vconv_div_cs_limit do_check_limits = terminate s% termination_code = t_peak_burn_vconv_div_cs_limit s% result_reason = result_reason_normal - - else if (s% model_number >= s% max_model_number .and. s% max_model_number >= 0) then + + else if (s% model_number >= s% max_model_number .and. s% max_model_number >= 0) then write(*, '(/,a,/, 2i9)') 'stop because model_number >= max_model_number', & s% model_number, s% max_model_number do_check_limits = terminate s% termination_code = t_max_model_number s% result_reason = result_reason_normal - - else if (period_number >= max_period_number .and. max_period_number >= 0) then + + else if (period_number >= max_period_number .and. max_period_number >= 0) then write(*, '(/,a,/, 2i9)') 'stop because period_number >= max_period_number', & period_number, max_period_number do_check_limits = terminate s% termination_code = t_max_period_number s% result_reason = result_reason_normal - + else if (GREKM_avg_abs < s% RSP_GREKM_avg_abs_limit & .and. s% RSP_GREKM_avg_abs_limit >= 0 & - .and. period_number >= 10) then + .and. period_number >= 10) then write(*, '(/,a,/, 2e20.10)') & 'stop because GREKM_avg_abs < RSP_GREKM_avg_abs_limit', & GREKM_avg_abs, s% RSP_GREKM_avg_abs_limit do_check_limits = terminate s% termination_code = 0 s% result_reason = result_reason_normal - - else if (s% center_degeneracy >= s% eta_center_limit) then + + else if (s% center_degeneracy >= s% eta_center_limit) then call compare_to_target('center_degeneracy >= eta_center_limit', & s% center_degeneracy, s% eta_center_limit, t_eta_center_limit) - - else if (s% log_center_temperature >= s% log_center_temp_upper_limit) then + + else if (s% log_center_temperature >= s% log_center_temp_upper_limit) then call compare_to_target('log_center_temperature >= log_center_temp_upper_limit', & center_value(s, s% lnT)/ln10, s% log_center_temp_upper_limit, t_log_center_temp_upper_limit) - - else if (s% log_center_temperature <= s% log_center_temp_lower_limit) then + + else if (s% log_center_temperature <= s% log_center_temp_lower_limit) then call compare_to_target('log_center_temperature <= log_center_temp_lower_limit', & center_value(s, s% lnT)/ln10, s% log_center_temp_lower_limit, & t_log_center_temp_lower_limit) - - else if (s% max_entropy >= s% max_entropy_upper_limit) then + + else if (s% max_entropy >= s% max_entropy_upper_limit) then call compare_to_target('max_entropy >= max_entropy_upper_limit', & s% max_entropy, s% max_entropy_upper_limit, t_max_entropy_upper_limit) - - else if (s% max_entropy <= s% max_entropy_lower_limit) then + + else if (s% max_entropy <= s% max_entropy_lower_limit) then call compare_to_target('max_entropy <= max_entropy_lower_limit', & s% max_entropy, s% max_entropy_lower_limit, & t_max_entropy_lower_limit) - - else if (s% center_entropy >= s% center_entropy_upper_limit) then + + else if (s% center_entropy >= s% center_entropy_upper_limit) then call compare_to_target('center_entropy >= center_entropy_upper_limit', & s% center_entropy, s% center_entropy_upper_limit, t_center_entropy_upper_limit) - - else if (s% center_entropy <= s% center_entropy_lower_limit) then + + else if (s% center_entropy <= s% center_entropy_lower_limit) then call compare_to_target('center_entropy <= center_entropy_lower_limit', & s% center_entropy, s% center_entropy_lower_limit, & t_center_entropy_lower_limit) - - else if (s% log_center_density <= s% log_center_density_lower_limit) then + + else if (s% log_center_density <= s% log_center_density_lower_limit) then call compare_to_target('log_center_density <= log_center_density_lower_limit', & center_value(s, s% lnd)/ln10, s% log_center_density_lower_limit, & t_log_center_density_lower_limit) - - else if (s% log_center_density >= s% log_center_density_upper_limit) then + + else if (s% log_center_density >= s% log_center_density_upper_limit) then call compare_to_target('log_center_density >= log_center_density_upper_limit', & center_value(s, s% lnd)/ln10, s% log_center_density_upper_limit, t_log_center_density_upper_limit) - - else if (center_gamma > s% gamma_center_limit) then + + else if (center_gamma > s% gamma_center_limit) then call compare_to_target('center_gamma > gamma_center_limit', & center_gamma, s% gamma_center_limit, t_gamma_center_limit) - - else if (s% log_max_temperature >= s% log_max_temp_upper_limit) then + + else if (s% log_max_temperature >= s% log_max_temp_upper_limit) then call compare_to_target('log_max_temperature >= log_max_temp_upper_limit', & s% log_max_temperature, s% log_max_temp_upper_limit, t_log_max_temp_upper_limit) - - else if (s% log_max_temperature <= s% log_max_temp_lower_limit) then + + else if (s% log_max_temperature <= s% log_max_temp_lower_limit) then call compare_to_target('log_max_temperature <= log_max_temp_lower_limit', & s% log_max_temperature, s% log_max_temp_lower_limit, t_log_max_temp_lower_limit) - - else if (s% center_he4 < s% HB_limit .and. s% center_h1 < 1d-4) then + + else if (s% center_he4 < s% HB_limit .and. s% center_h1 < 1d-4) then call compare_to_target('center he4 < HB_limit', s% center_he4, s% HB_limit, t_HB_limit) - - else if (s% star_mass_min_limit > 0 .and. s% star_mass <= s% star_mass_min_limit) then + + else if (s% star_mass_min_limit > 0 .and. s% star_mass <= s% star_mass_min_limit) then call compare_to_target('star_mass <= star_mass_min_limit', & s% star_mass, s% star_mass_min_limit, t_star_mass_min_limit) - - else if (s% star_mass_max_limit > 0 .and. s% star_mass >= s% star_mass_max_limit) then + + else if (s% star_mass_max_limit > 0 .and. s% star_mass >= s% star_mass_max_limit) then call compare_to_target('star_mass >= star_mass_max_limit', & s% star_mass, s% star_mass_max_limit, t_star_mass_max_limit) - - else if (s% remnant_mass_min_limit > 0 .and. remnant_mass <= s% remnant_mass_min_limit) then + + else if (s% remnant_mass_min_limit > 0 .and. remnant_mass <= s% remnant_mass_min_limit) then call compare_to_target('remnant_mass <= remnant_mass_min_limit', & remnant_mass, s% remnant_mass_min_limit, t_remnant_mass_min_limit) - - else if (s% ejecta_mass_max_limit > 0 .and. ejecta_mass >= s% ejecta_mass_max_limit) then + + else if (s% ejecta_mass_max_limit > 0 .and. ejecta_mass >= s% ejecta_mass_max_limit) then call compare_to_target('ejecta_mass >= ejecta_mass_max_limit', & ejecta_mass, s% ejecta_mass_max_limit, t_ejecta_mass_max_limit) - + else if (species_mass_for_min_limit >= 0 .and. & - species_mass_for_min_limit <= s% star_species_mass_min_limit) then + species_mass_for_min_limit <= s% star_species_mass_min_limit) then call compare_to_target( & trim(s% star_species_mass_min_limit_iso) // ' total mass <= star_species_mass_min_limit', & species_mass_for_min_limit, s% star_species_mass_min_limit, t_star_species_mass_min_limit) - - else if (species_mass_for_max_limit >= s% star_species_mass_max_limit) then + + else if (species_mass_for_max_limit >= s% star_species_mass_max_limit) then call compare_to_target( & trim(s% star_species_mass_max_limit_iso) // ' total mass >= star_species_mass_max_limit', & species_mass_for_max_limit, s% star_species_mass_max_limit, t_star_species_mass_max_limit) - - else if (s% xmstar_min_limit > 0 .and. s% xmstar <= s% xmstar_min_limit) then + + else if (s% xmstar_min_limit > 0 .and. s% xmstar <= s% xmstar_min_limit) then call compare_to_target('xmstar <= xmstar_min_limit', & s% xmstar, s% xmstar_min_limit, t_xmstar_min_limit) - - else if (s% xmstar_max_limit > 0 .and. s% xmstar >= s% xmstar_max_limit) then + + else if (s% xmstar_max_limit > 0 .and. s% xmstar >= s% xmstar_max_limit) then call compare_to_target('xmstar >= xmstar_max_limit', & s% xmstar, s% xmstar_max_limit, t_xmstar_max_limit) - - else if (s% star_mass - s% he_core_mass < s% envelope_mass_limit) then + + else if (s% star_mass - s% he_core_mass < s% envelope_mass_limit) then call compare_to_target('envelope mass < envelope_mass_limit', & s% star_mass - s% he_core_mass, s% envelope_mass_limit, & t_envelope_mass_limit) - - else if (envelope_fraction_left < s% envelope_fraction_left_limit) then + + else if (envelope_fraction_left < s% envelope_fraction_left_limit) then call compare_to_target('envelope_fraction_left < limit', & envelope_fraction_left, s% envelope_fraction_left_limit, & t_envelope_fraction_left_limit) - - else if (s% he_core_mass >= s% he_core_mass_limit) then + + else if (s% he_core_mass >= s% he_core_mass_limit) then call compare_to_target('he_core_mass >= he_core_mass_limit', & s% he_core_mass, s% he_core_mass_limit, t_he_core_mass_limit) - - else if (s% co_core_mass >= s% co_core_mass_limit) then + + else if (s% co_core_mass >= s% co_core_mass_limit) then call compare_to_target('co_core_mass >= co_core_mass_limit', & s% co_core_mass, s% co_core_mass_limit, t_co_core_mass_limit) - - else if (s% one_core_mass >= s% one_core_mass_limit) then + + else if (s% one_core_mass >= s% one_core_mass_limit) then call compare_to_target('one_core_mass >= one_core_mass_limit', & s% one_core_mass, s% one_core_mass_limit, t_one_core_mass_limit) - - else if (s% fe_core_mass >= s% fe_core_mass_limit) then + + else if (s% fe_core_mass >= s% fe_core_mass_limit) then call compare_to_target('fe_core_mass >= fe_core_mass_limit', & s% fe_core_mass, s% fe_core_mass_limit, t_fe_core_mass_limit) - - else if (s% neutron_rich_core_mass >= s% neutron_rich_core_mass_limit) then + + else if (s% neutron_rich_core_mass >= s% neutron_rich_core_mass_limit) then call compare_to_target('neutron_rich_core_mass >= neutron_rich_core_mass_limit', & s% neutron_rich_core_mass, s% neutron_rich_core_mass_limit, t_neutron_rich_core_mass_limit) - + else if ( & s% he_core_mass >= s% co_core_mass .and. & s% co_core_mass > 0 .and. & s% center_he4 < 1d-4 .and. & - s% he_core_mass - s% co_core_mass < s% he_layer_mass_lower_limit) then + s% he_core_mass - s% co_core_mass < s% he_layer_mass_lower_limit) then call compare_to_target('he layer mass < he_layer_mass_lower_limit', & s% he_core_mass - s% co_core_mass, s% he_layer_mass_lower_limit, & t_he_layer_mass_lower_limit) - + else if (abs(safe_log10(power_h_burn) - s% log_surface_luminosity) <= & s% abs_diff_lg_LH_lg_Ls_limit & - .and. s% abs_diff_lg_LH_lg_Ls_limit > 0) then + .and. s% abs_diff_lg_LH_lg_Ls_limit > 0) then call compare_to_target('abs(lg_LH - lg_Ls) <= limit', & abs(safe_log10(power_h_burn) - s% log_surface_luminosity), & s% abs_diff_lg_LH_lg_Ls_limit, t_abs_diff_lg_LH_lg_Ls_limit) - else if (s% Teff <= s% Teff_lower_limit) then + else if (s% Teff <= s% Teff_lower_limit) then call compare_to_target('Teff <= Teff_lower_limit', & s% Teff, s% Teff_lower_limit, t_Teff_lower_limit) - - else if (s% Teff >= s% Teff_upper_limit) then + + else if (s% Teff >= s% Teff_upper_limit) then call compare_to_target('Teff >= Teff_upper_limit', & s% Teff, s% Teff_upper_limit, t_Teff_upper_limit) - else if (delta_nu <= s% delta_nu_lower_limit .and. s% delta_nu_lower_limit > 0) then + else if (delta_nu <= s% delta_nu_lower_limit .and. s% delta_nu_lower_limit > 0) then call compare_to_target('delta_nu <= delta_nu_lower_limit', & delta_nu, s% delta_nu_lower_limit, t_delta_nu_lower_limit) - - else if (delta_nu >= s% delta_nu_upper_limit .and. s% delta_nu_upper_limit > 0) then + + else if (delta_nu >= s% delta_nu_upper_limit .and. s% delta_nu_upper_limit > 0) then call compare_to_target('delta_nu >= delta_nu_upper_limit', & delta_nu, s% delta_nu_upper_limit, t_delta_nu_upper_limit) - else if (s% delta_Pg <= s% delta_Pg_lower_limit .and. s% delta_Pg_lower_limit > 0) then + else if (s% delta_Pg <= s% delta_Pg_lower_limit .and. s% delta_Pg_lower_limit > 0) then call compare_to_target('delta_Pg <= delta_Pg_lower_limit', & s% delta_Pg, s% delta_Pg_lower_limit, t_delta_Pg_lower_limit) - - else if (s% delta_Pg >= s% delta_Pg_upper_limit .and. s% delta_Pg_upper_limit > 0) then + + else if (s% delta_Pg >= s% delta_Pg_upper_limit .and. s% delta_Pg_upper_limit > 0) then call compare_to_target('delta_Pg >= delta_Pg_upper_limit', & s% delta_Pg, s% delta_Pg_upper_limit, t_delta_Pg_upper_limit) - else if (s% photosphere_m - s% M_center/Msun <= s% photosphere_m_sub_M_center_limit) then + else if (s% photosphere_m - s% M_center/Msun <= s% photosphere_m_sub_M_center_limit) then call compare_to_target( & 'photosphere_m - M_center/Msun <= photosphere_m_sub_M_center_limit', & s% photosphere_m - s% M_center/Msun, & s% photosphere_m_sub_M_center_limit, & t_photosphere_m_sub_M_center_limit) - else if (s% photosphere_m <= s% photosphere_m_lower_limit) then + else if (s% photosphere_m <= s% photosphere_m_lower_limit) then call compare_to_target('photosphere_m <= photosphere_m_lower_limit', & s% photosphere_m, s% photosphere_m_lower_limit, t_photosphere_m_lower_limit) - - else if (s% photosphere_m >= s% photosphere_m_upper_limit) then + + else if (s% photosphere_m >= s% photosphere_m_upper_limit) then call compare_to_target('photosphere_m >= photosphere_m_upper_limit', & s% photosphere_m, s% photosphere_m_upper_limit, t_photosphere_m_upper_limit) - else if (s% photosphere_r <= s% photosphere_r_lower_limit) then + else if (s% photosphere_r <= s% photosphere_r_lower_limit) then call compare_to_target('photosphere_r <= photosphere_r_lower_limit', & s% photosphere_r, s% photosphere_r_lower_limit, t_photosphere_r_lower_limit) - - else if (s% photosphere_r >= s% photosphere_r_upper_limit) then + + else if (s% photosphere_r >= s% photosphere_r_upper_limit) then call compare_to_target('photosphere_r >= photosphere_r_upper_limit', & s% photosphere_r, s% photosphere_r_upper_limit, t_photosphere_r_upper_limit) - else if (log_Teff <= s% log_Teff_lower_limit) then + else if (log_Teff <= s% log_Teff_lower_limit) then call compare_to_target('log_Teff <= log_Teff_lower_limit', & log_Teff, s% log_Teff_lower_limit, t_log_Teff_lower_limit) - - else if (log_Teff >= s% log_Teff_upper_limit) then + + else if (log_Teff >= s% log_Teff_upper_limit) then call compare_to_target('log_Teff >= log_Teff_upper_limit', & log_Teff, s% log_Teff_upper_limit, t_log_Teff_upper_limit) - else if (log_surface_temperature <= s% log_Tsurf_lower_limit) then + else if (log_surface_temperature <= s% log_Tsurf_lower_limit) then call compare_to_target('log_surface_temperature <= log_Tsurf_lower_limit', & log_surface_temperature, s% log_Tsurf_lower_limit, t_log_Tsurf_lower_limit) - - else if (log_surface_temperature >= s% log_Tsurf_upper_limit) then + + else if (log_surface_temperature >= s% log_Tsurf_upper_limit) then call compare_to_target('log_surface_temperature >= log_Tsurf_upper_limit', & log_surface_temperature, s% log_Tsurf_upper_limit, t_log_Tsurf_upper_limit) - else if (s% log_surface_radius <= s% log_Rsurf_lower_limit) then + else if (s% log_surface_radius <= s% log_Rsurf_lower_limit) then call compare_to_target('log_surface_radius <= log_Rsurf_lower_limit', & s% log_surface_radius, s% log_Rsurf_lower_limit, t_log_Rsurf_lower_limit) - - else if (s% log_surface_radius >= s% log_Rsurf_upper_limit) then + + else if (s% log_surface_radius >= s% log_Rsurf_upper_limit) then call compare_to_target('log_surface_radius >= log_Rsurf_upper_limit', & s% log_surface_radius, s% log_Rsurf_upper_limit, t_log_Rsurf_upper_limit) - else if (log_surface_pressure <= s% log_Psurf_lower_limit) then + else if (log_surface_pressure <= s% log_Psurf_lower_limit) then call compare_to_target('log_surface_pressure <= log_Psurf_lower_limit', & log_surface_pressure, s% log_Psurf_lower_limit, t_log_Psurf_lower_limit) - - else if (log_surface_pressure >= s% log_Psurf_upper_limit) then + + else if (log_surface_pressure >= s% log_Psurf_upper_limit) then call compare_to_target('log_surface_pressure >= log_Psurf_upper_limit', & log_surface_pressure, s% log_Psurf_upper_limit, t_log_Psurf_upper_limit) - else if (log_surface_density <= s% log_Dsurf_lower_limit) then + else if (log_surface_density <= s% log_Dsurf_lower_limit) then call compare_to_target('log_surface_density <= log_Dsurf_lower_limit', & log_surface_density, s% log_Dsurf_lower_limit, t_log_Dsurf_lower_limit) - - else if (log_surface_density >= s% log_Dsurf_upper_limit) then + + else if (log_surface_density >= s% log_Dsurf_upper_limit) then call compare_to_target('log_surface_density >= log_Dsurf_upper_limit', & log_surface_density, s% log_Dsurf_upper_limit, t_log_Dsurf_upper_limit) - else if (s% log_surface_luminosity <= s% log_L_lower_limit) then + else if (s% log_surface_luminosity <= s% log_L_lower_limit) then call compare_to_target('log_surface_luminosity <= log_L_lower_limit', & s% log_surface_luminosity, s% log_L_lower_limit, t_log_L_lower_limit) - - else if (s% log_surface_luminosity >= s% log_L_upper_limit) then + + else if (s% log_surface_luminosity >= s% log_L_upper_limit) then call compare_to_target('log_surface_luminosity >= log_L_upper_limit', & s% log_surface_luminosity, s% log_L_upper_limit, t_log_L_upper_limit) - else if (log_surface_gravity <= s% log_g_lower_limit) then + else if (log_surface_gravity <= s% log_g_lower_limit) then call compare_to_target('log_surface_gravity <= log_g_lower_limit', & log_surface_gravity, s% log_g_lower_limit, t_log_g_lower_limit) - - else if (log_surface_gravity >= s% log_g_upper_limit) then + + else if (log_surface_gravity >= s% log_g_upper_limit) then call compare_to_target('log_surface_gravity >= log_g_upper_limit', & log_surface_gravity, s% log_g_upper_limit, t_log_g_upper_limit) - else if (power_nuc_burn >= s% power_nuc_burn_upper_limit) then + else if (power_nuc_burn >= s% power_nuc_burn_upper_limit) then call compare_to_target('power_nuc_burn >= power_nuc_burn_upper_limit', & power_nuc_burn, s% power_nuc_burn_upper_limit, t_power_nuc_burn_upper_limit) - else if (power_h_burn >= s% power_h_burn_upper_limit) then + else if (power_h_burn >= s% power_h_burn_upper_limit) then call compare_to_target('power_h_burn >= power_h_burn_upper_limit', & power_h_burn, s% power_h_burn_upper_limit, t_power_h_burn_upper_limit) - else if (power_he_burn >= s% power_he_burn_upper_limit) then + else if (power_he_burn >= s% power_he_burn_upper_limit) then call compare_to_target('power_he_burn >= power_he_burn_upper_limit', & power_he_burn, s% power_he_burn_upper_limit, t_power_he_burn_upper_limit) - else if (power_z_burn >= s% power_z_burn_upper_limit) then + else if (power_z_burn >= s% power_z_burn_upper_limit) then call compare_to_target('power_z_burn >= power_z_burn_upper_limit', & power_z_burn, s% power_z_burn_upper_limit, t_power_z_burn_upper_limit) - else if (power_nuc_burn < s% power_nuc_burn_lower_limit) then + else if (power_nuc_burn < s% power_nuc_burn_lower_limit) then call compare_to_target('power_nuc_burn < power_nuc_burn_lower_limit', & power_nuc_burn, s% power_nuc_burn_lower_limit, t_power_nuc_burn_lower_limit) - else if (power_h_burn < s% power_h_burn_lower_limit) then + else if (power_h_burn < s% power_h_burn_lower_limit) then call compare_to_target('power_h_burn < power_h_burn_lower_limit', & power_h_burn, s% power_h_burn_lower_limit, t_power_h_burn_lower_limit) - else if (power_he_burn < s% power_he_burn_lower_limit) then + else if (power_he_burn < s% power_he_burn_lower_limit) then call compare_to_target('power_he_burn < power_he_burn_lower_limit', & power_he_burn, s% power_he_burn_lower_limit, t_power_he_burn_lower_limit) - else if (power_z_burn < s% power_z_burn_lower_limit) then + else if (power_z_burn < s% power_z_burn_lower_limit) then call compare_to_target('power_z_burn < power_z_burn_lower_limit', & power_z_burn, s% power_z_burn_lower_limit, t_power_z_burn_lower_limit) - else if (s% center_Ye < s% center_Ye_lower_limit) then + else if (s% center_Ye < s% center_Ye_lower_limit) then call compare_to_target('center_Ye < center_Ye_lower_limit', & s% center_Ye, s% center_Ye_lower_limit, t_center_Ye_lower_limit) - else if (s% R_center < s% center_R_lower_limit) then + else if (s% R_center < s% center_R_lower_limit) then call compare_to_target('R_center < center_R_lower_limit', & s% R_center, s% center_R_lower_limit, t_center_R_lower_limit) - else if (s% fe_core_infall > s% fe_core_infall_limit) then + else if (s% fe_core_infall > s% fe_core_infall_limit) then if (abs(s% error_in_energy_conservation/s% total_energy_end) < & s% hard_limit_for_rel_error_in_energy_conservation) then do_check_limits = terminate @@ -1115,65 +1115,65 @@ integer function do_check_limits(id) else write(*,2) 'rel_E_err too large for fe_core_infall termination', & s% model_number, s% error_in_energy_conservation/abs(s% total_energy_end) - end if + end if - else if (s% non_fe_core_infall > s% non_fe_core_infall_limit) then + else if (s% non_fe_core_infall > s% non_fe_core_infall_limit) then call compare_to_target('non_fe_core_infall > non_fe_core_infall_limit', & s% non_fe_core_infall, s% non_fe_core_infall_limit, t_non_fe_core_infall_limit) - else if (s% non_fe_core_rebound > s% non_fe_core_rebound_limit) then + else if (s% non_fe_core_rebound > s% non_fe_core_rebound_limit) then call compare_to_target('non_fe_core_rebound > non_fe_core_rebound_limit', & s% non_fe_core_rebound, s% non_fe_core_rebound_limit, t_non_fe_core_rebound_limit) - else if (v_surf/csound_surf > s% v_div_csound_surf_limit) then + else if (v_surf/csound_surf > s% v_div_csound_surf_limit) then call compare_to_target('v_surf/csound_surf > v_div_csound_surf_limit', & v_surf/csound_surf, s% v_div_csound_surf_limit, t_v_div_csound_surf_limit) - else if (v_div_csound_max > s% v_div_csound_max_limit) then + else if (v_div_csound_max > s% v_div_csound_max_limit) then call compare_to_target('v_div_csound_max > v_div_csound_max_limit', & v_div_csound_max, s% v_div_csound_max_limit, t_v_div_csound_max_limit) - else if (s% min_gamma1 < s% gamma1_limit) then + else if (s% min_gamma1 < s% gamma1_limit) then call compare_to_target('min_gamma1 < gamma1_limit', & - s% min_gamma1, s% gamma1_limit, t_gamma1_limit) + s% min_gamma1, s% gamma1_limit, t_gamma1_limit) - else if (min_pgas_div_p < s% Pgas_div_P_limit) then + else if (min_pgas_div_p < s% Pgas_div_P_limit) then call compare_to_target('min_pgas_div_p < Pgas_div_P_limit', & - min_pgas_div_p, s% Pgas_div_P_limit, t_Pgas_div_P_limit) + min_pgas_div_p, s% Pgas_div_P_limit, t_Pgas_div_P_limit) - else if (Lnuc_div_L <= s% Lnuc_div_L_lower_limit) then + else if (Lnuc_div_L <= s% Lnuc_div_L_lower_limit) then call compare_to_target('Lnuc_div_L <= Lnuc_div_L_lower_limit', & Lnuc_div_L, s% Lnuc_div_L_lower_limit, t_Lnuc_div_L_lower_limit) - - else if (Lnuc_div_L >= s% Lnuc_div_L_upper_limit) then + + else if (Lnuc_div_L >= s% Lnuc_div_L_upper_limit) then call compare_to_target('Lnuc_div_L >= Lnuc_div_L_upper_limit', & Lnuc_div_L, s% Lnuc_div_L_upper_limit, t_Lnuc_div_L_upper_limit) - else if (v_surf_div_v_kh <= s% v_surf_div_v_kh_lower_limit) then + else if (v_surf_div_v_kh <= s% v_surf_div_v_kh_lower_limit) then call compare_to_target('v_surf_div_v_kh <= v_surf_div_v_kh_lower_limit', & v_surf_div_v_kh, s% v_surf_div_v_kh_lower_limit, t_v_surf_div_v_kh_lower_limit) - - else if (v_surf_div_v_kh >= s% v_surf_div_v_kh_upper_limit) then + + else if (v_surf_div_v_kh >= s% v_surf_div_v_kh_upper_limit) then call compare_to_target('v_surf_div_v_kh >= v_surf_div_v_kh_upper_limit', & v_surf_div_v_kh, s% v_surf_div_v_kh_upper_limit, t_v_surf_div_v_kh_upper_limit) - - else if (v_surf_div_v_esc >= s% v_surf_div_v_esc_limit) then + + else if (v_surf_div_v_esc >= s% v_surf_div_v_esc_limit) then call compare_to_target('v_surf_div_v_esc >= v_surf_div_v_esc_limit', & v_surf_div_v_esc, s% v_surf_div_v_esc_limit, t_v_surf_div_v_esc_limit) - - else if (v_surf*1d-5 >= s% v_surf_kms_limit) then + + else if (v_surf*1d-5 >= s% v_surf_kms_limit) then call compare_to_target('v_surf_kms >= v_surf_kms_limit', & v_surf*1d-5, s% v_surf_kms_limit, t_v_surf_kms_limit) - + else if (s% cumulative_extra_heating >= & s% stop_when_reach_this_cumulative_extra_heating .and.& - s% stop_when_reach_this_cumulative_extra_heating > 0) then + s% stop_when_reach_this_cumulative_extra_heating > 0) then call compare_to_target( & 'cumulative_extra_heating >= limit', & s% cumulative_extra_heating, & s% stop_when_reach_this_cumulative_extra_heating, & t_cumulative_extra_heating_limit) - + else if (s% stop_near_zams .and. & Lnuc_div_L >= s% Lnuc_div_L_zams_limit) then do_check_limits = terminate @@ -1181,79 +1181,79 @@ integer function do_check_limits(id) s% result_reason = result_reason_normal write(*, '(/,a,/, 99e20.10)') & 'stop because Lnuc_div_L >= Lnuc_div_L_zams_limit', Lnuc_div_L, s% Lnuc_div_L_zams_limit - + else if (s% stop_at_phase_PreMS .and. s% phase_of_evolution == phase_PreMS) then do_check_limits = terminate s% termination_code = t_phase_PreMS s% result_reason = result_reason_normal write(*, '(/,a,/)') 'stop because phase_of_evolution == phase_PreMS' - + else if (s% stop_at_phase_ZAMS .and. s% phase_of_evolution == phase_ZAMS) then do_check_limits = terminate s% termination_code = t_phase_ZAMS s% result_reason = result_reason_normal write(*, '(/,a,/)') 'stop because phase_of_evolution == phase_ZAMS' - + else if (s% stop_at_phase_IAMS .and. s% phase_of_evolution == phase_IAMS) then do_check_limits = terminate s% termination_code = t_phase_IAMS s% result_reason = result_reason_normal write(*, '(/,a,/)') 'stop because phase_of_evolution == phase_IAMS' - + else if (s% stop_at_phase_TAMS .and. s% phase_of_evolution == phase_TAMS) then do_check_limits = terminate s% termination_code = t_phase_TAMS s% result_reason = result_reason_normal write(*, '(/,a,/)') 'stop because phase_of_evolution == phase_TAMS' - + else if (s% stop_at_phase_He_Burn .and. s% phase_of_evolution == phase_He_Burn) then do_check_limits = terminate s% termination_code = t_phase_He_Burn s% result_reason = result_reason_normal write(*, '(/,a,/)') 'stop because phase_of_evolution == phase_He_Burn' - + else if (s% stop_at_phase_ZACHeB .and. s% phase_of_evolution == phase_ZACHeB) then do_check_limits = terminate s% termination_code = t_phase_ZACHeB s% result_reason = result_reason_normal write(*, '(/,a,/)') 'stop because phase_of_evolution == phase_ZACHeB' - + else if (s% stop_at_phase_TACHeB .and. s% phase_of_evolution == phase_TACHeB) then do_check_limits = terminate s% termination_code = t_phase_TACHeB s% result_reason = result_reason_normal write(*, '(/,a,/)') 'stop because phase_of_evolution == phase_TACHeB' - + else if (s% stop_at_phase_TP_AGB .and. s% phase_of_evolution == phase_TP_AGB) then do_check_limits = terminate s% termination_code = t_phase_TP_AGB s% result_reason = result_reason_normal write(*, '(/,a,/)') 'stop because phase_of_evolution == phase_TP_AGB' - + else if (s% stop_at_phase_C_Burn .and. s% phase_of_evolution == phase_C_Burn) then do_check_limits = terminate s% termination_code = t_phase_C_Burn s% result_reason = result_reason_normal write(*, '(/,a,/)') 'stop because phase_of_evolution == phase_C_Burn' - + else if (s% stop_at_phase_Ne_Burn .and. s% phase_of_evolution == phase_Ne_Burn) then do_check_limits = terminate s% termination_code = t_phase_Ne_Burn s% result_reason = result_reason_normal write(*, '(/,a,/)') 'stop because phase_of_evolution == phase_Ne_Burn' - + else if (s% stop_at_phase_O_Burn .and. s% phase_of_evolution == phase_O_Burn) then do_check_limits = terminate s% termination_code = t_phase_O_Burn s% result_reason = result_reason_normal write(*, '(/,a,/)') 'stop because phase_of_evolution == phase_O_Burn' - + else if (s% stop_at_phase_Si_Burn .and. s% phase_of_evolution == phase_Si_Burn) then do_check_limits = terminate s% termination_code = t_phase_Si_Burn s% result_reason = result_reason_normal write(*, '(/,a,/)') 'stop because phase_of_evolution == phase_Si_Burn' - + else if (s% stop_at_phase_WDCS .and. s% phase_of_evolution == phase_WDCS) then do_check_limits = terminate s% termination_code = t_phase_WDCS @@ -1263,14 +1263,14 @@ integer function do_check_limits(id) end if if (s% u_flag .or. s% v_flag) then ! Things that depend on hydro related quantities - if (s% shock_mass >= s% shock_mass_upper_limit .and. s% shock_mass_upper_limit > 0) then + if (s% shock_mass >= s% shock_mass_upper_limit .and. s% shock_mass_upper_limit > 0) then call compare_to_target('shock_mass >= shock_mass_upper_limit', & s% shock_mass, s% shock_mass_upper_limit, t_shock_mass_upper_limit) end if end if if (do_check_limits /= keep_going) return - + do j=1,num_xa_central_limits if (s% xa_central_lower_limit(j) <= 0) cycle if (len_trim(s% xa_central_lower_limit_species(j)) == 0) cycle @@ -1293,9 +1293,9 @@ integer function do_check_limits(id) exit end if end do - + if (do_check_limits /= keep_going) return - + do j=1,num_xa_central_limits if (s% xa_central_upper_limit(j) <= 0) cycle if (s% xa_central_upper_limit(j) >= 1) cycle @@ -1320,9 +1320,9 @@ integer function do_check_limits(id) exit end if end do - + if (do_check_limits /= keep_going) return - + do j=1,num_xa_surface_limits if (s% xa_surface_lower_limit(j) <= 0) cycle if (len_trim(s% xa_surface_lower_limit_species(j)) == 0) cycle @@ -1345,9 +1345,9 @@ integer function do_check_limits(id) exit end if end do - + if (do_check_limits /= keep_going) return - + do j=1,num_xa_surface_limits if (s% xa_surface_upper_limit(j) <= 0) cycle if (s% xa_surface_upper_limit(j) >= 1) cycle @@ -1372,9 +1372,9 @@ integer function do_check_limits(id) exit end if end do - + if (do_check_limits /= keep_going) return - + do j=1,num_xa_average_limits if (s% xa_average_lower_limit(j) <= 0) cycle if (len_trim(s% xa_average_lower_limit_species(j)) == 0) cycle @@ -1398,9 +1398,9 @@ integer function do_check_limits(id) exit end if end do - + if (do_check_limits /= keep_going) return - + do j=1,num_xa_average_limits if (s% xa_average_upper_limit(j) <= 0) cycle if (s% xa_average_upper_limit(j) >= 1) cycle @@ -1424,11 +1424,11 @@ integer function do_check_limits(id) exit end if end do - - + + contains - - + + subroutine compare_to_target(str, value, target_value, termination_code) character (len=*), intent(in) :: str real(dp), intent(in) :: value, target_value @@ -1450,8 +1450,8 @@ subroutine compare_to_target(str, value, target_value, termination_code) write(*, '(/,a,/, 99e20.10)') 'stop because ' // trim(str), value, target_value end if end subroutine compare_to_target - - + + real(dp) function get_species_mass(str) ! Msun use chem_lib, only: chem_get_iso_id character(len=*), intent(in) :: str @@ -1465,17 +1465,17 @@ real(dp) function get_species_mass(str) ! Msun end if end if end function get_species_mass - - + + end function do_check_limits - + integer function do_one_check_model(id) use rates_def, only: i_rate use chem_def, only: i_burn_c use star_utils, only: update_time, total_times integer, intent(in) :: id - + logical :: must_do_profile real(dp), parameter :: log_he_temp = 7.8d0 real(dp), parameter :: d_tau_min = 1d-2, d_tau_max = 1d0 @@ -1488,9 +1488,9 @@ integer function do_one_check_model(id) logical :: logged integer :: nz logical, parameter :: dbg = .false. - + include 'formats' - + call get_star_ptr(id, s, ierr) if (ierr /= 0) then do_one_check_model = terminate @@ -1502,14 +1502,14 @@ integer function do_one_check_model(id) profile_priority = delta_priority model = s% model_number do_one_check_model = keep_going - + do_one_check_model = do_check_limits(id) if (do_one_check_model /= keep_going) then if (dbg) write(*,*) 'do_check_limits /= keep_going' write(*,'(A)') must_do_profile = .true. end if - + if (s% u_flag) then v = s% u(1) else if (s% v_flag) then @@ -1517,13 +1517,13 @@ integer function do_one_check_model(id) else v = 0d0 end if - + power_he_burn = s% power_he_burn power_z_burn = s% power_z_burn power_neutrinos = s% power_neutrinos - + if (must_do_profile) profile_priority = phase_priority - + logged = get_history_info(s, must_do_profile) if (logged .and. s% write_profiles_flag) then @@ -1543,9 +1543,9 @@ integer function do_one_check_model(id) call set_save_profiles_info(s, profile_priority) end if end if - + end function do_one_check_model - + end module do_one_utils - + diff --git a/star/private/element_diffusion.f90 b/star/private/element_diffusion.f90 index d86617f28..d7ad6ce3e 100644 --- a/star/private/element_diffusion.f90 +++ b/star/private/element_diffusion.f90 @@ -81,7 +81,7 @@ subroutine do_element_diffusion(s, dt_in, ierr) nz = s% nz s% num_diffusion_solver_steps = 0 - + s% eps_diffusion(1:nz) = 0d0 do k = 1, nz s% energy_start(k) = s% energy(k) @@ -98,7 +98,7 @@ subroutine do_element_diffusion(s, dt_in, ierr) s% model_number, dt, s% diffusion_dt_limit return end if - + s% need_to_setvars = .true. if (s% use_other_diffusion_factor) then @@ -115,8 +115,8 @@ subroutine do_element_diffusion(s, dt_in, ierr) write(*,*) 'do_element_diffusion failed in other_diffusion_factor' return end if - - if (s% doing_timing) call start_time(s, time0, total) + + if (s% doing_timing) call start_time(s, time0, total) nz = s% nz nzlo = 1 @@ -253,7 +253,7 @@ subroutine do_element_diffusion(s, dt_in, ierr) if ( s% diffusion_use_full_net ) then s% diffusion_calculates_ionization = .true. ! class_typical_charges can't be used, so make sure they aren't. end if - + if (.not. s% diffusion_calculates_ionization) then do j=1,nc typical_charge(j,1:nz) = s% diffusion_class_typical_charge(j) @@ -306,7 +306,7 @@ subroutine do_element_diffusion(s, dt_in, ierr) ! print *, "class_chem_id: ", class_chem_id ! print *, "class: ", class ! print *, "class name: ", class_name - + ! args are at cell center points. !if (s% show_diffusion_info) write(*,*) 'call solve_diffusion' !write(*,4) 'call do_solve_diffusion nzlo nzhi nz', nzlo, nzhi, nz, & @@ -368,7 +368,7 @@ subroutine do_element_diffusion(s, dt_in, ierr) end if if (dumping) call mesa_error(__FILE__,__LINE__,'debug: dump_diffusion_info') - + do k=nzlo+1,nzhi do j=1,species i = class(j) @@ -385,7 +385,7 @@ subroutine do_element_diffusion(s, dt_in, ierr) write(*,*) "do_diffusion_heating is incompatible with do_WD_sedimentation_heating" write(*,*) "at least one of these options must be set to .false." call mesa_error(__FILE__,__LINE__,'do_element_diffusion') - end if + end if s% eps_WD_sedimentation(1:nz) = 0d0 @@ -415,7 +415,7 @@ subroutine do_element_diffusion(s, dt_in, ierr) end do end if - + do k=1,nzlo do j=1,species s% diffusion_D_self(j,k) = s% diffusion_D_self(j,nzlo+1) @@ -576,16 +576,16 @@ end subroutine set1_extras end subroutine do_element_diffusion - + subroutine finish_element_diffusion(s,dt) type (star_info), pointer :: s real(dp), intent(in) :: dt integer :: k - + do k=1,s% nz s% eps_diffusion(k) = (s% energy_start(k) - s% energy(k))/dt end do - + end subroutine finish_element_diffusion end module element_diffusion diff --git a/star/private/eos_support.f90 b/star/private/eos_support.f90 index fb34af903..d68599a66 100644 --- a/star/private/eos_support.f90 +++ b/star/private/eos_support.f90 @@ -51,7 +51,7 @@ module eos_support public :: solve_eos_given_PT public :: solve_eos_given_PgasT public :: solve_eos_given_PgasT_auto - + ! Procedures contains @@ -159,7 +159,7 @@ subroutine solve_eos_given_DE( & if (s% doing_timing) s% timing_num_solve_eos_calls = s% timing_num_solve_eos_calls + eos_calls end subroutine solve_eos_given_DE - + !**** ! Solve for temperature & eos results data given density & gas energy @@ -194,7 +194,7 @@ subroutine solve_eos_given_DEgas( & call eosDT_get_T( & s% eos_handle, & - s% species, s% chem_id, s% net_iso, xa, & + s% species, s% chem_id, s% net_iso, xa, & logRho, i_egas, egas, logT_tol, egas_tol, MAX_ITER_FOR_SOLVE, logT_guess, & arg_not_provided, arg_not_provided, arg_not_provided, arg_not_provided, & logT, res, dres_dlnRho, dres_dlnT, & @@ -241,7 +241,7 @@ subroutine solve_eos_given_DP( & arg_not_provided, arg_not_provided, arg_not_provided, arg_not_provided, & logT, res, dres_dlnRho, dres_dlnT, & dres_dxa, eos_calls, ierr) - + end subroutine solve_eos_given_DP !**** @@ -274,7 +274,7 @@ subroutine solve_eos_given_DS( & include 'formats' ierr = 0 - + call eosDT_get_T( & s% eos_handle, & s% species, s% chem_id, s% net_iso, xa, & @@ -415,7 +415,7 @@ subroutine solve_eos_given_PgasT_auto( & call basic_composition_info( & s% species, s% chem_id, xa, X, Y, Z, & abar, zbar, z2bar, z53bar, ye, mass_correction, sumx) - + gamma = 5d0/3d0 call eos_gamma_PT_get( & s% eos_handle, abar, exp10(logPgas), logPgas, exp10(logT), logT, gamma, & @@ -433,7 +433,7 @@ subroutine solve_eos_given_PgasT_auto( & ierr) end subroutine solve_eos_given_PgasT_auto - + !**** end module eos_support diff --git a/star/private/eps_mdot.f90 b/star/private/eps_mdot.f90 index b2b301f61..937111f43 100644 --- a/star/private/eps_mdot.f90 +++ b/star/private/eps_mdot.f90 @@ -101,14 +101,14 @@ real(dp) function interpolate_onto_faces(vec, dm, nz, j) ! (vec(j)-vec(j-1))/(dm-bar(j)), ! ! where - ! + ! ! dm-bar(j) = (1/2)(dm(j-1) + dm(j)). ! ! This is done because these finite differences are what ! MESA is using elsewhere, so in order to ensure consistency ! we want our interpolated vector to have derivatives consistent ! with these. - ! + ! ! When j == 1 we can't do this because we don't know vec(j-1), so ! we take vec(j-1) == vec(j) and return vec(1). ! When j == length(vec) + 1 we likewise need to assume vec(j-1) == vec(j) @@ -365,7 +365,7 @@ subroutine leak(nz, i_start, i_end, i_min, i_max, j_min, j_max, pf,& ! decremented from the excess. ! When the material reaches whatever cell it ends in (i == j) the excess is deposited ! in that cell. If material exits the star the excess it leaves with is accounted for - ! in mdot_adiabatic_surface. + ! in mdot_adiabatic_surface. @@ -419,10 +419,10 @@ subroutine leak(nz, i_start, i_end, i_min, i_max, j_min, j_max, pf,& ! counting that contribution is accounted for in the loop ! at the end of leak_frac. accumulated(i) = accumulated(i) + excess(j) - excess(j) = 0 + excess(j) = 0 else if (i == i_end .and. i == 1 .and. j == 0) then ! Material with j == 0 exits the star. Note that this implies direction == -1. - ! For i > 1 this material can be handled by the 'just passing through' else + ! For i > 1 this material can be handled by the 'just passing through' else ! clause, so we only need to think about the i == 1 case. ! Because this material isn't in the star at the end, we have to account @@ -464,7 +464,7 @@ subroutine calculate_eps_mdot(s, dt, ierr) type (star_info), pointer :: s real(dp) :: dt integer :: ierr - + ! Intermediates logical, parameter :: dbg = .false. integer :: nz, j @@ -491,7 +491,7 @@ subroutine calculate_eps_mdot(s, dt, ierr) s% total_energy_after_adjust_mass = 0d0 return end if - + s% need_to_setvars = .true. ! Stellar properties @@ -505,7 +505,7 @@ subroutine calculate_eps_mdot(s, dt, ierr) call find_mass_flux(nz, change_in_dm, mass_flux) ! Tabulate cell intersection widths between the new mesh and the old - allocate(mesh_intersects(2*nz)) + allocate(mesh_intersects(2*nz)) allocate(ranges(2*nz,2)) call make_compressed_intersect(dm, prev_mesh_dm, nz, mesh_intersects, ranges) @@ -514,7 +514,7 @@ subroutine calculate_eps_mdot(s, dt, ierr) allocate(density_weighted_flux(nz+1)) density_weighted_flux(nz+1) = 0 do j=nz,1,-1 - density_weighted_flux(j) = density_weighted_flux(j+1) + change_in_dm(j) / s%rho(j) + density_weighted_flux(j) = density_weighted_flux(j+1) + change_in_dm(j) / s%rho(j) end do ! We attribute eps_mdot evenly to all of the mass which is at any point within a cell. @@ -550,9 +550,9 @@ subroutine calculate_eps_mdot(s, dt, ierr) !$OMP PARALLEL DO do j=1,nz+1 ! We use the previous mesh for interpolation because that's the one for which our derivatives were calculated. - p_bar(j) = interpolate_onto_faces(s%Peos, prev_mesh_dm, nz, j) - rho_bar(j) = interpolate_onto_faces(s%rho, prev_mesh_dm, nz, j) - te_bar(j) = interpolate_onto_faces(te, prev_mesh_dm, nz, j) + p_bar(j) = interpolate_onto_faces(s%Peos, prev_mesh_dm, nz, j) + rho_bar(j) = interpolate_onto_faces(s%rho, prev_mesh_dm, nz, j) + te_bar(j) = interpolate_onto_faces(te, prev_mesh_dm, nz, j) end do !$OMP END PARALLEL DO diff --git a/star/private/evolve.f90 b/star/private/evolve.f90 index f2890c3f2..844995913 100644 --- a/star/private/evolve.f90 +++ b/star/private/evolve.f90 @@ -28,7 +28,7 @@ module evolve use star_private_def use const_def use star_utils - + implicit none private @@ -48,19 +48,19 @@ integer function do_evolve_step_part1(id, first_try) type (star_info), pointer :: s integer :: ierr include 'formats' - + do_evolve_step_part1 = terminate ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return if (s% trace_evolve) write(*,'(/,a)') 'start evolve step' - + if (is_bad(s% dt)) then write(*,1) 's% dt', s% dt call mesa_error(__FILE__,__LINE__,'do_evolve_step_part1') end if - + if (first_try .and. s% fill_arrays_with_NaNs .and. .not. s% RSP_flag) then if (mod(s% model_number, s% terminal_interval) == 0) & write(*,*) 'fill_arrays_with_NaNs at start of step' @@ -69,7 +69,7 @@ integer function do_evolve_step_part1(id, first_try) if (ierr /= 0) return call star_info_old_arrays(s, do_fill_arrays_with_NaNs, ierr) if (ierr /= 0) return - end if + end if do_evolve_step_part1 = do_step_part1(id, first_try) s% total_step_attempts = s% total_step_attempts + 1 if (s% doing_relax) & @@ -83,10 +83,10 @@ integer function do_evolve_step_part1(id, first_try) if (s% doing_relax) & s% total_relax_step_retries = s% total_relax_step_retries + 1 end if - + contains - - subroutine test_set_undefined + + subroutine test_set_undefined ! should include everything in star_data_step_work.inc ! may be missing some. if so, please add them. use utils_lib, only: set_to_NaN @@ -95,10 +95,10 @@ subroutine test_set_undefined s% nz_old = -999 s% model_number_old = -999 - s% prev_mesh_nz = -999 + s% prev_mesh_nz = -999 s% num_conv_boundaries = -999 s% num_mix_boundaries = -999 - s% num_mix_regions = -999 + s% num_mix_regions = -999 s% num_mixing_regions = -999 s% n_conv_regions = -999 s% atm_structure_num_pts = -999 @@ -122,12 +122,12 @@ subroutine test_set_undefined do j=1,max_num_mixing_regions call set_to_NaN(s% cz_top_mass_old(j)) call set_to_NaN(s% cz_bot_mass_old(j)) - end do + end do do j=1,num_categories call set_to_NaN(s% L_by_category(j)) end do - + ! sorted to help remove duplicates call set_to_NaN(s% L_center_old) call set_to_NaN(s% L_for_BB_outer_BC) @@ -163,15 +163,15 @@ subroutine test_set_undefined call set_to_NaN(s% dt_old) call set_to_NaN(s% dt_start) call set_to_NaN(s% dt_years) - call set_to_NaN(s% energy_change_from_do_adjust_mass_and_calculate_eps_mdot) + call set_to_NaN(s% energy_change_from_do_adjust_mass_and_calculate_eps_mdot) call set_to_NaN(s% error_in_energy_conservation) call set_to_NaN(s% explicit_mstar_dot) call set_to_NaN(s% gradT_excess_max_lambda) call set_to_NaN(s% gradT_excess_min_beta) - call set_to_NaN(s% h1_czb_mass) + call set_to_NaN(s% h1_czb_mass) call set_to_NaN(s% initial_L_center) call set_to_NaN(s% initial_R_center) - call set_to_NaN(s% initial_timestep) + call set_to_NaN(s% initial_timestep) call set_to_NaN(s% initial_v_center) call set_to_NaN(s% max_conv_time_scale) call set_to_NaN(s% max_residual) @@ -210,7 +210,7 @@ subroutine test_set_undefined call set_to_NaN(s% surf_r_equatorial) call set_to_NaN(s% surf_rho) call set_to_NaN(s% surface_cell_specific_total_energy_old) - call set_to_NaN(s% tau_center) + call set_to_NaN(s% tau_center) call set_to_NaN(s% time_days) call set_to_NaN(s% time_old) call set_to_NaN(s% time_step) @@ -219,16 +219,16 @@ subroutine test_set_undefined call set_to_NaN(s% total_abs_angular_momentum) call set_to_NaN(s% total_angular_momentum) call set_to_NaN(s% total_angular_momentum_old) - call set_to_NaN(s% total_energy) - call set_to_NaN(s% total_energy_after_adjust_mass) - call set_to_NaN(s% total_energy_before_adjust_mass) - call set_to_NaN(s% total_energy_change_from_mdot) - call set_to_NaN(s% total_energy_end) + call set_to_NaN(s% total_energy) + call set_to_NaN(s% total_energy_after_adjust_mass) + call set_to_NaN(s% total_energy_before_adjust_mass) + call set_to_NaN(s% total_energy_change_from_mdot) + call set_to_NaN(s% total_energy_end) call set_to_NaN(s% total_energy_from_diffusion) call set_to_NaN(s% total_energy_from_phase_separation) call set_to_NaN(s% total_energy_old) call set_to_NaN(s% total_energy_sources_and_sinks) - call set_to_NaN(s% total_energy_start) + call set_to_NaN(s% total_energy_start) call set_to_NaN(s% total_eps_grav) call set_to_NaN(s% total_eps_mdot) call set_to_NaN(s% total_extra_heating) @@ -275,11 +275,11 @@ subroutine test_set_undefined call set_to_NaN(s% work_inward_at_center) call set_to_NaN(s% work_outward_at_surface) call set_to_NaN(s% xmstar_old) - + end subroutine test_set_undefined - + end function do_evolve_step_part1 - + integer function do_step_part1(id, first_try) use evolve_support, only: set_current_to_old @@ -309,7 +309,7 @@ integer function do_step_part1(id, first_try) ierr = 0 call get_star_ptr(id, s, ierr) if (ierr /= 0) return - + s% termination_code = 0 s% retry_message = '' s% doing_solver_iterations = .false. @@ -321,8 +321,8 @@ integer function do_step_part1(id, first_try) s% need_to_setvars = .true. ! always start fresh s% okay_to_set_mixing_info = .true. ! set false by element diffusion s% okay_to_set_mlt_vc = .false. ! don't change mlt_vc until have set mlt_vc_old - - if (s% timestep_hold > s% model_number + 10000) then + + if (s% timestep_hold > s% model_number + 10000) then write(*,3) 'ERROR: s% timestep_hold', s% timestep_hold, s% model_number call mesa_error(__FILE__,__LINE__,'do_step_part1') end if @@ -338,7 +338,7 @@ integer function do_step_part1(id, first_try) if (failed('set_qs')) return call set_m_and_dm(s) call set_dm_bar(s, nz, s% dm, s% dm_bar) - + if (s% rotation_flag) then call set_cgrav(s, ierr) if (failed('set_cgrav')) return @@ -353,7 +353,7 @@ integer function do_step_part1(id, first_try) call set_rotation_info(s, .true., ierr) if (failed('set_rotation_info')) return end if - + if (s% doing_first_model_of_run) then if (s% do_history_file) then if (first_try) then @@ -397,9 +397,9 @@ integer function do_step_part1(id, first_try) end if end if end if - + call reset_epsnuc_vectors(s) - + call set_current_to_old(s) do_step_part1 = prepare_for_new_try(s) if (do_step_part1 /= keep_going) then @@ -407,7 +407,7 @@ integer function do_step_part1(id, first_try) write(*,*) 'do_step_part1: prepare_for_new_try' return end if - + call set_start_of_step_info(s, 'after prepare_for_new_try', ierr) ! does set_vars_if_needed if (failed('set_start_of_step_info')) return @@ -415,7 +415,7 @@ integer function do_step_part1(id, first_try) call set_cz_bdy_mass(s, ierr) if (failed('set_cz_bdy_mass')) return end if - + if (s% RSP_flag) then s% mstar_dot = 0 call rsp_total_energy_integrals(s, & @@ -437,7 +437,7 @@ integer function do_step_part1(id, first_try) s% total_turbulent_energy_old, & s% total_energy_old) end if - + s% surface_cell_specific_total_energy_old = cell_specific_total_energy(s,1) if (.not. s% have_initial_energy_integrals) then @@ -534,7 +534,7 @@ integer function do_step_part2(id, first_try) explicit_mdot, max_wind_mdot, wind_mdot, r_phot, kh_timescale, dmskhf, dmsfac, & too_large_wind_mdot, too_small_wind_mdot, boost, mstar_dot_nxt, & surf_omega_div_omega_crit_limit, dt - + integer :: ph_k, mdot_action real(dp) :: implicit_mdot, ph_L, iwind_tolerance, iwind_lambda real(dp) :: dummy1, dummy2, dummy3, dummy4, dummy5, dummy6, dummy7, dummy8 @@ -544,7 +544,7 @@ integer function do_step_part2(id, first_try) logical, parameter :: dbg = .false. include 'formats' - + ierr = 0 call get_star_ptr(id, s, ierr) if (ierr /= 0) return @@ -562,15 +562,15 @@ integer function do_step_part2(id, first_try) nz = s% nz call setup_for_implicit_mdot_loop - + implicit_mdot_loop: do - + dt = s% dt s% time = s% time_old + dt s% star_age = s% time/secyer s% okay_to_set_mixing_info = .true. - if (s% v_center /= 0d0) then ! adjust R_center + if (s% v_center /= 0d0) then ! adjust R_center s% R_center = s% R_center_old + dt*s% v_center if (s% R_center < 0d0) then write(*,2) 's% R_center', s% model_number, s% R_center @@ -578,15 +578,15 @@ integer function do_step_part2(id, first_try) return end if end if - + call set_vars_if_needed(s, dt, 'start of implicit_mdot_loop', ierr) if (failed('set_vars_if_needed start of implicit_mdot_loop')) return - if (s% RSP_flag) then - + if (s% RSP_flag) then + call set_cgrav(s, ierr) if (failed('set_cgrav')) return - + else call do_adjust_mass(s, s% species, ierr) @@ -597,14 +597,14 @@ integer function do_step_part2(id, first_try) call calculate_eps_mdot(s, dt, ierr) if (failed('calculate_eps_mdot')) return - + if (s% mstar_dot /= 0d0) then s% energy_change_from_do_adjust_mass_and_calculate_eps_mdot = & s% total_energy_after_adjust_mass - s% total_energy_before_adjust_mass else s% energy_change_from_do_adjust_mass_and_calculate_eps_mdot = 0d0 end if - + call set_vars_if_needed(s, dt, 'after calculate_eps_mdot', ierr) if (failed('set_vars_if_needed after calculate_eps_mdot')) return @@ -624,7 +624,7 @@ integer function do_step_part2(id, first_try) if(s% do_phase_separation) then call do_phase_separation(s, dt, ierr) if (failed('do_phase_separation')) return - + call set_vars_if_needed(s, dt, 'after phase separation', ierr) if (failed('set_vars_if_needed after phase separation')) return else @@ -632,19 +632,19 @@ integer function do_step_part2(id, first_try) end if s% okay_to_set_mixing_info = .false. ! no mixing changes in set_vars after this point - + if (s% do_element_diffusion) then call do_element_diffusion(s, dt, ierr) if (failed('do_element_diffusion')) return call set_vars_if_needed(s, dt, 'after element diffusion', ierr) if (failed('set_vars_if_needed after element diffusion')) return - call finish_element_diffusion(s,dt) ! calculates eps_diffusion from energy changes + call finish_element_diffusion(s,dt) ! calculates eps_diffusion from energy changes if (.false.) then write(*,1) 'dt*dm*eps_diffusion/total_energy_old', & dt*dot_product(s% dm(1:s% nz), s% eps_diffusion(1:s% nz))/s% total_energy_old end if end if - + end if if (s% rotation_flag .and. s% premix_omega .and. .not. s% j_rot_flag) then @@ -655,24 +655,24 @@ integer function do_step_part2(id, first_try) call set_vars_if_needed(s, dt, 'after do_solve_omega_mix', ierr) if (failed('after do_solve_omega_mix')) return end if - + if (s% use_other_pressure) then call s% other_pressure(s% id, ierr) if (failed('other_pressure returned ierr')) return end if call set_vars_if_needed(s, dt, 'after other_pressure', ierr) if (failed('set_vars_if_needed after other_pressure')) return - + call check_for_extra_heat(s, ierr) if (failed('check_for_extra_heat')) return call set_vars_if_needed(s, dt, 'after check_for_extra_heat', ierr) if (failed('set_vars_if_needed after check_for_extra_heat')) return - + if (.not. s% have_new_cz_bdy_info) then call set_cz_bdy_mass(s, ierr) if (failed('set_cz_bdy_mass')) return end if - + skip_global_corr_coeff_limit = (first_try .or. & s% model_number_for_last_retry /= s% model_number) ! last alternative is for redo's @@ -688,7 +688,7 @@ integer function do_step_part2(id, first_try) if (do_step_part2 /= keep_going) return if (mdot_action == exit_loop) exit implicit_mdot_loop if (s% trace_evolve) write(*,*) 'cycle implicit_mdot_loop' - + end do implicit_mdot_loop s% solver_iter = 0 ! to indicate that no longer doing solver iterations @@ -699,7 +699,7 @@ integer function do_step_part2(id, first_try) if (s% okay_to_set_mlt_vc .and. .not. s% have_mlt_vc) then s% have_mlt_vc = .true. end if - s% okay_to_set_mlt_vc = .false. + s% okay_to_set_mlt_vc = .false. end if if (.not. okay_energy_conservation()) return @@ -723,13 +723,13 @@ integer function do_step_part2(id, first_try) call do_report(s, ierr) if (failed('do_report')) return call set_phase_of_evolution(s) - + call system_clock(time0,clock_rate) s% current_system_clock_time = time0 s% total_elapsed_time = & dble(time0 - s% starting_system_clock_time)/dble(clock_rate) - - + + contains @@ -778,12 +778,12 @@ subroutine setup_for_implicit_mdot_loop end if abs_mstar_delta = 0 - + iwind_redo_cnt = 0 iwind_max_redo_cnt = s% max_tries_for_implicit_wind iwind_tolerance = s% iwind_tolerance - iwind_lambda = s% iwind_lambda - + iwind_lambda = s% iwind_lambda + end subroutine setup_for_implicit_mdot_loop @@ -791,12 +791,12 @@ integer function select_mdot_action(ierr) use hydro_rotation, only: set_surf_avg_rotation_info integer, intent(out) :: ierr include 'formats' - + select_mdot_action = exit_loop if (s% mstar_dot == 0 .or. max_mdot_redo_cnt <= 0) return ! the test of max_mdot_redo_cnt <= 0 belongs here. it was erroneously placed ! after possible select_mdot_action = cycle_loop, return. BP: Apr 25, 2021. - + if (iwind_redo_cnt < iwind_max_redo_cnt .and. iwind_lambda > 0d0) then ! check mdot calculated at end of step call get_phot_info(s, dummy1, dummy2, dummy3, ph_L, dummy4, dummy5, dummy6, dummy7, dummy8, ph_k) @@ -827,13 +827,13 @@ integer function select_mdot_action(ierr) select_mdot_action = exit_loop return end if - + ! check for omega > omega_crit mstar_dot_prev = mstar_dot mstar_dot = s% mstar_dot wind_mdot = -s% mstar_dot - + if (mdot_redo_cnt == 1 .or. ignored_first_step) then ! this is the 1st correction to mdot r_phot = sqrt(s% L(1)/(pi*crad*clight*pow4(s% Teff))) @@ -1112,7 +1112,7 @@ logical function okay_energy_conservation() sum_cell_dke, sum_cell_dpe, sum_cell_dL, sum_cell_ergs_error, sum_cell_others, & sum_cell_sources, sum_cell_terms, sum_cell_work, total_energy_from_pre_mixing,& total_energy_from_fixed_m_grav - + include 'formats' @@ -1165,16 +1165,16 @@ logical function okay_energy_conservation() s% total_turbulent_energy_end, & s% total_energy_end) end if - + if (s% mstar_dot == 0d0) then s% total_energy_change_from_mdot = 0d0 s% total_eps_mdot = 0d0 - else + else s% total_energy_change_from_mdot = & s% mstar_dot*dt*s% surface_cell_specific_total_energy_old s% total_eps_mdot = dt*dot_product(s% dm(1:nz), s% eps_mdot(1:nz)) end if - + virial = 3*sum(s% dm(1:nz)*s% Peos(1:nz)/s% rho(1:nz)) s% virial_thm_P_avg = virial @@ -1184,7 +1184,7 @@ logical function okay_energy_conservation() write(*,2) 'u_flag energy accounting ignores total_eps_grav', s% model_number, s% total_eps_grav s% total_eps_grav = 0 end if - + ! notes from Adam: ! When there are mass changes the total energy of the model changes. ! We can split this change into three parts: @@ -1193,7 +1193,7 @@ logical function okay_energy_conservation() ! 3. The mass in the model changes state. Near the surface matter changes to maintain the same rho(q) and T(q). ! Below the surface regions there is a transition region where the state interpolates between fixed-m and fixed-q. ! Still deeper the state is approximately maintained at fixed rho(m), T(m). - ! + ! ! Change (1) is accounted for entirely by the term s% total_energy_change_from_mdot. ! Change (2) is accounted for entirely by the term s% mdot_acoustic_surface. ! @@ -1206,7 +1206,7 @@ logical function okay_energy_conservation() ! state specified by the other_accreting_surface hook (if used). Matter not present in the model ! after adjust_mass is in a state calculated by comparing the thermal and mass-loss time-scales, ! and differences between this and the surface state are accounted for by the term mdot_adiabatic_surface. - ! + ! ! By adding eps_mdot, we cause a change in energy during the Newton iterations which ! cancels the change in (3). Thus eps_mdot does not enter into the energy *accounting*, just into ! the energy equation. A consequence of this is that the sum @@ -1223,7 +1223,7 @@ logical function okay_energy_conservation() associated(s% binary_other_torque))) then ! keep track of rotational kinetic energy end if - + if (s% eps_nuc_factor == 0d0 .or. s% nonlocal_NiCo_decay_heat) then s% total_nuclear_heating = 0d0 else if (s% op_split_burn) then @@ -1240,7 +1240,7 @@ logical function okay_energy_conservation() else s% total_nuclear_heating = dt*dot_product(s% dm(1:nz), s% eps_nuc(1:nz)) end if - + if (s% RSP_flag) then s% total_non_nuc_neu_cooling = 0d0 s% total_irradiation_heating = 0d0 @@ -1250,19 +1250,19 @@ logical function okay_energy_conservation() s% total_irradiation_heating = & dt*dot_product(s% dm(1:nz), s% irradiation_heat(1:nz)) end if - + s% total_WD_sedimentation_heating = 0d0 if (s% do_element_diffusion .and. s% do_WD_sedimentation_heating) then s% total_WD_sedimentation_heating = & dt*dot_product(s% dm(1:nz), s% eps_WD_sedimentation(1:nz)) end if - + s% total_energy_from_diffusion = 0d0 if (s% do_element_diffusion .and. s% do_diffusion_heating) then s% total_energy_from_diffusion = & dt*dot_product(s% dm(1:nz), s% eps_diffusion(1:nz)) end if - + total_energy_from_pre_mixing = 0d0 if (s% do_conv_premix) then total_energy_from_pre_mixing = & @@ -1277,11 +1277,11 @@ logical function okay_energy_conservation() phase2_total_energy_from_mdot = & dt*dot_product(s% dm(1:nz), s% eps_mdot(1:nz)) - + s% total_extra_heating = dt*dot_product(s% dm(1:nz), s% extra_heat(1:nz)%val) phase2_work = dt*(s% work_outward_at_surface - s% work_inward_at_center) - + if (.not. s% RSP_flag) then if (s% using_velocity_time_centering .and. & s% include_L_in_velocity_time_centering) then @@ -1335,7 +1335,7 @@ logical function okay_energy_conservation() - s% total_non_nuc_neu_cooling & + s% total_irradiation_heating & + s% total_extra_heating & - - total_radiation & + - total_radiation & - phase2_work s% total_energy_sources_and_sinks = & @@ -1354,11 +1354,11 @@ logical function okay_energy_conservation() write(*,2) 'phase2_work', s% model_number, phase2_work write(*,2) 's% work_outward_at_surface', s% model_number, s% work_outward_at_surface write(*,2) 's% work_inward_at_center', s% model_number, s% work_inward_at_center - !write(*,2) '', s% model_number, - !write(*,2) '', s% model_number, + !write(*,2) '', s% model_number, + !write(*,2) '', s% model_number, call mesa_error(__FILE__,__LINE__,'okay_energy_conservation') end if - + s% error_in_energy_conservation = & s% total_energy_end - (s% total_energy_old + s% total_energy_sources_and_sinks) @@ -1399,9 +1399,9 @@ logical function okay_energy_conservation() write(*,2) 's% total_energy_end', s% model_number, s% total_energy_end write(*,2) 's% total_energy_sources_and_sinks', s% model_number, s% total_energy_sources_and_sinks write(*,'(A)') - + if (trim(s% energy_eqn_option) == 'dedt') then - + write(*,'(A)') write(*,*) 'for debugging phase1_sources_and_sinks' write(*,'(A)') @@ -1422,7 +1422,7 @@ logical function okay_energy_conservation() write(*,2) 's% mdot_adiabatic_surface', s% model_number, s% mdot_adiabatic_surface write(*,2) 's% total_energy_change_from_mdot', s% model_number, s% total_energy_change_from_mdot write(*,2) 'phase1_sources_and_sinks', s% model_number, phase1_sources_and_sinks - write(*,*) + write(*,*) write(*,2) 'energy_start - energy_old', s% model_number, s% total_energy_start - s% total_energy_old write(*,2) 'err phase1_sources_and_sinks', s% model_number, & s% total_energy_start - (s% total_energy_old + phase1_sources_and_sinks) @@ -1430,12 +1430,12 @@ logical function okay_energy_conservation() (s% total_energy_start - (s% total_energy_old + phase1_sources_and_sinks))/s% total_energy write(*,'(A)') write(*,'(A)') - - - + + + write(*,*) 'for debugging phase2_sources_and_sinks' write(*,'(A)') - + write(*,2) 's% total_nuclear_heating', s% model_number, s% total_nuclear_heating write(*,2) 's% total_non_nuc_neu_cooling', s% model_number, s% total_non_nuc_neu_cooling write(*,2) 's% total_irradiation_heating', s% model_number, s% total_irradiation_heating @@ -1453,7 +1453,7 @@ logical function okay_energy_conservation() write(*,2) 'phase2_work', s% model_number, phase2_work write(*,2) 'total_radiation', s% model_number, total_radiation write(*,2) 's% non_epsnuc_energy_change_from_split_burn', s% model_number, & - s% non_epsnuc_energy_change_from_split_burn + s% non_epsnuc_energy_change_from_split_burn write(*,'(A)') write(*,2) 's% work_outward_at_surface', s% model_number, s% work_outward_at_surface @@ -1461,7 +1461,7 @@ logical function okay_energy_conservation() write(*,2) 'L_surf', s% model_number, L_surf write(*,2) 'L_center', s% model_number, s% L_center write(*,'(A)') - + sum_cell_dL = dt*dot_product(s% dm(1:nz), s% dL_dm(1:nz)) sum_cell_sources = dt*dot_product(s% dm(1:nz), s% energy_sources(1:nz)) sum_cell_others = dt*dot_product(s% dm(1:nz), s% energy_others(1:nz)) @@ -1475,7 +1475,7 @@ logical function okay_energy_conservation() - sum_cell_detrb - sum_cell_dke - sum_cell_dpe - sum_cell_de sum_cell_terms = -sum_cell_terms ! to make it the same sign as sum_cell_ergs_error sum_cell_ergs_error = sum(s% ergs_error(1:nz)) - + expected_sum_cell_others = & - total_energy_from_pre_mixing & - s% total_energy_from_phase_separation & @@ -1487,7 +1487,7 @@ logical function okay_energy_conservation() - s% total_non_nuc_neu_cooling & + s% total_irradiation_heating & + s% total_extra_heating - + !write(*,2) 'rel err sum all cell terms', s% model_number, & ! (phase2_sources_and_sinks - & ! (sum_cell_others + sum_cell_sources + sum_cell_dL + sum_cell_work))/s% total_energy @@ -1502,7 +1502,7 @@ logical function okay_energy_conservation() write(*,2) 'rel err sum_cell_work', s% model_number, & (sum_cell_work - phase2_work)/s% total_energy, sum_cell_work, phase2_work write(*,'(A)') - + diff_total_internal_energy = & s% total_internal_energy_end - s% total_internal_energy_start diff_total_gravitational_energy = & @@ -1513,7 +1513,7 @@ logical function okay_energy_conservation() ! s% total_rotational_kinetic_energy_end - s% total_rotational_kinetic_energy_start diff_total_turbulent_energy = & s% total_turbulent_energy_end - s% total_turbulent_energy_start - + write(*,2) 'phase2 rel err sum_cell_de', s% model_number, & (sum_cell_de - diff_total_internal_energy)/s% total_energy, & sum_cell_de, diff_total_internal_energy @@ -1530,8 +1530,8 @@ logical function okay_energy_conservation() (sum_cell_detrb - diff_total_turbulent_energy)/s% total_energy, & sum_cell_detrb, diff_total_turbulent_energy write(*,'(A)') - - + + write(*,2) 'expected rel sum_cell_ergs_error', s% model_number, & sum_cell_ergs_error/s% total_energy, & sum_cell_ergs_error, s% total_energy @@ -1544,7 +1544,7 @@ logical function okay_energy_conservation() s% error_in_energy_conservation, s% total_energy write(*,'(A)') end if - + call mesa_error(__FILE__,__LINE__,'okay_energy_conservation') end if @@ -1576,7 +1576,7 @@ logical function okay_energy_conservation() call mesa_error(__FILE__,__LINE__,'okay_energy_conservation') return end if - + if (is_bad_num(s% cumulative_energy_error)) then write(*,2) 's% cumulative_energy_error', & s% model_number, s% cumulative_energy_error @@ -1611,7 +1611,7 @@ subroutine debug(str, s) type(star_info), pointer :: s integer :: k, j include 'formats' - + return if (.not. s% rotation_flag) return @@ -1626,7 +1626,7 @@ subroutine debug(str, s) s% xa(j,k), s% abar(k) !end do end subroutine debug - + subroutine check_for_extra_heat(s, ierr) use hydro_vars, only: set_vars @@ -1650,7 +1650,7 @@ subroutine check_for_extra_heat(s, ierr) do k=1,nz s% extra_heat(k) = s% extra_power_source end do - + if (s% use_other_energy) then call s% other_energy(s% id, ierr) if (ierr /= 0) then @@ -1695,7 +1695,7 @@ subroutine check_for_extra_heat(s, ierr) end if if (s% inject_until_reach_model_with_total_energy <= s% total_energy_initial & - .or. dt <= 0d0 .or. s% total_mass_for_inject_extra_ergs_sec <= 0d0) return + .or. dt <= 0d0 .or. s% total_mass_for_inject_extra_ergs_sec <= 0d0) return start_time = s% start_time_for_inject_extra_ergs_sec if (s% time < start_time) return @@ -1710,11 +1710,11 @@ subroutine check_for_extra_heat(s, ierr) end_time = s% max_age*secyer end if if (s% time_old > end_time) return - + target_injection_ergs = & s% inject_until_reach_model_with_total_energy - s% total_energy_initial target_injection_time = end_time - start_time - s% inject_extra_ergs_sec = target_injection_ergs/target_injection_time + s% inject_extra_ergs_sec = target_injection_ergs/target_injection_time left_to_inject = & s% inject_until_reach_model_with_total_energy - s% total_energy_old qp1 = 0d0 @@ -1746,7 +1746,7 @@ subroutine check_for_extra_heat(s, ierr) end if qp1 = q00 end do - + end subroutine check_for_extra_heat @@ -1772,12 +1772,12 @@ subroutine set_start_of_step_info(s, str, ierr) if (.not. s% RSP_flag) then call set_vars_if_needed(s, s% dt, str, ierr) - if (failed('set_vars_if_needed')) return + if (failed('set_vars_if_needed')) return s% edv(1:s% species, 1:s% nz) = 0 call set_luminosity_by_category(s) s% total_angular_momentum = total_angular_momentum(s) call do_report(s, ierr) - if (failed('do_report ierr')) return + if (failed('do_report ierr')) return end if ! save a few things from start of step that will need later @@ -1791,7 +1791,7 @@ subroutine set_start_of_step_info(s, str, ierr) s% surf_rho = s% rho(1) s% prev_Ledd = eval_Ledd(s,ierr) if (failed('eval_Ledd ierr')) return - + if (.not. s% RSP_flag) then call set_gradT_excess_alpha(s, ierr) if (failed('set_gradT_excess_alpha ierr')) return @@ -1892,11 +1892,11 @@ integer function prepare_for_new_step(s) if (prepare_for_new_step /= keep_going) return end if end if - + call set_vars_if_needed(s, s% dt_next, 'prepare_for_new_step', ierr) if (failed('set_vars_if_needed ierr')) return call set_phot_info(s) ! this sets Teff and other stuff - + call new_generation(s, ierr) if (failed('new_generation ierr')) return s% generations = 2 @@ -1916,9 +1916,9 @@ integer function prepare_for_new_step(s) .and. s% max_age_in_days > 0) then s% dt_next = max(0d0, s% max_age_in_days*secday - s% time) end if - + s% dt = s% dt_next - + force_timestep_min = s% force_timestep_min if (force_timestep_min == 0) & force_timestep_min = secyer*s% force_timestep_min_years @@ -1926,15 +1926,15 @@ integer function prepare_for_new_step(s) s% dt = min(s% dt*s% force_timestep_min_factor, force_timestep_min) write(*,2) 'force increase in timestep', s% model_number, s% dt end if - + force_timestep = s% force_timestep if (force_timestep == 0) & force_timestep = secyer*s% force_timestep_years if (force_timestep > 0) s% dt = force_timestep - + s% dt_start = s% dt s% time_step = s% dt/secyer - + if (is_bad(s% dt)) then write(*,1) 's% dt', s% dt call mesa_error(__FILE__,__LINE__,'prepare_for_new_step') @@ -1976,7 +1976,7 @@ integer function do_mesh(s) if (s% restore_mesh_on_retry & .and. s% model_number_for_last_retry > s% model_number - s% num_steps_to_hold_mesh_after_retry) return s% need_to_setvars = .true. - if (s% doing_timing) call start_time(s, time0, total) + if (s% doing_timing) call start_time(s, time0, total) if (s% use_split_merge_amr) then do_mesh = remesh_split_merge(s) ! sets s% need_to_setvars = .true. if changes anything if (do_mesh /= keep_going .and. s% report_ierr) & @@ -2013,7 +2013,7 @@ integer function prepare_for_new_try(s) s% termination_code = 0 s% solver_iter = 0 s% solver_adjust_iter = 0 - + s% model_number = s% model_number_old + 1 prepare_for_new_try = keep_going @@ -2023,9 +2023,9 @@ integer function prepare_for_new_try(s) s% termination_code = 0 s% solver_iter = 0 s% solver_adjust_iter = 0 - + if (.not. s% RSP_flag) then - + screening = get_screening_mode(s,ierr) if (ierr /= 0) then write(*,*) 'bad value for screening_mode ' // trim(s% screening_mode) @@ -2053,15 +2053,15 @@ integer function pick_next_timestep(id) pick_next_timestep = terminate call get_star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% RSP_flag) then pick_next_timestep = keep_going s% dt_next = s% RSP_dt s% dt_next_unclipped = s% dt_next s% why_Tlim = Tlim_max_timestep return - end if - + end if + if (s% trace_evolve) write(*,'(/,a)') 'pick_next_timestep' if (s% max_years_for_timestep > 0) then @@ -2172,8 +2172,8 @@ integer function prepare_to_redo(id) return end if prepare_to_redo = keep_going - if (s% trace_evolve) write(*,'(/,a)') 'prepare_to_redo' - call set_current_to_old(s) + if (s% trace_evolve) write(*,'(/,a)') 'prepare_to_redo' + call set_current_to_old(s) s% need_to_setvars = .true. end function prepare_to_redo @@ -2191,7 +2191,7 @@ integer function prepare_to_retry(id) prepare_to_retry = terminate return end if - + s% need_to_setvars = .true. if (s% restore_mesh_on_retry .and. .not. s% RSP_flag) then @@ -2212,9 +2212,9 @@ integer function prepare_to_retry(id) s% nz_old = s% prev_mesh_nz end if end if - + if (s% trace_evolve) write(*,'(/,a)') 'prepare_to_retry' - + s% retry_cnt = s% retry_cnt + 1 if (s% retry_limit > 0 .and. s% retry_cnt > s% retry_limit) then s% dt_start = sqrt(s% dt*s% dt_start) @@ -2260,7 +2260,7 @@ integer function prepare_to_retry(id) end if call set_current_to_old(s) - + s% num_retries = s% num_retries+1 if (s% num_retries > s% max_number_retries .and. s% max_number_retries >= 0) then write(*,2) 'num_retries', s% num_retries diff --git a/star/private/evolve_support.f90 b/star/private/evolve_support.f90 index 28e4fecef..487cff754 100644 --- a/star/private/evolve_support.f90 +++ b/star/private/evolve_support.f90 @@ -48,7 +48,7 @@ subroutine new_generation(s, ierr) ierr = 0 nz = s% nz - + if (.not. s% rsp_flag) then call copy_to_old(s% dq, s% dq_old, ierr) @@ -62,7 +62,7 @@ subroutine new_generation(s, ierr) call copy_to_old(s% j_rot, s% j_rot_old, ierr) if (ierr /= 0) return - + call copy_to_old(s% mlt_vc, s% mlt_vc_old, ierr) if (ierr /= 0) return @@ -82,9 +82,9 @@ subroutine new_generation(s, ierr) s% xa_old(j,k) = s% xa(j,k) end do end do - + end if - + s% model_number_old = s% model_number s% nz_old = s% nz s% time_old = s% time @@ -104,7 +104,7 @@ subroutine new_generation(s, ierr) s% power_h_burn_old = s% power_h_burn s% power_he_burn_old = s% power_he_burn s% power_z_burn_old = s% power_z_burn - s% power_photo_old = s% power_photo + s% power_photo_old = s% power_photo s% mstar_dot_old = s% mstar_dot s% L_phot_old = s% L_phot s% L_surf_old = s% L_surf @@ -125,7 +125,7 @@ subroutine new_generation(s, ierr) s% lxtra_old = s% lxtra call s% other_new_generation(s% id, ierr) - + s% need_to_setvars = .true. contains @@ -201,7 +201,7 @@ subroutine set_current_to_old(s) s% mlt_vc(k) = s% mlt_vc_old(k) end do s% okay_to_set_mlt_vc = .true. - + call set_qs(s, s% nz, s% q, s% dq, ierr) if (ierr /= 0) then write(*,*) 'set_current_to_old failed in set_qs' diff --git a/star/private/gravity_darkening.f90 b/star/private/gravity_darkening.f90 index 34c40a10a..fbd8a2b47 100644 --- a/star/private/gravity_darkening.f90 +++ b/star/private/gravity_darkening.f90 @@ -8,7 +8,7 @@ !!% !!% 0 (no rotation) <= omega <= 1 (critical rotation) !!% 0 (equator) <= inclination in radians <= pi/2 (pole) -!!% +!!% !!% !!% The coefficients are obtained via 2D interpolation using the interp_2d !!% module in tables. The tables were computed using the code at @@ -45,7 +45,7 @@ module gravity_darkening private public :: gravity_darkening_Teff_coeff, gravity_darkening_L_coeff - + contains subroutine GD_init(ierr) @@ -63,7 +63,7 @@ subroutine GD_init(ierr) ibcxmin = 0; bcxmin = 0 ibcxmax = 0; bcxmax = 0 ibcymin = 0; bcymin = 0 - ibcymax = 0; bcymax = 0 + ibcymax = 0; bcymax = 0 coefficient_filename = trim(mesa_data_dir) // '/star_data/gravity_darkening_coefficients.data' @@ -90,7 +90,7 @@ subroutine GD_init(ierr) ibcxmin, bcxmin, ibcxmax, bcxmax, ibcymin, bcymin, ibcymax, bcymax, & ilinx, iliny, ierr) - if(ierr==0) GD_initialized = .true. + if(ierr==0) GD_initialized = .true. end subroutine GD_init diff --git a/star/private/history_specs.f90 b/star/private/history_specs.f90 index a686f686e..6bb9632b2 100644 --- a/star/private/history_specs.f90 +++ b/star/private/history_specs.f90 @@ -56,7 +56,7 @@ module history_specs integer, parameter :: abs_mag_offset = bc_offset + idel integer, parameter :: lum_band_offset = abs_mag_offset + idel integer, parameter :: log_lum_band_offset = lum_band_offset + idel - + integer, parameter :: raw_rate_offset = log_lum_band_offset + idel integer, parameter :: screened_rate_offset = raw_rate_offset + idel integer, parameter :: eps_nuc_rate_offset = screened_rate_offset + idel @@ -131,7 +131,7 @@ recursive subroutine add_history_columns( & open(newunit=iounit, file=trim(filename), action='read', status='old', iostat=ierr) - if (ierr /= 0) then + if (ierr /= 0) then write(*,*) 'failed to open ' // trim(history_columns_file) return end if @@ -224,7 +224,7 @@ recursive subroutine add_history_columns( & call count_specs cycle end if - + if (string == 'add_total_mass') then call do_abundances(total_mass_offset, spec_err) if (spec_err /= 0) then @@ -260,7 +260,7 @@ recursive subroutine add_history_columns( & call count_specs cycle end if - + if (string == 'add_lum_band') then call do_colors(lum_band_offset,'lum_band_', spec_err) if (spec_err /= 0) then @@ -269,7 +269,7 @@ recursive subroutine add_history_columns( & call count_specs cycle end if - + if (string == 'add_log_lum_band') then call do_colors(log_lum_band_offset,'log_lum_band_', spec_err) if (spec_err /= 0) then @@ -626,8 +626,8 @@ logical function do1(string, name, offset, func) ! We have string value (i.e total_mass c12) call func(offset) do1 = .true. - else if(string(1:len_trim(name)+1) == trim(name)//'_') then - ! We have string_value (i.e total_mass_c12) + else if(string(1:len_trim(name)+1) == trim(name)//'_') then + ! We have string_value (i.e total_mass_c12) ! Rewrite string so its in the form string value (i.e total_mass c12) ! By finding the last _ and replacing with a space k = index(string,'_',.true.) diff --git a/star/private/hydro_alpha_rti_eqns.f90 b/star/private/hydro_alpha_rti_eqns.f90 index b157b003e..9e86748f5 100644 --- a/star/private/hydro_alpha_rti_eqns.f90 +++ b/star/private/hydro_alpha_rti_eqns.f90 @@ -76,9 +76,9 @@ subroutine do1_dalpha_RTI_dt_eqn(s, k, nvar, ierr) dq = s% dq(k) dm = s% dm(k) rho = s% rho_start(k) - r00 = s% r_start(k) + r00 = s% r_start(k) fac = s% alpha_RTI_diffusion_factor - + sig00 = fac*sig(k) if (k < nz) then sigp1 = fac*sig(k+1) @@ -115,7 +115,7 @@ subroutine do1_dalpha_RTI_dt_eqn(s, k, nvar, ierr) ! Flux divergence dadt_mix = (fluxp1 - flux00)/dm - ! Sources and sink s + ! Sources and sink s dPdr_drhodr = s% dPdr_dRhodr_info(k) if (a_00 <= 0d0 .or. s% RTI_D <= 0d0) then @@ -130,8 +130,8 @@ subroutine do1_dalpha_RTI_dt_eqn(s, k, nvar, ierr) RTI_D = s% RTI_D*max(1d0,a_00/s% RTI_max_alpha) source_minus = RTI_D*a_00*cs/rmid end if - - instability2 = -dPdr_drhodr ! > 0 means Rayleigh-Taylor unstable + + instability2 = -dPdr_drhodr ! > 0 means Rayleigh-Taylor unstable if (instability2 <= 0d0 .or. & s% q(k) > s% alpha_RTI_src_max_q .or. & s% q(k) < s% alpha_RTI_src_min_q) then @@ -194,7 +194,7 @@ subroutine do1_dalpha_RTI_dt_eqn(s, k, nvar, ierr) end if - if (test_partials) then + if (test_partials) then s% solver_test_partials_var = i_alpha_RTI s% solver_test_partials_dval_dx = resid%d1val2 write(*,*) 'do1_dalpha_RTI_dt_eqn', s% solver_test_partials_var diff --git a/star/private/hydro_chem_eqns.f90 b/star/private/hydro_chem_eqns.f90 index 98385ad1c..66e0cb59a 100644 --- a/star/private/hydro_chem_eqns.f90 +++ b/star/private/hydro_chem_eqns.f90 @@ -89,7 +89,7 @@ subroutine do1_chem_eqns(s, k, nvar, ierr) dq = s% dq(k) dm = s% dm(k) - + max_abs_residual = 0 sum_dxdt_nuc = 0 @@ -109,7 +109,7 @@ subroutine do1_chem_eqns(s, k, nvar, ierr) sum_dx_burning = 0 sum_dx_mixing = 0 - + do j=1,species ! composition equation for species j in cell k !test_partials = (k == s% solver_test_partials_k .and. s% net_iso(ihe4) == j) @@ -118,7 +118,7 @@ subroutine do1_chem_eqns(s, k, nvar, ierr) i = s%nvar_hydro+j dxdt_actual = s% xa_sub_xa_start(j,k)/s% dt - + doing_op_split_burn = s% op_split_burn .and. s% T_start(k) >= s% op_split_burn_min_T if (s% do_burn .and. .not. doing_op_split_burn) then dxdt_nuc = s% dxdt_nuc(j,k) @@ -139,7 +139,7 @@ subroutine do1_chem_eqns(s, k, nvar, ierr) eqn_scale = max(s% min_chem_eqn_scale, s% x_scale(i,k)/s% dt) residual = (dxdt_expected - dxdt_actual)/eqn_scale s% equ(i,k) = residual - + if (abs(residual) > max_abs_residual) & max_abs_residual = abs(s% equ(i,k)) @@ -172,10 +172,10 @@ subroutine do1_chem_eqns(s, k, nvar, ierr) if (checking) call check_dequ(dequ,'d_dxdt_nuc_dx') call e00(s, i, ii, k, nvar, dxdt_factor*dequ) end do - + dequ_dlnd = s% d_dxdt_nuc_drho(j,k)*s% rho(k)/eqn_scale call e00(s, i, s% i_lnd, k, nvar, dxdt_factor*dequ_dlnd) - + dequ_dlnT = s% d_dxdt_nuc_dT(j,k)*s% T(k)/eqn_scale call e00(s, i, s% i_lnT, k, nvar, dxdt_factor*dequ_dlnT) @@ -202,7 +202,7 @@ subroutine do1_chem_eqns(s, k, nvar, ierr) end if - if (test_partials) then + if (test_partials) then s% solver_test_partials_dx_sink = s% net_iso(img24) s% solver_test_partials_val = s% dxdt_nuc(j,k) s% solver_test_partials_var = s% nvar_hydro + j @@ -211,9 +211,9 @@ subroutine do1_chem_eqns(s, k, nvar, ierr) end if end do - + contains - + subroutine check_dequ(dequ, str) real(dp), intent(in) :: dequ character (len=*), intent(in) :: str diff --git a/star/private/hydro_energy.f90 b/star/private/hydro_energy.f90 index 41c1c8525..9a724a4d3 100644 --- a/star/private/hydro_energy.f90 +++ b/star/private/hydro_energy.f90 @@ -39,7 +39,7 @@ module hydro_energy public :: do1_energy_eqn contains - + subroutine do1_energy_eqn( & ! energy conservation s, k, do_chem, nvar, ierr) @@ -47,8 +47,8 @@ subroutine do1_energy_eqn( & ! energy conservation type (star_info), pointer :: s integer, intent(in) :: k, nvar logical, intent(in) :: do_chem - integer, intent(out) :: ierr - real(dp), dimension(nvar) :: d_dm1, d_d00, d_dp1 + integer, intent(out) :: ierr + real(dp), dimension(nvar) :: d_dm1, d_d00, d_dp1 include 'formats' call get1_energy_eqn( & s, k, do_chem, nvar, & @@ -56,7 +56,7 @@ subroutine do1_energy_eqn( & ! energy conservation if (ierr /= 0) then if (s% report_ierr) write(*,2) 'ierr /= 0 for get1_energy_eqn', k return - end if + end if call store_partials( & s, k, s% i_dlnE_dt, nvar, d_dm1, d_d00, d_dp1, 'do1_energy_eqn', ierr) end subroutine do1_energy_eqn @@ -68,12 +68,12 @@ subroutine get1_energy_eqn( & use eps_grav, only: eval_eps_grav_and_partials use accurate_sum_auto_diff_star_order1 use auto_diff_support - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(in) :: k, nvar logical, intent(in) :: do_chem real(dp), intent(out), dimension(nvar) :: d_dm1, d_d00, d_dp1 integer, intent(out) :: ierr - + type(auto_diff_real_star_order1) :: resid_ad, & dL_dm_ad, sources_ad, others_ad, d_turbulent_energy_dt_ad, & dwork_dm_ad, eps_grav_ad, dke_dt_ad, dpe_dt_ad, de_dt_ad @@ -83,26 +83,26 @@ subroutine get1_energy_eqn( & d_dwork_dxam1, d_dwork_dxa00, d_dwork_dxap1 integer :: nz, i_dlnE_dt, i_lum, i_v logical :: test_partials, doing_op_split_burn, eps_grav_form - + include 'formats' !test_partials = (k == s% solver_test_partials_k) test_partials = .false. - + ierr = 0 call init - - call setup_eps_grav(ierr); if (ierr /= 0) return ! do this first - it sets eps_grav_form - call setup_de_dt_and_friends(ierr); if (ierr /= 0) return - call setup_dwork_dm(ierr); if (ierr /= 0) return - call setup_dL_dm(ierr); if (ierr /= 0) return - call setup_sources_and_others(ierr); if (ierr /= 0) return - call setup_d_turbulent_energy_dt(ierr); if (ierr /= 0) return + + call setup_eps_grav(ierr); if (ierr /= 0) return ! do this first - it sets eps_grav_form + call setup_de_dt_and_friends(ierr); if (ierr /= 0) return + call setup_dwork_dm(ierr); if (ierr /= 0) return + call setup_dL_dm(ierr); if (ierr /= 0) return + call setup_sources_and_others(ierr); if (ierr /= 0) return + call setup_d_turbulent_energy_dt(ierr); if (ierr /= 0) return call set_energy_eqn_scal(s, k, scal, ierr); if (ierr /= 0) return - + s% dL_dm(k) = dL_dm_ad%val s% dwork_dm(k) = dwork_dm_ad%val - s% energy_sources(k) = sources_ad%val + s% energy_sources(k) = sources_ad%val ! nuclear heating, non_nuc_neu_cooling, irradiation heating, extra_heat, eps_mdot s% energy_others(k) = others_ad%val ! eps_WD_sedimentation, eps_diffusion, eps_pre_mix, eps_phase_separation @@ -123,15 +123,15 @@ subroutine get1_energy_eqn( & resid_ad = scal*resid_ad residual = resid_ad%val s% equ(i_dlnE_dt, k) = residual - + if (test_partials) then s% solver_test_partials_val = residual end if call unpack_res18(s% species, resid_ad) - if (test_partials) then + if (test_partials) then s% solver_test_partials_var = s% i_u - s% solver_test_partials_dval_dx = d_d00(s% solver_test_partials_var) + s% solver_test_partials_dval_dx = d_d00(s% solver_test_partials_var) write(*,*) 'get1_energy_eqn', s% solver_test_partials_var if (eps_grav_form) write(*,*) 'eps_grav_form', eps_grav_form !if (.false. .and. s% solver_iter == s% solver_test_partials_iter_number) then @@ -153,9 +153,9 @@ subroutine get1_energy_eqn( & end if write(*,'(A)') end if - + contains - + subroutine init i_dlnE_dt = s% i_dlnE_dt i_lum = s% i_lum @@ -167,7 +167,7 @@ subroutine init s% T_start(k) >= s% op_split_burn_min_T d_dm1 = 0d0; d_d00 = 0d0; d_dp1 = 0d0 end subroutine init - + subroutine setup_dwork_dm(ierr) integer, intent(out) :: ierr real(dp) :: dwork @@ -178,7 +178,7 @@ subroutine setup_dwork_dm(ierr) if (s% using_velocity_time_centering .and. & s% use_P_d_1_div_rho_form_of_work_when_time_centering_velocity) then call eval_simple_PdV_work(s, k, skip_P, dwork_dm_ad, dwork, & - d_dwork_dxa00, ierr) + d_dwork_dxa00, ierr) d_dwork_dxam1 = 0 d_dwork_dxap1 = 0 if (k == s% nz) then @@ -193,7 +193,7 @@ subroutine setup_dwork_dm(ierr) end if else call eval_dwork(s, k, skip_P, dwork_dm_ad, dwork, & - d_dwork_dxam1, d_dwork_dxa00, d_dwork_dxap1, ierr) + d_dwork_dxam1, d_dwork_dxa00, d_dwork_dxap1, ierr) end if if (ierr /= 0) then if (s% report_ierr) write(*,*) 'failed in setup_dwork_dm', k @@ -201,13 +201,13 @@ subroutine setup_dwork_dm(ierr) end if dwork_dm_ad = dwork_dm_ad/dm end subroutine setup_dwork_dm - - subroutine setup_dL_dm(ierr) + + subroutine setup_dL_dm(ierr) integer, intent(out) :: ierr type(auto_diff_real_star_order1) :: L00_ad, Lp1_ad real(dp) :: L_theta include 'formats' - ierr = 0 + ierr = 0 if (s% using_velocity_time_centering .and. & s% include_L_in_velocity_time_centering) then L_theta = s% L_theta_for_velocity_time_centering @@ -228,7 +228,7 @@ subroutine setup_sources_and_others(ierr) ! sources_ad, others_ad v_00, v_p1, drag_force, drag_energy include 'formats' ierr = 0 - + if (s% eps_nuc_factor == 0d0 .or. s% nonlocal_NiCo_decay_heat) then eps_nuc_ad = 0 ! get eps_nuc from extra_heat instead else if (s% op_split_burn .and. s% T_start(k) >= s% op_split_burn_min_T) then @@ -240,19 +240,19 @@ subroutine setup_sources_and_others(ierr) ! sources_ad, others_ad eps_nuc_ad%d1Array(i_lnd_00) = s% d_epsnuc_dlnd(k) eps_nuc_ad%d1Array(i_lnT_00) = s% d_epsnuc_dlnT(k) end if - + non_nuc_neu_ad = 0d0 ! for reasons lost in the past, we always time center non_nuc_neu ! change that if you are feeling lucky. non_nuc_neu_ad%val = 0.5d0*(s% non_nuc_neu_start(k) + s% non_nuc_neu(k)) non_nuc_neu_ad%d1Array(i_lnd_00) = 0.5d0*s% d_nonnucneu_dlnd(k) non_nuc_neu_ad%d1Array(i_lnT_00) = 0.5d0*s% d_nonnucneu_dlnT(k) - + extra_heat_ad = s% extra_heat(k) - + ! other = eps_WD_sedimentation + eps_diffusion + eps_pre_mix + eps_phase_separation ! no partials for any of these - others_ad = 0d0 + others_ad = 0d0 if (s% do_element_diffusion) then if (s% do_WD_sedimentation_heating) then others_ad%val = others_ad%val + s% eps_WD_sedimentation(k) @@ -264,13 +264,13 @@ subroutine setup_sources_and_others(ierr) ! sources_ad, others_ad others_ad%val = others_ad%val + s% eps_pre_mix(k) if (s% do_phase_separation .and. s% do_phase_separation_heating) & others_ad%val = others_ad%val + s% eps_phase_separation(k) - + Eq_ad = 0d0 - if (s% RSP2_flag) then + if (s% RSP2_flag) then Eq_ad = s% Eq_ad(k) ! compute_Eq_cell(s, k, ierr) if (ierr /= 0) return - end if - + end if + call setup_RTI_diffusion(RTI_diffusion_ad) drag_energy = 0d0 @@ -299,11 +299,11 @@ subroutine setup_sources_and_others(ierr) ! sources_ad, others_ad sources_ad = eps_nuc_ad - non_nuc_neu_ad + extra_heat_ad + Eq_ad + RTI_diffusion_ad + drag_energy sources_ad%val = sources_ad%val + s% irradiation_heat(k) - + if (s% mstar_dot /= 0d0) sources_ad%val = sources_ad%val + s% eps_mdot(k) end subroutine setup_sources_and_others - + subroutine setup_RTI_diffusion(diffusion_eps_ad) type(auto_diff_real_star_order1), intent(out) :: diffusion_eps_ad real(dp) :: diffusion_factor, emin_start, sigp1, sig00 @@ -345,7 +345,7 @@ subroutine setup_RTI_diffusion(diffusion_eps_ad) end if s% dedt_RTI(k) = diffusion_eps_ad%val end subroutine setup_RTI_diffusion - + subroutine setup_d_turbulent_energy_dt(ierr) integer, intent(out) :: ierr include 'formats' @@ -357,22 +357,22 @@ subroutine setup_d_turbulent_energy_dt(ierr) end if s% detrbdt(k) = d_turbulent_energy_dt_ad%val end subroutine setup_d_turbulent_energy_dt - + subroutine setup_eps_grav(ierr) integer, intent(out) :: ierr include 'formats' ierr = 0 - - if (s% u_flag) then ! for now, assume u_flag means no eps_grav + + if (s% u_flag) then ! for now, assume u_flag means no eps_grav eps_grav_form = .false. return end if ! value from checking s% energy_eqn_option in hydro_eqns.f90 eps_grav_form = s% eps_grav_form_for_energy_eqn - + if (.not. eps_grav_form) then ! check if want it true - if (s% doing_relax .and. s% no_dedt_form_during_relax) eps_grav_form = .true. + if (s% doing_relax .and. s% no_dedt_form_during_relax) eps_grav_form = .true. end if if (eps_grav_form) then @@ -386,7 +386,7 @@ subroutine setup_eps_grav(ierr) end if eps_grav_ad = s% eps_grav_ad(k) end if - + end subroutine setup_eps_grav subroutine setup_de_dt_and_friends(ierr) @@ -403,7 +403,7 @@ subroutine setup_de_dt_and_friends(ierr) de_dt = 0d0; d_de_dt_dlnd = 0d0; d_de_dt_dlnT = 0d0 if (.not. eps_grav_form) then - + de_dt = (s% energy(k) - s% energy_start(k))/dt d_de_dt_dlnd = s% dE_dRho_for_partials(k)*s% rho(k)/dt d_de_dt_dlnT = s% Cv_for_partials(k)*s% T(k)/dt @@ -411,10 +411,10 @@ subroutine setup_de_dt_and_friends(ierr) de_dt_ad%val = de_dt de_dt_ad%d1Array(i_lnd_00) = d_de_dt_dlnd de_dt_ad%d1Array(i_lnT_00) = d_de_dt_dlnT - + call get_dke_dt_dpe_dt(s, k, dt, & dke_dt, d_dkedt_dv00, d_dkedt_dvp1, & - dpe_dt, d_dpedt_dlnR00, d_dpedt_dlnRp1, ierr) + dpe_dt, d_dpedt_dlnR00, d_dpedt_dlnRp1, ierr) if (ierr /= 0) then if (s% report_ierr) write(*,2) 'failed in get_dke_dt_dpe_dt', k return @@ -423,21 +423,21 @@ subroutine setup_de_dt_and_friends(ierr) dke_dt_ad%val = dke_dt dke_dt_ad%d1Array(i_v_00) = d_dkedt_dv00 dke_dt_ad%d1Array(i_v_p1) = d_dkedt_dvp1 - + dpe_dt_ad = 0d0 dpe_dt_ad%val = dpe_dt dpe_dt_ad%d1Array(i_lnR_00) = d_dpedt_dlnR00 dpe_dt_ad%d1Array(i_lnR_p1) = d_dpedt_dlnRp1 - + end if - + s% dkedt(k) = dke_dt s% dpedt(k) = dpe_dt s% dkedt(k) = dke_dt s% dedt(k) = de_dt - + end subroutine setup_de_dt_and_friends - + subroutine unpack_res18(species,res18) use star_utils, only: save_eqn_dxa_partials, unpack_residual_partials type(auto_diff_real_star_order1) :: res18 @@ -447,7 +447,7 @@ subroutine unpack_res18(species,res18) real(dp), dimension(species) :: dxam1, dxa00, dxap1 logical, parameter :: checking = .true. include 'formats' - + ! do partials wrt composition dxam1 = 0d0; dxa00 = 0d0; dxap1 = 0d0 if (.not. (s% nonlocal_NiCo_decay_heat .or. doing_op_split_burn)) then @@ -460,27 +460,27 @@ subroutine unpack_res18(species,res18) end if end if - if (.not. eps_grav_form) then + if (.not. eps_grav_form) then do j=1,s% species dequ = -scal*(s%energy(k)/dt)*s% dlnE_dxa_for_partials(j,k) if (checking) call check_dequ(dequ,'dlnE_dxa_for_partials') dxa00(j) = dxa00(j) + dequ - end do + end do else if (do_chem .and. (.not. doing_op_split_burn) .and. & - (s% dxdt_nuc_factor > 0d0 .or. s% mix_factor > 0d0)) then + (s% dxdt_nuc_factor > 0d0 .or. s% mix_factor > 0d0)) then do j=1,s% species dequ = scal*s% d_eps_grav_dx(j,k) if (checking) call check_dequ(dequ,'d_eps_grav_dx') dxa00(j) = dxa00(j) + dequ - end do + end do end if - + do j=1,s% species dequ = -scal*d_dwork_dxa00(j)/dm if (checking) call check_dequ(dequ,'d_dwork_dxa00') dxa00(j) = dxa00(j) + dequ end do - if (k > 1) then + if (k > 1) then do j=1,s% species dequ = -scal*d_dwork_dxam1(j)/dm if (checking) call check_dequ(dequ,'d_dwork_dxam1') @@ -493,14 +493,14 @@ subroutine unpack_res18(species,res18) if (checking) call check_dequ(dequ,'d_dwork_dxap1') dxap1(j) = dxap1(j) + dequ end do - end if + end if call save_eqn_dxa_partials(& s, k, nvar, i_dlnE_dt, species, dxam1, dxa00, dxap1, 'get1_energy_eqn', ierr) - + call unpack_residual_partials(s, k, nvar, i_dlnE_dt, & res18, d_dm1, d_d00, d_dp1) - + end subroutine unpack_res18 subroutine check_dequ(dequ, str) @@ -518,7 +518,7 @@ subroutine check_dequ(dequ, str) return end if end subroutine check_dequ - + subroutine unpack1(j, dvar_m1, dvar_00, dvar_p1) integer, intent(in) :: j real(dp), intent(in) :: dvar_m1, dvar_00, dvar_p1 @@ -531,11 +531,11 @@ end subroutine get1_energy_eqn subroutine eval_dwork(s, k, skip_P, dwork_ad, dwork, & - d_dwork_dxam1, d_dwork_dxa00, d_dwork_dxap1, ierr) + d_dwork_dxam1, d_dwork_dxa00, d_dwork_dxap1, ierr) use accurate_sum_auto_diff_star_order1 use auto_diff_support use star_utils, only: calc_Ptot_ad_tw - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(in) :: k logical, intent(in) :: skip_P type(auto_diff_real_star_order1), intent(out) :: dwork_ad @@ -543,7 +543,7 @@ subroutine eval_dwork(s, k, skip_P, dwork_ad, dwork, & real(dp), intent(out), dimension(s% species) :: & d_dwork_dxam1, d_dwork_dxa00, d_dwork_dxap1 integer, intent(out) :: ierr - + real(dp) :: work_00, work_p1 real(dp), dimension(s% species) :: & d_work_00_dxa00, d_work_00_dxam1, & @@ -560,18 +560,18 @@ subroutine eval_dwork(s, k, skip_P, dwork_ad, dwork, & call eval1_work(s, k+1, skip_P, & work_p1_ad, work_p1, d_work_p1_dxap1, d_work_p1_dxa00, ierr) if (ierr /= 0) return - work_p1_ad = shift_p1(work_p1_ad) ! shift the partials + work_p1_ad = shift_p1(work_p1_ad) ! shift the partials dwork_ad = work_00_ad - work_p1_ad dwork = dwork_ad%val do j=1,s% species d_dwork_dxam1(j) = d_work_00_dxam1(j) d_dwork_dxa00(j) = d_work_00_dxa00(j) - d_work_p1_dxa00(j) d_dwork_dxap1(j) = -d_work_p1_dxap1(j) - end do + end do - !test_partials = (k == s% solver_test_partials_k) + !test_partials = (k == s% solver_test_partials_k) test_partials = .false. - + if (test_partials) then s% solver_test_partials_val = 0 s% solver_test_partials_var = 0 @@ -580,7 +580,7 @@ subroutine eval_dwork(s, k, skip_P, dwork_ad, dwork, & end if end subroutine eval_dwork - + ! ergs/s at face(k) subroutine eval1_work(s, k, skip_Peos, & @@ -588,7 +588,7 @@ subroutine eval1_work(s, k, skip_Peos, & use star_utils, only: get_Pvsc_ad, calc_Ptrb_ad_tw, get_rho_face use accurate_sum_auto_diff_star_order1 use auto_diff_support - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(in) :: k logical, intent(in) :: skip_Peos type(auto_diff_real_star_order1), intent(out) :: work_ad @@ -623,19 +623,19 @@ subroutine eval1_work(s, k, skip_Peos, & end if end if work_ad%val = work - return + return end if - + call eval1_A_times_v_face_ad(s, k, A_times_v_face_ad, ierr) if (ierr /= 0) return - if (k > 1) then + if (k > 1) then alfa = s% dq(k-1)/(s% dq(k-1) + s% dq(k)) else alfa = 1d0 end if beta = 1d0 - alfa - + if (s% using_velocity_time_centering .and. & s% include_P_in_velocity_time_centering) then P_theta = s% P_theta_for_velocity_time_centering @@ -653,14 +653,14 @@ subroutine eval1_work(s, k, skip_Peos, & if (skip_Peos) then Peos_ad = 0d0 else - if (k > 1) then + if (k > 1) then PR_ad = P_theta*wrap_Peos_m1(s,k) + (1d0-P_theta)*s% Peos_start(k-1) else PR_ad = 0d0 end if PL_ad = P_theta*wrap_Peos_00(s,k) + (1d0-P_theta)*s% Peos_start(k) Peos_ad = alfa*PL_ad + beta*PR_ad - if (k > 1) then + if (k > 1) then do j=1,s% species d_Pface_dxa00(j) = & alfa*s% dlnPeos_dxa_for_partials(j,k)*P_theta*s% Peos(k) @@ -676,12 +676,12 @@ subroutine eval1_work(s, k, skip_Peos, & end do end if end if - + ! set Pvsc_ad if (.not. s% use_Pvsc_art_visc) then Pvsc_ad = 0d0 else - if (k > 1) then + if (k > 1) then call get_Pvsc_ad(s, k-1, PvscR_ad, ierr) if (ierr /= 0) return PvscR_ad = shift_m1(PvscR_ad) @@ -696,12 +696,12 @@ subroutine eval1_work(s, k, skip_Peos, & PvscL_ad = 0.5d0*(PvscL_ad + s% Pvsc_start(k)) Pvsc_ad = alfa*PvscL_ad + beta*PvscR_ad end if - + ! set Ptrb_ad if (.not. s% RSP2_flag) then Ptrb_ad = 0d0 else - if (k > 1) then + if (k > 1) then call calc_Ptrb_ad_tw(s, k-1, PtrbR_ad, Ptrb_div_etrb, ierr) if (ierr /= 0) return PtrbR_ad = shift_m1(PtrbR_ad) @@ -712,31 +712,31 @@ subroutine eval1_work(s, k, skip_Peos, & if (ierr /= 0) return Ptrb_ad = alfa*PtrbL_ad + beta*PtrbR_ad end if - + ! set extra_P if (.not. s% use_other_pressure) then extra_P = 0d0 - else if (k > 1) then + else if (k > 1) then ! my_val_m1 = shift_m1(get_my_val(s,k-1)) for use in terms going into equation at k extra_P = alfa*s% extra_pressure(k) + beta * shift_m1(s%extra_pressure(k-1)) else extra_P = s% extra_pressure(k) end if - + ! set mlt_Pturb_ad mlt_Pturb_ad = 0d0 if (s% mlt_Pturb_factor > 0d0 .and. s% mlt_vc_old(k) > 0d0) & mlt_Pturb_ad = s% mlt_Pturb_factor*pow2(s% mlt_vc_old(k))*get_rho_face(s,k)/3d0 - + P_face_ad = Peos_ad + Pvsc_ad + Ptrb_ad + mlt_Pturb_ad + extra_P - + end if - + work_ad = A_times_v_face_ad*P_face_ad work = work_ad%val - + if (k == 1) s% work_outward_at_surface = work - + Av_face = A_times_v_face_ad%val do j=1,s% species d_work_dxa00(j) = Av_face*d_Pface_dxa00(j) @@ -745,20 +745,20 @@ subroutine eval1_work(s, k, skip_Peos, & !test_partials = (k == s% solver_test_partials_k) test_partials = .false. - + if (test_partials) then s% solver_test_partials_val = 0 s% solver_test_partials_var = 0 s% solver_test_partials_dval_dx = 0 write(*,*) 'eval1_work', s% solver_test_partials_var end if - + end subroutine eval1_work - - + + subroutine eval1_A_times_v_face_ad(s, k, A_times_v_face_ad, ierr) use star_utils, only: get_area_info_opt_time_center - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(in) :: k type(auto_diff_real_star_order1), intent(out) :: A_times_v_face_ad integer, intent(out) :: ierr @@ -768,7 +768,7 @@ subroutine eval1_A_times_v_face_ad(s, k, A_times_v_face_ad, ierr) ierr = 0 call get_area_info_opt_time_center(s, k, A_ad, inv_R2, ierr) if (ierr /= 0) return - + u_face_ad = 0d0 if (s% v_flag) then u_face_ad%val = s% vc(k) @@ -784,18 +784,18 @@ subroutine eval1_A_times_v_face_ad(s, k, A_times_v_face_ad, ierr) u_face_ad%val = (s% r(k) - s% r_start(k))/s% dt u_face_ad%d1Array(i_lnR_00) = s% r(k)/s% dt end if - + A_times_v_face_ad = A_ad*u_face_ad - + end subroutine eval1_A_times_v_face_ad subroutine eval_simple_PdV_work( & - s, k, skip_P, dwork_ad, dwork, d_dwork_dxa00, ierr) + s, k, skip_P, dwork_ad, dwork, d_dwork_dxa00, ierr) use accurate_sum_auto_diff_star_order1 use auto_diff_support use star_utils, only: calc_Ptot_ad_tw - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(in) :: k logical, intent(in) :: skip_P type(auto_diff_real_star_order1), intent(out) :: dwork_ad @@ -812,8 +812,8 @@ subroutine eval_simple_PdV_work( & include 'formats' ierr = 0 - - ! dV = 1/rho - 1/rho_start + + ! dV = 1/rho - 1/rho_start call eval1_A_times_v_face_ad(s, k, Av_face00_ad, ierr) if (ierr /= 0) return if (k < s% nz) then @@ -830,21 +830,21 @@ subroutine eval_simple_PdV_work( & include_mlt_Pturb = s% mlt_Pturb_factor > 0d0 & .and. s% mlt_vc_old(k) > 0d0 .and. k > 1 - + call calc_Ptot_ad_tw( & s, k, skip_P, .not. include_mlt_Pturb, Ptot_ad, d_Ptot_dxa, ierr) if (ierr /= 0) return - + do j=1,s% species d_dwork_dxa00(j) = d_Ptot_dxa(j)*(Av_face00 - Av_facep1) end do if (k == 1) s% work_outward_at_surface = Ptot_ad%val*Av_face00 - + dwork_ad = Ptot_ad*dV dwork = dwork_ad%val end subroutine eval_simple_PdV_work - + end module hydro_energy diff --git a/star/private/hydro_eqns.f90 b/star/private/hydro_eqns.f90 index 575ac0cff..3380ecd44 100644 --- a/star/private/hydro_eqns.f90 +++ b/star/private/hydro_eqns.f90 @@ -106,7 +106,7 @@ subroutine eval_equ_for_solver(s, nvar, nzlo, nzhi, ierr) do_chem = (do_mix .or. s% do_burn) call unpack - + ! set flags indicating the variables currently in use do_dlnd_dt = (i_dlnd_dt > 0 .and. i_dlnd_dt <= nvar) do_dv_dt = (i_dv_dt > 0 .and. i_dv_dt <= nvar) @@ -165,7 +165,7 @@ subroutine eval_equ_for_solver(s, nvar, nzlo, nzhi, ierr) return end if end if - + !$OMP PARALLEL DO PRIVATE(op_err,k) SCHEDULE(dynamic,2) do k = nzlo, nzhi s% dblk(:,:,k) = 0 @@ -283,7 +283,7 @@ subroutine eval_equ_for_solver(s, nvar, nzlo, nzhi, ierr) end if end do !$OMP END PARALLEL DO - + if (ierr == 0 .and. nzlo == 1) then call PT_eqns_surf(s, nvar, do_du_dt, do_dv_dt, do_equL, ierr) if (ierr /= 0) then @@ -296,7 +296,7 @@ subroutine eval_equ_for_solver(s, nvar, nzlo, nzhi, ierr) if (s% report_ierr) write(*,*) 'ierr in eval_equ_for_solver' return end if - + if (.false. .and. s% model_number == 2) then ! .and. .not. s% doing_relax) then if (.false.) then i = s% i_dv_dt @@ -313,7 +313,7 @@ subroutine eval_equ_for_solver(s, nvar, nzlo, nzhi, ierr) call mesa_error(__FILE__,__LINE__,'after dump_equ') end if - + contains subroutine dump_equ @@ -416,7 +416,7 @@ subroutine fix_d_eos_dxa_partials(s, k, ierr) ! some EOSes have composition partials and some do not ! those currently without dx partials are PC & Skye & ideal frac_without_dxa = s% eos_frac_PC(k) + s% eos_frac_Skye(k) + s% eos_frac_ideal(k) - + if (debug .and. k == s% solver_test_partials_k) then write(*,2) 's% eos_frac_PC(k)', k, s% eos_frac_PC(k) write(*,2) 's% eos_frac_Skye(k)', k, s% eos_frac_Skye(k) @@ -469,13 +469,13 @@ subroutine fix_d_eos_dxa_partials(s, k, ierr) res, dres_dlnd, dres_dlnT, dres_dxa, ierr) if (is_bad(res(i_lnPgas))) ierr = -1 if (ierr /= 0) then - + ! punt silently for now s% dlnE_dxa_for_partials(:,k) = 0d0 s% dlnPeos_dxa_for_partials(:,k) = 0d0 ierr = 0 return - + if (s% report_ierr) write(*,2) 'failed in get_eos with xa_start_1', k return end if @@ -574,7 +574,7 @@ subroutine do1_density_eqn(s, k, nvar, ierr) lnR_expected = log(rp13 + dr3)/3d0 lnR_actual = wrap_lnR_00(s,k) - + resid_ad = lnR_actual - lnR_expected s% equ(s% i_dlnd_dt, k) = resid_ad%val @@ -583,16 +583,16 @@ subroutine do1_density_eqn(s, k, nvar, ierr) end if call save_eqn_residual_info( & - s, k, nvar, s% i_dlnd_dt, resid_ad, 'do1_density_eqn', ierr) + s, k, nvar, s% i_dlnd_dt, resid_ad, 'do1_density_eqn', ierr) - if (test_partials) then + if (test_partials) then s% solver_test_partials_var = 0 s% solver_test_partials_dval_dx = 0 write(*,*) 'do1_density_eqn', s% solver_test_partials_var end if end subroutine do1_density_eqn - + subroutine do1_w_div_wc_eqn(s, k, nvar, ierr) use hydro_rotation @@ -608,9 +608,9 @@ subroutine do1_w_div_wc_eqn(s, k, nvar, ierr) jrot_ratio, sigmoid_jrot_ratio logical :: test_partials include 'formats' - + ierr = 0 - + !test_partials = (k == s% solver_test_partials_k-1) test_partials = .false. @@ -651,17 +651,17 @@ subroutine do1_w_div_wc_eqn(s, k, nvar, ierr) s% equ(i_equ_w_div_wc, k) = resid_ad% val call save_eqn_residual_info( & - s, k, nvar, i_equ_w_div_wc, resid_ad, 'do1_w_div_wc_eqn', ierr) + s, k, nvar, i_equ_w_div_wc, resid_ad, 'do1_w_div_wc_eqn', ierr) if (test_partials) then s% solver_test_partials_var = s% i_w_div_wc s% solver_test_partials_dval_dx = 1d0 write(*,*) 'do1_w_div_wc_eqn', s% solver_test_partials_var end if - + end subroutine do1_w_div_wc_eqn - - + + subroutine do1_dj_rot_dt_eqn(s, k, nvar, ierr) use hydro_rotation use star_utils, only: save_eqn_residual_info @@ -673,7 +673,7 @@ subroutine do1_dj_rot_dt_eqn(s, k, nvar, ierr) type(auto_diff_real_star_order1) :: resid_ad, jrot00, djrot_dt, F00, Fm1, flux_diff logical :: test_partials include 'formats' - + ierr = 0 !test_partials = (k == s% solver_test_partials_k) @@ -702,7 +702,7 @@ subroutine do1_dj_rot_dt_eqn(s, k, nvar, ierr) s% equ(i_dj_rot_dt, k) = resid_ad% val call save_eqn_residual_info( & - s, k, nvar, i_dj_rot_dt, resid_ad, 'do1_dj_rot_dt_eqn', ierr) + s, k, nvar, i_dj_rot_dt, resid_ad, 'do1_dj_rot_dt_eqn', ierr) !if (test_partials) then ! s% solver_test_partials_val = s% i_rot(k) @@ -713,7 +713,7 @@ subroutine do1_dj_rot_dt_eqn(s, k, nvar, ierr) ! s% solver_test_partials_dval_dx = s% di_rot_dlnR(k) ! write(*,*) 'do1_w_div_wc_eqn', s% solver_test_partials_var !end if - + end subroutine do1_dj_rot_dt_eqn @@ -736,7 +736,7 @@ subroutine PT_eqns_surf(s, nvar, do_du_dt, do_dv_dt, do_equL, ierr) include 'formats' !test_partials = (s% solver_iter == s% solver_test_partials_iter_number) - test_partials = .false. + test_partials = .false. ierr = 0 if (s% u_flag) then i_P_eqn = s% i_du_dt @@ -747,11 +747,11 @@ subroutine PT_eqns_surf(s, nvar, do_du_dt, do_dv_dt, do_equL, ierr) if(s% drag_coefficient > 0) then ! We dont call expected_non_HSE_term with k==1 unless we call set_momentum_BC - ! so lets initilize this to zero, then if we dont call set_momentum_BC we have a + ! so lets initilize this to zero, then if we dont call set_momentum_BC we have a ! sensible value here. - s% dvdt_drag(1) = 0 + s% dvdt_drag(1) = 0 end if - + need_P_surf = .false. if (s% use_compression_outer_BC) then call set_compression_BC(ierr) @@ -763,29 +763,29 @@ subroutine PT_eqns_surf(s, nvar, do_du_dt, do_dv_dt, do_equL, ierr) call set_momentum_BC(ierr) else if (s% use_fixed_vsurf_outer_BC) then call set_fixed_vsurf_outer_BC(ierr) - else + else need_P_surf = .true. end if if (ierr /= 0) return need_T_surf = .false. if ((.not. do_equL) .or. & - (s% RSP2_flag .and. s% RSP2_use_L_eqn_at_surface)) then + (s% RSP2_flag .and. s% RSP2_use_L_eqn_at_surface)) then ! no Tsurf BC else need_T_surf = .true. end if if (ierr /= 0) return - + offset_P_to_cell_center = .not. s% use_momentum_outer_BC - + offset_T_to_cell_center = .true. if (s% use_other_surface_PT .or. s% RSP2_flag) & offset_T_to_cell_center = .false. call get_PT_bc_ad(ierr) if (ierr /= 0) return - + if (need_P_surf) then if (s% use_momentum_outer_BC) then call set_momentum_BC(ierr) @@ -795,7 +795,7 @@ subroutine PT_eqns_surf(s, nvar, do_du_dt, do_dv_dt, do_equL, ierr) if (ierr /= 0) return end if - if (need_T_surf) then + if (need_T_surf) then call set_Tsurf_BC(ierr) if (ierr /= 0) return end if @@ -811,7 +811,7 @@ subroutine PT_eqns_surf(s, nvar, do_du_dt, do_dv_dt, do_equL, ierr) end if contains - + subroutine get_PT_bc_ad(ierr) ! set P_bc_ad and T_bc_ad use hydro_vars, only: set_Teff_info_for_eqns use chem_def @@ -832,7 +832,7 @@ subroutine get_PT_bc_ad(ierr) ! set P_bc_ad and T_bc_ad logical, parameter :: skip_partials = .false. include 'formats' ierr = 0 - + call set_Teff_info_for_eqns(s, skip_partials, & need_P_surf, need_T_surf, r, L, Teff, & lnT_surf, dlnTsurf_dL, dlnTsurf_dlnR, dlnTsurf_dlnM, dlnTsurf_dlnkap, & @@ -848,7 +848,7 @@ subroutine get_PT_bc_ad(ierr) ! set P_bc_ad and T_bc_ad ! P_surf and T_surf are at outer boundary of cell 1 P_surf = exp(lnP_surf) T_surf = exp(lnT_surf) - + s% P_surf = P_surf s% T_surf = T_surf @@ -858,13 +858,13 @@ subroutine get_PT_bc_ad(ierr) ! set P_bc_ad and T_bc_ad dP0 = s% cgrav(1)*s% m_grav(1)*s% dm(1)/(8*pi*pow4(r)) if (offset_T_to_cell_center) & dT0 = dP0*s% gradT(1)*s% T(1)/s% Peos(1) - + P_bc = P_surf + dP0 T_bc = T_surf + dT0 lnP_bc = log(P_bc) lnT_bc = log(T_bc) - + if (is_bad(P_bc)) then write(*,1) 'lnP_bc', lnP_bc write(*,1) 'P_bc', P_bc @@ -874,7 +874,7 @@ subroutine get_PT_bc_ad(ierr) ! set P_bc_ad and T_bc_ad write(*,1) 'r', r call mesa_error(__FILE__,__LINE__,'P bc') end if - + if (is_bad(T_bc)) then write(*,1) 'lnT_bc', lnT_bc write(*,1) 'T_bc', T_bc @@ -883,17 +883,17 @@ subroutine get_PT_bc_ad(ierr) ! set P_bc_ad and T_bc_ad write(*,1) 'lnT_surf', lnT_surf call mesa_error(__FILE__,__LINE__,'T bc') end if - + dP0_dlnR = 0 if (offset_P_to_cell_center) then ! include partials of dP0 dP0_dlnR = -4*dP0 end if - + dT0_dlnR = 0 dT0_dlnT = 0 dT0_dlnd = 0 dT0_dL = 0 - if (offset_T_to_cell_center) then ! include partials of dT0 + if (offset_T_to_cell_center) then ! include partials of dT0 d_gradT_dlnR = s% gradT_ad(1)%d1Array(i_lnR_00) d_gradT_dlnT00 = s% gradT_ad(1)%d1Array(i_lnT_00) d_gradT_dlnd00 = s% gradT_ad(1)%d1Array(i_lnd_00) @@ -993,7 +993,7 @@ subroutine get_PT_bc_ad(ierr) ! set P_bc_ad and T_bc_ad 0d0, 0d0, 0d0, & 0d0, 0d0, 0d0, & 0d0, 0d0, 0d0) - + end subroutine get_PT_bc_ad @@ -1006,7 +1006,7 @@ subroutine set_Tsurf_BC(ierr) include 'formats' !test_partials = (1 == s% solver_test_partials_k) test_partials = .false. - ierr = 0 + ierr = 0 if (s% RSP2_flag) then ! interpolate lnT by mass T4_p1 = pow4(wrap_T_p1(s,1)) T4_surf = pow4(T_bc_ad) @@ -1015,7 +1015,7 @@ subroutine set_Tsurf_BC(ierr) T4_00_actual = pow4(wrap_T_00(s,1)) resid_ad = T4_00_expected/T4_00_actual - 1d0 else - lnT1_ad = wrap_lnT_00(s,1) + lnT1_ad = wrap_lnT_00(s,1) resid_ad = lnT_bc_ad/lnT1_ad - 1d0 end if residual = resid_ad%val @@ -1030,7 +1030,7 @@ subroutine set_Tsurf_BC(ierr) s% solver_test_partials_val = 0 end if call save_eqn_residual_info( & - s, 1, nvar, s% i_equL, resid_ad, 'set_Tsurf_BC', ierr) + s, 1, nvar, s% i_equL, resid_ad, 'set_Tsurf_BC', ierr) if (test_partials) then s% solver_test_partials_var = 0 s% solver_test_partials_dval_dx = 0 @@ -1038,7 +1038,7 @@ subroutine set_Tsurf_BC(ierr) end if end subroutine set_Tsurf_BC - + subroutine set_Psurf_BC(ierr) integer, intent(out) :: ierr logical :: test_partials @@ -1046,34 +1046,34 @@ subroutine set_Psurf_BC(ierr) include 'formats' !test_partials = (1 == s% solver_test_partials_k) test_partials = .false. - ierr = 0 - lnP1_ad = wrap_lnPeos_00(s,1) + ierr = 0 + lnP1_ad = wrap_lnPeos_00(s,1) resid_ad = lnP_bc_ad/lnP1_ad - 1d0 s% equ(i_P_eqn, 1) = resid_ad%val if (test_partials) then s% solver_test_partials_val = 0 end if call save_eqn_residual_info( & - s, 1, nvar, i_P_eqn, resid_ad, 'set_Psurf_BC', ierr) + s, 1, nvar, i_P_eqn, resid_ad, 'set_Psurf_BC', ierr) if (test_partials) then s% solver_test_partials_var = 0 s% solver_test_partials_dval_dx = 0 write(*,*) 'set_Psurf_BC', s% solver_test_partials_var end if end subroutine set_Psurf_BC - + subroutine set_momentum_BC(ierr) use hydro_riemann, only: do_surf_Riemann_dudt_eqn use hydro_momentum, only: do_surf_momentum_eqn integer, intent(out) :: ierr include 'formats' - ierr = 0 + ierr = 0 if (s% u_flag) then call do_surf_Riemann_dudt_eqn(s, P_bc_ad, nvar, ierr) else call do_surf_momentum_eqn(s, P_bc_ad, nvar, ierr) - end if + end if end subroutine set_momentum_BC @@ -1084,15 +1084,15 @@ subroutine set_compression_BC(ierr) include 'formats' ! gradient of compression vanishes fixes density for cell 1 ! d_dt(1/rho(1)) = d_dt(1/rho(2)) e.g., Grott, Chernigovski, Glatzel, 2005. - ierr = 0 + ierr = 0 rho1 = wrap_d_00(s,1) rho2 = wrap_d_p1(s,1) dlnd1 = wrap_dxh_lnd(s,1) ! lnd(1) - lnd_start(1) dlnd2 = shift_p1(wrap_dxh_lnd(s,2)) ! lnd(2) - lnd_start(2) - resid_ad = (rho2*dlnd1 - rho1*dlnd2)/s% dt - s% equ(i_P_eqn, 1) = resid_ad%val + resid_ad = (rho2*dlnd1 - rho1*dlnd2)/s% dt + s% equ(i_P_eqn, 1) = resid_ad%val call save_eqn_residual_info( & - s, 1, nvar, i_P_eqn, resid_ad, 'set_compression_BC', ierr) + s, 1, nvar, i_P_eqn, resid_ad, 'set_compression_BC', ierr) end subroutine set_compression_BC @@ -1109,11 +1109,11 @@ subroutine set_fixed_vsurf_outer_BC(ierr) ierr = -1 write(*,*) 'set_fixed_vsurf_outer_BC requires u_flag or v_flag true' return - end if + end if resid_ad = (vsurf - s% fixed_vsurf)/s% csound_start(1) s% equ(i_P_eqn,1) = resid_ad%val call save_eqn_residual_info( & - s, 1, nvar, i_P_eqn, resid_ad, 'set_fixed_vsurf_outer_BC', ierr) + s, 1, nvar, i_P_eqn, resid_ad, 'set_fixed_vsurf_outer_BC', ierr) end subroutine set_fixed_vsurf_outer_BC diff --git a/star/private/hydro_momentum.f90 b/star/private/hydro_momentum.f90 index 54b29fddc..46260f65f 100644 --- a/star/private/hydro_momentum.f90 +++ b/star/private/hydro_momentum.f90 @@ -41,7 +41,7 @@ module hydro_momentum contains - + subroutine do_surf_momentum_eqn(s, P_surf_ad, nvar, ierr) use star_utils, only: store_partials type (star_info), pointer :: s @@ -56,12 +56,12 @@ subroutine do_surf_momentum_eqn(s, P_surf_ad, nvar, ierr) if (ierr /= 0) then if (s% report_ierr) write(*,2) 'ierr /= 0 for do_surf_momentum_eqn' return - end if + end if call store_partials( & s, 1, s% i_dv_dt, nvar, d_dm1, d_d00, d_dp1, 'do_surf_momentum_eqn', ierr) end subroutine do_surf_momentum_eqn - + subroutine do1_momentum_eqn(s, k, nvar, ierr) use star_utils, only: store_partials type (star_info), pointer :: s @@ -77,7 +77,7 @@ subroutine do1_momentum_eqn(s, k, nvar, ierr) if (ierr /= 0) then if (s% report_ierr) write(*,2) 'ierr /= 0 for get1_momentum_eqn', k return - end if + end if call store_partials( & s, k, s% i_dv_dt, nvar, d_dm1, d_d00, d_dp1, 'do1_momentum_eqn', ierr) end subroutine do1_momentum_eqn @@ -95,14 +95,14 @@ subroutine get1_momentum_eqn( & integer, intent(in) :: nvar real(dp), intent(out) :: d_dm1(nvar), d_d00(nvar), d_dp1(nvar) integer, intent(out) :: ierr - + real(dp) :: residual, dm_face, dPtot, iPtotavg, dm_div_A real(dp), dimension(s% species) :: & d_dPtot_dxam1, d_dPtot_dxa00, d_iPtotavg_dxam1, d_iPtotavg_dxa00, & d_residual_dxam1, d_residual_dxa00 integer :: nz, i_dv_dt, i_lum, i_v logical :: test_partials - + type(auto_diff_real_star_order1) :: resid1_ad, resid_ad, & other_ad, dm_div_A_ad, grav_ad, area_ad, dPtot_ad, d_mlt_Pturb_ad, & iPtotavg_ad, other_dm_div_A_ad, grav_dm_div_A_ad, & @@ -110,15 +110,15 @@ subroutine get1_momentum_eqn( & type(accurate_auto_diff_real_star_order1) :: residual_sum_ad include 'formats' - + !test_partials = (k == s% solver_test_partials_k) test_partials = .false. - + ierr = 0 call init ! dv/dt = - G*m/r^2 - (dPtot_ad + d_mlt_Pturb_ad)*area/dm + extra_grav + Uq + RTI_diffusion + RTI_kick -! +! ! grav_ad = expected_HSE_grav_term = -G*m/r^2 with possible modifications for rotation ! other_ad = expected_non_HSE_term = extra_grav - dv/dt + Uq ! extra_grav is from the other_momentum hook @@ -128,7 +128,7 @@ subroutine get1_momentum_eqn( & ! d_mlt_Pturb_ad = difference in MLT convective pressure across face ! RTI_terms_ad = RTI_diffusion + RTI_kick ! dm_div_A_ad = dm/area -! +! ! 0 = extra_grav - dv/dt + Uq - G*m/r^2 - RTI_diffusion - RTI_kick - (dPtot_ad + d_mlt_Pturb_ad)*area/dm ! 0 = other + grav - RTI_terms - (dPtot_ad + d_mlt_Pturb_ad)*area/dm ! 0 = (other + grav - RTI_terms)*dm/area - dPtot_ad - d_mlt_Pturb_ad @@ -139,27 +139,27 @@ subroutine get1_momentum_eqn( & call setup_dPtot(ierr); if (ierr /= 0) return ! dPtot_ad, iPtotavg_ad call setup_d_mlt_Pturb(ierr); if (ierr /= 0) return ! d_mlt_Pturb_ad call setup_RTI_terms(ierr); if (ierr /= 0) return ! RTI_terms_ad - + other_dm_div_A_ad = other_ad*dm_div_A_ad grav_dm_div_A_ad = grav_ad*dm_div_A_ad RTI_terms_dm_div_A_ad = RTI_terms_ad*dm_div_A_ad - + ! sum terms in residual_sum_ad using accurate_auto_diff_real_star_order1 residual_sum_ad = & other_dm_div_A_ad + grav_dm_div_A_ad - dPtot_ad - d_mlt_Pturb_ad + RTI_terms_dm_div_A_ad - + resid1_ad = residual_sum_ad ! convert back to auto_diff_real_star_order1 resid_ad = resid1_ad*iPtotavg_ad ! scaling residual = resid_ad%val - s% equ(i_dv_dt, k) = residual - + s% equ(i_dv_dt, k) = residual + !s% xtra1_array(k) = s% Peos(k) !s% xtra2_array(k) = 1d0/s% rho(k) !s% xtra3_array(k) = s% T(k) !s% xtra4_array(k) = s% v(k) !s% xtra5_array(k) = s% etrb(k) !s% xtra6_array(k) = s% r(k) - + if (is_bad(residual)) then !$omp critical (hydro_momentum_crit1) write(*,2) 'momentum eqn residual', k, residual @@ -176,9 +176,9 @@ subroutine get1_momentum_eqn( & s% solver_test_partials_dval_dx = d_d00(s% solver_test_partials_var) write(*,*) 'get1_momentum_eqn', s% solver_test_partials_var end if - + contains - + subroutine init i_dv_dt = s% i_dv_dt i_lum = s% i_lum @@ -203,7 +203,7 @@ subroutine init end if d_dm1 = 0d0; d_d00 = 0d0; d_dp1 = 0d0 end subroutine init - + subroutine setup_HSE(dm_div_A, ierr) real(dp), intent(out) :: dm_div_A integer, intent(out) :: ierr @@ -214,7 +214,7 @@ subroutine setup_HSE(dm_div_A, ierr) dm_div_A_ad = dm_face/area_ad dm_div_A = dm_div_A_ad%val end subroutine setup_HSE - + subroutine setup_non_HSE(ierr) integer, intent(out) :: ierr real(dp) :: other @@ -235,7 +235,7 @@ subroutine setup_dPtot(ierr) iPtotavg_ad, iPtotavg, d_iPtotavg_dxam1, d_iPtotavg_dxa00, ierr) if (ierr /= 0) return end subroutine setup_dPtot - + subroutine setup_d_mlt_Pturb(ierr) use star_utils, only: get_rho_face integer, intent(out) :: ierr @@ -249,8 +249,8 @@ subroutine setup_d_mlt_Pturb(ierr) else d_mlt_Pturb_ad = 0d0 end if - end subroutine setup_d_mlt_Pturb - + end subroutine setup_d_mlt_Pturb + subroutine setup_RTI_terms(ierr) use auto_diff_support integer, intent(out) :: ierr @@ -283,10 +283,10 @@ subroutine setup_RTI_terms(ierr) dvdt_kick = f*(rho_00 - rho_m1)/s% dt ! change v according to direction of lower density else dvdt_kick = 0d0 - end if - RTI_terms_ad = dvdt_diffusion + dvdt_kick + end if + RTI_terms_ad = dvdt_diffusion + dvdt_kick end subroutine setup_RTI_terms - + subroutine unpack_res18(species, res18) use star_utils, only: save_eqn_dxa_partials, unpack_residual_partials integer, intent(in) :: species @@ -295,14 +295,14 @@ subroutine unpack_res18(species, res18) logical, parameter :: checking = .true. integer :: j include 'formats' - ! do partials wrt composition - resid1 = resid1_ad%val + ! do partials wrt composition + resid1 = resid1_ad%val do j=1,species d_residual_dxa00(j) = resid1*d_iPtotavg_dxa00(j) - iPtotavg*d_dPtot_dxa00(j) if (checking) call check_dequ(d_dPtot_dxa00(j),'d_dPtot_dxa00(j)') if (checking) call check_dequ(d_iPtotavg_dxa00(j),'d_iPtotavg_dxa00(j)') end do - if (k > 1) then + if (k > 1) then do j=1,species d_residual_dxam1(j) = resid1*d_iPtotavg_dxam1(j) - iPtotavg*d_dPtot_dxam1(j) if (checking) call check_dequ(d_dPtot_dxam1(j),'d_dPtot_dxam1(j)') @@ -310,7 +310,7 @@ subroutine unpack_res18(species, res18) end do else d_residual_dxam1 = 0d0 - end if + end if dxap1 = 0d0 call save_eqn_dxa_partials(& s, k, nvar, i_dv_dt, species, & @@ -334,10 +334,10 @@ subroutine check_dequ(dequ, str) return end if end subroutine check_dequ - + end subroutine get1_momentum_eqn - - + + ! returns -G*m/r^2 with possible modifications for rotation. MESA 2, eqn 22. subroutine expected_HSE_grav_term(s, k, grav, area, ierr) use star_utils, only: get_area_info_opt_time_center @@ -345,13 +345,13 @@ subroutine expected_HSE_grav_term(s, k, grav, area, ierr) integer, intent(in) :: k type(auto_diff_real_star_order1), intent(out) :: area, grav integer, intent(out) :: ierr - + type(auto_diff_real_star_order1) :: inv_R2 logical :: test_partials include 'formats' ierr = 0 - + call get_area_info_opt_time_center(s, k, area, inv_R2, ierr) if (ierr /= 0) return @@ -363,17 +363,17 @@ subroutine expected_HSE_grav_term(s, k, grav, area, ierr) !test_partials = (k == s% solver_test_partials_k) test_partials = .false. - + if (test_partials) then s% solver_test_partials_val = 0 s% solver_test_partials_var = 0 s% solver_test_partials_dval_dx = 0 write(*,*) 'expected_HSE_grav_term', s% solver_test_partials_var end if - + end subroutine expected_HSE_grav_term - - + + ! other = s% extra_grav(k) - s% dv_dt(k) subroutine expected_non_HSE_term( & s, k, other_ad, other, accel_ad, Uq_ad, ierr) @@ -394,17 +394,17 @@ subroutine expected_non_HSE_term( & include 'formats' ierr = 0 - + extra_ad = 0d0 if (s% use_other_momentum .or. s% use_other_momentum_implicit) then extra_ad = s% extra_grav(k) end if - + accel_ad = 0d0 drag = 0d0 s% dvdt_drag(k) = 0d0 if (s% v_flag) then - + if (s% i_lnT == 0) then local_v_flag = .true. else @@ -431,7 +431,7 @@ subroutine expected_non_HSE_term( & drag = -s% drag_coefficient*v_00/s% dt s% dvdt_drag(k) = drag%val end if - + end if ! v_flag Uq_ad = 0d0 @@ -439,20 +439,20 @@ subroutine expected_non_HSE_term( & Uq_ad = compute_Uq_face(s, k, ierr) if (ierr /= 0) return end if - + other_ad = extra_ad - accel_ad + drag + Uq_ad other = other_ad%val - + !test_partials = (k == s% solver_test_partials_k) test_partials = .false. - + if (test_partials) then s% solver_test_partials_val = 0 s% solver_test_partials_var = 0 s% solver_test_partials_dval_dx = 0d0 write(*,*) 'expected_non_HSE_term', s% solver_test_partials_var end if - + end subroutine expected_non_HSE_term ! dPtot = pressure difference across face from center to center of adjacent cells. @@ -471,7 +471,7 @@ subroutine get_dPtot_face_info(s, k, P_surf_ad, & real(dp), intent(out), dimension(s% species) :: & d_dPtot_dxam1, d_dPtot_dxa00, d_iPtotavg_dxam1, d_iPtotavg_dxa00 integer, intent(out) :: ierr - + real(dp) :: Ptotm1, Ptot00, Ptotavg, alfa, beta real(dp), dimension(s% species) :: & d_Ptotm1_dxam1, d_Ptot00_dxa00, d_Ptotavg_dxam1, d_Ptotavg_dxa00 @@ -484,12 +484,12 @@ subroutine get_dPtot_face_info(s, k, P_surf_ad, & include 'formats' ierr = 0 - + call calc_Ptot_ad_tw( & s, k, skip_P, skip_mlt_Pturb, Ptot00_ad, d_Ptot00_dxa00, ierr) if (ierr /= 0) return Ptot00 = Ptot00_ad%val - + if (k > 1) then call calc_Ptot_ad_tw( & s, k-1, skip_P, skip_mlt_Pturb, Ptotm1_ad, d_Ptotm1_dxam1, ierr) @@ -499,10 +499,10 @@ subroutine get_dPtot_face_info(s, k, P_surf_ad, & Ptotm1_ad = P_surf_ad end if Ptotm1 = Ptotm1_ad%val - + dPtot_ad = Ptotm1_ad - Ptot00_ad dPtot = Ptotm1 - Ptot00 - + do j=1,s% species d_dPtot_dxam1(j) = d_Ptotm1_dxam1(j) d_dPtot_dxa00(j) = -d_Ptot00_dxa00(j) @@ -511,7 +511,7 @@ subroutine get_dPtot_face_info(s, k, P_surf_ad, & if (k == 1) then Ptotavg_ad = Ptot00_ad do j=1,s% species - d_Ptotavg_dxam1(j) = 0d0 + d_Ptotavg_dxam1(j) = 0d0 d_Ptotavg_dxa00(j) = d_Ptot00_dxa00(j) end do else @@ -524,11 +524,11 @@ subroutine get_dPtot_face_info(s, k, P_surf_ad, & end do end if Ptotavg = Ptotavg_ad%val - + iPtotavg_ad = 1d0/Ptotavg_ad - iPtotavg = 1d0/Ptotavg + iPtotavg = 1d0/Ptotavg do j=1,s% species - d_iPtotavg_dxam1(j) = -iPtotavg*d_Ptotavg_dxam1(j)/Ptotavg + d_iPtotavg_dxam1(j) = -iPtotavg*d_Ptotavg_dxam1(j)/Ptotavg d_iPtotavg_dxa00(j) = -iPtotavg*d_Ptotavg_dxa00(j)/Ptotavg end do @@ -541,8 +541,8 @@ subroutine get_dPtot_face_info(s, k, P_surf_ad, & s% solver_test_partials_dval_dx = 0d0 write(*,*) 'get_dPtot_face_info', s% solver_test_partials_var end if - - end subroutine get_dPtot_face_info + + end subroutine get_dPtot_face_info subroutine do1_radius_eqn(s, k, nvar, ierr) @@ -558,13 +558,13 @@ subroutine do1_radius_eqn(s, k, nvar, ierr) include 'formats' !test_partials = (k == s% solver_test_partials_k) test_partials = .false. - ierr = 0 + ierr = 0 if (.not. (s% u_flag .or. s% v_flag)) call mesa_error(__FILE__,__LINE__,'must have either v or u for do1_radius_eqn') - + force_zero_v = (s% q(k) > s% velocity_q_upper_bound) .or. & (s% tau(k) < s% velocity_tau_lower_bound) .or. & (s% lnT_start(k)/ln10 < s% velocity_logT_lower_bound .and. & - s% dt < secyer*s% max_dt_yrs_for_velocity_logT_lower_bound) + s% dt < secyer*s% max_dt_yrs_for_velocity_logT_lower_bound) if (force_zero_v) then if (s% u_flag) then v00 = wrap_u_00(s,k) @@ -573,10 +573,10 @@ subroutine do1_radius_eqn(s, k, nvar, ierr) end if resid_ad = v00/s% csound_start(k) call save_eqn_residual_info( & - s, k, nvar, s% i_dlnR_dt, resid_ad, 'do1_radius_eqn', ierr) + s, k, nvar, s% i_dlnR_dt, resid_ad, 'do1_radius_eqn', ierr) return end if - + ! dr = r - r0 = v00*dt ! eqn: dr/r0 = v00*dt/r0 ! (r - r0)/r0 = r/r0 - 1 = exp(lnR)/exp(lnR0) - 1 @@ -584,19 +584,19 @@ subroutine do1_radius_eqn(s, k, nvar, ierr) ! eqn becomes: v00*dt/r0 = expm1(dlnR) dxh_lnR = wrap_dxh_lnR(s,k) ! lnR - lnR_start dr_div_r0_actual = expm1(dxh_lnR) ! expm1(x) = E^x - 1 - + v00 = wrap_opt_time_center_v_00(s,k) dr_div_r0_expected = v00*s% dt/s% r_start(k) resid_ad = dr_div_r0_expected - dr_div_r0_actual - + s% equ(s% i_dlnR_dt, k) = resid_ad%val - + if (test_partials) then s% solver_test_partials_val = 0 end if call save_eqn_residual_info( & - s, k, nvar, s% i_dlnR_dt, resid_ad, 'do1_radius_eqn', ierr) - if (test_partials) then + s, k, nvar, s% i_dlnR_dt, resid_ad, 'do1_radius_eqn', ierr) + if (test_partials) then s% solver_test_partials_var = 0 s% solver_test_partials_dval_dx = 0 write(*,*) 'do1_radius_eqn', s% solver_test_partials_var diff --git a/star/private/hydro_riemann.f90 b/star/private/hydro_riemann.f90 index d54392214..87b8654d9 100644 --- a/star/private/hydro_riemann.f90 +++ b/star/private/hydro_riemann.f90 @@ -24,22 +24,22 @@ ! *********************************************************************** module hydro_riemann - + use star_private_def use const_def use star_utils, only: em1, e00, ep1 use utils_lib use auto_diff use auto_diff_support - + implicit none ! Cheng, J, Shu, C-W, and Zeng, Q., ! "A Conservative Lagrangian Scheme for Solving ! Compressible Fluid Flows with Multiple Internal Energy Equations", ! Commun. Comput. Phys., 12, pp 1307-1328, 2012. - - ! Cheng, J. and Shu, C-W, + + ! Cheng, J. and Shu, C-W, ! "Positivity-preserving Lagrangian scheme for multi-material ! compressible flow", J. Comp. Phys., 257 (2014), 143-168. @@ -58,16 +58,16 @@ module hydro_riemann subroutine do_surf_Riemann_dudt_eqn(s, P_surf_ad, nvar, ierr) - type (star_info), pointer :: s + type (star_info), pointer :: s type(auto_diff_real_star_order1), intent(in) :: P_surf_ad integer, intent(in) :: nvar integer, intent(out) :: ierr call do1_dudt_eqn(s, 1, P_surf_ad, nvar, ierr) end subroutine do_surf_Riemann_dudt_eqn - + subroutine do1_Riemann_momentum_eqn(s, k, nvar, ierr) - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(in) :: k integer, intent(in) :: nvar integer, intent(out) :: ierr @@ -75,25 +75,25 @@ subroutine do1_Riemann_momentum_eqn(s, k, nvar, ierr) P_surf_ad = 0 call do1_dudt_eqn(s, k, P_surf_ad, nvar, ierr) end subroutine do1_Riemann_momentum_eqn - + subroutine do1_dudt_eqn( & s, k, P_surf_ad, nvar, ierr) use accurate_sum_auto_diff_star_order1 use star_utils, only: get_area_info_opt_time_center, save_eqn_residual_info - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(in) :: k type(auto_diff_real_star_order1), intent(in) :: P_surf_ad ! only for k=1 integer, intent(in) :: nvar integer, intent(out) :: ierr - + integer :: nz, i_du_dt type(auto_diff_real_star_order1) :: & flux_in_ad, flux_out_ad, diffusion_source_ad, & geometry_source_ad, gravity_source_ad, & area_00, area_p1, inv_R2_00, inv_R2_p1, & dudt_expected_ad, dudt_actual_ad, resid_ad - type(accurate_auto_diff_real_star_order1) :: sum_ad + type(accurate_auto_diff_real_star_order1) :: sum_ad real(dp) :: dt, dm, ie_plus_ke, scal, residual logical :: dbg, do_diffusion, test_partials real(dp) :: v_drag, drag_factor, drag_fraction @@ -103,20 +103,20 @@ subroutine do1_dudt_eqn( & !test_partials = (k == s% solver_test_partials_k) test_partials = .false. - + if (s% use_other_momentum) & call mesa_error(__FILE__,__LINE__,'Riemann dudt does not support use_other_momentum') if (s% use_other_momentum_implicit) & call mesa_error(__FILE__,__LINE__,'Riemann dudt does not support use_other_momentum_implicit') if (s% use_mass_corrections) & call mesa_error(__FILE__,__LINE__,'Riemann dudt does not support use_mass_corrections') - + ierr = 0 nz = s% nz i_du_dt = s% i_du_dt dt = s% dt - dm = s% dm(k) - + dm = s% dm(k) + call get_area_info_opt_time_center(s, k, area_00, inv_R2_00, ierr) if (ierr /= 0) return if (k < nz) then @@ -157,19 +157,20 @@ subroutine do1_dudt_eqn( & end if end if + ! make residual units be relative difference in energy ie_plus_ke = s% energy_start(k) + 0.5d0*s% u_start(k)*s% u_start(k) scal = dt*max(abs(s% u_start(k)),s% csound_start(k))/ie_plus_ke if (k == 1) scal = scal*1d-2 - + dudt_actual_ad = 0d0 dudt_actual_ad%val = s% dxh_u(k)/dt dudt_actual_ad%d1Array(i_v_00) = 1d0/dt - + resid_ad = scal*(dudt_expected_ad - dudt_actual_ad) residual = resid_ad%val s% equ(i_du_dt, k) = residual - + if (is_bad(residual)) then ierr = -1 return @@ -178,7 +179,7 @@ subroutine do1_dudt_eqn( & call mesa_error(__FILE__,__LINE__,'do1_dudt_eqn') !$omp end critical (dudt_eqn) end if - + call save_eqn_residual_info(s, k, nvar, i_du_dt, resid_ad, 'do1_dudt_eqn', ierr) if (test_partials) then @@ -192,7 +193,7 @@ subroutine do1_dudt_eqn( & end if contains - + subroutine setup_momentum_flux if (k == 1) then flux_out_ad = P_surf_ad*area_00 @@ -203,7 +204,7 @@ subroutine setup_momentum_flux flux_in_ad = shift_p1(s% P_face_ad(k+1))*area_p1 else flux_in_ad = 0d0 - end if + end if end subroutine setup_momentum_flux subroutine setup_geometry_source(ierr) @@ -216,7 +217,7 @@ subroutine setup_geometry_source(ierr) ! use same P here as the cell pressure in P_face calculation call calc_Ptot_ad_tw(s, k, skip_Peos, skip_mlt_Pturb, P, d_Ptot_dxa, ierr) if (ierr /= 0) return - if (k == nz) then + if (k == nz) then ! no flux in from left, so only have geometry source on right ! this matters for cases with R_center > 0. geometry_source_ad = P*area_00 @@ -224,7 +225,7 @@ subroutine setup_geometry_source(ierr) geometry_source_ad = P*(area_00 - area_p1) end if end subroutine setup_geometry_source - + subroutine setup_gravity_source type(auto_diff_real_star_order1) :: G00, Gp1, gsL, gsR real(dp) :: mR, mL @@ -247,7 +248,7 @@ subroutine setup_gravity_source gsL = -Gp1*mL*0.5d0*dm*inv_R2_p1 end if gravity_source_ad = gsL + gsR ! total gravitational force on cell - + end subroutine setup_gravity_source @@ -281,12 +282,12 @@ subroutine setup_diffusion_source end if s% dudt_RTI(k) = diffusion_source_ad%val/dm end subroutine setup_diffusion_source - + end subroutine do1_dudt_eqn - + subroutine do_uface_and_Pface(s, ierr) - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(out) :: ierr integer :: k, op_err include 'formats' @@ -312,12 +313,12 @@ subroutine get_G(s, k, G) G = G*s% fp_rot(k) end subroutine get_G - + subroutine do1_uface_and_Pface(s, k, ierr) use eos_def, only: i_gamma1, i_lnfree_e, i_lnPgas use star_utils, only: calc_Ptot_ad_tw, get_face_weights use hydro_rsp2, only: compute_Uq_face - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(in) :: k integer, intent(out) :: ierr logical :: test_partials @@ -330,25 +331,25 @@ subroutine do1_uface_and_Pface(s, k, ierr) real(dp), dimension(s% species) :: d_Ptot_dxa ! skip this logical, parameter :: skip_Peos = .false., skip_mlt_Pturb = .false. real(dp) :: delta_m, f - + include 'formats' - + ierr = 0 test_partials = .false. !test_partials = (k == s% solver_test_partials_k) - + s% RTI_du_diffusion_kick(k) = 0d0 s% d_uface_domega(k) = 0 - + if (k == 1) then s% u_face_ad(k) = wrap_u_00(s,k) s% P_face_ad(k) = wrap_Peos_00(s,k) - return + return end if - + r_ad = wrap_r_00(s,k) A_ad = 4d0*pi*pow2(r_ad) - + call calc_Ptot_ad_tw(s, k, skip_Peos, skip_mlt_Pturb, PL_ad, d_Ptot_dxa, ierr) if (ierr /= 0) return call calc_Ptot_ad_tw(s, k-1, skip_Peos, skip_mlt_Pturb, PR_ad, d_Ptot_dxa, ierr) @@ -357,27 +358,27 @@ subroutine do1_uface_and_Pface(s, k, ierr) uL_ad = wrap_u_00(s,k) uR_ad = wrap_u_m1(s,k) - + rhoL_ad = wrap_d_00(s,k) rhoR_ad = wrap_d_m1(s,k) - + gamma1L_ad = wrap_gamma1_00(s,k) gamma1R_ad = wrap_gamma1_m1(s,k) - + csL_ad = sqrt(gamma1L_ad*PL_ad/rhoL_ad) csR_ad = sqrt(gamma1R_ad*PR_ad/rhoR_ad) - + ! change PR and PL for gravity call get_G(s, k, G_ad) - + dPdm_grav_ad = -G_ad*s% m_grav(k)/(pow2(r_ad)*A_ad) ! cm^-1 s^-2 - + delta_m = 0.5d0*s% dm(k) ! positive delta_m from left center to edge PL_ad = PL_ad + delta_m*dPdm_grav_ad delta_m = -0.5d0*s% dm(k-1) ! negative delta_m from right center to edge PR_ad = PR_ad + delta_m*dPdm_grav_ad - + ! acoustic wavespeeds (eqn 2.38) Sl1_ad = uL_ad - csL_ad Sl2_ad = uR_ad - csR_ad @@ -389,19 +390,19 @@ subroutine do1_uface_and_Pface(s, k, ierr) Sl_ad = Sl2_ad end if - Sr1_ad = uR_ad + csR_ad + Sr1_ad = uR_ad + csR_ad Sr2_ad = uL_ad + csL_ad - + ! take Sr = max(Sr1, Sr2) if (Sr1_ad%val > Sr2_ad%val) then Sr_ad = Sr1_ad else Sr_ad = Sr2_ad end if - + ! contact velocity (eqn 2.20) - numerator_ad = uR_ad*rhoR_ad*(Sr_ad - uR_ad) + uL_ad*rhoL_ad*(uL_ad - Sl_ad) + (PL_ad - PR_ad) - denominator_ad = rhoR_ad*(Sr_ad - uR_ad) + rhoL_ad*(uL_ad - Sl_ad) + numerator_ad = uR_ad*rhoR_ad*(Sr_ad - uR_ad) + uL_ad*rhoL_ad*(uL_ad - Sl_ad) + (PL_ad - PR_ad) + denominator_ad = rhoR_ad*(Sr_ad - uR_ad) + rhoL_ad*(uL_ad - Sl_ad) if (denominator_ad%val == 0d0 .or. is_bad(denominator_ad%val)) then ierr = -1 @@ -410,16 +411,16 @@ subroutine do1_uface_and_Pface(s, k, ierr) end if return end if - + Ss_ad = numerator_ad/denominator_ad - + s% u_face_ad(k) = Ss_ad s% d_uface_domega(k) = s% u_face_ad(k)%d1Array(i_L_00) ! contact pressure (eqn 2.19) - P_face_L_ad = rhoL_ad*(uL_ad-Sl_ad)*(uL_ad-Ss_ad) + PL_ad + P_face_L_ad = rhoL_ad*(uL_ad-Sl_ad)*(uL_ad-Ss_ad) + PL_ad P_face_R_ad = rhoR_ad*(uR_ad-Sr_ad)*(uR_ad-Ss_ad) + PR_ad - + s% P_face_ad(k) = 0.5d0*(P_face_L_ad + P_face_R_ad) ! these are ideally equal if (k < s% nz .and. s% RTI_flag) then @@ -431,13 +432,13 @@ subroutine do1_uface_and_Pface(s, k, ierr) s% u_face_ad(k) = s% u_face_ad(k) + du_ad end if end if - + if (s% RSP2_flag) then ! include Uq in u_face Uq_ad = compute_Uq_face(s, k, ierr) if (ierr /= 0) return s% u_face_ad(k) = s% u_face_ad(k) + Uq_ad end if - + s% u_face_val(k) = s% u_face_ad(k)%val if (s% P_face_start(k) < 0d0) then @@ -451,9 +452,9 @@ subroutine do1_uface_and_Pface(s, k, ierr) s% solver_test_partials_dval_dx = PL_ad% d1Array(i_w_div_wc_00) write(*,*) 'do1_uface_and_Pface', s% solver_test_partials_var, PL_ad% val end if - + end subroutine do1_uface_and_Pface - + end module hydro_riemann diff --git a/star/private/hydro_rotation.f90 b/star/private/hydro_rotation.f90 index 71be26bf6..b362e704a 100644 --- a/star/private/hydro_rotation.f90 +++ b/star/private/hydro_rotation.f90 @@ -63,7 +63,7 @@ real(dp) function w_div_w_roche_omega(rphi,Mphi,omega,cgrav, max_w, max_w2, w_di end if else ! smoothly cap to max_w to get a continuous function - ! nothing is done when we are below max_w2, but between max_w2 and max_w we smoothly + ! nothing is done when we are below max_w2, but between max_w2 and max_w we smoothly ! produce an asymptote that would result in w_div_wc=max_w for jrot->infinity wr = max_w rphi_lim1 = pow(wr,two_thirds)*(1-pow2(wr)/6d0+0.01726d0*pow4(wr)-0.03569d0*pow6(wr)) @@ -81,7 +81,7 @@ real(dp) function w_div_w_roche_omega(rphi,Mphi,omega,cgrav, max_w, max_w2, w_di wr_high = wr wr_low = 0 do while (wr_high-wr_low>1d-6) - wr = 0.5d0*(wr_high+wr_low) + wr = 0.5d0*(wr_high+wr_low) new_dimless_rphi = pow(wr,two_thirds)*(1-pow2(wr)/6d0+0.01726d0*pow4(wr)-0.03569d0*pow6(wr)) if (dimless_rphi > new_dimless_rphi) then wr_low = wr @@ -96,7 +96,7 @@ real(dp) function w_div_w_roche_omega(rphi,Mphi,omega,cgrav, max_w, max_w2, w_di end if end function w_div_w_roche_omega - + ! compute w_div_w_roche for a known specific angular momentum jrot, rphi, and Mphi real(dp) function w_div_w_roche_jrot(rphi,Mphi,jrot,cgrav, max_w, max_w2, w_div_wc_flag) result(w_roche) real(dp), intent(in) :: rphi,Mphi,jrot,cgrav, max_w, max_w2 @@ -126,7 +126,7 @@ real(dp) function w_div_w_roche_jrot(rphi,Mphi,jrot,cgrav, max_w, max_w2, w_div_ end if else ! smoothly cap to max_w to get a continuous function - ! nothing is done when we are below max_w2, but between max_w2 and max_w we smoothly + ! nothing is done when we are below max_w2, but between max_w2 and max_w we smoothly ! produce an asymptote that would result in w_div_wc=max_w for jrot->infinity wr = max_w A = 1d0-0.1076d0*pow4(wr)-0.2336d0*pow6(wr)-0.5583d0*log(1d0-pow4(wr)) @@ -147,7 +147,7 @@ real(dp) function w_div_w_roche_jrot(rphi,Mphi,jrot,cgrav, max_w, max_w2, w_div_ wr_high = wr wr_low = 0 do while (wr_high-wr_low>1d-6) - wr = 0.5d0*(wr_high+wr_low) + wr = 0.5d0*(wr_high+wr_low) w2 = pow2(wr) w4 = pow4(wr) w6 = pow6(wr) @@ -201,7 +201,7 @@ subroutine eval_i_rot(s,k,r00,w_div_w_crit_roche, i_rot) re = r*(1d0+w2/6d0-0.0002507d0*w4+0.06075d0*w6) B = (1d0+w2/5d0-0.2735d0*w4-0.4327d0*w6-3d0/2d0*0.5583d0*lg_one_sub_w4) A = (1d0-0.1076d0*w4-0.2336d0*w6-0.5583d0*lg_one_sub_w4) - + ir = two_thirds*pow2(re)*B/A i_rot = 0d0 @@ -345,7 +345,7 @@ subroutine get_rotation_sigmas(s, nzlo, nzhi, dt, ierr) ierr = 0 nz = s% nz - + allocate(am_nu(nz), am_sig(nz)) call get1_am_sig(s, nzlo, nzhi, s% am_nu_j, s% am_sig_j, dt, ierr) @@ -527,7 +527,7 @@ subroutine set_surf_avg_rotation_info(s) s% logRho_avg_surf = 0 return end if - + ierr = 0 call set_rotation_info(s,.true.,ierr) if (ierr /= 0) then diff --git a/star/private/hydro_rsp2.f90 b/star/private/hydro_rsp2.f90 index 3f040ebea..0b5e34040 100644 --- a/star/private/hydro_rsp2.f90 +++ b/star/private/hydro_rsp2.f90 @@ -41,7 +41,7 @@ module hydro_rsp2 compute_Eq_cell, compute_Uq_face, set_RSP2_vars, & Hp_face_for_rsp2_val, Hp_face_for_rsp2_eqn, set_etrb_start_vars, & RSP2_adjust_vars_before_call_solver, get_RSP2_alfa_beta_face_weights - + real(dp), parameter :: & x_ALFAP = 2.d0/3.d0, & ! Ptrb x_ALFAS = (1.d0/2.d0)*sqrt_2_div_3, & ! PII_face and Lc @@ -50,14 +50,14 @@ module hydro_rsp2 x_GAMMAR = 2.d0*sqrt(3.d0) ! DAMPR contains - - + + subroutine set_RSP2_vars(s,ierr) type (star_info), pointer :: s - integer, intent(out) :: ierr + integer, intent(out) :: ierr type(auto_diff_real_star_order1) :: x integer :: k, op_err - include 'formats' + include 'formats' ierr = 0 op_err = 0 !$OMP PARALLEL DO PRIVATE(k,op_err) SCHEDULE(dynamic,2) @@ -98,7 +98,7 @@ subroutine set_RSP2_vars(s,ierr) s% Eq(k) = 0d0; s% Eq_ad(k) = 0d0 s% Chi(k) = 0d0; s% Chi_ad(k) = 0d0 s% COUPL(k) = 0d0; s% COUPL_ad(k) = 0d0 - !s% Ptrb(k) = 0d0; + !s% Ptrb(k) = 0d0; s% Lc(k) = 0d0; s% Lc_ad(k) = 0d0 s% Lt(k) = 0d0; s% Lt_ad(k) = 0d0 end do @@ -106,7 +106,7 @@ subroutine set_RSP2_vars(s,ierr) s% Eq(k) = 0d0; s% Eq_ad(k) = 0d0 s% Chi(k) = 0d0; s% Chi_ad(k) = 0d0 s% COUPL(k) = 0d0; s% COUPL_ad(k) = 0d0 - !s% Ptrb(k) = 0d0; + !s% Ptrb(k) = 0d0; s% Lc(k) = 0d0; s% Lc_ad(k) = 0d0 s% Lt(k) = 0d0; s% Lt_ad(k) = 0d0 end do @@ -117,7 +117,7 @@ subroutine do1_rsp2_L_eqn(s, k, nvar, ierr) use star_utils, only: save_eqn_residual_info type (star_info), pointer :: s integer, intent(in) :: k, nvar - integer, intent(out) :: ierr + integer, intent(out) :: ierr type(auto_diff_real_star_order1) :: & L_expected, L_actual,resid real(dp) :: scale, residual, L_start_max @@ -125,7 +125,7 @@ subroutine do1_rsp2_L_eqn(s, k, nvar, ierr) include 'formats' !test_partials = (k == s% solver_test_partials_k) - test_partials = .false. + test_partials = .false. if (.not. s% RSP2_flag) then ierr = -1 return @@ -133,23 +133,23 @@ subroutine do1_rsp2_L_eqn(s, k, nvar, ierr) ierr = 0 !L_expected = compute_L_face(s, k, ierr) - !if (ierr /= 0) return + !if (ierr /= 0) return L_expected = s% Lr_ad(k) + s% Lc_ad(k) + s% Lt_ad(k) - L_actual = wrap_L_00(s, k) + L_actual = wrap_L_00(s, k) L_start_max = maxval(s% L_start(1:s% nz)) scale = 1d0/L_start_max if (is_bad(scale)) then write(*,2) 'do1_rsp2_L_eqn scale', k, scale call mesa_error(__FILE__,__LINE__,'do1_rsp2_L_eqn') end if - resid = (L_expected - L_actual)*scale - + resid = (L_expected - L_actual)*scale + residual = resid%val - s% equ(s% i_equL, k) = residual + s% equ(s% i_equL, k) = residual if (test_partials) then - s% solver_test_partials_val = residual + s% solver_test_partials_val = residual end if - + call save_eqn_residual_info(s, k, nvar, s% i_equL, resid, 'do1_rsp2_L_eqn', ierr) if (ierr /= 0) return @@ -157,15 +157,15 @@ subroutine do1_rsp2_L_eqn(s, k, nvar, ierr) s% solver_test_partials_var = s% i_lnR s% solver_test_partials_dval_dx = resid%d1Array(i_lnR_00) write(*,4) 'do1_rsp2_L_eqn', s% solver_test_partials_var - end if + end if end subroutine do1_rsp2_L_eqn - + subroutine do1_rsp2_Hp_eqn(s, k, nvar, ierr) use star_utils, only: save_eqn_residual_info type (star_info), pointer :: s integer, intent(in) :: k, nvar - integer, intent(out) :: ierr + integer, intent(out) :: ierr type(auto_diff_real_star_order1) :: & Hp_expected, Hp_actual,resid real(dp) :: residual, Hp_start @@ -173,7 +173,7 @@ subroutine do1_rsp2_Hp_eqn(s, k, nvar, ierr) include 'formats' !test_partials = (k == s% solver_test_partials_k) test_partials = .false. - + if (.not. s% RSP2_flag) then ierr = -1 return @@ -181,17 +181,17 @@ subroutine do1_rsp2_Hp_eqn(s, k, nvar, ierr) ierr = 0 Hp_expected = Hp_face_for_rsp2_eqn(s, k, ierr) - if (ierr /= 0) return - Hp_actual = wrap_Hp_00(s, k) + if (ierr /= 0) return + Hp_actual = wrap_Hp_00(s, k) Hp_start = s% Hp_face_start(k) - resid = (Hp_expected - Hp_actual)/max(Hp_expected,Hp_actual) - + resid = (Hp_expected - Hp_actual)/max(Hp_expected,Hp_actual) + residual = resid%val - s% equ(s% i_equ_Hp, k) = residual + s% equ(s% i_equ_Hp, k) = residual if (test_partials) then - s% solver_test_partials_val = residual + s% solver_test_partials_val = residual end if - + if (residual > 1d3) then !$omp critical (hydro_rsp2_1) write(*,2) 'residual', k, residual @@ -200,7 +200,7 @@ subroutine do1_rsp2_Hp_eqn(s, k, nvar, ierr) call mesa_error(__FILE__,__LINE__,'do1_rsp2_Hp_eqn') !$omp end critical (hydro_rsp2_1) end if - + call save_eqn_residual_info(s, k, nvar, s% i_equ_Hp, resid, 'do1_rsp2_Hp_eqn', ierr) if (ierr /= 0) return @@ -208,11 +208,11 @@ subroutine do1_rsp2_Hp_eqn(s, k, nvar, ierr) s% solver_test_partials_var = s% i_lnR s% solver_test_partials_dval_dx = resid%d1Array(i_lnR_00) write(*,4) 'do1_rsp2_Hp_eqn', s% solver_test_partials_var - end if - + end if + end subroutine do1_rsp2_Hp_eqn - - + + real(dp) function Hp_face_for_rsp2_val(s, k, ierr) result(Hp_face) ! cm type (star_info), pointer :: s integer, intent(in) :: k @@ -223,8 +223,8 @@ real(dp) function Hp_face_for_rsp2_val(s, k, ierr) result(Hp_face) ! cm if (ierr /= 0) return Hp_face = Hp_face_ad%val end function Hp_face_for_rsp2_val - - + + function Hp_face_for_rsp2_eqn(s, k, ierr) result(Hp_face) ! cm type (star_info), pointer :: s integer, intent(in) :: k @@ -235,7 +235,7 @@ function Hp_face_for_rsp2_eqn(s, k, ierr) result(Hp_face) ! cm r_00, Peos_00, d_00, Peos_m1, d_m1, Peos_div_rho, & d_face, Peos_face, alt_Hp_face, A real(dp) :: alfa, beta - include 'formats' + include 'formats' ierr = 0 if (k > s% nz) then Hp_face = 1d0 ! not used @@ -287,7 +287,7 @@ subroutine do1_turbulent_energy_eqn(s, k, nvar, ierr) use star_utils, only: set_energy_eqn_scal, save_eqn_residual_info type (star_info), pointer :: s integer, intent(in) :: k, nvar - integer, intent(out) :: ierr + integer, intent(out) :: ierr ! for OLD WAY type(auto_diff_real_star_order1) :: & d_turbulent_energy_ad, Ptrb_dV_ad, dt_C_ad, dt_Eq_ad @@ -299,36 +299,36 @@ subroutine do1_turbulent_energy_eqn(s, k, nvar, ierr) include 'formats' !test_partials = (k == s% solver_test_partials_k) test_partials = .false. - + ierr = 0 w_00 = wrap_w_00(s,k) - + non_turbulent_cell = & s% mixing_length_alpha == 0d0 .or. & k <= s% RSP2_num_outermost_cells_forced_nonturbulent .or. & - k > s% nz - int(s% nz/s% RSP2_nz_div_IBOTOM) - if (.not. s% RSP2_flag) then + k > s% nz - int(s% nz/s% RSP2_nz_div_IBOTOM) + if (.not. s% RSP2_flag) then resid_ad = w_00 - s% w_start(k) ! just hold w constant when not using RSP2 else if (non_turbulent_cell) then - resid_ad = w_00/s% csound(k) ! make w = 0 - else + resid_ad = w_00/s% csound(k) ! make w = 0 + else call setup_d_turbulent_energy(ierr); if (ierr /= 0) return ! erg g^-1 = cm^2 s^-2 call setup_Ptrb_dV_ad(ierr); if (ierr /= 0) return ! erg g^-1 call setup_dt_dLt_dm_ad(ierr); if (ierr /= 0) return ! erg g^-1 call setup_dt_C_ad(ierr); if (ierr /= 0) return ! erg g^-1 call setup_dt_Eq_ad(ierr); if (ierr /= 0) return ! erg g^-1 - call set_energy_eqn_scal(s, k, scal, ierr); if (ierr /= 0) return ! 1/(erg g^-1 s^-1) + call set_energy_eqn_scal(s, k, scal, ierr); if (ierr /= 0) return ! 1/(erg g^-1 s^-1) ! sum terms in esum_ad using accurate_auto_diff_real_star_order1 esum_ad = d_turbulent_energy_ad + Ptrb_dV_ad + dt_dLt_dm_ad - dt_C_ad - dt_Eq_ad ! erg g^-1 resid_ad = esum_ad - + if (k==-35 .and. s% solver_iter == 1) then write(*,3) 'RSP2 w dEt PdV dtC dtEq', k, s% solver_iter, & w_00%val, d_turbulent_energy_ad%val, Ptrb_dV_ad%val, dt_C_ad%val, dt_Eq_ad%val end if resid_ad = resid_ad*scal/s%dt ! to make residual unitless, must cancel out the dt in scal - + end if residual = resid_ad%val @@ -340,7 +340,7 @@ subroutine do1_turbulent_energy_eqn(s, k, nvar, ierr) if (s% solver_iter == 12) & write(*,*) 'do1_turbulent_energy_eqn', s% solver_test_partials_var, s% lnd(k), tst%val end if - + call save_eqn_residual_info(s, k, nvar, s% i_detrb_dt, resid_ad, 'do1_turbulent_energy_eqn', ierr) if (ierr /= 0) return @@ -348,16 +348,16 @@ subroutine do1_turbulent_energy_eqn(s, k, nvar, ierr) s% solver_test_partials_var = s% i_lnd s% solver_test_partials_dval_dx = tst%d1Array(i_lnd_00) ! xi0 good , xi1 partial 0, xi2 good. Af horrible.' write(*,*) 'do1_turbulent_energy_eqn', s% solver_test_partials_var, s% lnd(k)/ln10, tst%val - end if + end if contains - + subroutine setup_d_turbulent_energy(ierr) ! erg g^-1 integer, intent(out) :: ierr ierr = 0 d_turbulent_energy_ad = wrap_etrb_00(s,k) - get_etrb_start(s,k) end subroutine setup_d_turbulent_energy - + ! Ptrb_dV_ad = Ptrb_ad*dV_ad subroutine setup_Ptrb_dV_ad(ierr) ! erg g^-1 use star_utils, only: calc_Ptrb_ad_tw @@ -371,7 +371,7 @@ subroutine setup_Ptrb_dV_ad(ierr) ! erg g^-1 end subroutine setup_Ptrb_dV_ad subroutine setup_dt_dLt_dm_ad(ierr) ! erg g^-1 - integer, intent(out) :: ierr + integer, intent(out) :: ierr type(auto_diff_real_star_order1) :: Lt_00, Lt_p1 real(dp) :: L_theta include 'formats' @@ -391,7 +391,7 @@ subroutine setup_dt_dLt_dm_ad(ierr) ! erg g^-1 end if dt_dLt_dm_ad = (Lt_00 - Lt_p1)*s%dt/s%dm(k) end subroutine setup_dt_dLt_dm_ad - + subroutine setup_dt_C_ad(ierr) ! erg g^-1 integer, intent(out) :: ierr type(auto_diff_real_star_order1) :: C @@ -399,7 +399,7 @@ subroutine setup_dt_C_ad(ierr) ! erg g^-1 if (ierr /= 0) return dt_C_ad = s%dt*C end subroutine setup_dt_C_ad - + subroutine setup_dt_Eq_ad(ierr) ! erg g^-1 integer, intent(out) :: ierr type(auto_diff_real_star_order1) :: Eq_cell @@ -407,10 +407,10 @@ subroutine setup_dt_Eq_ad(ierr) ! erg g^-1 if (ierr /= 0) return dt_Eq_ad = s%dt*Eq_cell end subroutine setup_dt_Eq_ad - + end subroutine do1_turbulent_energy_eqn - - + + subroutine get_RSP2_alfa_beta_face_weights(s, k, alfa, beta) type (star_info), pointer :: s integer, intent(in) :: k @@ -426,7 +426,7 @@ subroutine get_RSP2_alfa_beta_face_weights(s, k, alfa, beta) end if end subroutine get_RSP2_alfa_beta_face_weights - + function compute_Y_face(s, k, ierr) result(Y_face) ! superadiabatic gradient [unitless] type (star_info), pointer :: s integer, intent(in) :: k @@ -439,25 +439,25 @@ function compute_Y_face(s, k, ierr) result(Y_face) ! superadiabatic gradient [un real(dp) :: dm_bar, alfa, beta include 'formats' ierr = 0 - + if (k > s% nz) then Y_face = 0d0 return end if - + if (k == 1 .or. s% mixing_length_alpha == 0d0) then Y_face = 0d0 s% Y_face(k) = 0d0 s% Y_face_ad(k) = 0d0 return end if - + call get_RSP2_alfa_beta_face_weights(s, k, alfa, beta) - + if (s% RSP2_use_RSP_eqn_for_Y_face) then - + dm_bar = s% dm_bar(k) - Hp_face = wrap_Hp_00(s,k) + Hp_face = wrap_Hp_00(s,k) r_00 = wrap_r_00(s, k) d_00 = wrap_d_00(s, k) Peos_00 = wrap_Peos_00(s, k) @@ -467,7 +467,7 @@ function compute_Y_face(s, k, ierr) result(Y_face) ! superadiabatic gradient [un chiRho_00 = wrap_chiRho_00(s, k) QQ_00 = chiT_00/(d_00*T_00*chiRho_00) lnT_00 = wrap_lnT_00(s,k) - + r_m1 = wrap_r_m1(s, k) d_m1 = wrap_d_m1(s, k) Peos_m1 = wrap_Peos_m1(s, k) @@ -485,16 +485,16 @@ function compute_Y_face(s, k, ierr) result(Y_face) ! superadiabatic gradient [un ! = g^-1 cm s^2 ! P units = erg cm^-3 = g cm^2 s^-2 cm^-3 = g cm^-1 s^-2 ! QQ/Cp*P is unitless. - + Y1 = QQ_div_Cp_face*(Peos_m1 - Peos_00) - (lnT_m1 - lnT_00) ! Y1 unitless - + Y2 = 4d0*pi*pow2(r_00)*Hp_face*2d0/(1d0/d_00 + 1d0/d_m1)/dm_bar ! units = cm^2 cm / (cm^3 g^-1) / g ! = cm^2 cm cm^-3 g g^-1 = unitless - + Y_face = Y1*Y2 ! unitless - + if (k==-35) then write(*,3) 'RSP2 Y_face Y1 Y2', k, s% solver_iter, s% Y_face(k), Y1%val, Y2%val write(*,3) 'Peos', k, s% solver_iter, Peos_00%val @@ -511,7 +511,7 @@ function compute_Y_face(s, k, ierr) result(Y_face) ! superadiabatic gradient [un end if else - + grad_ad_00 = wrap_grad_ad_00(s,k) grad_ad_m1 = wrap_grad_ad_m1(s,k) grad_ad_face = alfa*grad_ad_00 + beta*grad_ad_m1 @@ -528,15 +528,15 @@ function compute_Y_face(s, k, ierr) result(Y_face) ! superadiabatic gradient [un end if if (is_bad(alt_Y_face%val)) alt_Y_face = 0 Y_face = alt_Y_face - + end if s% Y_face_ad(k) = Y_face s% Y_face(k) = Y_face%val end function compute_Y_face - - + + function compute_PII_face(s, k, ierr) result(PII_face) ! ergs g^-1 K^-1 (like Cp) type (star_info), pointer :: s integer, intent(in) :: k @@ -573,13 +573,13 @@ function compute_PII_face(s, k, ierr) result(PII_face) ! ergs g^-1 K^-1 (like Cp write(*,2) 'Y_face', k, Y_face%val !write(*,2) 'PII_face%val', k, PII_face%val !write(*,2) 'T_rho_face%val', k, T_rho_face%val - !write(*,2) '', k, - !write(*,2) '', k, + !write(*,2) '', k, + !write(*,2) '', k, call mesa_error(__FILE__,__LINE__,'compute_PII_face') end if end function compute_PII_face - - + + function compute_d_v_div_r(s, k, ierr) result(d_v_div_r) ! s^-1 type (star_info), pointer :: s integer, intent(in) :: k @@ -595,8 +595,8 @@ function compute_d_v_div_r(s, k, ierr) result(d_v_div_r) ! s^-1 if (r_p1%val == 0d0) r_p1 = 1d0 d_v_div_r = v_00/r_00 - v_p1/r_p1 ! units s^-1 end function compute_d_v_div_r - - + + function compute_d_v_div_r_opt_time_center(s, k, ierr) result(d_v_div_r) ! s^-1 type (star_info), pointer :: s integer, intent(in) :: k @@ -620,8 +620,8 @@ function wrap_Hp_cell(s, k) result(Hp_cell) ! cm type(auto_diff_real_star_order1) :: Hp_cell Hp_cell = 0.5d0*(wrap_Hp_00(s,k) + wrap_Hp_p1(s,k)) end function wrap_Hp_cell - - + + function Hp_cell_for_Chi(s, k, ierr) result(Hp_cell) ! cm type (star_info), pointer :: s integer, intent(in) :: k @@ -629,12 +629,12 @@ function Hp_cell_for_Chi(s, k, ierr) result(Hp_cell) ! cm type(auto_diff_real_star_order1) :: Hp_cell type(auto_diff_real_star_order1) :: d_00, Peos_00, rmid real(dp) :: mmid, cgrav_mid - include 'formats' + include 'formats' ierr = 0 - + Hp_cell = wrap_Hp_cell(s, k) return - + d_00 = wrap_d_00(s, k) Peos_00 = wrap_Peos_00(s, k) if (k < s% nz) then @@ -651,9 +651,9 @@ function Hp_cell_for_Chi(s, k, ierr) result(Hp_cell) ! cm call mesa_error(__FILE__,__LINE__,'Hp_cell_for_Chi: cannot use alt_scale_height_flag') end if end function Hp_cell_for_Chi - - - function compute_Chi_cell(s, k, ierr) result(Chi_cell) + + + function compute_Chi_cell(s, k, ierr) result(Chi_cell) ! eddy viscosity energy (Kuhfuss 1986) [erg] type (star_info), pointer :: s integer, intent(in) :: k @@ -680,7 +680,7 @@ function compute_Chi_cell(s, k, ierr) result(Chi_cell) if (ierr /= 0) return w_00 = wrap_w_00(s,k) d_00 = wrap_d_00(s,k) - f = (16d0/3d0)*pi*ALFAM_ALFA/s% dm(k) + f = (16d0/3d0)*pi*ALFAM_ALFA/s% dm(k) rho2 = pow2(d_00) r_00 = wrap_r_00(s,k) r_p1 = wrap_r_p1(s,k) @@ -688,14 +688,14 @@ function compute_Chi_cell(s, k, ierr) result(Chi_cell) Chi_cell = f*rho2*r6_cell*d_v_div_r*Hp_cell*w_00 ! units = g^-1 cm s^-1 g^2 cm^-6 cm^6 s^-1 cm ! = g cm^2 s^-2 - ! = erg + ! = erg end if s% Chi(k) = Chi_cell%val s% Chi_ad(k) = Chi_cell end function compute_Chi_cell - + function compute_Eq_cell(s, k, ierr) result(Eq_cell) ! erg g^-1 s^-1 type (star_info), pointer :: s integer, intent(in) :: k @@ -728,7 +728,7 @@ function compute_Uq_face(s, k, ierr) result(Uq_face) ! cm s^-2, acceleration integer, intent(out) :: ierr type(auto_diff_real_star_order1) :: Chi_00, Chi_m1, r_00 include 'formats' - ierr = 0 + ierr = 0 if (s% mixing_length_alpha == 0d0 .or. & k <= s% RSP2_num_outermost_cells_forced_nonturbulent .or. & k > s% nz - int(s% nz/s% RSP2_nz_div_IBOTOM)) then @@ -744,12 +744,12 @@ function compute_Uq_face(s, k, ierr) result(Uq_face) ! cm s^-2, acceleration Chi_m1 = 0d0 end if Uq_face = 4d0*pi*(Chi_m1 - Chi_00)/(r_00*s% dm_bar(k)) - + if (k==-56) then write(*,3) 'RSP2 Uq chi_m1 chi_00 r', k, s% solver_iter, & Uq_face%val, Chi_m1%val, Chi_00%val, r_00%val end if - + end if ! erg g^-1 cm^-1 = g cm^2 s^-2 g^-1 cm^-1 = cm s^-2, acceleration s% Uq(k) = Uq_face%val @@ -769,18 +769,18 @@ function compute_Source(s, k, ierr) result(Source) ! erg g^-1 s^-1 include 'formats' ierr = 0 w_00 = wrap_w_00(s, k) - T_00 = wrap_T_00(s, k) - d_00 = wrap_d_00(s, k) - Peos_00 = wrap_Peos_00(s, k) + T_00 = wrap_T_00(s, k) + d_00 = wrap_d_00(s, k) + Peos_00 = wrap_Peos_00(s, k) Cp_00 = wrap_Cp_00(s, k) chiT_00 = wrap_chiT_00(s, k) chiRho_00 = wrap_chiRho_00(s, k) QQ_00 = chiT_00/(d_00*T_00*chiRho_00) - + Hp_face_00 = wrap_Hp_00(s,k) PII_face_00 = s% PII_ad(k) ! compute_PII_face(s, k, ierr) if (ierr /= 0) return - + if (k == s% nz) then PII_div_Hp_cell = PII_face_00/Hp_face_00 else @@ -791,17 +791,17 @@ function compute_Source(s, k, ierr) result(Source) ! erg g^-1 s^-1 if (ierr /= 0) return PII_div_Hp_cell = 0.5d0*(PII_face_00/Hp_face_00 + PII_face_p1/Hp_face_p1) end if - + ! Peos_00*QQ_00/Cp_00 = grad_ad if all perfect. !grad_ad_00 = wrap_grad_ad_00(s, k) P_QQ_div_Cp = Peos_00*QQ_00/Cp_00 ! use this to be same as RSP Source = (w_00 + s% RSP2_source_seed)*PII_div_Hp_cell*T_00*P_QQ_div_Cp - + ! PII units same as Cp = erg g^-1 K^-1 ! P*QQ/Cp is unitless (see Y_face) ! Source units = (erg g^-1 K^-1) cm^-1 cm s^-1 K ! = erg g^-1 s^-1 - + if (k==-109) then write(*,3) 'RSP2 Source w PII_div_Hp T_P_QQ_div_Cp', k, s% solver_iter, & Source%val, w_00%val, PII_div_Hp_cell%val, T_00%val*P_QQ_div_Cp% val @@ -863,7 +863,7 @@ function compute_Dr(s, k, ierr) result(Dr) ! erg g^-1 s^-1 = cm^2 s^-3 kap_00 = wrap_kap_00(s,k) Hp_cell = wrap_Hp_cell(s,k) POM = 4d0*boltz_sigma*pow2(gammar/alpha) ! erg cm^-2 K^-4 s^-1 - POM2 = pow3(T_00)/(pow2(d_00)*Cp_00*kap_00) + POM2 = pow3(T_00)/(pow2(d_00)*Cp_00*kap_00) ! K^3 / ((g cm^-3)^2 (erg g^-1 K^-1) (cm^2 g^-1)) ! K^3 / (cm^-4 erg K^-1) = K^4 cm^4 erg^-1 Dr = get_etrb(s,k)*POM*POM2/pow2(Hp_cell) @@ -918,7 +918,7 @@ subroutine compute_L_terms(s, k, L, Lr, Lc, Lt, ierr) type (star_info), pointer, intent(in) :: s integer, intent(in) :: k type(auto_diff_real_star_order1), intent(out) :: L, Lr, Lc, Lt - integer, intent(out) :: ierr + integer, intent(out) :: ierr include 'formats' ierr = 0 if (k > s% nz) then @@ -931,7 +931,7 @@ subroutine compute_L_terms(s, k, L, Lr, Lc, Lt, ierr) end if Lr = compute_Lr(s, k, ierr) if (ierr /= 0) return - if (k == 1) then + if (k == 1) then Lc = 0d0 Lt = 0d0 else @@ -972,7 +972,7 @@ function compute_Lr(s, k, ierr) result(Lr) ! erg s^-1 return end if T_m1 = wrap_T_m1(s,k) - T4m1 = pow4(T_m1) + T4m1 = pow4(T_m1) alfa = s% dq(k-1)/(s% dq(k-1) + s% dq(k)) kap_00 = wrap_kap_00(s,k) kap_m1 = wrap_kap_m1(s,k) @@ -988,14 +988,14 @@ function compute_Lr(s, k, ierr) result(Lr) ! erg s^-1 end if end if end if - Lr = -crad*clight/3d0*diff_T4_div_kap*pow2(area)/s% dm_bar(k) - ! units (erg cm^-3 K^-4) (cm s^-1) (K^4 cm^-2 g cm^4) g^-1 = erg s^-1 - + Lr = -crad*clight/3d0*diff_T4_div_kap*pow2(area)/s% dm_bar(k) + ! units (erg cm^-3 K^-4) (cm s^-1) (K^4 cm^-2 g cm^4) g^-1 = erg s^-1 + !s% xtra1_array(k) = s% T_start(k) !s% xtra2_array(k) = T4m1%val - T400%val !s% xtra3_array(k) = kap_face%val !s% xtra4_array(k) = diff_T4_div_kap%val - !s% xtra5_array(k) = Lr%val/Lsun + !s% xtra5_array(k) = Lr%val/Lsun !s% xtra6_array(k) = 1 end if @@ -1034,7 +1034,7 @@ function compute_Lc_terms(s, k, Lc_div_w_face, ierr) result(Lc) r_00 = wrap_r_00(s, k) area = 4d0*pi*pow2(r_00) T_m1 = wrap_T_m1(s, k) - T_00 = wrap_T_00(s, k) + T_00 = wrap_T_00(s, k) d_m1 = wrap_d_m1(s, k) d_00 = wrap_d_00(s, k) w_m1 = wrap_w_m1(s, k) @@ -1055,8 +1055,8 @@ function compute_Lc_terms(s, k, Lc_div_w_face, ierr) result(Lc) write(*,2) 'Lc_div_w_face', k, Lc_div_w_face%val write(*,2) 'PII_face%val', k, PII_face%val write(*,2) 'T_rho_face%val', k, T_rho_face%val - !write(*,2) '', k, - !write(*,2) '', k, + !write(*,2) '', k, + !write(*,2) '', k, call mesa_error(__FILE__,__LINE__,'compute_Lc_terms') end if end function compute_Lc_terms @@ -1075,7 +1075,7 @@ function compute_Lt(s, k, ierr) result(Lt) ! erg s^-1 if (k > s% nz) then Lt = 0d0 return - end if + end if alpha_alpha_t = s% mixing_length_alpha*s% RSP2_alfat if (alpha_alpha_t == 0d0 .or. & k <= s% RSP2_num_outermost_cells_forced_nonturbulent .or. & @@ -1084,7 +1084,7 @@ function compute_Lt(s, k, ierr) result(Lt) ! erg s^-1 s% Lt(k) = 0d0 return end if - r_00 = wrap_r_00(s,k) + r_00 = wrap_r_00(s,k) area2 = pow2(4d0*pi*pow2(r_00)) d_m1 = wrap_d_m1(s,k) d_00 = wrap_d_00(s,k) @@ -1095,21 +1095,21 @@ function compute_Lt(s, k, ierr) result(Lt) ! erg s^-1 w_face = alfa*w_00 + beta*w_m1 etrb_m1 = wrap_etrb_m1(s,k) etrb_00 = wrap_etrb_00(s,k) - Hp_face = wrap_Hp_00(s,k) + Hp_face = wrap_Hp_00(s,k) ! Ft = - alpha_t * rho_face * alpha * Hp_face * w_face * detrb/dr (thesis eqn 2.44) ! replace dr by dm_bar/(area*rho_face) ! Ft = - alpha_alpha_t * rho_face * Hp_face * w_face * (area*rho_face) * detrb/dm_bar ! Lt = area * Ft ! Lt = -alpha_alpha_t * (area*rho_face)**2 * Hp_face * w_face * (etrb(k-1) - etrb(k))/dm_bar - Lt = - alpha_alpha_t * area2 * rho2_face * Hp_face * w_face * (etrb_m1 - etrb_00) / s% dm_bar(k) + Lt = - alpha_alpha_t * area2 * rho2_face * Hp_face * w_face * (etrb_m1 - etrb_00) / s% dm_bar(k) ! units = (cm^4) (g^2 cm^-6) (cm) (cm s^-1) (ergs g^-1) g^-1 = erg s^-1 - s% Lt(k) = Lt%val + s% Lt(k) = Lt%val end function compute_Lt subroutine set_etrb_start_vars(s, ierr) type (star_info), pointer :: s - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: k type(auto_diff_real_star_order1) :: Y_face, Lt include 'formats' @@ -1117,47 +1117,47 @@ subroutine set_etrb_start_vars(s, ierr) do k=1,s%nz Y_face = compute_Y_face(s, k, ierr) if (ierr /= 0) return - s% Y_face_start(k) = Y_face%val + s% Y_face_start(k) = Y_face%val Lt = compute_Lt(s, k, ierr) if (ierr /= 0) return - s% Lt_start(k) = Lt%val + s% Lt_start(k) = Lt%val s% w_start(k) = s% w(k) s% Hp_face_start(k) = s% Hp_face(k) - end do + end do end subroutine set_etrb_start_vars - + subroutine RSP2_adjust_vars_before_call_solver(s, ierr) ! replaces check_omega in RSP ! JAK OKRESLIC OMEGA DLA PIERWSZEJ ITERACJI use micro, only: do_eos_for_cell type (star_info), pointer :: s - integer, intent(out) :: ierr + integer, intent(out) :: ierr real(dp) :: PII_div_Hp, QQ, SOURCE, Hp_cell, DAMP, POM, POM2, DAMPR, del, soln !type(auto_diff_real_star_order1) :: x integer :: k - include 'formats' + include 'formats' ierr = 0 if (s% mixing_length_alpha == 0d0) return - + !$OMP PARALLEL DO PRIVATE(k,PII_div_Hp,QQ,SOURCE,Hp_cell,DAMP,POM,POM2,DAMPR,del,soln) SCHEDULE(dynamic,2) do k=s% RSP2_num_outermost_cells_forced_nonturbulent+1, & s% nz - max(1,int(s% nz/s% RSP_nz_div_IBOTOM)) - + if (s% w(k) > s% RSP2_w_min_for_damping) cycle - + PII_div_Hp = 0.5d0*(s% PII(k)/s% Hp_face(k) + s% PII(k+1)/s% Hp_face(k+1)) - QQ = s% chiT(k)/(s% rho(k)*s% T(k)*s% chiRho(k)) + QQ = s% chiT(k)/(s% rho(k)*s% T(k)*s% chiRho(k)) SOURCE = PII_div_Hp*s% T(k)*s% Peos(k)*QQ/s% Cp(k) - + Hp_cell = 0.5d0*(s% Hp_face(k) + s% Hp_face(k+1)) - DAMP = (s% RSP2_alfad*x_CEDE/s% mixing_length_alpha)/Hp_cell - + DAMP = (s% RSP2_alfad*x_CEDE/s% mixing_length_alpha)/Hp_cell + POM = 4d0*boltz_sigma*pow2(s% RSP2_alfar*x_GAMMAR/s% mixing_length_alpha) - POM2 = pow3(s% T(k))/(pow2(s% rho(k))*s% Cp(k)*s% opacity(k)) + POM2 = pow3(s% T(k))/(pow2(s% rho(k))*s% Cp(k)*s% opacity(k)) DAMPR = POM*POM2/pow2(Hp_cell) - + del = pow2(DAMPR) + 4d0*DAMP*SOURCE - + if (k==-35) then write(*,2) 'del', k, del write(*,2) 'DAMPR', k, DAMPR @@ -1172,7 +1172,7 @@ subroutine RSP2_adjust_vars_before_call_solver(s, ierr) ! replaces check_omega i write(*,2) 's% Y_face(k)', k, s% Y_face(k) write(*,2) 's% Y_face(k+1)', k+1, s% Y_face(k+1) end if - + if (del < 0d0) cycle soln = (-DAMPR + sqrt(del))/(2d0*DAMP) if (k==-35) write(*,2) 'soln', k, soln diff --git a/star/private/hydro_rsp2_support.f90 b/star/private/hydro_rsp2_support.f90 index 9c4baf1d6..ff59663b1 100644 --- a/star/private/hydro_rsp2_support.f90 +++ b/star/private/hydro_rsp2_support.f90 @@ -40,7 +40,7 @@ module hydro_rsp2_support contains - + subroutine remesh_for_RSP2(s,ierr) ! uses these controls ! RSP2_nz = 150 @@ -49,14 +49,14 @@ subroutine remesh_for_RSP2(s,ierr) ! RSP2_dq_1_factor = 2d0 use interp_1d_def, only: pm_work_size use interp_1d_lib, only: interpolate_vector_pm - type (star_info), pointer :: s - integer, intent(out) :: ierr + type (star_info), pointer :: s + integer, intent(out) :: ierr integer :: k, j, nz_old, nz real(dp) :: xm_anchor, P_surf, T_surf, old_L1, old_r1 real(dp), allocatable, dimension(:) :: & xm_old, xm, xm_mid_old, xm_mid, v_old, v_new real(dp), pointer :: work1(:) ! =(nz_old+1, pm_work_size) - include 'formats' + include 'formats' ierr = 0 nz_old = s% nz nz = s% RSP2_nz @@ -91,13 +91,13 @@ subroutine remesh_for_RSP2(s,ierr) do k=1,nz call set_Hp_face(k) end do - deallocate(work1) + deallocate(work1) s% nz = nz write(*,1) 'new old L_surf/Lsun', s% xh(s% i_lum,1)/Lsun, old_L1/Lsun write(*,1) 'new old R_surf/Rsun', exp(s% xh(s% i_lnR,1))/Rsun, old_r1/Rsun write(*,'(A)') !call mesa_error(__FILE__,__LINE__,'remesh_for_RSP2') - + contains subroutine setvars(ierr) @@ -128,7 +128,7 @@ subroutine setvars(ierr) skip_mixing_info, skip_set_cz_bdy_mass, skip_mlt, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'remesh_for_RSP2 failed in set_hydro_vars') end subroutine setvars - + subroutine get_PT_surf(P_surf, T_surf, ierr) use atm_support, only: get_atm_PT real(dp), intent(out) :: P_surf, T_surf @@ -149,7 +149,7 @@ subroutine get_PT_surf(P_surf, T_surf, ierr) P_surf = exp(lnP_surf) T_surf = exp(lnT_surf) return - + write(*,1) 'get_PT_surf P_surf', P_surf write(*,1) 'get_PT_surf T_surf', T_surf write(*,1) 'get_PT_surf Teff', Teff @@ -157,7 +157,7 @@ subroutine get_PT_surf(P_surf, T_surf, ierr) write(*,1) !call mesa_error(__FILE__,__LINE__,'get_PT_surf') end subroutine get_PT_surf - + subroutine set_xm_old xm_old(1) = 0d0 do k=2,nz_old @@ -168,7 +168,7 @@ subroutine set_xm_old xm_mid_old(k) = xm_old(k) + 0.5d0*s% dm(k) end do end subroutine set_xm_old - + subroutine find_xm_anchor real(dp) :: lnT_anchor, xmm1, xm00, lnTm1, lnT00 include 'formats' @@ -193,8 +193,8 @@ subroutine find_xm_anchor return end if end do - end subroutine find_xm_anchor - + end subroutine find_xm_anchor + subroutine set_xm_new ! sets xm, dm, m, dq, q integer :: nz_outer, k real(dp) :: dq_1_factor, dxm_outer, lnx, dlnx @@ -236,14 +236,14 @@ subroutine set_xm_new ! sets xm, dm, m, dq, q end do call set_dm_bar(s, s% nz, s% dm, s% dm_bar) return - + do k=2,nz write(*,2) 'dm(k)/dm(k-1) m(k)', k, s%dm(k)/s%dm(k-1), s%m(k)/Msun end do write(*,1) 'm_center', s% m_center/msun call mesa_error(__FILE__,__LINE__,'set_xm_new') end subroutine set_xm_new - + subroutine interpolate1_face_val(i, cntr_val) integer, intent(in) :: i real(dp), intent(in) :: cntr_val @@ -257,7 +257,7 @@ subroutine interpolate1_face_val(i, cntr_val) s% xh(i,k) = v_new(k) end do end subroutine interpolate1_face_val - + subroutine check_new_lnR include 'formats' do k=1,nz @@ -275,7 +275,7 @@ subroutine check_new_lnR call mesa_error(__FILE__,__LINE__,'check_new_lnR remesh rsp2') end if end subroutine check_new_lnR - + subroutine set_new_lnd real(dp) :: vol, r300, r3p1 include 'formats' @@ -296,7 +296,7 @@ subroutine set_new_lnd end if end do end subroutine set_new_lnd - + subroutine interpolate1_cell_val(i) integer, intent(in) :: i do k=1,nz_old @@ -308,7 +308,7 @@ subroutine interpolate1_cell_val(i) s% xh(i,k) = v_new(k) end do end subroutine interpolate1_cell_val - + subroutine interpolate1_xa(j) integer, intent(in) :: j do k=1,nz_old @@ -320,7 +320,7 @@ subroutine interpolate1_xa(j) s% xa(j,k) = v_new(k) end do end subroutine interpolate1_xa - + subroutine rescale_xa integer :: k, j real(dp) :: sum_xa @@ -331,7 +331,7 @@ subroutine rescale_xa end do end do end subroutine rescale_xa - + subroutine revise_lnT_for_QHSE(P_surf, ierr) use eos_def, only: num_eos_basic_results, num_eos_d_dxa_results use chem_def, only: chem_isos @@ -395,7 +395,7 @@ subroutine revise_lnT_for_QHSE(P_surf, ierr) !write(*,2) 'logP dlogT logT logT_guess logRho', k, & ! logP, logT - logT_guess, logT, logT_guess, logRho P_m1 = P_00 - + if (k == 1) then ! get opacity and recheck surf BCs call get_kap( & ! assume zbar is set s, k, s% zbar(k), s% xa(:,k), logRho, logT, & @@ -419,7 +419,7 @@ subroutine revise_lnT_for_QHSE(P_surf, ierr) write(*,1) 'new old kap(1)', kap, old_kap !call mesa_error(__FILE__,__LINE__,'revise_lnT_for_QHSE') end if - + end do !write(*,1) 'after revise_lnT_for_QHSE: logT cntr', s% lnT(nz)/ln10 !stop diff --git a/star/private/hydro_temperature.f90 b/star/private/hydro_temperature.f90 index ea5c2307d..563ae2b35 100644 --- a/star/private/hydro_temperature.f90 +++ b/star/private/hydro_temperature.f90 @@ -38,7 +38,7 @@ module hydro_temperature public :: do1_alt_dlnT_dm_eqn, do1_gradT_eqn, do1_dlnT_dm_eqn contains - + ! just relate L_rad to T gradient. @@ -58,7 +58,7 @@ subroutine do1_alt_dlnT_dm_eqn(s, k, nvar, ierr) type(auto_diff_real_star_order1) :: L_ad, r_00, area, area2, Lrad_ad, & kap_00, kap_m1, kap_face, d_P_rad_expected_ad, T_m1, T4_m1, T_00, T4_00, & P_rad_m1, P_rad_00, d_P_rad_actual_ad, resid - + integer :: i_equL logical :: dbg logical :: test_partials @@ -99,10 +99,10 @@ subroutine do1_alt_dlnT_dm_eqn(s, k, nvar, ierr) kap_face = alfa*kap_00 + beta*kap_m1 if (kap_face%val < s% min_kap_for_dPrad_dm_eqn) & kap_face = s% min_kap_for_dPrad_dm_eqn - + ! calculate expected d_P_rad from current L_rad d_P_rad_expected_ad = -dm_bar*kap_face*Lrad_ad/(clight*area2) - + ! calculate actual d_P_rad in current model T_m1 = wrap_T_m1(s,k); T4_m1 = pow4(T_m1) T_00 = wrap_T_00(s,k); T4_00 = pow4(T_00) @@ -112,11 +112,11 @@ subroutine do1_alt_dlnT_dm_eqn(s, k, nvar, ierr) P_rad_m1 = (crad/3d0)*T4_m1 P_rad_00 = (crad/3d0)*T4_00 d_P_rad_actual_ad = P_rad_m1 - P_rad_00 - + ! residual - resid = (d_P_rad_expected_ad - d_P_rad_actual_ad)/scale + resid = (d_P_rad_expected_ad - d_P_rad_actual_ad)/scale s% equ(i_equL, k) = resid%val - + if (is_bad(resid%val)) then !$OMP critical (star_alt_dlntdm_bad_num) write(*,2) 'resid%val', k, resid%val @@ -137,7 +137,7 @@ subroutine do1_alt_dlnT_dm_eqn(s, k, nvar, ierr) write(*,*) 'do1_alt_dlnT_dm_eqn', s% solver_test_partials_var end if - contains + contains end subroutine do1_alt_dlnT_dm_eqn @@ -188,11 +188,11 @@ subroutine do1_gradT_eqn(s, k, nvar, ierr) call save_eqn_residual_info( & s, k, nvar, i_equL, resid, 'do1_gradT_eqn', ierr) - + !call set_xtras - + contains - + subroutine set_xtras use auto_diff_support use star_utils, only: get_Lrad @@ -211,10 +211,10 @@ subroutine set_xtras s% xtra2_array(k) = T4m1%val - T400%val s% xtra3_array(k) = kap_face%val s% xtra4_array(k) = diff_T4_div_kap%val - s% xtra5_array(k) = get_Lrad(s,k) + s% xtra5_array(k) = get_Lrad(s,k) s% xtra6_array(k) = 1 end subroutine set_xtras - + end subroutine do1_gradT_eqn @@ -239,23 +239,23 @@ subroutine do1_dlnT_dm_eqn(s, k, nvar, ierr) i_equL = s% i_equL if (i_equL == 0) return - + if (s% use_gradT_actual_vs_gradT_MLT_for_T_gradient_eqn) then - call do1_gradT_eqn(s, k, nvar, ierr) + call do1_gradT_eqn(s, k, nvar, ierr) return end if if (s% use_dPrad_dm_form_of_T_gradient_eqn) then - call do1_alt_dlnT_dm_eqn(s, k, nvar, ierr) + call do1_alt_dlnT_dm_eqn(s, k, nvar, ierr) return end if - + ! dT/dm = dP/dm * T/P * grad_T, grad_T = dlnT/dlnP from MLT. ! but use hydrostatic value for dP/dm in this. ! this is because of limitations of MLT for calculating grad_T. ! (MLT assumes hydrostatic equilibrium) ! see comment in K&W chpt 9.1. - + call eval_dlnPdm_qhse(s, k, dlnPdm, Ppoint, ierr) if (ierr /= 0) return @@ -269,7 +269,7 @@ subroutine do1_dlnT_dm_eqn(s, k, nvar, ierr) Tpoint = alfa*T00 + (1d0 - alfa)*Tm1 lnTdiff = dT/Tpoint ! use this in place of lnT(k-1)-lnT(k) delm = (s% dm(k) + s% dm(k-1))/2 - + resid = delm*dlnTdm - lnTdiff s% equ(i_equL, k) = resid%val @@ -316,13 +316,13 @@ subroutine eval_dlnPdm_qhse(s, k, & ! calculate the expected dlnPdm for HSE ! divide by Ppoint to make it unitless ! for rotation, multiply gravity by factor fp. MESA 2, eqn 22. - + call expected_HSE_grav_term(s, k, grav, area, ierr) if (ierr /= 0) return - + P00 = wrap_Peos_00(s,k) if (s% using_velocity_time_centering) P00 = 0.5d0*(P00 + s% Peos_start(k)) - + if (k == 1) then Pm1 = 0d0 Ppoint = P00 @@ -331,9 +331,9 @@ subroutine eval_dlnPdm_qhse(s, k, & ! calculate the expected dlnPdm for HSE alfa = s% dq(k-1)/(s% dq(k-1) + s% dq(k)) Ppoint = alfa*P00 + (1d0-alfa)*Pm1 end if - + dlnPdm_qhse = grav/(area*Ppoint) ! note that expected_HSE_grav_term is negative - + if (is_bad(dlnPdm_qhse%val)) then ierr = -1 s% retry_message = 'eval_dlnPdm_qhse: is_bad(dlnPdm_qhse)' @@ -350,7 +350,7 @@ subroutine eval_dlnPdm_qhse(s, k, & ! calculate the expected dlnPdm for HSE return end if - end subroutine eval_dlnPdm_qhse - + end subroutine eval_dlnPdm_qhse + end module hydro_temperature diff --git a/star/private/hydro_vars.f90 b/star/private/hydro_vars.f90 index 5f1dcaa01..25ad12b43 100644 --- a/star/private/hydro_vars.f90 +++ b/star/private/hydro_vars.f90 @@ -86,7 +86,7 @@ subroutine set_vars(s, dt, ierr) dt, ierr) end subroutine set_vars - + subroutine set_final_vars(s, dt, ierr) use rates_def, only: num_rvs type (star_info), pointer :: s @@ -109,30 +109,30 @@ subroutine set_final_vars(s, dt, ierr) skip_set_cz_bdy_mass, & skip_mlt integer :: nz, k - + include 'formats' - + ierr = 0 nz = s% nz - + skip_grads = .false. skip_rotation = .false. skip_brunt = .false. skip_other_cgrav = .false. skip_set_cz_bdy_mass = .false. skip_m_grav_and_grav = .false. - skip_mixing_info = .not. s% recalc_mix_info_after_evolve + skip_mixing_info = .not. s% recalc_mix_info_after_evolve ! only need to do things that were skipped in set_vars_for_solver ! i.e., skip what it already did for the last solver iteration - skip_basic_vars = .not. s% need_to_setvars + skip_basic_vars = .not. s% need_to_setvars skip_micro_vars = .not. s% need_to_setvars skip_kap = .not. s% need_to_setvars skip_neu = .not. s% need_to_setvars skip_net = .not. s% need_to_setvars skip_eos = .not. s% need_to_setvars skip_mlt = .not. s% need_to_setvars - + if (s% need_to_setvars) then s% num_setvars = s% num_setvars + 1 if (trace_setvars) write(*,*) 'set_vars in set_final_vars' @@ -141,7 +141,7 @@ subroutine set_final_vars(s, dt, ierr) if (trace_setvars) write(*,*) '** skip set_vars in set_final_vars' end if if (trace_setvars) write(*,*) - + call set_hydro_vars( & s, 1, nz, skip_basic_vars, & skip_micro_vars, skip_m_grav_and_grav, skip_eos, skip_net, skip_neu, & @@ -185,7 +185,7 @@ subroutine set_some_vars( & logical, parameter :: skip_eos = .false. include 'formats' - + call update_vars(s, & skip_basic_vars, skip_micro_vars, & skip_m_grav_and_grav, skip_net, skip_neu, skip_kap, & @@ -197,7 +197,7 @@ subroutine set_some_vars( & write(*,*) 'set_some_vars: update_vars returned ierr', ierr return end if - + end subroutine set_some_vars @@ -231,9 +231,9 @@ subroutine update_vars(s, & if (.not. skip_mixing_info) then s% mixing_type(1:nz) = no_mixing s% adjust_mlt_gradT_fraction(1:nz) = -1 - end if + end if end if - + call set_hydro_vars( & s, 1, nz, skip_basic_vars, & skip_micro_vars, skip_m_grav_and_grav, skip_eos, skip_net, skip_neu, & @@ -253,7 +253,7 @@ subroutine update_vars(s, & return end if end if - + if (.not. skip_irradiation_heat) then if (s% irradiation_flux /= 0) then do k=1,nz @@ -265,8 +265,8 @@ subroutine update_vars(s, & end if end subroutine update_vars - - + + subroutine unpack_xh(s,ierr) use star_utils, only: set_qs, set_dm_bar, set_m_and_dm type (star_info), pointer :: s @@ -290,7 +290,7 @@ subroutine unpack_xh(s,ierr) i_u = s% i_u i_alpha_RTI = s% i_alpha_RTI i_Et_RSP = s% i_Et_RSP - + do j=1,s% nvar_hydro if (j == i_lnd) then do k=1,nz @@ -407,7 +407,7 @@ subroutine set_Teff_info_for_eqns(s, skip_partials, & need_atm_Tsurf = need_atm_Tsurf_in ierr = 0 - + r_surf = s% r(1) L_surf = s% L(1) @@ -430,7 +430,7 @@ subroutine set_Teff_info_for_eqns(s, skip_partials, & dlnP_dlnkap = 0d0 return end if - + if (s% use_other_surface_PT) then call s% other_surface_PT( & s% id, skip_partials, & @@ -521,7 +521,7 @@ subroutine set_hydro_vars( & end if if (.not. skip_other_cgrav) call set_cgrav(s, ierr) - + call get_tau(s, ierr) if (failed('get_tau')) return @@ -550,22 +550,22 @@ subroutine set_hydro_vars( & call set_conv_time_scales(s) ! uses brunt_B end if - if (.not. skip_mixing_info) then + if (.not. skip_mixing_info) then if (.not. s% RSP2_flag) then if (dbg) write(*,*) 'call other_adjust_mlt_gradT_fraction' call s% other_adjust_mlt_gradT_fraction(s% id,ierr) if (failed('other_adjust_mlt_gradT_fraction')) return - end if + end if if (dbg) write(*,*) 'call set_abs_du_div_cs' call set_abs_du_div_cs(s) end if - + if (.not. skip_mlt .and. .not. s% RSP_flag) then - + if (.not. skip_mixing_info) then if (s% make_gradr_sticky_in_solver_iters) then - s% fixed_gradr_for_rest_of_solver_iters(nzlo:nzhi) = .false. - end if + s% fixed_gradr_for_rest_of_solver_iters(nzlo:nzhi) = .false. + end if s% alpha_mlt(nzlo:nzhi) = s% mixing_length_alpha if (s% use_other_alpha_mlt) then call s% other_alpha_mlt(s% id, ierr) @@ -576,7 +576,7 @@ subroutine set_hydro_vars( & end if end if end if - + if (s% use_other_gradr_factor) then if (dbg) write(*,*) 'call other_gradr_factor' call s% other_gradr_factor(s% id, ierr) @@ -596,14 +596,14 @@ subroutine set_hydro_vars( & else s% gradr_factor(nzlo:nzhi) = 1d0 end if - + call set_mlt_vars(s, nzlo, nzhi, ierr) if (failed('set_mlt_vars')) return if (dbg) write(*,*) 'call check_for_redo_MLT' - + call check_for_redo_MLT(s, nzlo, nzhi, ierr) if (failed('check_for_redo_MLT')) return - + end if if (.not. skip_brunt) then ! skip_brunt during solver iterations @@ -624,7 +624,7 @@ subroutine set_hydro_vars( & write(*,*) 'failed in compute_j_fluxes' end if end if - + if (s% RSP2_flag) then call set_RSP2_vars(s,ierr) if (ierr /= 0) then @@ -636,10 +636,10 @@ subroutine set_hydro_vars( & if (s% doing_timing) & call update_time(s, time0, total, s% time_set_hydro_vars) - + s% need_to_setvars = .false. - + contains logical function failed(str) @@ -652,7 +652,7 @@ logical function failed(str) write(*,*) 'set_hydro_vars failed in call to ' // trim(str) failed = .true. end function failed - + end subroutine set_hydro_vars @@ -729,7 +729,7 @@ subroutine set_basic_vars(s, nzlo, nzhi, ierr) end if end if if (s% r_start(k) < 0) s% r_start(k) = s% r(k) - call set_rv_info(s,k) + call set_rv_info(s,k) do j=1,species s% xa(j,k) = max(0d0, min(1d0, s% xa(j,k))) end do @@ -745,8 +745,8 @@ subroutine set_basic_vars(s, nzlo, nzhi, ierr) call set_rmid(s, nzlo, nzhi, ierr) end subroutine set_basic_vars - - + + subroutine set_cgrav(s, ierr) type (star_info), pointer :: s integer, intent(out) :: ierr @@ -800,13 +800,13 @@ subroutine get_surf_PT( & include 'formats' ! Set up stellar surface parameters - + L_surf = s% L(1) R_surf = s% r(1) kap_surf = s% opacity(1) M_surf = s% m(1) Teff = s% Teff - + ! Initialize partials dlnT_dL = 0._dp; dlnT_dlnR = 0._dp; dlnT_dlnM = 0._dp; dlnT_dlnkap = 0._dp dlnP_dL = 0._dp; dlnP_dlnR = 0._dp; dlnP_dlnM = 0._dp; dlnP_dlnkap = 0._dp @@ -822,7 +822,7 @@ subroutine get_surf_PT( & end if ! Evaluate surface temperature and pressure - + if (.not. (need_atm_Psurf .or. need_atm_Tsurf)) then ! Special-case boundary condition @@ -847,7 +847,7 @@ subroutine get_surf_PT( & ! The first few are special, 'trivial-atmosphere' options select case (s% atm_option) - + case ('fixed_Teff') ! set Tsurf from Eddington T-tau relation @@ -864,7 +864,7 @@ subroutine get_surf_PT( & dlnT_dL = 0._dp; dlnT_dlnR = 0._dp; dlnT_dlnM = 0._dp; dlnT_dlnkap = 0._dp dlnP_dL = 0._dp; dlnP_dlnR = 0._dp; dlnP_dlnM = 0._dp; dlnP_dlnkap = 0._dp endif - + case ('fixed_Tsurf') ! set Teff from Eddington T-tau relation for given @@ -971,7 +971,7 @@ subroutine get_surf_PT( & end if end select end if - + ! if using fixed surface, calculate Pextra. if (s% atm_option == 'fixed_Tsurf' .or. s% atm_option == 'fixed_Psurf_and_Tsurf' & .or. s% atm_option == 'fixed_Psurf' .or. s% atm_option == 'fixed_Teff') then @@ -1001,7 +1001,7 @@ subroutine get_surf_PT( & end if ! Check outputs - + if (is_bad(lnT_surf) .or. is_bad(lnP_surf)) then if (len_trim(s% retry_message) == 0) s% retry_message = 'bad logT surf or logP surf' ierr = -1 @@ -1149,6 +1149,6 @@ end subroutine do_work_arrays end subroutine set_grads - + end module hydro_vars diff --git a/star/private/init.f90 b/star/private/init.f90 index 47ca40b9a..6ea9b3da4 100644 --- a/star/private/init.f90 +++ b/star/private/init.f90 @@ -44,7 +44,7 @@ module init integer, parameter :: do_create_initial_model = 3 integer, parameter :: do_create_RSP_model = 4 integer, parameter :: do_create_RSP2_model = 5 - + logical :: have_done_starlib_init = .false. @@ -72,7 +72,7 @@ subroutine set_kap_and_eos_handles(id, ierr) if (ierr /= 0) then write(*,*) 'eos_ptr failed in alloc_eos_handle' return - end if + end if end if if (s% kap_handle == 0) then s% kap_handle = alloc_kap_handle_using_inlist(s% inlist_fname, ierr) @@ -203,7 +203,7 @@ subroutine alloc_star_data(id, ierr) nullify(s% dq) nullify(s% xa) nullify(s% xh) - + nullify( & s% op_mono_umesh1, s% op_mono_semesh1, s% op_mono_ff1, & s% op_mono_rs1) @@ -329,7 +329,7 @@ subroutine alloc_star_data(id, ierr) s% using_revised_max_yr_dt = .false. s% revised_max_yr_dt = 0 - + s% astero_using_revised_max_yr_dt = .false. s% astero_revised_max_yr_dt = 0 @@ -338,7 +338,7 @@ subroutine alloc_star_data(id, ierr) s% have_initial_energy_integrals = .false. - s% num_solver_iterations = 0 + s% num_solver_iterations = 0 s% mesh_call_number = 0 s% solver_call_number = 0 s% diffusion_call_number = 0 @@ -346,7 +346,7 @@ subroutine alloc_star_data(id, ierr) s% RSP_have_set_velocities = .false. s% RSP_just_set_velocities = .false. s% rsp_period = 0d0 - + s% dt = 0d0 s% mstar_dot = 0d0 @@ -462,14 +462,14 @@ subroutine set_starting_star_data(s, ierr) s% model_number = 0 s% time = 0 s% dt = 0 - + s% total_num_solver_iterations = 0 s% total_num_solver_relax_iterations = 0 s% total_num_solver_calls_made = 0 s% total_num_solver_relax_calls_made = 0 s% total_num_solver_calls_converged = 0 s% total_num_solver_relax_calls_converged = 0 - + s% num_solver_iterations = 0 s% num_skipped_setvars = 0 s% num_setvars = 0 @@ -478,7 +478,7 @@ subroutine set_starting_star_data(s, ierr) s% num_hydro_merges = 0 s% num_hydro_splits = 0 s% timestep_hold = -1 - + s% mesh_call_number = 0 s% solver_call_number = 0 s% diffusion_call_number = 0 @@ -510,7 +510,7 @@ subroutine set_starting_star_data(s, ierr) s% am_nu_rot_flag = .false. s% RSP_flag = .false. s% RSP2_flag = .false. - + s% have_mixing_info = .false. s% doing_solver_iterations = .false. s% need_to_setvars = .true. @@ -638,7 +638,7 @@ subroutine set_starting_star_data(s, ierr) s% data_for_binary_history_columns => null_data_for_binary_history_columns s% how_many_extra_binary_history_columns => null_how_many_extra_binary_history_columns s% data_for_extra_binary_history_columns => null_data_for_extra_binary_history_columns - + s% generations = 0 s% nz = 0 @@ -674,7 +674,7 @@ subroutine set_starting_star_data(s, ierr) s% L_phot = 0 s% T_surf = 0 s% P_surf = 0 - + s% gradT_excess_alpha = 0 s% gradT_excess_alpha_old = 0 @@ -685,7 +685,7 @@ subroutine set_starting_star_data(s, ierr) s% Teff = -1 ! need to calculate it s% center_eps_nuc = 0 s% Lrad_div_Ledd_avg_surf = 0 - s% w_div_w_crit_avg_surf = 0 + s% w_div_w_crit_avg_surf = 0 s% total_internal_energy = 0d0 s% total_gravitational_energy = 0d0 s% total_radial_kinetic_energy = 0d0 @@ -890,13 +890,13 @@ subroutine model_builder( & num_trace_history_values = s% num_trace_history_values s% num_trace_history_values = 0 - + warning_limit_for_max_residual = s% warning_limit_for_max_residual s% warning_limit_for_max_residual = 1d0 - + s% doing_first_model_of_run = .true. s% doing_first_model_after_restart = .false. - + if (do_which == do_load_saved_model) then s% dt_next = -1 call do_read_saved_model(s, model_info, ierr) @@ -1014,7 +1014,7 @@ subroutine model_builder( & return end select end if - + do k=1,s% nz s% extra_heat(k) = 0 end do @@ -1024,7 +1024,7 @@ subroutine model_builder( & write(*,*) 'failed in finish_load_model' return end if - + if (s% max_years_for_timestep > 0) & s% dt_next = min(s% dt_next, secyer*s% max_years_for_timestep) call set_phase_of_evolution(s) @@ -1074,8 +1074,8 @@ subroutine model_builder( & write(*,*) 'failed in do_relax_num_steps' return end if - - if (s% job% pre_ms_relax_to_start_radiative_core) then + + if (s% job% pre_ms_relax_to_start_radiative_core) then call do_relax_to_radiative_core(s% id, ierr) if (ierr /= 0) then write(*,*) 'failed in do_relax_to_radiative_core' @@ -1098,7 +1098,7 @@ subroutine model_builder( & s% warning_limit_for_max_residual = warning_limit_for_max_residual contains - + subroutine setup_for_relax_after_create_pre_ms_model save_atm_option = s% atm_option save_atm_T_tau_relation = s% atm_T_tau_relation @@ -1172,8 +1172,8 @@ subroutine null_data_for_binary_history_columns( & integer, intent(out) :: ierr ierr = 0 end subroutine null_data_for_binary_history_columns - - + + integer function null_how_many_extra_binary_history_columns(binary_id) integer, intent(in) :: binary_id null_how_many_extra_binary_history_columns = 0 @@ -1196,7 +1196,7 @@ subroutine do_garbage_collection(eosDT_cache_dir, ierr) use eos_def, only: use_cache_for_eos integer, intent(inout) :: ierr character (len=*), intent(in) :: eosDT_cache_dir - ! Remove existing eos data + ! Remove existing eos data call eos_shutdown() ! Re-initliaze eos call eos_init(eosDT_cache_dir,& @@ -1204,6 +1204,6 @@ subroutine do_garbage_collection(eosDT_cache_dir, ierr) use_cache_for_eos,& ierr) end subroutine do_garbage_collection - - + + end module init diff --git a/star/private/init_model.f90 b/star/private/init_model.f90 index 196ca85e0..0238e3ad5 100644 --- a/star/private/init_model.f90 +++ b/star/private/init_model.f90 @@ -392,11 +392,11 @@ subroutine get1_mass( & write(*,*) 'm_in', m_in write(*,*) 'nz_in', nz_in ierr = -1 - exit + exit mass_loop end if call get_chem_col_names(s, iounit, species, names, perm, ierr) - if (ierr /= 0) exit + if (ierr /= 0) exit mass_loop if (abs(m_in-m_read) > 1d-4) then diff --git a/star/private/ionization_potentials.f90 b/star/private/ionization_potentials.f90 index 19ecd50e3..4aa80b320 100644 --- a/star/private/ionization_potentials.f90 +++ b/star/private/ionization_potentials.f90 @@ -24,44 +24,44 @@ ! *********************************************************************** module ionization_potentials - + use const_def, only: dp use utils_lib, only: mesa_error implicit none - + logical :: ionization_tables_okay = .false. - + real(dp) :: ip(30,30) ! ionization_potentials contains - - + + subroutine set_ionization_potentials ! data from ! Allen, C.W., 1973, "Astrophysical Quantities", 3rd edition, pg 37-38. - + ! 1 h ip(1,1) = 13.598d0 - + ! 2 he ip(2,1:2) = (/ & 24.587d0, & 54.416d0 /) - + ! 3 Li ip(3,1:3) = (/ & 5.392d0, & 75.638d0, & 122.451d0 /) - + ! 4 Be ip(4,1:4) = (/ & 9.322d0, & 18.211d0, & 153.893d0, & 217.713d0 /) - + ! 5 B ip(5,1:5) = (/ & 8.298d0, & @@ -69,7 +69,7 @@ subroutine set_ionization_potentials ! data from 37.930d0, & 259.366d0, & 340.22d0 /) - + ! 6 C ip(6,1:6) = (/ & 11.260d0, & @@ -78,7 +78,7 @@ subroutine set_ionization_potentials ! data from 64.492d0, & 392.08d0, & 489.98d0 /) - + ! 7 N ip(7,1:7) = (/ & 14.543d0, & @@ -88,7 +88,7 @@ subroutine set_ionization_potentials ! data from 97.89d0, & 552.06d0, & 667.03d0 /) - + ! 8 O ip(8,1:8) = (/ & 13.618d0, & @@ -99,7 +99,7 @@ subroutine set_ionization_potentials ! data from 138.12d0, & 739.32d0, & 871.39d0 /) - + ! 9 F ip(9,1:9) = (/ & 17.422d0, & @@ -111,7 +111,7 @@ subroutine set_ionization_potentials ! data from 185.18d0, & 953.89d0, & 1103.1d0 /) - + ! 10 Ne ip(10,1:10) = (/ & 21.564d0, & @@ -124,7 +124,7 @@ subroutine set_ionization_potentials ! data from 239.09d0, & 1195.8d0, & 1362.2d0 /) - + ! 11 Na ip(11,1:11) = (/ & 5.139d0, & @@ -138,7 +138,7 @@ subroutine set_ionization_potentials ! data from 299.9d0, & 1465.1d0, & 1648.7d0 /) - + ! 12 Mg ip(12,1:12) = (/ & 7.646d0, & @@ -153,7 +153,7 @@ subroutine set_ionization_potentials ! data from 367.5d0, & 1761.8d0, & 1963.0d0 /) - + ! 13 Al ip(13,1:13) = (/ & 5.986d0, & @@ -169,7 +169,7 @@ subroutine set_ionization_potentials ! data from 442.0d0, & 2086.0d0, & 2304.0d0 /) - + ! 14 Si ip(14,1:14) = (/ & 8.151d0, & @@ -186,7 +186,7 @@ subroutine set_ionization_potentials ! data from 523.0d0, & 2438.0d0, & 2304.0d0 /) - + ! 15 P ip(15,1:15) = (/ & 10.486d0, & @@ -204,7 +204,7 @@ subroutine set_ionization_potentials ! data from 612.0d0, & 2817.0d0, & 3070.0d0 /) - + ! 16 S ip(16,1:16) = (/ & 10.360d0, & @@ -223,7 +223,7 @@ subroutine set_ionization_potentials ! data from 750.0d0, & 3224.0d0, & 3494.0d0 /) - + ! 17 Cl ip(17,1:17) = (/ & 12.967d0, & @@ -243,7 +243,7 @@ subroutine set_ionization_potentials ! data from 809.0d0, & 3658.0d0, & 3946.0d0 /) - + ! 18 Ar ip(18,1:18) = (/ & 15.759d0, & @@ -264,7 +264,7 @@ subroutine set_ionization_potentials ! data from 918.0d0, & 4121.0d0, & 4426.0d0 /) - + ! 19 K ip(19,1:19) = (/ & 4.341d0, & @@ -286,7 +286,7 @@ subroutine set_ionization_potentials ! data from 1034.0d0, & 4611.0d0, & 4934.0d0 /) - + ! 20 Ca ip(20,1:20) = (/ & 6.113d0, & @@ -309,7 +309,7 @@ subroutine set_ionization_potentials ! data from 1157.0d0, & 5129.0d0, & 5470.0d0 /) - + ! 21 Sc ip(21,1:21) = (/ & 6.54d0, & @@ -333,7 +333,7 @@ subroutine set_ionization_potentials ! data from 1288.0d0, & 5675.0d0, & 6034.0d0 /) - + ! 22 Ti ip(22,1:22) = (/ & 6.82d0, & @@ -358,7 +358,7 @@ subroutine set_ionization_potentials ! data from 1425.0d0, & 6249.0d0, & 6626.0d0 /) - + ! 23 V ip(23,1:23) = (/ & 6.74d0, & @@ -384,7 +384,7 @@ subroutine set_ionization_potentials ! data from 1569.0d0, & 6851.0d0, & 7246.0d0 /) - + ! 24 Cr ip(24,1:24) = (/ & 6.766d0, & @@ -411,7 +411,7 @@ subroutine set_ionization_potentials ! data from 1721.0d0, & 7482.0d0, & 7895.0d0 /) - + ! 25 Mn ip(25,1:25) = (/ & 7.435d0, & @@ -439,7 +439,7 @@ subroutine set_ionization_potentials ! data from 1879.0d0, & 8141.0d0, & 8572.0d0 /) - + ! 26 Fe ip(26,1:26) = (/ & 7.870d0, & @@ -468,7 +468,7 @@ subroutine set_ionization_potentials ! data from 2045.0d0, & 8828.0d0, & 9278.0d0 /) - + ! 27 Co ip(27,1:27) = (/ & 7.86d0, & @@ -498,7 +498,7 @@ subroutine set_ionization_potentials ! data from 2218.0d0, & 9544.0d0, & 10030.0d0 /) - + ! 28 Ni ip(28,1:28) = (/ & 7.635d0, & @@ -529,7 +529,7 @@ subroutine set_ionization_potentials ! data from 2398.0d0, & 10280.0d0, & 10790.0d0 /) - + ! 29 Cu ip(29,1:29) = (/ & 7.726d0, & @@ -561,7 +561,7 @@ subroutine set_ionization_potentials ! data from 2560.0d0, & 11050.0d0, & 1d35 /) - + ! 30 Zn ip(30,1:30) = (/ & 9.394d0, & @@ -594,7 +594,7 @@ subroutine set_ionization_potentials ! data from 2730.0d0, & 1d35, & 1d35 /) - + end subroutine set_ionization_potentials diff --git a/star/private/kap_support.f90 b/star/private/kap_support.f90 index 2031eee4a..8a68fe7ea 100644 --- a/star/private/kap_support.f90 +++ b/star/private/kap_support.f90 @@ -146,7 +146,7 @@ real(dp) function fraction_of_op_mono(s, k) result(beta) else frac = frac_op_mono(s, s% lnd(k)/ln10, s% lnT(k)/ln10) end if - + beta = frac% val end function fraction_of_op_mono @@ -330,7 +330,7 @@ subroutine get_kap( & else beta = frac_op_mono(s, logRho, logT) end if - + if (k > 0 .and. k <= s% nz) s% kap_frac_op_mono(k) = beta % val if (beta > 0d0) then @@ -360,7 +360,7 @@ subroutine get_kap( & nptot = s% op_mono_nptot ipe = s% op_mono_ipe nrad = s% op_mono_nrad - + sz = nptot; offset = thread_num*sz umesh(1:nptot) => s% op_mono_umesh1(offset+1:offset+sz) semesh(1:nptot) => s% op_mono_semesh1(offset+1:offset+sz) @@ -377,16 +377,16 @@ subroutine get_kap( & rs(1:nptot,1:4,1:4) => s% op_mono_rs1(offset+1:offset+sz) sz = nptot*nrad*4*4; offset = thread_num*sz end if - + else - + call load_op_mono_data( & s% op_mono_data_path, s% op_mono_data_cache_filename, ierr) if (ierr /= 0) then write(*,*) 'error while loading OP data, ierr = ',ierr return end if - + call get_op_mono_params(nptot, ipe, nrad) if (s% use_op_mono_alt_get_kap) then allocate( & @@ -398,15 +398,15 @@ subroutine get_kap( & rs(nptot,4,4), stat=ierr) end if if (ierr /= 0) return - + end if - + if (s% solver_test_kap_partials) then kap_test_partials = (k == s% solver_test_partials_k .and. & s% solver_call_number == s% solver_test_partials_call_number .and. & s% solver_iter == s% solver_test_partials_iter_number ) end if - + screening = .true. if (s% use_other_kap) then call s% other_kap_get_op_mono( & @@ -428,7 +428,7 @@ subroutine get_kap( & end if if (.not. associated(s% op_mono_umesh1)) deallocate(umesh, semesh, ff, rs) - + else if (s% op_mono_method == 'mombarg') then fk = 0 if (logT > 3.5 .and. logT < 8.0) then diff --git a/star/private/mass_utils.f90 b/star/private/mass_utils.f90 index 255b42f13..9b2e13001 100644 --- a/star/private/mass_utils.f90 +++ b/star/private/mass_utils.f90 @@ -7,7 +7,7 @@ module mass_utils use const_def use accurate_sum ! Provides the accurate_real type, which enables us to do !sums and differences without much loss of precision. - + implicit none @@ -78,7 +78,7 @@ end function reconstruct_xm ! ! The reason we specify dm's rather than m's is to avoid ! having to subtract large numbers and incur the resultant - ! penalty in precision. + ! penalty in precision. ! ! We require length(dm1) == length(dm2) == nz. ! We permit j and k to range from 1 ... nz+1 inclusive. @@ -92,12 +92,12 @@ end function reconstruct_xm ! to perform this sum accurately. As a preprocessing step we present ! terms to this algorithm with alternating signs and ! descending magnitudes for as long as possible. - ! Hence we actually begin with the + ! Hence we actually begin with the ! ! Sum_{l = nz ... max(j,k)} dm1(l) - dm2(l) () ! ! If j < k we then add Sum_{l=k-1 ... j} dm1(l). - ! If j > k we then subtract Sum_{l=j-1 ... k} dm2(l). + ! If j > k we then subtract Sum_{l=j-1 ... k} dm2(l). ! ! Not currently used, but helpful for debugging. real(qp) function accurate_mass_difference(dm1, dm2, j, k, nz) @@ -117,8 +117,8 @@ real(qp) function accurate_mass_difference(dm1, dm2, j, k, nz) do l=nz,max(j,k),-1 sum = sum + dm1(l) sum = sum - dm2(l) - end do - end if + end do + end if if (j /= k) then do l=max(j,k) - 1,min(j,k),-1 @@ -171,7 +171,7 @@ end function accurate_mass_difference ! overlap (0,1) is non-zero, as is the overlap (nz,nz). Because ! mass is monotonic, the (j,k) with non-zero overlaps form a sequence ! which is monotonic in both j and k. There are at most 2*nz points in - ! such a sequence. To avoid allocating a quadratic amount of memory in nz + ! such a sequence. To avoid allocating a quadratic amount of memory in nz ! we therefore store just 2*nz overlaps. The locations of these overlaps are ! given by j == ranges(:,1), k == ranges(:,2). Some of these j's or k's ! will generally be zero, corresponding to the padding described above. @@ -205,7 +205,7 @@ subroutine make_compressed_intersect(dm1, dm2, nz, mesh_intersects, ranges) ! terminate, because all remaining overlaps will be zero. ! 2. Calculate the overlap between the new cell and the old one on the other side. ! 3. Return to 1. - ! + ! ! Along the way we store overlaps in the order in which we encounter them. ! As discussed in the comments above, we know there will be precisely 2*nz of these. ! The indices of these are stored as ranges(counter,1) = j, ranges(counter,2) = k. @@ -250,7 +250,7 @@ subroutine make_compressed_intersect(dm1, dm2, nz, mesh_intersects, ranges) remainders1(j) = remainders1(j) - dm1(j) remainders2(j) = remainders2(j) - dm1(j) diff = dm2(k) - dm1(j) - end if + end if do while (k > 0 .and. j > 0 .and. ((side == 1 .and. k > 1) .or. (side == 2 .and. j > 1))) if (side == 1) then @@ -313,7 +313,7 @@ subroutine make_compressed_intersect(dm1, dm2, nz, mesh_intersects, ranges) end do - if (j > 1) then + if (j > 1) then do i=j,1,-1 ranges(counter,1) = i ranges(counter,2) = 0 @@ -405,7 +405,7 @@ subroutine prepare_pass_fraction(nz, delta_m, dm, mesh_intersects, ranges, i_min pf(j)%arr(i) = pf(j)%arr(i) + pf(j)%arr(i - 1) end do do i=i_max(j)-1,max(j,i_min(j)),-1 - pf(j)%arr(i) = pf(j)%arr(i) + pf(j)%arr(i + 1) + pf(j)%arr(i) = pf(j)%arr(i) + pf(j)%arr(i + 1) end do end do diff --git a/star/private/mesh_adjust.f90 b/star/private/mesh_adjust.f90 index 60661cce5..4310e1e99 100644 --- a/star/private/mesh_adjust.f90 +++ b/star/private/mesh_adjust.f90 @@ -250,12 +250,12 @@ subroutine do_mesh_adjust( & if (failed('D_omega')) return end if end if - + call do_interp_pt_val( & s, nz, nz_old, nzlo, nzhi, s% mlt_vc, mlt_vc_old, & 0d0, xq, xq_old_plus1, xq_new, .true., work, tmp1, tmp2, ierr) if (failed('mlt_cv')) return - + call do_interp_pt_val( & s, nz, nz_old, nzlo, nzhi, s% D_mix, D_mix_old, & 0d0, xq, xq_old_plus1, xq_new, .true., work, tmp1, tmp2, ierr) @@ -442,7 +442,7 @@ subroutine do_alloc(ierr) dqbar(sz), dqbar_old(sz), new_r(sz), Vol_new(sz), xq_old_plus1(sz), & xout_old(sz), xout_new(sz), xq_new(sz), energy_new(sz), density_new(sz), & tmp1(sz), tmp2(sz), tmp3(sz), tmp4(sz), tmp5(sz), tmp6(sz), tmp7(sz), & - xa_c0(sz,species), xa_c1(sz,species), xa_c2(sz,species)) + xa_c0(sz,species), xa_c1(sz,species), xa_c2(sz,species)) end subroutine do_alloc subroutine dealloc @@ -941,7 +941,7 @@ subroutine do_interp_cell_val( & call dealloc contains - + subroutine do_alloc(ierr) integer, intent(out) :: ierr call do_work_arrays(.true.,ierr) @@ -1186,7 +1186,7 @@ subroutine do_lnR_and_lnd( & end if if (density_new(k) == old_rho(from_k)) then xh(s%i_lnd,k) = xh_old(s%i_lnd,from_k) - else + else call store_rho_in_xh(s,k,density_new(k),xh) end if end do @@ -1434,11 +1434,11 @@ subroutine do1_lnT( & end if avg_energy = sum_energy/cell_dq end if - + if (s% max_rel_delta_IE_for_mesh_total_energy_balance == 0d0) then - + energy_new(k) = avg_energy - + else if (cell_type(k) == revised_type) then @@ -1468,7 +1468,7 @@ subroutine do1_lnT( & end if avg_KE = sum_energy/cell_dq end if - + if (ierr /= 0) return new_PE = cell_specific_PE(s,k,d_dlnR00,d_dlnRp1) if (s% u_flag) then @@ -1485,12 +1485,12 @@ subroutine do1_lnT( & delta_energy = sign(max_delta_energy,delta_energy) end if energy_new(k) = avg_energy + delta_energy - + if (energy_new(k) <= 0d0) then write(*,2) 'energy_new(k) <= 0d0', k, energy_new(k), avg_energy energy_new(k) = avg_energy end if - + end if ! call eos to calculate lnT from new internal energy @@ -1507,7 +1507,7 @@ subroutine do1_lnT( & energy_new(k) = energy_old(k_old) ierr = 0 end if - + call store_lnT_in_xh(s, k, new_lnT, xh) if (ierr /= 0) then @@ -1555,7 +1555,7 @@ subroutine get_old_integral( & if (dbg) write(*,*) ierr = 0 - + k_old = k_old_in ! move starting k_old if necessary do @@ -1606,8 +1606,8 @@ subroutine get_old_integral( & if (xq_inner <= old_xq_inner) then - if (dbg) write(*,1) 'last part of the new range' - + if (dbg) write(*,1) 'last part of the new range' + integral = integral + val*(dq_range - sum_dqs) sum_dqs = dq_range @@ -1644,8 +1644,8 @@ subroutine set_lnT_for_energy( & s, k, h1, he3, he4, species, xa, 1d-11, & Rho, logRho, energy, lnT_guess, lnT, result_energy, ierr) end subroutine set_lnT_for_energy - - + + subroutine set_lnT_for_energy_with_tol( & s, k, h1, he3, he4, species, xa, tol, & Rho, logRho, energy, lnT_guess, lnT, result_energy, ierr) @@ -1678,7 +1678,7 @@ subroutine set_lnT_for_energy_with_tol( & d_dxa, & ierr) lnT = logT*ln10 - + result_energy = exp(res(i_lnE)) if (ierr /= 0 .or. is_bad_num(lnT)) then @@ -2670,7 +2670,7 @@ subroutine do_Hp_face( & end subroutine do_Hp_face - + subroutine do_etrb( & ! same logic as do_u s, nz, nz_old, cell_type, comes_from, & old_xq, new_xq, old_dq, new_dq, xh, xh_old, & diff --git a/star/private/mesh_functions.f90 b/star/private/mesh_functions.f90 index 76a19c52a..69b838180 100644 --- a/star/private/mesh_functions.f90 +++ b/star/private/mesh_functions.f90 @@ -309,7 +309,7 @@ subroutine do_conv_bdy(i) do k=2,nz vals(k,i) = vals(k,i) + vals(k-1,i) end do - + end subroutine do_conv_bdy subroutine do1_xa_function(k,i) diff --git a/star/private/mesh_plan.f90 b/star/private/mesh_plan.f90 index d0ef6d420..d8c19a5cf 100644 --- a/star/private/mesh_plan.f90 +++ b/star/private/mesh_plan.f90 @@ -93,15 +93,15 @@ subroutine do_mesh_plan( & include 'formats' ierr = 0 - + min_dq = min_dq_in - + if (max_k_old_for_split_in < 0) then max_k_old_for_split = nz_old + max_k_old_for_split_in else max_k_old_for_split = max_k_old_for_split_in end if - + if (min_k_old_for_split_in < 0) then min_k_old_for_split = nz_old + min_k_old_for_split_in else @@ -164,7 +164,7 @@ subroutine do_mesh_plan( & call pick_new_points(s, ierr) if (ierr /= 0) return - + if (min_k_old_for_split <= 1) then do while (dq_new(1) > max(max_surface_cell_dq,2*min_dq,min_dq_for_split)) call split1(1, ierr) @@ -648,14 +648,14 @@ subroutine pick_new_points(s, ierr) write(*,'(A)') write(*,3) 'call pick_next_dq', k_old, k_new, next_dq_max end if - + if (s% gradr(k_old) > s% grada(k_old) .and. & s% min_dq_for_xa_convective > 0d0) then min_dq_for_xa = s% min_dq_for_xa_convective else min_dq_for_xa = s% min_dq_for_xa end if - + min_dq_for_logT = s% min_dq_for_logT next_dq = pick_next_dq(s, & @@ -723,14 +723,14 @@ subroutine pick_new_points(s, ierr) next_dq > dq_old(k_old) - min_dq/2) then if (.not. okay_to_merge) then - + k_old_next = k_old + 1 - + else if (k_old < min_k_old_for_split .or. & k_old > max_k_old_for_split) then - + k_old_next = k_old + 1 - + else ! consider doing merge if (next_dq > 1.5d0*dq_old(k_old)) then @@ -1012,7 +1012,7 @@ real(dp) function pick_next_dq(s, & end do return end if - + default = pick_next_dq ! default size. can be reduced according to gradients of gvals do j=1,num_gvals nxt_dqs(j) = pick1_dq(s, & @@ -1182,10 +1182,10 @@ real(dp) function pick1_dq(s, & write(*,1) 'default', default end if pick1_dq = max(min_dq, sz, xq - xq_new(k_new)) - + if (is_xa_function .and. pick1_dq < min_dq_for_xa) & pick1_dq = min_dq_for_xa - + if (is_logT_function .and. pick1_dq < min_dq_for_logT) & pick1_dq = min_dq_for_logT diff --git a/star/private/mix_info.f90 b/star/private/mix_info.f90 index b81b7d11d..efee98aa1 100644 --- a/star/private/mix_info.f90 +++ b/star/private/mix_info.f90 @@ -70,13 +70,13 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) ierr = 0 nz = s% nz - + min_conv_vel_for_convective_mixing_type = 1d0 ! make this a control parameter - + RSP2_or_RSP = s% RSP_flag .or. s% RSP2_flag if (s% doing_timing) call start_time(s, time0, total) - + if (s% RTI_flag) then call set_RTI_mixing_info(s, ierr) if (failed('set_RTI_mixing_info')) return @@ -104,13 +104,13 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) if (.not. associated(s% burn_z_mix_region)) allocate(s% burn_z_mix_region(max_mix_bdy)) allocate(eps_h(nz), eps_he(nz), eps_z(nz), cdc_factor(nz)) - + if (.not. RSP2_or_RSP) then do k = 1, nz s% mixing_type(k) = s% mlt_mixing_type(k) end do end if - + cdc_factor(1) = 1d0 do k = 2, nz rho_face = (s% dq(k-1)*s% rho(k) + s% dq(k)*s% rho(k-1))/& @@ -118,7 +118,7 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) f = pi4*s% r(k)*s% r(k)*rho_face cdc_factor(k) = f*f end do - + if (s% RSP_flag) then do k = 1, nz s% mixing_type(k) = no_mixing @@ -149,9 +149,9 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) s% conv_vel(k) = s% mlt_vc(k) end do end if - + call check('after get mlt_D') - + if (s% remove_mixing_glitches .and. .not. RSP2_or_RSP) then call remove_tiny_mixing(s, ierr) @@ -176,7 +176,7 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) if (failed('remove_embedded_semiconvection')) return end if - + call check('after get remove_mixing_glitches') call do_mix_envelope(s) @@ -187,7 +187,7 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) eps_he(k) = s% eps_nuc_categories(i3alf,k) eps_z(k) = s% eps_nuc(k) - (eps_h(k) + eps_he(k)) end do - + if (.not. s% RSP_flag) then call set_cz_boundary_info(s, ierr) @@ -197,12 +197,12 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) s, nz, eps_h, eps_he, eps_z, s% mstar, & s% q, s% cdc, ierr) if (failed('locate_convection_boundaries')) return - + call add_predictive_mixing(s, ierr) if (failed('add_predictive_mixing')) return - + end if - + call check('after add_predictive_mixing') ! NB: re-call locate_convection_boundries to take into @@ -217,12 +217,12 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) call locate_mixing_boundaries(s, eps_h, eps_he, eps_z, ierr) if (failed('locate_mixing_boundaries')) return - + call add_overshooting(s, ierr) if (failed('add_overshooting')) return - + end if - + call check('after add_overshooting') call add_RTI_turbulence(s, ierr) @@ -279,7 +279,7 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) do k=1,nz s% D_mix_non_rotation(k) = s% D_mix(k) end do - + call check('before rotation_flag') if (s% rotation_flag) then @@ -297,12 +297,12 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) s% cdc(1) = s% cdc(2) end if - + call check('after update_rotation_mixing_info') - + region_bottom_q = s% D_mix_zero_region_bottom_q region_top_q = s% D_mix_zero_region_top_q - + if (s% dq_D_mix_zero_at_H_He_crossover > 0d0) then i_h1 = s% net_iso(ih1) i_he4 = s% net_iso(ihe4) @@ -319,7 +319,7 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) end do end if end if - + if (region_bottom_q < region_top_q) then do k=2,nz if (s% q(k) >= region_bottom_q .and. s% q(k) <= region_top_q) then @@ -328,7 +328,7 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) end if end do end if - + region_bottom_q = 1d99 region_top_q = -1d99 if (s% dq_D_mix_zero_at_H_C_crossover > 0d0) then @@ -347,7 +347,7 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) end do end if end if - + if (region_bottom_q < region_top_q) then do k=2,nz if (s% q(k) >= region_bottom_q .and. s% q(k) <= region_top_q) then @@ -356,7 +356,7 @@ subroutine set_mixing_info(s, skip_set_cz_bdy_mass, ierr) end if end do end if - + ! as last thing, update conv_vel from D_mix and mixing length. do k=2,nz if (s% alpha_mlt(k)*s% scale_height(k) > 0) then @@ -511,7 +511,7 @@ subroutine set_cz_bdy_mass(s, ierr) if (in_convective_region) then s% cz_top_mass(s% n_conv_regions) = s% mstar end if - + s% have_new_cz_bdy_info = .true. if (dbg) then @@ -714,7 +714,7 @@ subroutine end_of_convective_region() end if end do if (max_logT > s% burn_z_mix_region_logT & - .and. max_Y < s% max_Y_for_burn_z_mix_region) then + .and. max_Y < s% max_Y_for_burn_z_mix_region) then s% burn_z_conv_region(i) = .true. if (i > 1) s% burn_z_conv_region(i-1) = .true. !write(*,*) 'burn z mix region', i, & @@ -849,7 +849,7 @@ subroutine locate_mixing_boundaries(s, eps_h, eps_he, eps_z, ierr) call end_of_mixing_region end if - + !do i=1,s% num_conv_boundaries ! write(*,*) 'locate_mixing_boundaries region burn_h he z', i, & ! s% burn_h_mix_region(i), s% burn_he_conv_region(i), s% burn_z_conv_region(i) @@ -894,7 +894,7 @@ subroutine end_of_mixing_region() end if end do if (max_logT > s% burn_z_mix_region_logT & - .and. max_Y < s% max_Y_for_burn_z_mix_region) then + .and. max_Y < s% max_Y_for_burn_z_mix_region) then s% burn_z_mix_region(i) = .true. if (i > 1) s% burn_z_mix_region(i-1) = .true. !write(*,*) 'burn z mix region', i @@ -1585,7 +1585,7 @@ subroutine update_rotation_mixing_info(s, ierr) write(*,*) 'update_rotation_mixing_info failed in call to set_rotation_mixing_info' return end if - + call check('after set_rotation_mixing_info') if (s% D_omega_flag) call check_D_omega('check_D_omega after set_rotation_mixing_info') @@ -1616,7 +1616,7 @@ subroutine update_rotation_mixing_info(s, ierr) end if s% D_mix(k) = s% D_mix_non_rotation(k) + s% D_mix_rotation(k) end do - + call check('after include rotation part for mixing abundances') am_nu_DSI_factor = s% am_nu_DSI_factor @@ -1626,7 +1626,7 @@ subroutine update_rotation_mixing_info(s, ierr) am_nu_GSF_factor = s% am_nu_GSF_factor am_nu_ST_factor = s% am_nu_ST_factor am_nu_visc_factor = s% am_nu_visc_factor - + if ((.not. s% am_nu_rot_flag) .and. & (s% D_omega_flag .and. .not. s% job% use_D_omega_for_am_nu_rot)) then ! check for any am_nu factors > 0 and not same as for D_omega @@ -1646,7 +1646,7 @@ subroutine update_rotation_mixing_info(s, ierr) return end if end if - + ! If am_nu_..._factor < -1, use the D_..._factor if (am_nu_DSI_factor < 0) am_nu_DSI_factor = s% D_DSI_factor if (am_nu_SH_factor < 0) am_nu_SH_factor = s% D_SH_factor @@ -1719,7 +1719,7 @@ subroutine update_rotation_mixing_info(s, ierr) call s% other_am_mixing(s% id, ierr) if (ierr /= 0) return end if - + contains subroutine check(str) @@ -1774,7 +1774,7 @@ subroutine check_D_omega(str) end if end do end subroutine check_D_omega - + subroutine set_am_nu_rot(ierr) use alloc use rotation_mix_info, only: smooth_for_rotation @@ -1784,17 +1784,17 @@ subroutine set_am_nu_rot(ierr) dt, rate, d_ddt_dm1, d_ddt_d00, d_ddt_dp1, m, & d_dt, d_dt_in, d_dt_out, am_nu_rot_source include 'formats' - + ierr = 0 nz = s% nz dt = s% dt - + if (s% am_nu_rot_flag .and. s% doing_finish_load_model) then do k=1,nz s% am_nu_rot(k) = 0d0 end do else if (s% am_nu_rot_flag) then - + do k=1,nz if (s% q(k) <= s% max_q_for_nu_omega_zero_in_convection_region .and. & s% mixing_type(k) == convective_mixing) then @@ -1820,18 +1820,18 @@ subroutine set_am_nu_rot(ierr) call mesa_error(__FILE__,__LINE__,'set am_nu_rot') end if end do - + if (s% smooth_am_nu_rot > 0 .or. & (s% nu_omega_mixing_rate > 0d0 .and. s% dt > 0)) then - + allocate(sig(nz), rhs(nz), d(nz), du(nz), dl(nz), bp(nz), vp(nz), xp(nz), x(nz)) if (s% smooth_am_nu_rot > 0) then call smooth_for_rotation(s, s% am_nu_rot, s% smooth_am_nu_rot, sig) end if - + if (s% nu_omega_mixing_rate > 0d0 .and. s% dt > 0) then ! mix am_nu_rot - + rate = min(s% nu_omega_mixing_rate, 1d0/dt) do k=2,nz-1 if (s% am_nu_rot(k) == 0 .or. s% am_nu_rot(k+1) == 0) then @@ -1843,11 +1843,11 @@ subroutine set_am_nu_rot(ierr) sig(k) = 0 else sig(k) = rate*dt - end if + end if end do sig(1) = 0 sig(nz) = 0 - + do k=1,nz if (k < nz) then d_dt_in = sig(k)*(s% am_nu_rot(k+1) - s% am_nu_rot(k)) @@ -1872,10 +1872,10 @@ subroutine set_am_nu_rot(ierr) else du(k) = 0 end if - if (k > 1) dl(k-1) = -d_ddt_dm1 + if (k > 1) dl(k-1) = -d_ddt_dm1 end do dl(nz) = 0 - + ! solve tridiagonal bp(1) = d(1) vp(1) = rhs(1) @@ -1896,7 +1896,7 @@ subroutine set_am_nu_rot(ierr) xp(i) = (vp(i) - du(i)*xp(i+1))/bp(i) x(i) = xp(i) end do - + do k=2,nz if (is_bad(x(k))) then return @@ -1905,7 +1905,7 @@ subroutine set_am_nu_rot(ierr) call mesa_error(__FILE__,__LINE__,'mix_am_nu_rot') end if end do - + ! update am_nu_rot do k=2,nz s% am_nu_rot(k) = s% am_nu_rot(k) + x(k) @@ -1916,13 +1916,13 @@ subroutine set_am_nu_rot(ierr) if (s% am_nu_rot(k) < 0d0) s% am_nu_rot(k) = 0d0 end do s% am_nu_rot(1) = 0d0 - + end if end if - + end if - + if (s% am_nu_rot_flag) then ! check do k=1,nz if (is_bad(s% am_nu_rot(k))) then @@ -1931,8 +1931,8 @@ subroutine set_am_nu_rot(ierr) end if if (s% am_nu_rot(k) < 0d0) s% am_nu_rot(k) = 0d0 end do - end if - + end if + end subroutine set_am_nu_rot end subroutine update_rotation_mixing_info @@ -1952,7 +1952,7 @@ subroutine set_RTI_mixing_info(s, ierr) include 'formats' ierr = 0 if (.not. s% RTI_flag) return - + nz = s% nz s% eta_RTI(1:nz) = 0d0 @@ -1962,9 +1962,9 @@ subroutine set_RTI_mixing_info(s, ierr) s% sigmid_RTI(1:nz) = 0d0 if (s% RTI_C <= 0d0) return - + i_h1 = s% net_iso(ih1) - + shock_mass_start = 1d99 do k = 1, nz if (s% u_flag) then @@ -1977,21 +1977,21 @@ subroutine set_RTI_mixing_info(s, ierr) exit end if end do - - min_dm = s% RTI_min_dm_behind_shock_for_full_on*Msun + + min_dm = s% RTI_min_dm_behind_shock_for_full_on*Msun log_max_boost = s% RTI_log_max_boost max_boost = exp10(log_max_boost) m_full_boost = s% RTI_m_full_boost*Msun m_no_boost = s% RTI_m_no_boost*Msun - + min_eta = -1d0 dm_for_center_eta_nondecreasing = Msun*s% RTI_dm_for_center_eta_nondecreasing - + do k=1,nz - + f = max(0d0, s% X(k) - s% RTI_C_X0_frac*s% surface_h1) C = s% RTI_C*(1d0 + f*f*s% RTI_C_X_factor) - + if (s% m(k) < m_no_boost) then if (s% m(k) <= m_full_boost) then C = C*max_boost @@ -2020,7 +2020,7 @@ subroutine set_RTI_mixing_info(s, ierr) call mesa_error(__FILE__,__LINE__,'set_RTI_mixing_info') end if end if - + if (s% m(k) - s% M_center <= dm_for_center_eta_nondecreasing) then if (min_eta < 0d0) then min_eta = s% eta_RTI(k) @@ -2030,24 +2030,24 @@ subroutine set_RTI_mixing_info(s, ierr) end if end if - + s% etamid_RTI(k) = max(min_eta, C*s% alpha_RTI(k)*s% csound(k)*s% rmid(k)) s% boost_for_eta_RTI(k) = C/s% RTI_C - + if (is_bad(s% etamid_RTI(k))) then ierr = -1 return end if end do - + call get_shock_info(s) ! sig_RTI(k) is mixing flow across face k in (gm sec^1) call get_RTI_sigmas(s, s% sig_RTI, s% eta_RTI, & s% rho_face, s% r, s% dm_bar, s% dt, ierr) if (ierr /= 0) return - + if (s% v_flag) then ! sigmid_RTI(k) is mixing flow at center k in (gm sec^1) call get_RTI_sigmas(s, s% sigmid_RTI, s% etamid_RTI, & @@ -2125,7 +2125,7 @@ subroutine set_dPdr_dRhodr_info(s, ierr) end if nz = s% nz - + allocate(dPdr(nz), drhodr(nz), P_face(nz), rho_face(nz)) do k=2,nz @@ -2154,7 +2154,7 @@ subroutine set_dPdr_dRhodr_info(s, ierr) dr_m1 = s% r(k-1) - s% r(k) dr_00 = s% r(k) - s% r(k+1) dPdr(k) = slope_limit(P_face, k, dr_m1, dr_00) - drhodr(k) = slope_limit(rho_face, k, dr_m1, dr_00) + drhodr(k) = slope_limit(rho_face, k, dr_m1, dr_00) else !dr_00 = s% r(k) - s% r(k+1) rmid = 0.5d0*(s% r(k) + s% r(k+1)) diff --git a/star/private/mod_typical_charge.f90 b/star/private/mod_typical_charge.f90 index 6fbee90e9..66c6fb22b 100644 --- a/star/private/mod_typical_charge.f90 +++ b/star/private/mod_typical_charge.f90 @@ -29,10 +29,10 @@ module mod_typical_charge use math_lib implicit none - + logical, parameter :: dbg = .false. - + contains @@ -51,9 +51,9 @@ module mod_typical_charge ! uses ionization potentials from ! Allen, C.W., 1973, "Astrophysical Quantities", 3rd edition, pg 37-38. - + ! tables go from H to Zn. - + ! the routine is written so that it doesn't ever return 0 as a typical charge. ! these are "typical" charges rather than average. the values are whole numbers. @@ -61,15 +61,15 @@ real(dp) function eval_typical_charge( & cid, abar, free_e, T, log10_T, rho, log10_rho) integer, intent(in) :: cid ! chem id such as ihe4. defined in chem_def. real(dp), intent(in) :: abar ! average atomic weight (from chem_lib) - real(dp), intent(in) :: free_e + real(dp), intent(in) :: free_e ! mean number of free electrons per nucleon (from eos_lib) ! abar*free_e = (nucleons/particle)*(charge/nucleon) = charge/particle = z1 real(dp), intent(in) :: T, log10_T, rho, log10_rho eval_typical_charge = get_typical_charge( & - cid, abar, abar*free_e, T, log10_T, rho, log10_rho) + cid, abar, abar*free_e, T, log10_T, rho, log10_rho) end function eval_typical_charge - + subroutine chi_info(a1, z1, T, log_T, rho, log_rho, chi, c0, c1, c2) real(dp), intent(in) :: a1, z1, T, log_T, rho, log_rho real(dp), intent(out) :: chi, c0, c1, c2 @@ -80,18 +80,18 @@ subroutine chi_info(a1, z1, T, log_T, rho, log_rho, chi, c0, c1, c2) c2 = 29.38d0*z1*pow(rho/a1,one_third) ! c2 had a typo in eqn 21, now corrected to match Dupuis et al. (1992) eqn 3 end subroutine chi_info - + real(dp) function chi_effective(chi, c0, c1, c2, z1, z2) real(dp), intent(in) :: chi, c0, c1, c2, z1, z2 chi_effective = chi + c0/(z2*z2*z2) + & min(c1*z2, c2*(pow(z2/z1,two_thirds) + 0.6d0)) end function chi_effective - + real(dp) function get_typical_charge(cid, a1, z1, T, log_T, rho, log_rho) use ionization_potentials use chem_def integer, intent(in) :: cid - real(dp), intent(in) :: a1, z1, T, log_T, rho, log_rho + real(dp), intent(in) :: a1, z1, T, log_T, rho, log_rho real(dp) :: chi, c0, c1, c2, z2, chi_eff integer :: i, izmax include 'formats' @@ -112,8 +112,8 @@ real(dp) function get_typical_charge(cid, a1, z1, T, log_T, rho, log_rho) end if end do end function get_typical_charge - - + + diff --git a/star/private/net.f90 b/star/private/net.f90 index 96304dcbc..943f01859 100644 --- a/star/private/net.f90 +++ b/star/private/net.f90 @@ -96,7 +96,7 @@ subroutine do_net(s, nzlo, nzhi, ierr) end if check_op_split_burn = s% op_split_burn - + if (nzlo == nzhi) then call do1_net(s, nzlo, s% species, & s% num_reactions, & @@ -169,7 +169,7 @@ subroutine do1_net(s, k, species, & n% star_id = s% id n% zone = k - + s% eps_nuc(k) = 0d0 s% d_epsnuc_dlnd(k) = 0d0 s% d_epsnuc_dlnT(k) = 0d0 @@ -189,7 +189,7 @@ subroutine do1_net(s, k, species, & log10_rho = s% lnd(k)/ln10 log10_T = s% lnT(k)/ln10 T = s% T(k) - + clipped_T = (s% max_logT_for_net > 0 .and. log10_T > s% max_logT_for_net) if (clipped_T) then log10_T = s% max_logT_for_net @@ -218,7 +218,7 @@ subroutine do1_net(s, k, species, & s% solver_call_number == s% solver_test_partials_call_number .and. & s% solver_iter == s% solver_test_partials_iter_number) ! if the test is for a partial wrt an abundance, do this - ! in inlist set solver_test_partials_var_name and solver_test_partials_sink_name + ! in inlist set solver_test_partials_var_name and solver_test_partials_sink_name ! set solver_test_partials_equ_name = '' i_var = lookup_nameofvar(s, s% solver_test_partials_var_name) i_var_sink = lookup_nameofvar(s, s% solver_test_partials_sink_name) @@ -231,7 +231,7 @@ subroutine do1_net(s, k, species, & net_test_partials_i = i_var - s% nvar_hydro ! index in xa for var net_test_partials_iother = i_var_sink - s% nvar_hydro ! index in xa for var end if - + if (s% use_other_net_get) then call s% other_net_get( & s% id, k, & @@ -289,14 +289,14 @@ subroutine do1_net(s, k, species, & write(*,2) trim(s% net_name), s% species call mesa_error(__FILE__,__LINE__,'after net_get in star') end if - + if (s% solver_test_net_partials .and. net_test_partials) then s% solver_test_partials_val = net_test_partials_val s% solver_test_partials_dval_dx = net_test_partials_dval_dx end if - + if (ierr == 0) then - + if (clipped_T) then d_eps_nuc_dT = 0 s% d_dxdt_nuc_dT(1:species,k) = 0 @@ -311,14 +311,14 @@ subroutine do1_net(s, k, species, & tau_gamma = tau_gamma*s% nonlocal_NiCo_kap_gamma s% eps_nuc(k) = s% eps_nuc(k)*(1d0 - exp(-tau_gamma)) end if - + if (abs(s% eps_nuc(k)) > s% max_abs_eps_nuc) then s% eps_nuc(k) = sign(s% max_abs_eps_nuc, s% eps_nuc(k)) d_eps_nuc_dRho = 0d0 d_eps_nuc_dT = 0d0 s% d_epsnuc_dx(:,k) = 0d0 end if - + eps_cat_sum = sum(s% eps_nuc_categories(:,k)) if (abs(eps_cat_sum) < 1d-10) then alfa = 1d0 @@ -392,7 +392,7 @@ subroutine do1_net(s, k, species, & if (s% stop_for_bad_nums) call mesa_error(__FILE__,__LINE__,'do1_net') return end if - + if (k == -1) then write(*,'(A)') call show_stuff(s,k) @@ -402,7 +402,7 @@ subroutine do1_net(s, k, species, & write(*,5) 'eps_nuc', k, s% solver_iter, s% model_number, s% solver_adjust_iter, & s% eps_nuc(k) end if - + if (.false.) then write(*,'(A)') call show_stuff(s,k) @@ -531,7 +531,7 @@ subroutine show_stuff(s,k) trim(chem_isos% name(s% chem_id(j))) // '))= ', s% xa(j,k) end do end if - + if (.false.) then do i=1,species write(*,'(a,i3,a,d26.16)') 'values_for_Xinit(', i, ')= ', s% xa(i,k) @@ -658,7 +658,7 @@ subroutine set_net(s, new_net_name, ierr) write(*,*) 'set_net failed in get_net_iso_table_ptr' return end if - + if (s% net_iso(ih1) == 0 .or. s% net_iso(ihe4) == 0) then write(*,*) 'mesa/star requires both h1 and he4 in net isotopes' write(*,*) 'but they are not included in ' // trim(new_net_name) @@ -687,7 +687,7 @@ subroutine set_net(s, new_net_name, ierr) end if s% net_rq% use_3a_fl87 = s% job% use_3a_fl87 - + s% need_to_setvars = .true. s% net_rq% fill_arrays_with_nans = s% fill_arrays_with_NaNs diff --git a/star/private/overshoot.f90 b/star/private/overshoot.f90 index 3b4c645df..d0de6a2d7 100644 --- a/star/private/overshoot.f90 +++ b/star/private/overshoot.f90 @@ -34,7 +34,7 @@ module overshoot use overshoot_utils use overshoot_exp use overshoot_step - + ! No implicit typing implicit none @@ -125,7 +125,7 @@ subroutine add_overshooting (s, ierr) match_zone_type = .NOT. ( & s%burn_h_conv_region(i) .OR. & s%burn_he_conv_region(i) .OR. & - s%burn_z_conv_region(i) ) + s%burn_z_conv_region(i) ) case ('any') match_zone_type = .true. case default @@ -212,7 +212,7 @@ subroutine add_overshooting (s, ierr) ! Check if the overshoot will be stabilized by the stratification if (s%overshoot_brunt_B_max > 0._dp .and. s% calculate_Brunt_B) then - + if (.not. s% calculate_Brunt_N2) & call mesa_error(__FILE__,__LINE__,'add_overshooting: when overshoot_brunt_B_max > 0, must have calculate_Brunt_N2 = .true.') @@ -233,7 +233,7 @@ subroutine add_overshooting (s, ierr) if (D(k) < s%overshoot_D_min) then ! Update conv_bdy_dq to reflect where D drops below the minimum - ! Convective regions can happen to be entirely below s%overshoot_D_min, + ! Convective regions can happen to be entirely below s%overshoot_D_min, ! in which case we ignore this correction. if (s%top_conv_bdy(i)) then if (s%D_mix(k+1) > s%overshoot_D_min) then @@ -277,7 +277,7 @@ subroutine add_overshooting (s, ierr) else rho = s%rho(k) endif - + cdc = (pi4*s%r(k)*s%r(k)*rho)*(pi4*s%r(k)*s%r(k)*rho)*D(k) ! gm^2/sec call eval_conv_bdy_r(s, i, r_cb, ierr) @@ -310,7 +310,7 @@ subroutine add_overshooting (s, ierr) s%D_mix(k:k_cb:dk) = 0._dp s%conv_vel(k:k_cb:dk) = 0._dp s%mixing_type(k:k_cb:dk) = no_mixing - + ! Finish (we apply at most a single overshoot scheme to each boundary) exit criteria_loop diff --git a/star/private/overshoot_exp.f90 b/star/private/overshoot_exp.f90 index 75d5b5d11..2ea2a3898 100644 --- a/star/private/overshoot_exp.f90 +++ b/star/private/overshoot_exp.f90 @@ -174,7 +174,7 @@ subroutine eval_overshoot_exp (s, i, j, k_a, k_b, D, vc, ierr) k_b = k exit face_loop endif - + end do face_loop if (DEBUG) then diff --git a/star/private/overshoot_step.f90 b/star/private/overshoot_step.f90 index b9f54c0c5..8e1f7bd38 100644 --- a/star/private/overshoot_step.f90 +++ b/star/private/overshoot_step.f90 @@ -166,7 +166,7 @@ subroutine eval_overshoot_step (s, i, j, k_a, k_b, D, vc, ierr) k_b = k exit face_loop endif - + end do face_loop ! Finish diff --git a/star/private/overshoot_utils.f90 b/star/private/overshoot_utils.f90 index 98298f5da..4994b876b 100644 --- a/star/private/overshoot_utils.f90 +++ b/star/private/overshoot_utils.f90 @@ -37,7 +37,7 @@ module overshoot_utils ! Access specifiers private - + public :: eval_conv_bdy_k public :: eval_conv_bdy_r public :: eval_conv_bdy_Hp @@ -58,7 +58,7 @@ subroutine eval_conv_bdy_k (s, i, k, ierr) ! boundary ierr = 0 - + if (s%top_conv_bdy(i)) then k = s%conv_bdy_loc(i) else @@ -229,7 +229,7 @@ subroutine eval_conv_bdy_Hp (s, i, Hp, ierr) endif endif - + dr = r_top - r_bot ! Apply the limit @@ -339,7 +339,7 @@ subroutine eval_over_bdy_params (s, i, f0, k, r, D, vc, ierr) end if ! Interpolate mixing parameters - + w = (s%r(k)*s%r(k)*s%r(k) - r*r*r)/ & (s%r(k)*s%r(k)*s%r(k) - s%r(k+1)*s%r(k+1)*s%r(k+1)) diff --git a/star/private/paquette_coeffs.f90 b/star/private/paquette_coeffs.f90 index d6738d11f..b9a5da436 100644 --- a/star/private/paquette_coeffs.f90 +++ b/star/private/paquette_coeffs.f90 @@ -6,7 +6,7 @@ module paquette_coeffs implicit none private - + public :: paquette_coefficients public :: initialise_collision_integrals public :: free_collision_integrals @@ -674,7 +674,7 @@ subroutine initialise_collision_integrals !$omp end critical (collision_integrals) end subroutine initialise_collision_integrals - + subroutine free_collision_integrals !$omp critical (collision_integrals_shutdown) @@ -700,5 +700,5 @@ subroutine free_collision_integrals !$omp end critical (collision_integrals_shutdown) end subroutine free_collision_integrals - + end module paquette_coeffs diff --git a/star/private/pgstar_abundance.f90 b/star/private/pgstar_abundance.f90 index f3d52cce3..f0cebd4df 100644 --- a/star/private/pgstar_abundance.f90 +++ b/star/private/pgstar_abundance.f90 @@ -174,7 +174,7 @@ subroutine plot(ierr) end if num_labels = max(0,min(max_num_labels, s% pg% num_abundance_line_labels)) - + iloc_abundance_label = -HUGE(grid_min) xloc_abundance_label = -HUGE(grid_min) do i=1,num_labels @@ -238,7 +238,7 @@ subroutine plot(ierr) end if call pgunsa - + if (s% pg% Abundance_show_photosphere_location .and. & (xaxis_name == 'mass' .or. & xaxis_name == 'logxm' .or. & @@ -271,7 +271,7 @@ subroutine plot(ierr) call pgdraw(dx, 1.0) call pgunsa end if - + call show_pgstar_decorator(s%id,s% pg% Abundance_use_decorator,s% pg% Abundance_pgstar_decorator,0, ierr) end subroutine plot diff --git a/star/private/pgstar_color_magnitude.f90 b/star/private/pgstar_color_magnitude.f90 index 307093df6..524cd6653 100644 --- a/star/private/pgstar_color_magnitude.f90 +++ b/star/private/pgstar_color_magnitude.f90 @@ -864,7 +864,7 @@ subroutine do_Color_Magnitude_plot( & end if call pgsci(1) - + call show_pgstar_decorator(s%id,color_use_decorator,color_pgstar_decorator, j, ierr) end do @@ -876,11 +876,11 @@ subroutine do_Color_Magnitude_plot( & end if call pgunsa - + call dealloc contains - + subroutine dealloc deallocate(xvec, yvec, other_yvec, yvec1, yvec2, other_yvec1, other_yvec2) end subroutine dealloc diff --git a/star/private/pgstar_ctrls_io.f90 b/star/private/pgstar_ctrls_io.f90 index b343bea73..8ab623e2a 100644 --- a/star/private/pgstar_ctrls_io.f90 +++ b/star/private/pgstar_ctrls_io.f90 @@ -716,7 +716,7 @@ module pgstar_ctrls_io logg_Teff_file_width, & logg_Teff_file_aspect_ratio, & logg_Teff_use_decorator, & - + logL_Teff_win_flag, & logL_Teff_file_flag, & show_logL_Teff_target_box, & @@ -753,7 +753,7 @@ module pgstar_ctrls_io logL_Teff_file_width, & logL_Teff_file_aspect_ratio, & logL_Teff_use_decorator, & - + logL_R_win_flag, & logL_R_file_flag, & show_logL_R_target_box, & @@ -1245,7 +1245,7 @@ module pgstar_ctrls_io History_Track2_txt_scale, & History_Track2_title, & History_Track2_use_decorator, & - + History_Track3_win_flag, & History_Track3_file_flag, & History_Track3_file_interval, & @@ -2147,7 +2147,7 @@ module pgstar_ctrls_io History_Panels9_ymargin, & History_Panels9_other_ymargin, & History_Panels9_use_decorator, & - + History_Panel_points_error_bars, & History_Panel_points_interval, & History_Panel_points_marker, & @@ -2639,7 +2639,7 @@ module pgstar_ctrls_io Summary_Burn_title, & Summary_Burn_title_shift, & Summary_Burn_use_decorator, & - + Summary_Profile_win_flag, & Summary_Profile_file_flag, & Summary_Profile_file_interval, & @@ -2664,7 +2664,7 @@ module pgstar_ctrls_io Summary_Profile_legend, & Summary_Profile_num_lines, & Summary_Profile_use_decorator, & - + Summary_History_win_flag, & Summary_History_file_flag, & Summary_History_file_interval, & @@ -3136,7 +3136,7 @@ recursive subroutine read_pgstar_file(s, filename, level, ierr) read_extra_pgstar_inlist(i) = .false. extra(i) = extra_pgstar_inlist_name(i) extra_pgstar_inlist_name(i) = 'undefined' - + if (read_extra(i)) then call read_pgstar_file(s, extra(i), level+1, ierr) if (ierr /= 0) return @@ -4631,7 +4631,7 @@ subroutine store_pgstar_controls(s, ierr) s% pg% History_Track4_txt_scale = History_Track4_txt_scale s% pg% History_Track4_title = History_Track4_title s% pg% History_Track4_use_decorator = History_Track4_use_decorator - + s% pg% History_Track5_win_flag = History_Track5_win_flag s% pg% History_Track5_file_flag = History_Track5_file_flag s% pg% History_Track5_file_interval = History_Track5_file_interval @@ -4721,7 +4721,7 @@ subroutine store_pgstar_controls(s, ierr) s% pg% History_Track6_txt_scale = History_Track6_txt_scale s% pg% History_Track6_title = History_Track6_title s% pg% History_Track6_use_decorator = History_Track6_use_decorator - + s% pg% History_Track7_win_flag = History_Track7_win_flag s% pg% History_Track7_file_flag = History_Track7_file_flag s% pg% History_Track7_file_interval = History_Track7_file_interval @@ -4996,7 +4996,7 @@ subroutine store_pgstar_controls(s, ierr) s% pg% profile_mass_point_str_clr = profile_mass_point_str_clr s% pg% profile_mass_point_str_scale = profile_mass_point_str_scale s% pg% TRho_Profile_use_decorator = TRho_Profile_use_decorator - + s% pg% History_Panels1_win_flag = History_Panels1_win_flag s% pg% History_Panels1_win_width = History_Panels1_win_width @@ -5385,7 +5385,7 @@ subroutine store_pgstar_controls(s, ierr) s% pg% History_Panels9_ymargin = History_Panels9_ymargin s% pg% History_Panels9_other_ymargin = History_Panels9_other_ymargin s% pg% History_Panels9_use_decorator = History_Panels9_use_decorator - + s% pg% History_Panel_points_error_bars = History_Panel_points_error_bars s% pg% History_Panel_points_interval = History_Panel_points_interval s% pg% History_Panel_points_marker = History_Panel_points_marker @@ -5826,7 +5826,7 @@ subroutine store_pgstar_controls(s, ierr) s% pg% Summary_Burn_title = Summary_Burn_title s% pg% Summary_Burn_title_shift = Summary_Burn_title_shift s% pg% Summary_Burn_use_decorator = Summary_Burn_use_decorator - + s% pg% Summary_Profile_win_flag = Summary_Profile_win_flag s% pg% Summary_Profile_file_flag = Summary_Profile_file_flag s% pg% Summary_Profile_file_interval = Summary_Profile_file_interval @@ -5931,7 +5931,7 @@ subroutine store_pgstar_controls(s, ierr) s% pg% Abundance_txt_scale = Abundance_txt_scale s% pg% Abundance_title = Abundance_title s% pg% Abundance_use_decorator = Abundance_use_decorator - + s% pg% dPg_dnu_win_flag = dPg_dnu_win_flag s% pg% dPg_dnu_file_flag = dPg_dnu_file_flag s% pg% dPg_dnu_xleft = dPg_dnu_xleft diff --git a/star/private/pgstar_dynamo.f90 b/star/private/pgstar_dynamo.f90 index 9b4ed745f..24901f4cf 100644 --- a/star/private/pgstar_dynamo.f90 +++ b/star/private/pgstar_dynamo.f90 @@ -159,7 +159,7 @@ subroutine Dyn_plot(s, device_id, & call pgunsa deallocate(xvec, yvec, yvec2, yvec3) - + contains diff --git a/star/private/pgstar_hist_track.f90 b/star/private/pgstar_hist_track.f90 index fce694473..75e0bb37b 100644 --- a/star/private/pgstar_hist_track.f90 +++ b/star/private/pgstar_hist_track.f90 @@ -807,7 +807,7 @@ end subroutine decorate call pgunsa call show_pgstar_decorator(s%id, use_decorator, pgstar_decorator, 0, ierr) - + deallocate(xvec, yvec) contains diff --git a/star/private/pgstar_history_panels.f90 b/star/private/pgstar_history_panels.f90 index 09ec4521b..7daa5b3ac 100644 --- a/star/private/pgstar_history_panels.f90 +++ b/star/private/pgstar_history_panels.f90 @@ -849,7 +849,7 @@ subroutine do_history_panels_plot( & if (other_ytop > ytop) ytop = other_ytop if (ytop > other_ytop) other_ytop = ytop end if - + if (have_other_yaxis) then !write(*,1) trim(other_yname), other_ybot, other_ytop call pgswin(xleft, xright, other_ybot, other_ytop) @@ -891,7 +891,7 @@ subroutine do_history_panels_plot( & call show_box_pgstar(s,'BCNST','BNSTV') end if end if - + if (len_trim(hist_points_name(j)) > 0) then iounit = 33 open(unit=iounit, file=trim(hist_points_name(j)), & @@ -930,7 +930,7 @@ subroutine do_history_panels_plot( & call show_left_yaxis_label_pgstar(s,'log ' // yname) else call show_left_yaxis_label_pgstar(s,yname) - end if + end if call pgslw(s% pg% pgstar_lw) if (yfile_data_len > 0) then call pgsls(s% pg% pgstar_history_line_style) @@ -958,7 +958,7 @@ subroutine do_history_panels_plot( & deallocate(xvec, yvec, other_yvec) call pgunsa - + contains diff --git a/star/private/pgstar_hr.f90 b/star/private/pgstar_hr.f90 index 2d5286bc5..200c1e16c 100644 --- a/star/private/pgstar_hr.f90 +++ b/star/private/pgstar_hr.f90 @@ -86,27 +86,27 @@ subroutine HR_decorate(id, ierr) call pgsls(Line_Type_Solid) call pgslw(s% pg% pgstar_lw) - + ! approximate edges - + ! blue edge logT1 = 3.70 logL1 = 5.5 - + logT2 = 3.93 logL2 = 1.0 - + call pgsci(clr_Blue) call pgmove(logT1, logL1) call pgdraw(logT2, logL2) - + ! red edge logT1 = 3.60 logL1 = 5.5 - + logT2 = 3.83 logL2 = 1.0 - + call pgsci(clr_FireBrick) call pgmove(logT1, logL1) call pgdraw(logT2, logL2) diff --git a/star/private/pgstar_kipp.f90 b/star/private/pgstar_kipp.f90 index 2d5f81997..055c44769 100644 --- a/star/private/pgstar_kipp.f90 +++ b/star/private/pgstar_kipp.f90 @@ -205,7 +205,7 @@ subroutine do_Kipp_Plot(s, id, device_id, & xmin=max(s% pg% kipp_xmin,xvec(1)) xmax=min(s% pg% kipp_xmax,xvec(n)) - + burn_type_cutoff = s% pg% Kipp_burn_type_cutoff call set_xleft_xright( & @@ -279,12 +279,12 @@ subroutine do_Kipp_Plot(s, id, device_id, & call finish_Kipp_plot call pgunsa - + call dealloc contains - + subroutine dealloc deallocate(xvec, & log_L, & @@ -347,10 +347,10 @@ subroutine finish_Kipp_plot call show_title_pgstar(s, title) call show_mix_legend call show_burn_legend - + call show_pgstar_decorator(s%id, s% pg% kipp_use_decorator,s% pg% kipp_pgstar_decorator, 0, ierr) - + end subroutine finish_Kipp_plot diff --git a/star/private/pgstar_logl_r.f90 b/star/private/pgstar_logl_r.f90 index 2ab0a71a6..47c217f0e 100644 --- a/star/private/pgstar_logl_r.f90 +++ b/star/private/pgstar_logl_r.f90 @@ -74,7 +74,7 @@ subroutine do_logL_R_Plot( & logical, parameter :: reverse_xaxis = .false., reverse_yaxis = .false. character (len=64) :: xname, xaxis_label ierr = 0 - if (show_photosphere_r) then + if (show_photosphere_r) then xname = 'photosphere_r' xaxis_label = 'R\dphot\u/R\d\(2281)' else diff --git a/star/private/pgstar_logl_v.f90 b/star/private/pgstar_logl_v.f90 index dddb12f3a..498766858 100644 --- a/star/private/pgstar_logl_v.f90 +++ b/star/private/pgstar_logl_v.f90 @@ -72,7 +72,7 @@ subroutine do_logL_v_Plot(s, id, device_id, show_photosphere_v, & logical, parameter :: reverse_xaxis = .false., reverse_yaxis = .false. character (len=64) :: xname, xaxis_label ierr = 0 - if (show_photosphere_v) then + if (show_photosphere_v) then xname = 'photosphere_v_km_s' xaxis_label = 'v\dphot (km/s)' else diff --git a/star/private/pgstar_mixing_ds.f90 b/star/private/pgstar_mixing_ds.f90 index 164a416ca..cf903ddd2 100644 --- a/star/private/pgstar_mixing_ds.f90 +++ b/star/private/pgstar_mixing_ds.f90 @@ -347,21 +347,21 @@ subroutine plot(ierr) call show_left_yaxis_label_pgstar(s,'log D (cm\u2\d s\u-1\d)') call pgsch(txt_scale*s% pg% Mixing_legend_txt_scale_factor) - + if (rotation) then - - if (s% D_omega_flag) then - + + if (s% D_omega_flag) then + do k=grid_min, grid_max yvec(k) = safe_log10(s% D_mix_rotation(k)) end do call pgsci(clr_rotation) call pgslw(lw) call pgline(npts, xvec(grid_min:grid_max), yvec(grid_min:grid_max)) - call pgslw(lw_sav) - + call pgslw(lw_sav) + else if (.not. s% pg% Mixing_show_rotation_details) then - + do k=grid_min, grid_max yvec(k) = safe_log10( & s% D_DSI_factor * s% D_DSI(k) + & @@ -375,9 +375,9 @@ subroutine plot(ierr) call pgslw(lw) call pgline(npts, xvec(grid_min:grid_max), yvec(grid_min:grid_max)) call pgslw(lw_sav) - + end if - + if (s% pg% Mixing_show_rotation_details) then D_DSI_factor = s% D_DSI_factor @@ -444,11 +444,11 @@ subroutine plot(ierr) call pgslw(lw) call pgline(npts, xvec(grid_min:grid_max), yvec(grid_min:grid_max)) call pgslw(lw_sav) - + end if - + end if - + call pgsci(clr_convection) call pgslw(lw) call pgline(npts, xvec(grid_min:grid_max), y_conv(grid_min:grid_max)) @@ -480,12 +480,12 @@ subroutine plot(ierr) call pgline(npts, xvec(grid_min:grid_max), y_RTI_mix(grid_min:grid_max)) call pgslw(lw_sav) end if - + call pgsci(clr_minimum) call pgslw(lw) call pgline(npts, xvec(grid_min:grid_max), y_min_mix(grid_min:grid_max)) call pgslw(lw_sav) - + ! now do legend lines call pgsave @@ -508,7 +508,7 @@ subroutine plot(ierr) lw, lw_sav, txt_scale, 'thermohaline') end if if (rotation) then - if (s% D_omega_flag) then + if (s% D_omega_flag) then cnt = mixing_line_legend(cnt, clr_rotation, & lw, lw_sav, txt_scale, 'D_mix_rotation') else @@ -536,7 +536,7 @@ subroutine plot(ierr) cnt = mixing_line_legend(cnt, clr_MediumSlateBlue, & lw, lw_sav, txt_scale, 'GSF') end if - + call pgunsa call show_pgstar_decorator(s%id,s% pg% mixing_use_decorator,s% pg% mixing_pgstar_decorator, 0, ierr) diff --git a/star/private/pgstar_network.f90 b/star/private/pgstar_network.f90 index dea0bd988..d384a3adf 100644 --- a/star/private/pgstar_network.f90 +++ b/star/private/pgstar_network.f90 @@ -229,7 +229,7 @@ subroutine plot(ierr) if(s% pg% network_show_colorbar)then call network_colorbar_legend(winxmin, winxmax, winymin, winymax,log10_min_abun,log10_max_abun) end if - + call show_pgstar_decorator(s%id,s% pg% network_use_decorator,s% pg% network_pgstar_decorator, 0, ierr) @@ -237,15 +237,15 @@ end subroutine plot end subroutine do_network_panel - - + + subroutine network_colorbar_legend(winxmin, winxmax, winymin, winymax,abun_min,abun_max) real,intent(in) :: winxmin, winxmax, winymin, winymax,abun_min,abun_max real :: legend_xmin,legend_xmax,legend_ymin,legend_ymax real :: xmin,xmax,ymin,ymax real :: dx, dyline, xpts(2),yt,yb,text character(len=16) :: str - + integer :: i,j,clr,mid_map,num_cms call PGQWIN(xmin, xmax, ymin, ymax) @@ -259,7 +259,7 @@ subroutine network_colorbar_legend(winxmin, winxmax, winymin, winymax,abun_min,a num_cms=colormap_size-mid_map dyline = (ymax-ymin)/num_cms dx = 0.1 - + xpts(1) = 2.0*dx xpts(2) = xpts(1) + 2.0*dx @@ -272,7 +272,7 @@ subroutine network_colorbar_legend(winxmin, winxmax, winymin, winymax,abun_min,a call pgsci(clr) yt = ymin + (i)*dyline yb = ymin + (i-1)*dyline - + call pgrect(xpts(1),xpts(2),yb,yt) end do @@ -282,7 +282,7 @@ subroutine network_colorbar_legend(winxmin, winxmax, winymin, winymax,abun_min,a write(str,'(F8.3)') text call pgptxt(xpts(2) + 0.025, ymin+(j-1)*(ymax-ymin)/4.0, 0.0, 0.0, trim(str)) end do - + call pgunsa end subroutine network_colorbar_legend diff --git a/star/private/pgstar_production.f90 b/star/private/pgstar_production.f90 index 11871e8bf..09e8cbd27 100644 --- a/star/private/pgstar_production.f90 +++ b/star/private/pgstar_production.f90 @@ -142,7 +142,7 @@ subroutine plot(ierr) call pgsave call pgsch(txt_scale) call pgsvp(winxmin, winxmax, winymin, winymax) - + amax=0 amin=0.0 zmax=0 @@ -216,14 +216,14 @@ subroutine plot(ierr) end do !Get stable isotope abundances - call get_stable_mass_frac(s%chem_id,s%species,dble(abun),scaled_abun) - call get_stable_mass_frac(s%chem_id,s%species,init_comp,scaled_abun_init) + call get_stable_mass_frac(s%chem_id,s%species,dble(abun),scaled_abun) + call get_stable_mass_frac(s%chem_id,s%species,init_comp,scaled_abun_init) do i=1,solsiz - + la=safe_log10(scaled_abun(i)) lac=safe_log10(scaled_abun_init(i)) - + !Remove low abundance isotopes, low in star and low in solar can lead to large production factor if(la solsiz) exit outer - + ! Z is greater than zmax if(izsol(i)>zmax) exit outer @@ -306,7 +306,7 @@ subroutine plot(ierr) last_y=-HUGE(last_y) inner: do j=i,solsiz - + if(izsol(j)==izsol(i))then if((scaled_abun(j)>= ymin) .and. (scaled_abun(j) <= ymax)& .and.(iasol(j)<=xright).and.(iasol(j)>=xleft)) then @@ -322,7 +322,7 @@ subroutine plot(ierr) !Save last x,y pair we saw last_x=A*1.0 - last_y=scaled_abun(j) + last_y=scaled_abun(j) end if else exit inner @@ -335,11 +335,11 @@ subroutine plot(ierr) call pgunsa deallocate(abun,init_comp) - + call show_pgstar_decorator(id,s% pg% production_use_decorator,& s% pg% production_pgstar_decorator, 0, ierr) - + end subroutine plot subroutine set_line_style(cnt) diff --git a/star/private/pgstar_profile_panels.f90 b/star/private/pgstar_profile_panels.f90 index 0f9e6b976..f339f7d63 100644 --- a/star/private/pgstar_profile_panels.f90 +++ b/star/private/pgstar_profile_panels.f90 @@ -749,7 +749,7 @@ subroutine Pro_panels_plot(s, device_id, & do k=1,npts xvec(k) = xvec(k+grid_min-1) end do - end if + end if do j = 1, panels_num_panels @@ -913,14 +913,14 @@ subroutine Pro_panels_plot(s, device_id, & npts, yvec, panels_ymin(j), panels_ymax(j), panels_ycenter(j), panels_ymargin(j), & panels_yaxis_reversed(j), panels_dymin(j), ybot, ytop) end if - + if (panels_same_yaxis_range(j) .and. len_trim(panels_other_yaxis_name(j)) > 0) then if (other_ybot < ybot) ybot = other_ybot if (ybot < other_ybot) other_ybot = ybot if (other_ytop > ytop) ytop = other_ytop if (ytop > other_ytop) other_ytop = ytop end if - + if (len_trim(panels_other_yaxis_name(j)) > 0) then call pgswin(xleft, xright, other_ybot, other_ytop) call pgscf(1) @@ -949,7 +949,7 @@ subroutine Pro_panels_plot(s, device_id, & end if call pgslw(1) end if - + call pgswin(xleft, xright, ybot, ytop) call pgscf(1) call pgsci(1) @@ -993,7 +993,7 @@ subroutine Pro_panels_plot(s, device_id, & end if call pgslw(1) call pgsci(1) - + call show_pgstar_decorator(s% id, use_decorator, pgstar_decorator, j, ierr) end do diff --git a/star/private/pgstar_rti.f90 b/star/private/pgstar_rti.f90 index b5877134f..4a6e416fd 100644 --- a/star/private/pgstar_rti.f90 +++ b/star/private/pgstar_rti.f90 @@ -140,7 +140,7 @@ subroutine do_rti_Plot(s, id, device_id, & end if call get_hist_points(s, step_min, step_max, n, ix, xvec, ierr) - if (ierr /= 0) then + if (ierr /= 0) then write(*,*) 'pgstar get_hist_points failed ' // trim(s% pg% rti_xaxis_name) call dealloc ierr = 0 @@ -224,12 +224,12 @@ subroutine do_rti_Plot(s, id, device_id, & call finish_rti_plot call pgunsa - + call dealloc contains - + subroutine dealloc deallocate(xvec, star_mass, star_M_center, log_xmstar, & he_core_mass, & @@ -316,7 +316,7 @@ subroutine finish_rti_plot call show_age_pgstar(s) end if call show_title_pgstar(s, title) - + call show_pgstar_decorator(s% pg%id, s% pg% rti_use_decorator, & s% pg% rti_pgstar_decorator, 0, ierr) diff --git a/star/private/pgstar_stub.f90 b/star/private/pgstar_stub.f90 index a1a2fb03c..4d3fadeb1 100644 --- a/star/private/pgstar_stub.f90 +++ b/star/private/pgstar_stub.f90 @@ -22,19 +22,19 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module pgstar use star_def use const_def use star_pgstar - + implicit none - - + + contains - - + + subroutine do_create_file_name(s, dir, prefix, name) type (star_info), pointer :: s character (len=*), intent(in) :: dir, prefix @@ -50,29 +50,29 @@ subroutine do_write_plot_to_file(s, p, filename, ierr) integer, intent(out) :: ierr ierr = 0 end subroutine do_write_plot_to_file - - + + subroutine do_show_pgstar_annotations( & s, show_annotation1, show_annotation2, show_annotation3) type (star_info), pointer :: s logical, intent(in) :: & show_annotation1, show_annotation2, show_annotation3 end subroutine do_show_pgstar_annotations - - + + subroutine do_start_new_run_for_pgstar(s, ierr) type (star_info), pointer :: s integer, intent(out) :: ierr ierr = 0 end subroutine do_start_new_run_for_pgstar - - + + subroutine do_restart_run_for_pgstar(s, ierr) type (star_info), pointer :: s integer, intent(out) :: ierr ierr = 0 end subroutine do_restart_run_for_pgstar - + subroutine do_read_pgstar_controls(s, inlist_fname, ierr) type (star_info), pointer :: s @@ -80,7 +80,7 @@ subroutine do_read_pgstar_controls(s, inlist_fname, ierr) integer, intent(out) :: ierr ierr = 0 end subroutine do_read_pgstar_controls - + subroutine do_pgstar_plots( & s, must_write_files, & @@ -91,7 +91,7 @@ subroutine do_pgstar_plots( & integer, intent(out) :: ierr ierr = 0 end subroutine do_pgstar_plots - + subroutine do_set_xaxis_bounds( & s, xaxis_by, win_xmin_in, win_xmax_in, xmargin, & @@ -107,54 +107,54 @@ subroutine do_set_xaxis_bounds( & xmin=0; xmax=0; xleft=0; xright=0; dx=0 grid_min=0; grid_max=0; npts=0; ierr=0 end subroutine do_set_xaxis_bounds - - + + subroutine do_show_xaxis_by(s,by,ierr) type (star_info), pointer :: s character (len=*), intent(in) :: by integer, intent(out) :: ierr ierr=0 end subroutine do_show_xaxis_by - - + + subroutine show_box_pgstar(s, str1, str2) type (star_info), pointer :: s character (len=*), intent(in) :: str1, str2 end subroutine show_box_pgstar - - + + subroutine show_title_pgstar(s, title, pad) type (star_info), pointer :: s character (len=*), intent(in) :: title real, intent(in) :: pad optional pad end subroutine show_title_pgstar - - + + subroutine show_xaxis_label_pgstar(s, label, pad) type (star_info), pointer :: s character (len=*), intent(in) :: label real, intent(in) :: pad optional pad end subroutine show_xaxis_label_pgstar - - + + subroutine show_left_yaxis_label_pgstar(s, label, pad) type (star_info), pointer :: s character (len=*), intent(in) :: label real, intent(in) :: pad optional pad end subroutine show_left_yaxis_label_pgstar - - + + subroutine show_right_yaxis_label_pgstar(s, label, pad) type (star_info), pointer :: s character (len=*), intent(in) :: label real, intent(in) :: pad optional pad end subroutine show_right_yaxis_label_pgstar - - + + subroutine show_left_yaxis_label_pgmtxt_pgstar( & s, coord, fjust, label, pad) type (star_info), pointer :: s @@ -162,8 +162,8 @@ subroutine show_left_yaxis_label_pgmtxt_pgstar( & real, intent(in) :: pad, coord, fjust optional pad end subroutine show_left_yaxis_label_pgmtxt_pgstar - - + + subroutine show_right_yaxis_label_pgmtxt_pgstar( & s, coord, fjust, label, pad) type (star_info), pointer :: s @@ -171,13 +171,13 @@ subroutine show_right_yaxis_label_pgmtxt_pgstar( & real, intent(in) :: pad, coord, fjust optional pad end subroutine show_right_yaxis_label_pgmtxt_pgstar - - + + subroutine show_model_number_pgstar(s) type (star_info), pointer :: s end subroutine show_model_number_pgstar - - + + subroutine show_age_pgstar(s) type (star_info), pointer :: s end subroutine show_age_pgstar @@ -193,4 +193,4 @@ subroutine shutdown_pgstar(s) end subroutine shutdown_pgstar end module pgstar - + diff --git a/star/private/pgstar_trho_profile.f90 b/star/private/pgstar_trho_profile.f90 index e99eb2bce..d2e57bc6f 100644 --- a/star/private/pgstar_trho_profile.f90 +++ b/star/private/pgstar_trho_profile.f90 @@ -207,7 +207,7 @@ subroutine do_TRho_Profile_plot(s, id, device_id, & s% pg% show_TRho_Profile_annotation3) deallocate(xvec, yvec) - + call show_pgstar_decorator(s%id,s% pg% TRho_Profile_use_decorator,& s% pg% TRho_Profile_pgstar_decorator, 0, ierr) @@ -362,7 +362,7 @@ subroutine do_eos_regions call pgsls(Line_Type_Dot) logRho0 = logRho1 - + logT1 = s% eos_rq% logT_cut_FreeEOS_hi logT2 = s% eos_rq% logT_cut_FreeEOS_lo logT3 = s% eos_rq% logT_min_FreeEOS_hi @@ -379,12 +379,12 @@ subroutine do_eos_regions call stroke_line(logRho0, logT1, logRho2, logT1) call stroke_line(logRho2, logT1, logRho4, logT3) - call stroke_line(logRho4, logT3, logRho5, logT3) + call stroke_line(logRho4, logT3, logRho5, logT3) call stroke_line(logRho0, logT2, logRho1, logT2) call stroke_line(logRho1, logT2, logRho3, logT4) call stroke_line(logRho3, logT4, logRho5, logT4) - + call stroke_line(logRho0, logT5, logRho6, logT6) call stroke_line(logRho5, logT6, logRho6, logT6) @@ -394,7 +394,7 @@ subroutine do_eos_regions call show_label(-1.5, 3.7, 0.0, 0.5, 'OPAL/SCVH') call show_label(-1.5, 9.7, 0.0, 0.5, 'HELM/Skye EOS') call show_label(6.0, 4.5, 0.0, 0.5, 'Skye EOS') - + call pgunsa end subroutine do_eos_regions diff --git a/star/private/phase_separation.f90 b/star/private/phase_separation.f90 index 223377d21..c53fed2f2 100644 --- a/star/private/phase_separation.f90 +++ b/star/private/phase_separation.f90 @@ -36,7 +36,7 @@ module phase_separation ! offset to higher phase than 0.5 to avoid interference ! between phase separation mixing and latent heat for Skye. real(dp), parameter :: eos_phase_boundary = 0.9d0 - + private public :: do_phase_separation @@ -64,7 +64,7 @@ subroutine do_2component_phase_separation(s, dt, components, ierr) real(dp), intent(in) :: dt character (len=*), intent(in) :: components integer, intent(out) :: ierr - + real(dp) :: XNe, XO, XC, pad integer :: k, k_bound, kstart, net_ic12, net_io16, net_ine20 logical :: save_Skye_use_ion_offsets @@ -72,16 +72,16 @@ subroutine do_2component_phase_separation(s, dt, components, ierr) ! Set phase separation mixing mass negative at beginning of phase separation s% phase_sep_mixing_mass = -1d0 s% eps_phase_separation(1:s%nz) = 0d0 - + if(s% phase(s% nz) < eos_phase_boundary) then s% crystal_core_boundary_mass = 0d0 return end if - + net_ic12 = s% net_iso(ic12) net_io16 = s% net_iso(io16) net_ine20 = s% net_iso(ine20) - + ! Find zone of phase transition from liquid to solid k_bound = -1 do k = s%nz,1,-1 @@ -90,7 +90,7 @@ subroutine do_2component_phase_separation(s, dt, components, ierr) exit end if end do - + XC = s% xa(net_ic12,k_bound) XO = s% xa(net_io16,k_bound) XNe = s% xa(net_ine20,k_bound) @@ -98,7 +98,7 @@ subroutine do_2component_phase_separation(s, dt, components, ierr) ! otherwise skip phase separation if(components == 'CO'.and. XO + XC < 0.9d0) return if(components == 'ONe'.and. XNe + XO < 0.8d0) return ! O/Ne mixtures tend to have more byproducts of burning mixed in - + ! If there is a phase transition, reset the composition at the boundary if(k_bound > 0) then @@ -120,7 +120,7 @@ subroutine do_2component_phase_separation(s, dt, components, ierr) do k=1,s% nz s% eps_phase_separation(k) = s% energy(k) end do - + ! loop runs outward starting at previous crystallization boundary do k = kstart,1,-1 ! Start by checking if this material should be crystallizing @@ -133,7 +133,7 @@ subroutine do_2component_phase_separation(s, dt, components, ierr) ! crystallized out to k now, liquid starts at k-1. ! now mix the liquid material outward until stably stratified call mix_outward(s, k-1, 0) - + end do call update_model_(s,1,s%nz,.false.) @@ -155,29 +155,29 @@ subroutine move_one_zone(s,k,components) type(star_info), pointer :: s integer, intent(in) :: k character (len=*), intent(in) :: components - + real(dp) :: XC, XO, XNe, XC1, XO1, XNe1, dXO, dXNe, Xfac integer :: net_ic12, net_io16, net_ine20 - + net_ic12 = s% net_iso(ic12) net_io16 = s% net_iso(io16) net_ine20 = s% net_iso(ine20) - + if(components == 'CO') then XO = s% xa(net_io16,k) XC = s% xa(net_ic12,k) - + ! Call Blouin phase diagram. ! Need to rescale temporarily because phase diagram assumes XO + XC = 1 Xfac = XO + XC XO = XO/Xfac XC = XC/Xfac - + dXO = blouin_delta_xo(XO) - + s% xa(net_io16,k) = Xfac*(XO + dXO) s% xa(net_ic12,k) = Xfac*(XC - dXO) - + ! Redistribute change in C,O into zone k-1, ! conserving total mass of C,O XC1 = s% xa(net_ic12,k-1) @@ -187,18 +187,18 @@ subroutine move_one_zone(s,k,components) else if(components == 'ONe') then XNe = s% xa(net_ine20,k) XO = s% xa(net_io16,k) - + ! Call Blouin phase diagram. ! Need to rescale temporarily because phase diagram assumes XO + XNe = 1 Xfac = XO + XNe XO = XO/Xfac XNe = XNe/Xfac - + dXNe = blouin_delta_xne(XNe) - + s% xa(net_ine20,k) = Xfac*(XNe + dXNe) s% xa(net_io16,k) = Xfac*(XO - dXNe) - + ! Redistribute change in Ne,O into zone k-1, ! conserving total mass of Ne,O XO1 = s% xa(net_io16,k-1) @@ -211,19 +211,19 @@ subroutine move_one_zone(s,k,components) end if call update_model_(s,k-1,s%nz,.true.) - + end subroutine move_one_zone ! mix composition outward until reaching stable composition profile subroutine mix_outward(s,kbot,min_mix_zones) type(star_info), pointer :: s integer, intent(in) :: kbot, min_mix_zones - + real(dp) :: avg_xa(s%species) real(dp) :: mass, B_term, grada, gradr integer :: k, l, ktop logical :: use_brunt - + use_brunt = s% phase_separation_mixing_use_brunt do k=kbot-min_mix_zones,1,-1 @@ -270,7 +270,7 @@ subroutine mix_outward(s,kbot,min_mix_zones) ! Call a final update over all mixed cells now. call update_model_(s, ktop, kbot+1, .true.) - + end subroutine mix_outward real(dp) function blouin_delta_xo(Xin) @@ -281,7 +281,7 @@ real(dp) function blouin_delta_xo(Xin) ! Convert input mass fraction to number fraction, assuming C/O mixture xo = (Xin/16d0)/(Xin/16d0 + (1d0 - Xin)/12d0) - + a0 = 0d0 a1 = -0.311540d0 a2 = 2.114743d0 @@ -301,7 +301,7 @@ real(dp) function blouin_delta_xo(Xin) ! Convert back to mass fraction Xnew = 16d0*xo/(16d0*xo + 12d0*(1d0-xo)) - + blouin_delta_xo = Xnew - Xin end function blouin_delta_xo @@ -313,7 +313,7 @@ real(dp) function blouin_delta_xne(Xin) ! Convert input mass fraction to number fraction, assuming O/Ne mixture xne = (Xin/20d0)/(Xin/20d0 + (1d0 - Xin)/16d0) - + a0 = 0d0 a1 = -0.120299d0 a2 = 1.304399d0 @@ -333,7 +333,7 @@ real(dp) function blouin_delta_xne(Xin) ! Convert back to mass fraction Xnew = 20d0*xne/(20d0*xne + 16d0*(1d0-xne)) - + blouin_delta_xne = Xnew - Xin end function blouin_delta_xne @@ -342,12 +342,12 @@ subroutine update_model_ (s, kc_t, kc_b, do_brunt) use turb_info, only: set_mlt_vars use brunt, only: do_brunt_B use micro - + type(star_info), pointer :: s integer, intent(in) :: kc_t integer, intent(in) :: kc_b logical, intent(in) :: do_brunt - + integer :: ierr integer :: kf_t integer :: kf_b @@ -366,9 +366,9 @@ subroutine update_model_ (s, kc_t, kc_b, do_brunt) stop end if s%fix_Pgas = .false. - + ! Update opacities across cells kc_t:kc_b (this also sets rho_face - ! and related quantities on faces kc_t:kc_b) + ! and related quantities on faces kc_t:kc_b) call set_micro_vars(s, kc_t, kc_b, & skip_eos=.TRUE., skip_net=.TRUE., skip_neu=.TRUE., skip_kap=.FALSE., ierr=ierr) if (ierr /= 0) then @@ -390,20 +390,20 @@ subroutine update_model_ (s, kc_t, kc_b, do_brunt) end if ! Finally update MLT for interior faces - + kf_t = kc_t kf_b = kc_b + 1 - + call set_mlt_vars(s, kf_t+1, kf_b-1, ierr) if (ierr /= 0) then write(*,*) 'phase_separation: failed in call to set_mlt_vars during update_model_' stop endif - + ! Finish - + return - + end subroutine update_model_ end module phase_separation diff --git a/star/private/photo_in.f90 b/star/private/photo_in.f90 index 53d7ca870..b6ac575e0 100644 --- a/star/private/photo_in.f90 +++ b/star/private/photo_in.f90 @@ -95,10 +95,10 @@ subroutine read_star_photo(s, fname, ierr) s% have_initial_energy_integrals, s% total_energy_initial, & s% force_tau_factor, s% force_Tsurf_factor, s% force_opacity_factor, & s% crystal_core_boundary_mass - + if (failed('initial_y')) return s% nz_old = s% nz ! needed by alloc - + if (s% force_tau_factor > 0 .and. s% tau_factor /= s% force_tau_factor .and. & s% tau_factor /= s% job% set_to_this_tau_factor) then s% tau_factor = s% force_tau_factor @@ -184,7 +184,7 @@ subroutine read_star_photo(s, fname, ierr) if (failed('read_part_number')) return read(iounit, iostat=ierr) & - s% num_skipped_setvars, s% num_retries, s% num_setvars, & + s% num_skipped_setvars, s% num_retries, s% num_setvars, & s% total_num_solver_iterations, s% total_num_solver_relax_iterations, & s% total_num_solver_calls_made, s% total_num_solver_relax_calls_made, & s% total_num_solver_calls_converged, s% total_num_solver_relax_calls_converged, & @@ -280,7 +280,7 @@ subroutine read_star_photo(s, fname, ierr) if (failed('integer_dict_create_hash history_names_dict')) return end if - + if (s% rsp_flag) then call rsp_photo_in(s, iounit, ierr) if (failed('after rsp_photo_in')) return @@ -294,7 +294,7 @@ subroutine read_star_photo(s, fname, ierr) call read_part_number(iounit) if (failed('final read_part_number')) return - + s% need_to_setvars = .true. ! set this after photo out or photo in close(iounit) diff --git a/star/private/photo_out.f90 b/star/private/photo_out.f90 index 1872d3ebd..74aeac541 100644 --- a/star/private/photo_out.f90 +++ b/star/private/photo_out.f90 @@ -54,7 +54,7 @@ subroutine output_star_photo(s,iounit,ierr) part_number = 0 ! part_numbers are just a consistency check on the data file write(iounit) star_def_version - + call write_part_number(iounit) write(iounit) & s% initial_z, & ! need this since read_model can change what is in the inlist @@ -108,12 +108,12 @@ subroutine output_star_photo(s,iounit,ierr) write(iounit) & s% recent_log_header, s% phase_of_evolution, s% dt_next, s% dt_next_unclipped - call write_part_number(iounit) + call write_part_number(iounit) write(iounit) & - s% num_skipped_setvars, s% num_retries, s% num_setvars, & + s% num_skipped_setvars, s% num_retries, s% num_setvars, & s% total_num_solver_iterations, & s% total_num_solver_relax_iterations, & - s% total_num_solver_calls_made, & + s% total_num_solver_calls_made, & s% total_num_solver_relax_calls_made, & s% total_num_solver_calls_converged, & s% total_num_solver_relax_calls_converged, & @@ -162,7 +162,7 @@ subroutine output_star_photo(s,iounit,ierr) write(iounit) s% history_names(k) end do end if - + if (s% rsp_flag) call rsp_photo_out(s, iounit) call write_part_number(iounit) @@ -170,7 +170,7 @@ subroutine output_star_photo(s,iounit,ierr) call s% other_photo_write(s% id, iounit) call write_part_number(iounit) - + s% need_to_setvars = .true. contains diff --git a/star/private/pre_ms_model.f90 b/star/private/pre_ms_model.f90 index 3b916731e..10fc233c6 100644 --- a/star/private/pre_ms_model.f90 +++ b/star/private/pre_ms_model.f90 @@ -29,15 +29,15 @@ module pre_ms_model use const_def implicit none - + private public :: build_pre_ms_model logical, parameter :: dbg = .false. contains - - + + subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) use chem_def use chem_lib, only: basic_composition_info, chem_Xsol @@ -48,7 +48,7 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) type (star_info), pointer :: s integer, intent(in) :: id, nvar_hydro, species integer, intent(out) :: ierr - + real(dp) :: & initial_z, x, y, z, xa(species), mstar, mstar1, lgM, rstar, rho_c, & abar, zbar, z53bar, mass_correction, z2bar, ye, sumx, & @@ -66,14 +66,14 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) xsol_he3, xsol_he4 integer :: initial_zfracs real(dp), parameter :: max_mass_to_create = 90, min_mass_to_create = 0.03d0 - + include 'formats' - + ipar => ipar_ary rpar => rpar_ary - + pre_ms_lrpar = rpar_init+species - + if (nvar_hydro > 4) then write(*,*) 'sorry, build_pre_ms_model only supports the basic 4 vars.' ierr = -1 @@ -101,7 +101,7 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) s% L_center = 0 s% R_center = 0 s% v_center = 0 - + initial_h1 = max(0d0, min(1d0, 1d0 - (initial_z + initial_y))) initial_h2 = 0 if (s% initial_he3 < 0d0) then @@ -117,14 +117,14 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) ierr = -1 end if initial_zfracs = s% pre_ms_initial_zfracs - + call get_xa_for_standard_metals(s, & species, s% chem_id, s% net_iso, & initial_h1, initial_h2, initial_he3, initial_he4, & initial_zfracs, s% pre_ms_dump_missing_heaviest, & xa, ierr) if (ierr /= 0) return - + if (dbg) then write(*,*) 'abundances' do i=1,species @@ -132,7 +132,7 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) end do write(*,'(A)') end if - + if (abs(1-sum(xa(:))) > 1d-8) then write(*,1) 'initial_h1', initial_h1 write(*,1) 'initial_h2', initial_h2 @@ -147,14 +147,14 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) ierr = -1 return end if - + call basic_composition_info( & species, s% chem_id, xa(:), x, y, z, abar, zbar, z2bar, z53bar, ye, & mass_correction, sumx) - - mu_eff = 4 / (3 + 5*x) + + mu_eff = 4 / (3 + 5*x) ! estimate mu_eff assuming complete ionization and Z << 1 - + guess_rho_c = s% pre_ms_guess_rho_c if (guess_rho_c <= 0) then ! use n=3/2 polytrope rstar = Rsun*7.41d6*(mu_eff/0.6d0)*(mstar/Msun)/T_c ! Ushomirsky et al, 6 @@ -163,7 +163,7 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) else rho_c = guess_rho_c end if - + ! pick a luminosity that is above the zams level lgM = log10(mstar/Msun) if (lgM > 1) then @@ -175,10 +175,10 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) else lgL = 0.5d0 end if - + ! use uniform eps_grav to give that luminosity eps_grav = exp10(lgL)*Lsun/mstar - + if (dbg) then write(*,1) 'initial_z', initial_z write(*,1) 'T_c', T_c @@ -193,7 +193,7 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) nullify(s% dq) d_log10_P = s% pre_ms_d_log10_P - + i = 1 ! rpar(1) for mstar result rpar(i+1) = T_c; i = i+1 rpar(i+1) = eps_grav; i = i+1 @@ -202,9 +202,9 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) rpar(i+1) = abar; i = i+1 rpar(i+1) = zbar; i = i+1 rpar(i+1) = d_log10_P; i = i+1 - + rpar(i+1:i+species) = xa(1:species); i = i+species - + if (i /= pre_ms_lrpar) then write(*,*) 'i /= pre_ms_lrpar', i, pre_ms_lrpar write(*,*) 'pre ms' @@ -213,10 +213,10 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) end if ipar(1) = id - + lnd = log(rho_c) dlnd = 0.01d0 - + call look_for_brackets(lnd, dlnd, lnd1, lnd3, pre_ms_f, y1, y3, & imax, pre_ms_lrpar, rpar, pre_ms_lipar, ipar, ierr) if (ierr /= 0) then @@ -229,10 +229,10 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) end if return end if - + epsx = 1d-3 ! limit for variation in lnd epsy = 1d-3 ! limit for matching desired mass as fraction of total mass - + lnd = safe_root(pre_ms_f, lnd1, lnd3, y1, y3, imax, epsx, epsy, & pre_ms_lrpar, rpar, pre_ms_lipar, ipar, ierr) if (ierr /= 0) then @@ -241,7 +241,7 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) end if mstar1 = rpar(1) - + xh => s% xh q => s% q dq => s% dq @@ -263,13 +263,13 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) if (ASSOCIATED(s% xh_old)) deallocate(s% xh_old) if (ASSOCIATED(s% xh_start)) deallocate(s% xh_start) - + call allocate_star_info_arrays(s, ierr) if (ierr /= 0) then call dealloc return end if - + do k=1,nz do j=1,nvar_hydro s% xh(j,k) = xh(j,k) @@ -281,15 +281,15 @@ subroutine build_pre_ms_model(id, s, nvar_hydro, species, ierr) s% q(k) = q(k) s% dq(k) = dq(k) end do - + call dealloc - + contains - + subroutine dealloc deallocate(xh, q, dq) end subroutine dealloc - + end subroutine build_pre_ms_model @@ -300,17 +300,17 @@ real(dp) function pre_ms_f(lnd, dfdx, lrpar, rpar, lipar, ipar, ierr) integer, intent(inout), pointer :: ipar(:) ! (lipar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(out) :: ierr - + type (star_info), pointer :: s real(dp) :: rho_c, T_c, eps_grav, x, z, abar, zbar, d_log10_P real(dp), pointer :: xa(:) integer :: i, nz, species real(dp) :: mstar, mstar1 - + logical, parameter :: dbg = .false. - + include 'formats' - + ierr = 0 pre_ms_f = 0 if (lipar <= 0) then @@ -319,18 +319,18 @@ real(dp) function pre_ms_f(lnd, dfdx, lrpar, rpar, lipar, ipar, ierr) ierr = -1 return end if - + call get_star_ptr(ipar(1), s, ierr) if (ierr /= 0) return - + species = s% species if (associated(s% xh)) deallocate(s% xh) if (associated(s% q)) deallocate(s% q) if (associated(s% dq)) deallocate(s% dq) - + rho_c = exp(lnd) - + i = 1 ! rpar(1) for mstar result T_c = rpar(i+1); i = i+1 eps_grav = rpar(i+1); i = i+1 @@ -346,7 +346,7 @@ real(dp) function pre_ms_f(lnd, dfdx, lrpar, rpar, lipar, ipar, ierr) ierr = -1 return end if - + mstar = s% mstar ! desired value mstar1 = mstar ! to keep gfortran quiet @@ -360,12 +360,12 @@ real(dp) function pre_ms_f(lnd, dfdx, lrpar, rpar, lipar, ipar, ierr) end if s% nz = nz - + rpar(1) = mstar1 ! return the actual mass - + pre_ms_f = (mstar - mstar1) / mstar dfdx = 0 - + if (dbg) then write(*,1) 'rho_c', rho_c write(*,1) 'pre_ms_f', pre_ms_f @@ -396,7 +396,7 @@ subroutine build1_pre_ms_model( & real(dp), parameter :: LOGRHO_TOL = 1E-6_dp real(dp), parameter :: LOGPGAS_TOL = 1E-6_dp - + integer :: i, ii, k, j, prune, max_retries real(dp), parameter :: & delta_logPgas = 0.004d0, q_at_nz = 1d-5 @@ -412,34 +412,34 @@ subroutine build1_pre_ms_model( & grada0, grada_mid, mmid, Tmid, Lmid, & chiRho, chiT, Cp, grada, gradT, logT_surf_limit, logP_surf_limit real(dp), pointer :: xh(:,:), q(:), dq(:) ! model structure info - + logical, parameter :: dbg = .false. - + include 'formats' - + ierr = 0 - + logP_surf_limit = s% pre_ms_logP_surf_limit if (logP_surf_limit <= 0) logP_surf_limit = 3.5d0 P_surf_limit = exp10(logP_surf_limit) - + logT_surf_limit = s% pre_ms_logT_surf_limit if (logT_surf_limit <= 0) logT_surf_limit = 3.7d0 - + if (dbg) write(*,1) 'logT_surf_limit', logT_surf_limit cgrav = standard_cgrav - + eps_grav = eps_grav_in if (dbg) write(*,1) 'eps_grav', eps_grav - + if (d_log10_P_in == 0) then dlogPgas = delta_logPgas else dlogPgas = abs(d_log10_P_in) end if if (dbg) write(*,1) 'dlogPgas', dlogPgas - + call get_eos( & s, 0, xa, & rho_c, log10(rho_c), T_c, log10(T_c), & @@ -447,7 +447,7 @@ subroutine build1_pre_ms_model( & d_eos_dxa, ierr) if (ierr /= 0) return call unpack_eos_results - + logPgas = res(i_lnPgas)/ln10 Pgas = exp10(logPgas) P_c = Pgas + Radiation_Pressure(T_c) ! center pressure @@ -457,15 +457,15 @@ subroutine build1_pre_ms_model( & ! pressure at innermost point using K&W 10.6 P = P_c - 3*cgrav/(8*pi)*pow(pi4*rho_c/3,4d0/3d0)*pow(m,two_thirds) logP = log10(P) - + ! estimate nz from lgP nz = 1 + (logP - s% pre_ms_logP_surf_limit)/dlogPgas - + ! temperature at nz using K&W 10.9 assuming convective core lnT = log(T_c) - & pow(pi/6,one_third)*cgrav*grada*pow(rho_c*rho_c*m,two_thirds)/P_c T = exp(lnT) - + ! density at nz call solve_eos_given_PgasT_auto( & s, 0, xa, & @@ -474,16 +474,16 @@ subroutine build1_pre_ms_model( & ierr) if (ierr /= 0) return rho = exp10(logRho) - call unpack_eos_results + call unpack_eos_results r = pow(m/(pi4*rho/3),one_third) ! radius at nz - + y = 1 - (x+z) - + do - + L = eps_grav*m ! L at nz - + ! check for convective core call eval_gradT( & s, zbar, x, y, xa, rho, m, mstar, r, T, lnT, L, P, & @@ -492,33 +492,33 @@ subroutine build1_pre_ms_model( & eta, d_eta_dlnRho, d_eta_dlnT, & gradT, ierr ) if (ierr /= 0) return - + if (gradT >= grada) exit - + eps_grav = 1.1d0*eps_grav end do - + allocate(xh(s% nvar_hydro,nz), q(nz), dq(nz), stat=ierr) if (ierr /= 0) return s% xh => xh s% dq => dq s% q => q - + call store_lnd_in_xh(s, nz, logRho*ln10, xh) call store_lnT_in_xh(s, nz, lnT, xh) call store_r_in_xh(s, nz, r, xh) if (s% i_lum /= 0) xh(s% i_lum,nz) = L - + q(nz) = q_at_nz dq(nz) = q_at_nz - + if (dbg) write(*,*) 'nz', nz - - max_retries = 10 + + max_retries = 10 prune = 0 step_loop: do k = nz-1, 1, -1 - + try_dlogPgas = dlogPgas logPgas0 = logPgas P0 = P @@ -533,23 +533,23 @@ subroutine build1_pre_ms_model( & Cp0 = Cp grada0 = grada dm = 0 ! for gfortran - + if (dbg) write(*,3) 'step', k, nz, logPgas0 - + retry_loop: do j = 1, max_retries - + logPgas = logPgas0 - try_dlogPgas Pgas = exp10(logPgas) - + if (j > 1) write(*,2) 'retry', j, logPgas - + do i = 1, 2 - + Prad = Radiation_Pressure(T) P = Pgas + Prad - + rho_mid = (rho+rho0)/2 - + do ii = 1, 10 ! repeat to get hydrostatic balance rmid = pow((r*r*r + r0*r0*r0)/2,one_third) mmid = (m + m0)/2 @@ -559,17 +559,17 @@ subroutine build1_pre_ms_model( & r = pow(r0*r0*r0 + dm/(four_thirds_pi*rho_mid),one_third) if (dbg) write(*,2) 'r', ii, r, m, dm end do - + L = L0 + dm*eps_grav ! luminosity at point k Lmid = (L0+L)/2 - + Pmid = (P+P0)/2 - + chiRho_mid = (chiRho0 + chiRho)/2 chiT_mid = (chiT0 + chiT)/2 Cp_mid = (Cp0 + Cp)/2 grada_mid = (grada0 + grada)/2 - + do ii = 1, 2 Tmid = (T+T0)/2 call eval_gradT( & @@ -583,9 +583,9 @@ subroutine build1_pre_ms_model( & lnT = log(T) if (dbg) write(*,2) 'T', ii, T end do - + if (i == 2) exit - + call solve_eos_given_PgasT_auto( & s, 0, xa, & lnT/ln10, logPgas, LOGRHO_TOL, LOGPGAS_TOL, & @@ -594,40 +594,40 @@ subroutine build1_pre_ms_model( & rho = exp10(logRho) if (ierr /= 0) return call unpack_eos_results - + end do - + if (lnT <= logT_surf_limit*ln10) then if (dbg) write(*,*) 'have reached lgT_surf_limit', lnT/ln10, logT_surf_limit prune = k exit step_loop end if - + if (P <= P_surf_limit) then if (dbg) write(*,1) 'have reached P_surf limit', P, P_surf_limit prune = k exit step_loop end if - + call store_lnd_in_xh(s, k, logRho*ln10, xh) call store_lnT_in_xh(s, k, lnT, xh) call store_r_in_xh(s, k, r, xh) if (s% i_lum /= 0) xh(s% i_lum,k) = L q(k) = m/mstar dq(k) = dm/mstar - + if (dbg) then write(*,2) 'L', k, L write(*,2) 'q(k)', k, q(k) write(*,2) 'dq(k)', k, dq(k) end if - + exit retry_loop - + end do retry_loop - + end do step_loop - + if (prune > 0) then ! move stuff and reduce nz if (dbg) write(*,*) 'prune', prune do k=1,nz-prune @@ -639,9 +639,9 @@ subroutine build1_pre_ms_model( & nz = nz-prune if (dbg) write(*,*) 'final nz', nz end if - + mstar = m ! actual total mass - + if (.not. s% do_normalize_dqs_as_part_of_set_qs) then call normalize_dqs(s, nz, dq, ierr) if (ierr /= 0) then @@ -656,8 +656,8 @@ subroutine build1_pre_ms_model( & end if contains - - + + subroutine unpack_eos_results chiRho = res(i_chiRho) chiT = res(i_chiT) @@ -670,11 +670,11 @@ subroutine unpack_eos_results d_eta_dlnRho = d_eos_dlnd(i_eta) d_eta_dlnT = d_eos_dlnT(i_eta) end subroutine unpack_eos_results - + end subroutine build1_pre_ms_model - - + + subroutine eval_gradT( & s, zbar, x, y, xa, rho, m, mstar, r, T, lnT, L, P, & chiRho, chiT, Cp, grada, & @@ -695,13 +695,13 @@ subroutine eval_gradT( & real(dp), intent(out) :: gradT integer, intent(out) :: ierr - + real(dp) :: dlnkap_dlnd, dlnkap_dlnT, gradL_composition_term, & opacity, grav, scale_height, scale_height2, gradr, cgrav real(dp) :: kap_fracs(num_kap_fracs), dlnkap_dxa(s% species) real(dp) :: Y_face, conv_vel, D, Gamma ! Not used integer :: mixing_type - + ierr = 0 if (s% use_simple_es_for_kap) then @@ -720,7 +720,7 @@ subroutine eval_gradT( & return end if end if - + gradL_composition_term = 0d0 cgrav = standard_cgrav grav = cgrav*m/pow2(r) @@ -731,15 +731,15 @@ subroutine eval_gradT( & scale_height = scale_height2 end if end if - gradr = P*opacity*L/(16d0*pi*clight*m*cgrav*crad*pow4(T)/3d0) - + gradr = P*opacity*L/(16d0*pi*clight*m*cgrav*crad*pow4(T)/3d0) + call get_gradT(s, s% MLT_option, & ! used to create models r, L, T, P, opacity, rho, chiRho, chiT, Cp, gradr, grada, scale_height, & s% net_iso(ih1), x, standard_cgrav, m, gradL_composition_term, s% mixing_length_alpha, & mixing_type, gradT, Y_face, conv_vel, D, Gamma, ierr) - + end subroutine eval_gradT end module pre_ms_model - + diff --git a/star/private/predictive_mix.f90 b/star/private/predictive_mix.f90 index f823c43c8..6ed00ebb1 100644 --- a/star/private/predictive_mix.f90 +++ b/star/private/predictive_mix.f90 @@ -111,7 +111,7 @@ subroutine add_predictive_mixing (s, ierr) match_zone_type = .NOT. ( & s%burn_h_conv_region(i) .OR. & s%burn_he_conv_region(i) .OR. & - s%burn_z_conv_region(i) ) + s%burn_z_conv_region(i) ) case ('any') match_zone_type = .true. case default @@ -127,7 +127,7 @@ subroutine add_predictive_mixing (s, ierr) else is_surf_zone = s%conv_bdy_loc(i+1) == 1 endif - + select case (s%predictive_zone_loc(j)) case ('core') match_zone_loc = is_core_zone @@ -160,7 +160,7 @@ subroutine add_predictive_mixing (s, ierr) if (s%conv_bdy_q(i) < s%predictive_bdy_q_min(j) .OR. & s%conv_bdy_q(i) > s%predictive_bdy_q_max(j)) cycle criteria_loop - + if (dbg) then write(*,*) 'Predictive mixing at convective boundary: i, j=', i, j write(*,*) ' s%predictive_zone_type=', TRIM(s%predictive_zone_type(j)) @@ -222,13 +222,13 @@ subroutine do_predictive_mixing (s, i, j, ierr, mix_mask) logical, parameter :: dbg = .false. logical, parameter :: DUMP_PREDICTIONS = .false. - real(dp) :: superad_thresh + real(dp) :: superad_thresh real(dp) :: ingest_factor integer :: iso_id integer :: iso_r integer :: iso_i integer :: k_bot_cz - integer :: k_top_cz + integer :: k_top_cz integer :: k_bot_ez integer :: k_top_ez integer :: k_bot_mz @@ -310,7 +310,7 @@ subroutine do_predictive_mixing (s, i, j, ierr, mix_mask) end if k_bot_cz = s%conv_bdy_loc(i-1) - 1 endif - + k_top_cz = s%conv_bdy_loc(i) else @@ -341,7 +341,7 @@ subroutine do_predictive_mixing (s, i, j, ierr, mix_mask) ! Determine average abundances of the initial convection zone call eval_abundances(s, k_bot_cz, k_top_cz, xa_cz, xa_cz_burn) - + ! Decide whether we are starting in the "Ledoux extension" phase, ! where the boundary moves to where it would be if the ! Schwarzschild (rather than Ledoux) criterion had been used in @@ -356,10 +356,10 @@ subroutine do_predictive_mixing (s, i, j, ierr, mix_mask) k_top_ez = k_top_cz call eval_abundances(s, k_bot_ez, k_top_ez, xa_ez, xa_ez_burn) - + ! Begin the predictive mixing search, expanding the extent of the ! mixed zone until one of a number of criteria are met - + outward = s%top_conv_bdy(i) k_bot_mz = k_bot_cz @@ -424,7 +424,7 @@ subroutine do_predictive_mixing (s, i, j, ierr, mix_mask) ! Check whether the predictive mixing will lead to a ! reversal in the abundance evolution of isotope iso_r due ! to nuclear burning; if so, finish the search. - + if (iso_r /= 0) then if (SIGN(1._dp, xa_mz_burn(iso_r)-xa_ez(iso_r)) /= SIGN(1._dp, xa_ez_burn(iso_r)-xa_ez(iso_r))) then @@ -438,7 +438,7 @@ subroutine do_predictive_mixing (s, i, j, ierr, mix_mask) ! Check whether the predictive mixing will cause the ! ingestion rate for isotope iso_i to exceed the limit - + if (iso_i /= 0) then ! Calculate the mass ingested @@ -511,7 +511,7 @@ subroutine do_predictive_mixing (s, i, j, ierr, mix_mask) close(unit) print *,'Writing prediction data to file:',TRIM(filename) end if - + ! Back off the mixing by one zone if (outward) then @@ -590,7 +590,7 @@ subroutine do_predictive_mixing (s, i, j, ierr, mix_mask) else rho = s%rho(k) endif - + cdc = (pi4*s%r(k)*s%r(k)*rho)*(pi4*s%r(k)*s%r(k)*rho)*D(k) ! gm^2/sec s%cdc(k) = cdc @@ -626,7 +626,7 @@ subroutine do_predictive_mixing (s, i, j, ierr, mix_mask) dg0 = grada(k_b) - gradr(k_b) dg1 = s%grada_face(k_b+1) - s%gradr(k_b+1) - + if (dg0*dg1 < 0) then s%cz_bdy_dq(k_bot_mz) = find0(0._dp, dg0, s%dq(k_bot_mz), dg1) if (s%cz_bdy_dq(k_bot_mz) < 0._dp .or. s%cz_bdy_dq(k_bot_mz) > s%dq(k_bot_mz)) then @@ -688,9 +688,9 @@ subroutine eval_abundances (s, k_bot, k_top, xa, xa_burn) return end subroutine eval_abundances - + !**** - + subroutine eval_mixing_coeffs (s, k_bot_mz, k_top_mz, xa_mx, k_a, k_b, D, vc, grada, gradr, ierr) use eos_def @@ -950,7 +950,7 @@ subroutine eval_eos (s, k, z, x, abar, zbar, xa, & lnfree_e = res(i_lnfree_e) ! Finish - + return end subroutine eval_eos @@ -981,7 +981,7 @@ subroutine eval_ingest_limit (s, grada, gradr, ingest_factor, k, m_ingest_limit) alfa = s%dq(k-1)/(s%dq(k-1) + s%dq(k)) end if beta = 1._dp - alfa - + T_face = alfa*s%T(k) + beta*s%T(k-1) ! Evaluate the limit diff --git a/star/private/profile.f90 b/star/private/profile.f90 index 253507b83..267ee44eb 100644 --- a/star/private/profile.f90 +++ b/star/private/profile.f90 @@ -94,7 +94,7 @@ recursive subroutine add_profile_columns( & end if open(newunit=iounit, file=trim(filename), action='read', status='old', iostat=ierr) - if (ierr /= 0) then + if (ierr /= 0) then write(*,*) 'failed to open ' // trim(profile_columns_file) return end if @@ -137,25 +137,25 @@ recursive subroutine add_profile_columns( & ierr = -1; call error; return end if call count_specs - + case ('add_eps_neu_rates') call insert_spec(eps_neu_rate_offset, 'add_eps_neu_rate', spec_err) if (spec_err /= 0) then ierr = -1; call error; return end if - + case ('add_eps_nuc_rates') call insert_spec(eps_nuc_rate_offset, 'add_eps_nuc_rate', spec_err) if (spec_err /= 0) then ierr = -1; call error; return end if - + case ('add_screened_rates') call insert_spec(screened_rate_offset, 'add_screened_rates', spec_err) if (spec_err /= 0) then ierr = -1; call error; return end if - + case ('add_raw_rates') call insert_spec(raw_rate_offset, 'add_raw_rates', spec_err) if (spec_err /= 0) then @@ -297,8 +297,8 @@ subroutine set_profile_columns(id, profile_columns_file, report, ierr) if (dbg) write(*,*) 'num profile columns', cnt-1 if (dbg) call mesa_error(__FILE__,__LINE__,'debug: set_profile_columns') end subroutine set_profile_columns - - + + integer function do_get_num_standard_profile_columns(s) ! not inluding extra profile columns use star_def, only: star_info type (star_info), pointer :: s @@ -314,8 +314,8 @@ integer function do_get_num_standard_profile_columns(s) ! not inluding extra pro s% profile_column_spec(j) == add_log_abundances) then numcols = numcols + s% species else if (s% profile_column_spec(j) == raw_rate_offset .or. & - s% profile_column_spec(j) == screened_rate_offset .or. & - s% profile_column_spec(j) == eps_nuc_rate_offset .or. & + s% profile_column_spec(j) == screened_rate_offset .or. & + s% profile_column_spec(j) == eps_nuc_rate_offset .or. & s% profile_column_spec(j) == eps_neu_rate_offset) then numcols = numcols + s% num_reactions else @@ -370,7 +370,7 @@ subroutine do_profile_info(s, fname, & use pulse, only: export_pulse_data use math_lib, only: math_backend use utils_lib, only: mkdir, folder_exists - + type (star_info), pointer :: s character (len=*) :: fname logical, intent(in) :: write_flag @@ -417,7 +417,7 @@ subroutine do_profile_info(s, fname, & write(*,*) 'WARNING: do not have any output specified for profiles.' return end if - + numcols = do_get_num_standard_profile_columns(s) num_extra_cols = s% how_many_extra_profile_columns(s% id) @@ -579,7 +579,7 @@ subroutine do_profile_info(s, fname, & call do_val(i, 'time_seconds', s% time) call do_string(i, 'version_number', version_number) - + if (s% profile_header_include_sys_details) then ! make this optional call do_string(i, 'compiler', compiler_name) call do_string(i, 'build', compiler_version_name) @@ -725,7 +725,7 @@ subroutine do_profile_info(s, fname, & contains - + subroutine do_string(pass, col_name, val) integer, intent(in) :: pass character (len=*), intent(in) :: col_name, val diff --git a/star/private/profile_getval.f90 b/star/private/profile_getval.f90 index 76a4c8931..c937ae1df 100644 --- a/star/private/profile_getval.f90 +++ b/star/private/profile_getval.f90 @@ -206,7 +206,7 @@ subroutine do1_rate(offset) ! raw_rate, screened_rate, eps_nuc_rate, eps_neu_rat ierr = -1; return end if id = rates_reaction_id(string) - id = g% net_reaction(id) ! Convert to net id not the gloabl rate id + id = g% net_reaction(id) ! Convert to net id not the gloabl rate id if (id > 0) then spec = offset + id return @@ -269,7 +269,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) use ionization_def use mod_typical_charge, only: eval_typical_charge use rsp_def, only: rsp_WORK, rsp_WORKQ, rsp_WORKT, rsp_WORKC - + type (star_info), pointer :: s integer, intent(in) :: c, k real(dp), intent(out) :: val @@ -307,7 +307,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) int_flag = .false. rsp_or_w = s% RSP_flag .or. s% RSP2_flag - + if (c > extra_offset) then i = c - extra_offset val = s% profile_extra(k,i) @@ -496,7 +496,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) else if (s% v_flag) then val = safe_log10(abs(s% v(k))) end if - + case (p_superad_reduction_factor) val = s% superad_reduction_factor(k) case (p_gradT_excess_effect) @@ -684,12 +684,12 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) case (p_ergs_rel_error_integral) if (s% total_energy_end /= 0d0) & val = sum(s% ergs_error(1:k))/s% total_energy_end - + case (p_cell_internal_energy_fraction) val = s% energy(k)*s% dm(k)/s% total_internal_energy_end case (p_cell_internal_energy_fraction_start) val = s% energy_start(k)*s% dm(k)/s% total_internal_energy_start - + case (p_dr_div_R) if (k < s% nz) then val = (s% r(k) - s% r(k+1))/s% r(1) @@ -709,7 +709,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) val = (s% r(k) - s% r_center)/s% r(1) end if val = safe_log10(val) - + case(p_t_rad) val = 1d0/(clight*s% opacity(k)*s% rho(k)) case(p_log_t_rad) @@ -945,7 +945,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) val = s% eos_frac_CMS(k) case (p_eos_frac_ideal) val = s% eos_frac_ideal(k) - + case (p_log_c_div_tau) val = safe_log10(clight/s% tau(k)) case (p_log_v_escape) @@ -995,7 +995,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) val = s% latent_ddlnT(k) case (p_latent_ddlnRho) val = s% latent_ddlnRho(k) - + case (p_chiRho_for_partials) val = s% chiRho_for_partials(k) case (p_chiT_for_partials) @@ -1031,7 +1031,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) val = s% eps_nuc(k) case (p_signed_log_eps_nuc) val = s% eps_nuc(k) - val = sign(1d0,val)*log10(max(1d0,abs(val))) + val = sign(1d0,val)*log10(max(1d0,abs(val))) case (p_log_abs_eps_nuc) val = safe_log10(abs(s% eps_nuc(k))) case (p_d_epsnuc_dlnd) @@ -1090,12 +1090,12 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) case (p_eps_grav_composition_term) if (s% include_composition_in_eps_grav) & val = s% eps_grav_composition_term(k) - + case (p_eps_grav_plus_eps_mdot) val = s% eps_grav_ad(k)% val + s% eps_mdot(k) case (p_ergs_eps_grav_plus_eps_mdot) val = (s% eps_grav_ad(k)% val + s% eps_mdot(k))*s% dm(k)*s% dt - + case (p_eps_mdot) val = s% eps_mdot(k) case (p_ergs_mdot) @@ -1186,7 +1186,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) val = s% eps_grav_ad(k)% val*s% dm(k) case (p_eps_grav) val = s% eps_grav_ad(k)% val - + case (p_log_xm_div_delta_m) if(abs(s% dt*s% mstar_dot) > 0) val = safe_log10((s% m(1) - s% m(k))/abs(s% dt*s% mstar_dot)) case (p_xm_div_delta_m) @@ -1279,7 +1279,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) case (p_log_D_thrm) if (s% mixing_type(k) == thermohaline_mixing) then val = safe_log10(s% D_mix_non_rotation(k)) - else + else val = -99 end if @@ -1289,7 +1289,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) else val = -99 end if - + case (p_log_lambda_RTI_div_Hrho) if (s% RTI_flag) val = safe_log10( & sqrt(s% alpha_RTI(k))*s% r(k)/s% rho(k)*abs(s% dRhodr_info(k))) @@ -1299,7 +1299,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) if (s% RTI_flag) val = s% dPdr_info(k) case (p_dRhodr_info) if (s% RTI_flag) val = s% dRhodr_info(k) - + case (p_source_plus_alpha_RTI) if (s% RTI_flag) val = s% source_plus_alpha_RTI(k) case (p_log_source_plus_alpha_RTI) @@ -1339,7 +1339,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) case (p_log_D_omega) if (s% rotation_flag) val = safe_log10(s% D_omega(k)) - + case (p_log_D_mix_non_rotation) val = safe_log10(s% D_mix_non_rotation(k)) case (p_log_D_mix_rotation) @@ -1366,7 +1366,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) case (p_conv_vel_div_mlt_vc) if (s% mlt_vc(k) > 0d0) val = s% conv_vel(k)/s% mlt_vc(k) - + case (p_conv_vel) val = s% conv_vel(k) case (p_dt_times_conv_vel_div_mixing_length) @@ -1643,7 +1643,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) val = s% gradr(k) - s% gradT(k) case (p_gradT_sub_gradr) val = s% gradT(k) - s% gradr(k) - + case (p_gradT_rel_err) if (k > 1) then val = (s% lnT(k-1) - s% lnT(k))/(s% lnPeos(k-1) - s% lnPeos(k)) @@ -1853,7 +1853,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) val = s% RSP_w(k) else val = s% mlt_vc(k)/sqrt_2_div_3 - end if + end if case(p_log_w) if (s% RSP2_flag) then val = get_w(s,k) @@ -1861,14 +1861,14 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) val = s% RSP_w(k) else val = s% mlt_vc(k)/sqrt_2_div_3 - end if - val = safe_log10(val) + end if + val = safe_log10(val) case(p_etrb) if (s% RSP2_flag) then val = get_etrb(s,k) else if (s% RSP_flag) then val = s% RSP_Et(k) - end if + end if case(p_log_etrb) if (s% RSP2_flag) then val = safe_log10(get_etrb(s,k)) @@ -1901,7 +1901,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) if (rsp_or_w) val = s% Lt(k) case(p_Lt_div_L) if (rsp_or_w) val = s% Lt(k)/s% L(k) - + case(p_rsp_Et) if (s% rsp_flag) val = s% RSP_Et(k) @@ -1962,7 +1962,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) else ! for plotting, use value at k=2 val = s% Uq(2) end if - end if + end if case(p_rsp_Lr) if (s% rsp_flag) val = s% Fr(k)*pi4*s% r(k)*s% r(k) case(p_rsp_Lr_div_L) @@ -2002,7 +2002,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) end if case (p_total_energy) ! specific total energy at k - val = eval_cell_section_total_energy(s,k,k)/s% dm(k) + val = eval_cell_section_total_energy(s,k,k)/s% dm(k) case (p_total_energy_sign) ! specific total energy at k val = eval_cell_section_total_energy(s,k,k) if (val > 0d0) then @@ -2011,10 +2011,10 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) int_val = -1 else int_val = 0 - end if + end if val = dble(int_val) int_flag = .true. - + case (p_cell_specific_IE) val = s% energy(k) case (p_cell_ie_div_star_ie) @@ -2032,7 +2032,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) case (p_cell_IE_div_IE_plus_KE) val = s% energy(k)/(s% energy(k) + cell_specific_KE(s,k,d_dv00,d_dvp1)) - + case (p_cell_KE_div_IE_plus_KE) f = cell_specific_KE(s,k,d_dv00,d_dvp1) val = f/(s% energy(k) + f) @@ -2204,7 +2204,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) if (abs(s% u_face_ad(k)%val) > 1d0) & val = safe_log10(abs(s% RTI_du_diffusion_kick(k)/s% u_face_ad(k)%val)) end if - + case(p_log_dt_div_tau_conv) val = safe_log10(s% dt/max(1d-20,conv_time_scale(s,k))) case(p_dt_div_tau_conv) @@ -2217,7 +2217,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) val = eps_nuc_time_scale(s,k) case(p_tau_cool) val = cooling_time_scale(s,k) - + case(p_max_abs_xa_corr) val = s% max_abs_xa_corr(k) @@ -2234,7 +2234,7 @@ subroutine getval_for_profile(s, c, k, val, int_flag, int_val) contains - + real(dp) function get_L_vel(k) result(v) ! velocity if L carried by convection integer, intent(in) :: k diff --git a/star/private/pulse.f90 b/star/private/pulse.f90 index 97ab17943..a3e77d401 100644 --- a/star/private/pulse.f90 +++ b/star/private/pulse.f90 @@ -39,7 +39,7 @@ module pulse use pulse_gr1d ! No implicit typing - + implicit none ! Access specifiers @@ -174,7 +174,7 @@ subroutine write_pulse_data (id, data_format, filename, global_data, point_data, real(dp), intent(in) :: global_data(:) real(dp), intent(in) :: point_data(:,:) integer, intent(out) :: ierr - + ! Write pulsation data select case (StrLowCase(data_format)) diff --git a/star/private/pulse_cafein.f90 b/star/private/pulse_cafein.f90 index c7b0fcb54..85136383b 100644 --- a/star/private/pulse_cafein.f90 +++ b/star/private/pulse_cafein.f90 @@ -173,7 +173,7 @@ subroutine get_cafein_data (id, & call store_point_data_atm(j, k) j = j + 1 end do atm_loop - + ! Envelope env_loop : do k = 1, n_env @@ -211,7 +211,7 @@ subroutine get_cafein_data (id, & V => point_data(14,:), & nabla_ad => point_data(15,:), & c_2_fit => point_data(22,:), & - dlnLr_dlnr => point_data(25,:), & + dlnLr_dlnr => point_data(25,:), & surf_r_rad_beg => point_data(27,:), & surf_r_rad_end => point_data(28,:), & U_U_surf => point_data(34,:), & @@ -365,7 +365,7 @@ subroutine store_point_data_atm (j, k) kap_T = s%atm_structure(atm_dlnkap_dlnT,k) kap_ad = nabla_ad*kap_T + kap_rho/Gamma_1 kap_S = kap_T - delta*kap_rho - + eps = 0d0 eps_ad = 0d0 eps_S = 0d0 @@ -453,7 +453,7 @@ subroutine store_point_data_env (j, k) m = s%m_grav(k) r = s%r(k) l = s%L(k) - + if (s%interpolate_rho_for_pulse_data) then rho = eval_face(s%dq, s%rho, k, 1, s%nz) else @@ -480,7 +480,7 @@ subroutine store_point_data_env (j, k) kap_T = eval_face(s%dq, s%d_opacity_dlnT, k, 1, s%nz)/kap kap_ad = nabla_ad*kap_T + kap_rho/Gamma_1 kap_S = kap_T - delta*kap_rho - + eps = eval_face(s%dq, s%eps_nuc, k, 1, s%nz) if (ABS(eps) > 1D-99) then eps_rho = eval_face(s%dq, s%d_epsnuc_dlnd, k, 1, s%nz)/eps @@ -496,7 +496,7 @@ subroutine store_point_data_env (j, k) N2 = eval_face_A_ast(s, k, 1, s%nz)*g/r L2_ll1 = Gamma_1*P/(rho*r**2) P_scale = s%scale_height(k) - + V = rho*g*r/P V_g = V/Gamma_1 As = N2*r/g @@ -508,7 +508,7 @@ subroutine store_point_data_env (j, k) c_2 = (kap_ad - 4d0*nabla_ad)*V*nabla ! Note -- we omit the nabla_ad*(dnabla_ad + V) term for now c_3 = pi4*r**3*rho*eps/l_rad(j) c_4 = pi4*r**3*rho*T*c_P/l_rad(j)*SQRT(s%cgrav(1)*M_star/R_star**3) - + end associate ! Finish @@ -592,7 +592,7 @@ subroutine store_point_data_ctr (j) entropy = exp(eval_center(s%rmid, s%lnS, 1, s%nz)) chi_rho = eval_center(s%rmid, s%chiRho, 1, s%nz) chi_T = eval_center(s%rmid, s%chiT, 1, s%nz) - + kap = eval_center(s%rmid, s%opacity, 1, s%nz) kap_rho = eval_center(s%rmid, s%d_opacity_dlnd, 1, s%nz)/kap kap_T = eval_center(s%rmid, s%d_opacity_dlnT, 1, s%nz)/kap @@ -609,12 +609,12 @@ subroutine store_point_data_ctr (j) endif eps_ad = nabla_ad*eps_T + eps_rho/Gamma_1 eps_S = eps_T - delta*eps_rho - + g = 0d0 N2 = 0d0 L2_ll1 = HUGE(0d0) P_scale = eval_center(s%r, s%scale_height, 1, s%nz) - + V = 0d0 V_g = 0d0 As = 0d0 @@ -676,7 +676,7 @@ function log_deriv (x, y, dy_a, dy_b) result (dy) return end function log_deriv - + end subroutine get_cafein_data !**** @@ -741,7 +741,7 @@ subroutine write_cafein_data (id, filename, global_data, point_data, ierr) ! Finish ! Close the file - + close(iounit) ! Finish diff --git a/star/private/pulse_fgong.f90 b/star/private/pulse_fgong.f90 index 7f6c35b4e..60139f829 100644 --- a/star/private/pulse_fgong.f90 +++ b/star/private/pulse_fgong.f90 @@ -211,7 +211,7 @@ subroutine get_fgong_data (id, & allocate(point_data(IVAR,nn)) point_data = 0d0 - + j = 1 ! Atmosphere (we skip the point at the base of the atm to smooth @@ -221,7 +221,7 @@ subroutine get_fgong_data (id, & call store_point_data_atm(j, k, k_a(1), k_b(1)) j = j + 1 end do atm_loop - + ! Envelope sg = 1 @@ -239,7 +239,7 @@ subroutine get_fgong_data (id, & call store_point_data_env(j, k, k_a(sg), k_b(sg)) j = j + 1 - + endif end do env_loop @@ -445,7 +445,7 @@ subroutine store_point_data_env (j, k, k_a, k_b) X_O17 => point_data(34,j), & X_O18 => point_data(35,j), & X_Ne20 => point_data(36,j)) - + r = s%r(k) lnq = log(s%m_grav(k)/m_outer) T = eval_face(s%dq, s%T, k, 1, s%nz) @@ -537,7 +537,7 @@ subroutine store_point_data_ctr (j, k_a, k_b) integer, intent(in) :: j integer, intent(in) :: k_a integer, intent(in) :: k_b - + ! Store data for the center into the point_data array at position j associate ( & @@ -576,7 +576,7 @@ subroutine store_point_data_ctr (j, k_a, k_b) X_O17 => point_data(34,j), & X_O18 => point_data(35,j), & X_Ne20 => point_data(36,j)) - + r = 0d0 lnq = log(TINY(0d0)) T = eval_center(s%rmid, s%T, 1, s%nz) diff --git a/star/private/pulse_gr1d.f90 b/star/private/pulse_gr1d.f90 index 94ae658a2..26211d583 100644 --- a/star/private/pulse_gr1d.f90 +++ b/star/private/pulse_gr1d.f90 @@ -191,7 +191,7 @@ subroutine write_gr1d_data (id, filename, global_data, point_data, ierr) end do ! Close the file - + close(iounit) ! Finish diff --git a/star/private/pulse_gsm.f90 b/star/private/pulse_gsm.f90 index 82dbe15fc..b2d0c7b43 100644 --- a/star/private/pulse_gsm.f90 +++ b/star/private/pulse_gsm.f90 @@ -80,7 +80,7 @@ subroutine write_gsm_data (id, filename, global_data, point_data, ierr) call hi%write_attr('M_star', global_data(1)) call hi%write_attr('R_star', global_data(2)) call hi%write_attr('L_star', global_data(3)) - + call hi%write_attr('version', s%gyre_data_schema) select case(s%gyre_data_schema) @@ -133,7 +133,7 @@ subroutine write_gsm_data (id, filename, global_data, point_data, ierr) ! Close the file call hi%final() - + ! Finish ierr = 0 diff --git a/star/private/pulse_gyre.f90 b/star/private/pulse_gyre.f90 index ce6298d01..15c40f38e 100644 --- a/star/private/pulse_gyre.f90 +++ b/star/private/pulse_gyre.f90 @@ -234,7 +234,7 @@ subroutine get_gyre_data (id, & call store_point_data_atm(j, k) j = j + 1 end do atm_loop - + ! Envelope sg = 1 @@ -252,7 +252,7 @@ subroutine get_gyre_data (id, & call store_point_data_env(j, k, k_a(sg), k_b(sg)) j = j + 1 - + endif end do env_loop @@ -330,7 +330,7 @@ subroutine store_point_data_atm (j, k) return end subroutine store_point_data_atm - + !**** subroutine store_point_data_env (j, k, k_a, k_b) @@ -436,7 +436,7 @@ subroutine store_point_data_ctr (j, k_a, k_b) return end subroutine store_point_data_ctr - + end subroutine get_gyre_data !**** @@ -491,7 +491,7 @@ subroutine write_gyre_data (id, filename, global_data, point_data, ierr) end do ! Close the file - + close(iounit) ! Finish diff --git a/star/private/pulse_osc.f90 b/star/private/pulse_osc.f90 index bdfd9c511..b4831c235 100644 --- a/star/private/pulse_osc.f90 +++ b/star/private/pulse_osc.f90 @@ -202,12 +202,12 @@ subroutine get_osc_data (id, & ! global_data(13) should be the initial rotation rate, but we lack ! that datum - + ! Store point data allocate(point_data(IVAR+IABUND,nn)) point_data = 0d0 - + j = 1 ! Atmosphere (we skip the point at the base of the atm to @@ -217,7 +217,7 @@ subroutine get_osc_data (id, & call store_point_data_atm(j, k, k_a(1), k_b(1)) j = j + 1 end do atm_loop - + ! Envelope sg = 1 @@ -235,7 +235,7 @@ subroutine get_osc_data (id, & call store_point_data_env(j, k, k_a(sg), k_b(sg)) j = j + 1 - + endif end do env_loop @@ -309,7 +309,7 @@ subroutine store_point_data_atm (j, k, k_a, k_b) X_O17 => point_data(34,j), & X_Be9 => point_data(35,j), & X_Si28 => point_data(36,j)) - + r = s%r(1) + s%atm_structure(atm_delta_r,k) lnq = log(s%m_grav(1)/m_outer) T = exp(s%atm_structure(atm_lnT,k)) @@ -412,7 +412,7 @@ subroutine store_point_data_env (j, k, k_a, k_b) X_O17 => point_data(34,j), & X_Be9 => point_data(35,j), & X_Si28 => point_data(36,j)) - + r = s%r(k) lnq = log(s%m_grav(k)/m_outer) T = eval_face(s%dq, s%T, k, 1, s%nz) diff --git a/star/private/pulse_saio.f90 b/star/private/pulse_saio.f90 index 7df1d4754..74b7723d9 100644 --- a/star/private/pulse_saio.f90 +++ b/star/private/pulse_saio.f90 @@ -115,7 +115,7 @@ subroutine get_saio_data (id, & ! Store global data allocate(global_data(4)) - + r_outer = Rsun*s%photosphere_r m_outer = s%m_grav(1) @@ -123,11 +123,11 @@ subroutine get_saio_data (id, & global_data(2) = log10(s%L(1)/Lsun) global_data(3) = log10(r_outer/Rsun) global_data(4) = s%star_age - + ! Store point data allocate(point_data(20,nn)) - + j = 1 ! Atmosphere (we skip the point at the base of the atm to @@ -137,7 +137,7 @@ subroutine get_saio_data (id, & call store_saio_data_atm(j, k, k_a(1), k_b(1)) j = j + 1 end do atm_loop - + ! Envelope sg = 1 @@ -155,7 +155,7 @@ subroutine get_saio_data (id, & call store_saio_data_env(j, k, k_a(sg), k_b(sg)) j = j + 1 - + endif end do env_loop @@ -347,7 +347,7 @@ subroutine write_saio_data (id, filename, global_data, point_data, ierr) end if ! Write the data - + nn = SIZE(point_data, 2) write(iounit, 100) nn, global_data diff --git a/star/private/pulse_utils.f90 b/star/private/pulse_utils.f90 index 0cf357c21..b216ae3f7 100644 --- a/star/private/pulse_utils.f90 +++ b/star/private/pulse_utils.f90 @@ -31,7 +31,7 @@ module pulse_utils use const_def use num_lib use star_utils - + ! No implicit typing implicit none @@ -107,7 +107,7 @@ subroutine set_segment_indices (s, k_a, k_b, include_last_face) endif else - + mask = .false. endif @@ -149,7 +149,7 @@ subroutine set_segment_indices (s, k_a, k_b, include_last_face) end subroutine set_segment_indices !**** - + real(dp) function eval_face (dq, v, k, k_a, k_b, v_lo, v_hi) result (v_face) real(dp), intent(in) :: dq(:) @@ -167,7 +167,7 @@ real(dp) function eval_face (dq, v, k, k_a, k_b, v_lo, v_hi) result (v_face) if (k < k_a .OR. k > k_b+1) call mesa_error(__FILE__,__LINE__,'eval_face: out-of-bounds interpolation') if (k_b == k_a) then - + ! Using a single cell v_face = v(k_a) @@ -175,7 +175,7 @@ real(dp) function eval_face (dq, v, k, k_a, k_b, v_lo, v_hi) result (v_face) else ! Using multiple cells - + if (k == k_a) then v_face = v(k_a) - dq(k_a)*(v(k_a+1) - v(k_a))/(dq(k_a+1) + dq(k_a)) elseif (k == k_a+1) then @@ -203,11 +203,11 @@ real(dp) function eval_face (dq, v, k, k_a, k_b, v_lo, v_hi) result (v_face) ! Finish return - + end function eval_face !**** - + real(dp) function eval_face_X (s, i, k, k_a, k_b) result (X_face) type(star_info), intent(in) :: s @@ -223,9 +223,9 @@ real(dp) function eval_face_X (s, i, k, k_a, k_b) result (X_face) if (k < k_a .OR. k > k_b+1) call mesa_error(__FILE__,__LINE__,'eval_face_X: out-of-bounds interpolation') if (i >= 1) then - + if (k_b == k_a) then - + ! Using a single cell X_face = s%xa(i,k_a) @@ -233,7 +233,7 @@ real(dp) function eval_face_X (s, i, k, k_a, k_b) result (X_face) else ! Using multiple cells - + if (k == k_a) then X_face = s%xa(i,k_a) - s%dq(k_a)*(s%xa(i,k_a+1) - s%xa(i,k_a))/(s%dq(k_a+1) + s%dq(k_a)) elseif (k == k_a+1) then @@ -261,7 +261,7 @@ real(dp) function eval_face_X (s, i, k, k_a, k_b) result (X_face) ! Finish return - + end function eval_face_X !**** @@ -302,7 +302,7 @@ real(dp) function eval_face_A_ast (s, k, k_a, k_b) result (A_ast_face) A_ast_1 = s%brunt_N2(k_b-1)*s%r(k_b-1)/s%grav(k_b) A_ast_2 = s%brunt_N2(k_b)*s%r(k_b)/s%grav(k_b) - + A_ast_face = A_ast_2 + s%dq(k_b)*(A_ast_2 - A_ast_1)/s%dq(k_b-1) else @@ -312,7 +312,7 @@ real(dp) function eval_face_A_ast (s, k, k_a, k_b) result (A_ast_face) endif end if - + ! Finish return @@ -380,7 +380,7 @@ end function eval_face_rho !**** real(dp) function eval_center (r, v, k_a, k_b, v_lo, v_hi) result (v_center) - + real(dp), intent(in) :: r(:) real(dp), intent(in) :: v(:) integer, intent(in) :: k_a @@ -466,7 +466,7 @@ real(dp) function eval_center_X (s, i, k_a, k_b) result (X_center) ! Using the innermost two cells/faces in k_a:k_b; fit a parabola, ! with dv/dr = 0 at the center - + r_1 = s%rmid(k_b) r_2 = s%rmid(k_b-1) @@ -496,7 +496,7 @@ end function eval_center_X !**** real(dp) function eval_center_rho (s, k_b) result (rho_center) - + type(star_info), intent(in) :: s integer, intent(in) :: k_b diff --git a/star/private/read_model.f90 b/star/private/read_model.f90 index ff62eff99..9089b8c93 100644 --- a/star/private/read_model.f90 +++ b/star/private/read_model.f90 @@ -56,7 +56,7 @@ module read_model integer, parameter :: increment_for_RTI_flag = 1 integer, parameter :: increment_for_RSP_flag = 3 integer, parameter :: increment_for_RSP2_flag = 1 - + integer, parameter :: max_increment = increment_for_rotation_flag & + increment_for_have_j_rot & + increment_for_have_mlt_vc & @@ -100,8 +100,8 @@ subroutine finish_load_model(s, restart, ierr) end if call set_m_and_dm(s) call set_m_grav_and_grav(s) - call set_dm_bar(s, nz, s% dm, s% dm_bar) - + call set_dm_bar(s, nz, s% dm, s% dm_bar) + call reset_epsnuc_vectors(s) s% star_mass = s% mstar/msun @@ -149,7 +149,7 @@ subroutine finish_load_model(s, restart, ierr) call fill_ad_with_zeros(s% u_face_ad,1,-1) call fill_ad_with_zeros(s% P_face_ad,1,-1) end if - + if (s% RSP_flag) then call RSP_setup_part1(s, restart, ierr) if (ierr /= 0) then @@ -161,8 +161,8 @@ subroutine finish_load_model(s, restart, ierr) if (.not. s% have_mlt_vc) then s% okay_to_set_mlt_vc = .true. end if - - s% doing_finish_load_model = .true. + + s% doing_finish_load_model = .true. call set_vars(s, s% dt, ierr) if (ierr == 0 .and. s% RSP2_flag) call set_RSP2_vars(s,ierr) s% doing_finish_load_model = .false. @@ -272,7 +272,7 @@ subroutine do_read_saved_model(s, filename, ierr) s% model_number = 0 s% star_age = 0 s% xmstar = -1 - + tau_factor = s% tau_factor Tsurf_factor = s% Tsurf_factor mixing_length_alpha = s% mixing_length_alpha @@ -300,7 +300,7 @@ subroutine do_read_saved_model(s, filename, ierr) write(*,*) 'species', species return end if - + s% init_model_number = s% model_number s% time = s% star_age*secyer @@ -340,7 +340,7 @@ subroutine do_read_saved_model(s, filename, ierr) write(*,1) 'but current setting for mixing_length_alpha =', s% mixing_length_alpha write(*,'(A)') end if - + s% v_flag = BTEST(file_type, bit_for_velocity) s% u_flag = BTEST(file_type, bit_for_u) s% rotation_flag = BTEST(file_type, bit_for_rotation) @@ -352,7 +352,7 @@ subroutine do_read_saved_model(s, filename, ierr) s% RSP_flag = BTEST(file_type, bit_for_RSP) s% RSP2_flag = BTEST(file_type, bit_for_RSP2) no_L = BTEST(file_type, bit_for_no_L_basic_variable) - + if (BTEST(file_type, bit_for_lnPgas)) then write(*,'(A)') write(*,*) 'MESA no longer supports models using lnPgas as a structure variable' @@ -384,7 +384,7 @@ subroutine do_read_saved_model(s, filename, ierr) 'do_read_saved_model failed in set_net for net_name = ' // trim(s% net_name) return end if - + call set_var_info(s, ierr) if (ierr /= 0) then write(*,*) 'do_read_saved_model failed in set_var_info' @@ -416,7 +416,7 @@ subroutine do_read_saved_model(s, filename, ierr) count = count+1 write(*,*) "Mod file has isotope ",trim(names(i)), " but that is not in the net" end if - end do + end do if (count/=0) call mesa_error(__FILE__,__LINE__) nvar = s% nvar_total @@ -469,7 +469,7 @@ subroutine read_prev_properties character (len=132) :: line real(dp) :: tmp, skip_val include 'formats' - + ierr = 0 s% dt = -1 s% mstar_old = -1 @@ -549,15 +549,15 @@ subroutine read1_model( & i_lnT = s% i_lnT i_lnR = s% i_lnR i_lum = s% i_lum - i_w = s% i_w - i_Hp = s% i_Hp + i_w = s% i_w + i_Hp = s% i_Hp i_v = s% i_v i_u = s% i_u i_alpha_RTI = s% i_alpha_RTI i_Et_RSP = s% i_Et_RSP i_erad_RSP = s% i_erad_RSP i_Fr_RSP = s% i_Fr_RSP - + n = species + nvar_hydro + 1 ! + 1 is for dq if (s% rotation_flag) n = n+increment_for_rotation_flag ! read omega if (s% have_j_rot) n = n+increment_for_have_j_rot ! read j_rot @@ -595,15 +595,15 @@ subroutine read1_model( & j = 1 j=j+1; xh(i_lnd,k) = vec(j) j=j+1; xh(i_lnT,k) = vec(j) - j=j+1; xh(i_lnR,k) = vec(j) + j=j+1; xh(i_lnR,k) = vec(j) if (s% RSP_flag) then j=j+1; xh(i_Et_RSP,k) = vec(j) j=j+1; xh(i_erad_RSP,k) = vec(j) j=j+1; xh(i_Fr_RSP,k) = vec(j) - else if (s% RSP2_flag) then + else if (s% RSP2_flag) then j=j+1; xh(i_w,k) = vec(j) j=j+1; xh(i_Hp,k) = vec(j) - end if + end if if (i_lum /= 0) then j=j+1; xh(i_lum,k) = vec(j) else @@ -654,10 +654,10 @@ subroutine read1_model( & write(*,*) 'read1_model_loop failed' return end if - + if (s% rotation_flag .and. .not. s% D_omega_flag) & s% D_omega(1:nz) = 0d0 - + if (s% rotation_flag .and. .not. s% am_nu_rot_flag) & s% am_nu_rot(1:nz) = 0d0 @@ -949,11 +949,11 @@ subroutine get_chem_col_names(s, iounit, species, names, perm, ierr) case default j1 = i; j2 = i name_loop: do - if (i+1 > n) exit - if (buffer(i+1:i+1) == ' ') exit - if (buffer(i+1:i+1) == '(') exit - if (buffer(i+1:i+1) == ')') exit - if (buffer(i+1:i+1) == ',') exit + if (i+1 > n) exit name_loop + if (buffer(i+1:i+1) == ' ') exit name_loop + if (buffer(i+1:i+1) == '(') exit name_loop + if (buffer(i+1:i+1) == ')') exit name_loop + if (buffer(i+1:i+1) == ',') exit name_loop i = i+1 j2 = i end do name_loop diff --git a/star/private/relax.f90 b/star/private/relax.f90 index 05f5d1b22..38cb3d647 100644 --- a/star/private/relax.f90 +++ b/star/private/relax.f90 @@ -365,7 +365,7 @@ subroutine do_relax_composition( & s% mix_factor = mix_factor s% do_element_diffusion = do_element_diffusion s% include_composition_in_eps_grav = include_composition_in_eps_grav - + call error_check('relax composition',ierr) deallocate(rpar) @@ -715,10 +715,10 @@ subroutine do_relax_entropy( & x(1:num_pts) => rpar(1:num_pts) f1(1:4*num_pts) => rpar(num_pts+1:lrpar) f(1:4,1:num_pts) => f1(1:4*num_pts) - + call store_rpar(num_pts, ierr) if (ierr /= 0) return - + ! need to use global variables, as relax_entropy uses ! the other_energy routine to which it can't pass rpar relax_num_pts = num_pts @@ -887,7 +887,7 @@ subroutine adjust_entropy(num_pts, avg_err, ierr) do k=1,nz entropy(k) = exp(s% lnS(k)) end do - + dentropy_sum = sum(abs((entropy(1:nz)-vals(1:nz))/vals(1:nz))) avg_err = dentropy_sum/nz deallocate(vals, xq, entropy) @@ -971,7 +971,7 @@ subroutine do_relax_angular_momentum( & f(1:4,1:num_pts) => f1(1:4*num_pts) call store_rpar(num_pts, ierr) if (ierr /= 0) return - + ! need to use global variables, as relax_angular_momentum uses ! the other_torque routine to which it can't pass rpar relax_num_pts = num_pts @@ -1237,7 +1237,7 @@ subroutine do_relax_uniform_omega( & call get_star_ptr(id, s, ierr) if (ierr /= 0) return - + if (.not. s% rotation_flag) return rpar(1) = target_value @@ -1644,13 +1644,13 @@ subroutine do_relax_Tsurf_factor(id, new_Tsurf_factor, dlogTsurf_factor, ierr) write(*,'(A)') call mesa_error(__FILE__,__LINE__,'do_relax_Tsurf_factor') end if - + if (new_Tsurf_factor == 1d0) then s% force_Tsurf_factor = 0d0 else s% force_Tsurf_factor = s% Tsurf_factor end if - + call error_check('relax tsurf factor',ierr) end subroutine do_relax_Tsurf_factor @@ -2144,11 +2144,11 @@ integer function relax_core_check_model(s, id, lipar, ipar, lrpar, rpar) write(*,1) 's% xmstar', s% xmstar write(*,'(A)') end if - + if(end_now) then relax_core_check_model = terminate s% termination_code = t_relax_finished_okay - return + return end if end function relax_core_check_model @@ -2410,7 +2410,7 @@ integer function relax_M_center_check_model(s, id, lipar, ipar, lrpar, rpar) if (mod(s% model_number, s% terminal_interval) == 0 .and. s% M_center>0.0) & write(*,1) 'relax_M_center target/current', new_mass/(s% M_center/Msun) - + end_now=.false. if (new_mass < s% star_mass) then next = exp10(safe_log10(s% star_mass) - dlgm_per_step) @@ -3125,7 +3125,7 @@ subroutine do_relax_opacity_max(id, new_value, per_step_multiplier, ierr) id, before_evolve_relax_opacity_max, & relax_opacity_max_adjust_model, relax_opacity_max_check_model, & null_finish_model, .true., lipar, ipar, lrpar, rpar, ierr) - + s% max_model_number = max_model_number s% opacity_max = new_value s% dt_next = rpar(1) ! keep dt from relax @@ -3318,7 +3318,7 @@ subroutine do_relax_num_steps(id, num_steps, max_timestep, ierr) include 'formats' ierr = 0 if (num_steps <= 0) return - + call get_star_ptr(id, s, ierr) if (ierr /= 0) return @@ -3377,7 +3377,7 @@ end function relax_num_steps_adjust_model integer function relax_num_steps_check_model(s, id, lipar, ipar, lrpar, rpar) use do_one_utils, only:do_bare_bones_check_model - + type (star_info), pointer :: s integer, intent(in) :: id, lipar, lrpar integer, intent(inout), pointer :: ipar(:) ! (lipar) @@ -3417,14 +3417,14 @@ subroutine do_relax_to_radiative_core(id, ierr) call get_star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% star_mass < s% job% pre_ms_check_radiative_core_min_mass) then write(*,*) 'stop relax to begin radiative core because star_mass < pre_ms_check_radiative_core_min_mass' return end if - + max_timestep = 1d3*secyer ! can provide a parameter for this if necessary - + write(*,'(A)') write(*,1) 'relax_to_radiative_core' write(*,'(A)') @@ -3701,17 +3701,17 @@ subroutine do_relax_Y(id, new_Y, dY, minq, maxq, ierr) ierr = 0 call get_star_ptr(id, s, ierr) if (ierr /= 0) return - + khi = k_for_q(s, minq) klo = k_for_q(s, maxq) - + y = eval_current_y(s, klo, khi, ierr) if (ierr /= 0) return if (is_bad(y)) then write(*,1) 'y', y call mesa_error(__FILE__,__LINE__,'do_relax_Y') end if - + if (abs(new_Y - y) <= 1d-6*new_Y) return if (new_Y < 0 .or. new_Y > 1) then ierr = -1 @@ -3784,14 +3784,14 @@ integer function relax_Y_check_model(s, id, lipar, ipar, lrpar, rpar) dy = rpar(2) minq = rpar(3) maxq = rpar(4) - + khi = k_for_q(s, minq) klo = k_for_q(s, maxq) if (ydbg) then write(*,4) 'klo, khi nz', klo, khi, s% nz end if - + current_y = eval_current_y(s, klo, khi, ierr) if (is_bad(current_y)) then write(*,1) 'current_y', current_y @@ -3951,7 +3951,7 @@ end function finish_model procedure(integer), pointer :: tmp_ptr1 => null(), tmp_ptr3 => null() procedure(), pointer :: tmp_ptr2 => null(), tmp_ptr4 => null() logical, parameter :: dbg = .false. - + include 'formats' ierr = 0 @@ -3980,26 +3980,26 @@ end function finish_model s% tol_correction_norm = s% relax_tol_correction_norm if (s% relax_tol_max_correction /= 0) & s% tol_max_correction = s% relax_tol_max_correction - + if (s% relax_iter_for_resid_tol2 /= 0) & s% iter_for_resid_tol2 = s% relax_iter_for_resid_tol2 if (s% relax_tol_residual_norm1 /= 0) & s% tol_residual_norm1 = s% relax_tol_residual_norm1 if (s% relax_tol_max_residual1 /= 0) & s% tol_max_residual1 = s% relax_tol_max_residual1 - + if (s% relax_iter_for_resid_tol3 /= 0) & s% iter_for_resid_tol3 = s% relax_iter_for_resid_tol3 if (s% relax_tol_residual_norm2 /= 0) & s% tol_residual_norm2 = s% relax_tol_residual_norm2 if (s% relax_tol_max_residual2 /= 0) & s% tol_max_residual2 = s% relax_tol_max_residual2 - + if (s% relax_tol_residual_norm3 /= 0) & s% tol_residual_norm3 = s% relax_tol_residual_norm3 if (s% relax_tol_max_residual3 /= 0) & s% tol_max_residual3 = s% relax_tol_max_residual3 - + if (s% relax_maxT_for_gold_tolerances /= 0) & s% maxT_for_gold_tolerances = s% relax_maxT_for_gold_tolerances @@ -4041,7 +4041,7 @@ end function finish_model first_try = .true. step_loop: do ! may need to repeat this loop for retry - + result = do_evolve_step_part1(id, first_try) if (result == keep_going) & result = adjust_model(s, id, lipar, ipar, lrpar, rpar) @@ -4069,12 +4069,12 @@ end function finish_model if(dbg) write(*,2) 'after step_loop: call update_pgstar_data', s% model_number call update_pgstar_data(s, ierr) if (failed()) return - call do_read_pgstar_controls(s, s% inlist_fname, ierr) + call do_read_pgstar_controls(s, s% inlist_fname, ierr) if (failed()) return call do_pgstar_plots( s, .false., ierr) if (failed()) return end if - + result = finish_model(s) if (result /= keep_going) exit evolve_loop @@ -4126,7 +4126,7 @@ end function finish_model if (associated(s% finished_relax)) call s% finished_relax(id) if (restore_at_end) call restore_stuff - + if (s% job% set_cumulative_energy_error_each_relax) & s% cumulative_energy_error = s% job% new_cumulative_energy_error @@ -4137,7 +4137,7 @@ end function finish_model s% model_number_for_last_retry = -100 contains - + logical function failed() failed = .false. if (ierr == 0) return @@ -4179,20 +4179,20 @@ subroutine save_stuff dt_next = s% dt_next max_number_retries = s% max_number_retries MLT_option = s% MLT_option - + use_gold2_tolerances = s% use_gold2_tolerances steps_before_use_gold2_tolerances = s% steps_before_use_gold2_tolerances use_gold_tolerances = s% use_gold_tolerances steps_before_use_gold_tolerances = s% steps_before_use_gold_tolerances solver_iters_timestep_limit = s% solver_iters_timestep_limit tol_correction_norm = s% tol_correction_norm - tol_max_correction = s% tol_max_correction + tol_max_correction = s% tol_max_correction iter_for_resid_tol2 = s% iter_for_resid_tol2 tol_residual_norm1 = s% tol_residual_norm1 - tol_max_residual1 = s% tol_max_residual1 + tol_max_residual1 = s% tol_max_residual1 iter_for_resid_tol3 = s% iter_for_resid_tol3 tol_residual_norm2 = s% tol_residual_norm2 - tol_max_residual2 = s% tol_max_residual2 + tol_max_residual2 = s% tol_max_residual2 tol_residual_norm3 = s% tol_residual_norm3 tol_max_residual3 = s% tol_max_residual3 maxT_for_gold_tolerances = s% maxT_for_gold_tolerances @@ -4236,7 +4236,7 @@ subroutine restore_stuff s% dt_next = dt_next s% max_number_retries = max_number_retries s% MLT_option = MLT_option - + s% use_gold2_tolerances = use_gold2_tolerances s% steps_before_use_gold2_tolerances = steps_before_use_gold2_tolerances s% use_gold_tolerances = use_gold_tolerances diff --git a/star/private/remove_shells.f90 b/star/private/remove_shells.f90 index 3b6c50c4f..fcce27b3f 100644 --- a/star/private/remove_shells.f90 +++ b/star/private/remove_shells.f90 @@ -217,11 +217,11 @@ subroutine do_remove_center_to_reduce_co56_ni56(id, x, ierr) do jj=2,species if (s% xa(jj,nz) > s% xa(j,nz)) j = jj end do - + s% xa(co56,nz) = x56_new*alfa_co56 s% xa(ni56,nz) = x56_new*(1d0 - alfa_co56) s% xa(j,nz) = s% xa(j,nz) - (x56_new - x56_old) - + write(*,1) 'new s% xa(co56,nz)', s% xa(co56,nz) write(*,1) 'new s% xa(ni56,nz)', s% xa(ni56,nz) mtotal = dot_product(s% dm(1:nz), & @@ -249,15 +249,15 @@ subroutine do_remove_fallback(id, ierr) real(dp) :: ie, ke, pe, rR, rL, rC, m_cntr, & sum_total_energy, speed_limit real(dp), pointer :: v(:) - + include 'formats' - + call get_star_ptr(id, s, ierr) if (ierr /= 0) then write(*,*) 'do_remove_fallback: get_star_ptr ierr', ierr return end if - + if (s% u_flag) then v => s% u else if (s% v_flag) then @@ -265,9 +265,9 @@ subroutine do_remove_fallback(id, ierr) else return end if - + nz = s% nz - + ! check to see how far extend fallback above innermost cell k0 = nz if (s% job% fallback_check_total_energy) then ! remove_bound_inner_region @@ -277,7 +277,7 @@ subroutine do_remove_fallback(id, ierr) do k = nz,1,-1 ie = s% energy(k)*s% dm(k) ke = 0.5d0*v(k)*v(k)*s% dm(k) - if (k == s% nz) then + if (k == s% nz) then rL = s% R_center else rL = s% r(k+1) @@ -330,11 +330,11 @@ subroutine do_remove_fallback(id, ierr) if (-v(k) < speed_limit*s% csound(k)) exit end do end if - + !call mesa_error(__FILE__,__LINE__,'do_remove_fallback') - + !write(*,3) 'k0 old nz', k0, s% nz, s% m(k0)/Msun - + ! remove cells k0..nz call do_remove_inner_fraction_q(id, s% q(k0), ierr) @@ -351,13 +351,13 @@ subroutine do_remove_center_by_logRho(id, logRho_limit, ierr) integer :: k, k0 real(dp) :: lnd_limit include 'formats' - + call get_star_ptr(id, s, ierr) if (ierr /= 0) then write(*,*) 'do_remove_center_by_logRho: get_star_ptr ierr', ierr return end if - + lnd_limit = logRho_limit*ln10 k0 = 0 do k = s% nz,1,-1 @@ -367,10 +367,10 @@ subroutine do_remove_center_by_logRho(id, logRho_limit, ierr) end if if (s% q(k) > 0.01d0) return end do - + ! k0 is innermost cell with density below limit ! search out from there for outermost with density too low - + do k = k0,1,-1 if (s% lnd(k) < lnd_limit) cycle call do_remove_inner_fraction_q(id, s% q(k), ierr) @@ -392,7 +392,7 @@ subroutine do_limit_center_logP(id, logP_limit, ierr) if (ierr /= 0) then write(*,*) 'do_limit_center_logP: get_star_ptr ierr', ierr return - end if + end if lnP_limit = logP_limit*ln10 k = s% nz if (s% lnPeos(k) > lnP_limit) then @@ -1002,7 +1002,7 @@ subroutine do_remove_surface(id, surface_k, ierr) write(*,*) 'remove surface currently requires model with inner boundary at true center of star' ierr = -1 call mesa_error(__FILE__,__LINE__,'do_remove_surface') - end if + end if call do_relax_to_star_cut( & id, surface_k, s% job% remove_surface_do_jrot, & s% job% remove_surface_do_entropy, & @@ -1121,9 +1121,9 @@ subroutine do_remove_surface(id, surface_k, ierr) if (dbg) write(*,1) 'do_remove_surface tau_factor, Tsurf_factor', & s% tau_factor, s% Tsurf_factor - + if (dbg) call mesa_error(__FILE__,__LINE__,'do_remove_surface') - + end subroutine do_remove_surface @@ -1143,7 +1143,7 @@ subroutine do_relax_to_star_cut( & integer, intent(in) :: id, k_remove logical, intent(in) :: do_jrot, do_entropy - logical, intent(in) :: turn_off_energy_sources_and_sinks + logical, intent(in) :: turn_off_energy_sources_and_sinks ! determines if we turn off non_nuc_neu and eps_nuc for entropy relax integer, intent(out) :: ierr @@ -1374,7 +1374,7 @@ subroutine do_relax_to_star_cut( & s% photo_interval = photo_interval deallocate(q, xq) - + s% need_to_setvars = .true. end subroutine do_relax_to_star_cut diff --git a/star/private/report.f90 b/star/private/report.f90 index 751a26d45..6c4f85ddf 100644 --- a/star/private/report.f90 +++ b/star/private/report.f90 @@ -78,8 +78,8 @@ subroutine set_power_info(s) end if end do end if - end do - + end do + if (s% eps_nuc_factor == 0d0) then s% power_nuc_burn = 0d0 s% power_nuc_neutrinos = 0d0 @@ -89,7 +89,7 @@ subroutine set_power_info(s) s% power_he_burn = 0d0 s% power_z_burn = 0d0 s% power_photo = 0d0 - else + else ! better if set power_nuc_burn using eps_nuc instead of categories ! categories can be subject to numerical jitters at very high temperatures s% power_nuc_burn = 0d0 @@ -101,14 +101,14 @@ subroutine set_power_info(s) end if s% power_nuc_burn = s% power_nuc_burn + eps_nuc*s% dm(k) end do - s% power_nuc_burn = s% power_nuc_burn/Lsun + s% power_nuc_burn = s% power_nuc_burn/Lsun s% power_nuc_neutrinos = dot_product(s% dm(1:nz),s% eps_nuc_neu_total(1:nz))/Lsun s% power_h_burn = s% L_by_category(ipp) + s% L_by_category(icno) s% power_he_burn = s% L_by_category(i3alf) s% power_z_burn = s% power_nuc_burn - (s% power_h_burn + s% power_he_burn) s% power_photo = s% L_by_category(iphoto) end if - + if (s% non_nuc_neu_factor == 0d0) then s% power_nonnuc_neutrinos = 0d0 else @@ -117,7 +117,7 @@ subroutine set_power_info(s) end if s% power_neutrinos = s% power_nuc_neutrinos + s% power_nonnuc_neutrinos s% L_nuc_burn_total = s% power_nuc_burn - + contains real(dp) function center_value_eps_burn(j) @@ -158,7 +158,7 @@ subroutine do_report(s, ierr) include 'formats' - ierr = 0 + ierr = 0 nz = s% nz net_iso => s% net_iso @@ -173,7 +173,7 @@ subroutine do_report(s, ierr) si28 = net_iso(isi28) co56 = net_iso(ico56) ni56 = net_iso(ini56) - + radius = s% r(1) ! radius in cm s% log_surface_radius = log10(radius/Rsun) ! log10(stellar radius in solar units) @@ -204,7 +204,7 @@ subroutine do_report(s, ierr) s% center_omega = center_value(s, s% omega) s% center_omega_div_omega_crit = center_omega_div_omega_crit() end if - + luminosity = s% L(1) if (s% u_flag) then @@ -216,7 +216,7 @@ subroutine do_report(s, ierr) end if call set_surf_avg_rotation_info(s) - + call set_min_gamma1(s) ! s% time is in seconds @@ -228,27 +228,27 @@ subroutine do_report(s, ierr) s% time_days = 0d0 s% time_years = 0d0 end if - + ! s% dt is in seconds s% time_step = s% dt/secyer ! timestep in years s% dt_years = s% dt/secyer s% dt_days = s% dt/secday - + mstar = s% mstar s% star_mass = mstar/Msun ! stellar mass in solar units s% kh_timescale = eval_kh_timescale(s% cgrav(1), mstar, radius, luminosity)/secyer ! kelvin-helmholtz timescale in years (about 1.6x10^7 for the sun) - + if (is_bad(s% kh_timescale)) then write(*,1) 's% kh_timescale', s% kh_timescale write(*,1) 's% cgrav(1)', s% cgrav(1) write(*,1) 'mstar', mstar write(*,1) 'radius', radius write(*,1) 'luminosity', luminosity - stop + stop end if - + if (luminosity > 0d0) then s% nuc_timescale = 1d10*s% star_mass/(luminosity/Lsun) else @@ -262,7 +262,7 @@ subroutine do_report(s, ierr) end if ! center_avg_x and surface_avg_x check if the species is not in the net - ! and set's the values to 0 if so. So dont check species here. + ! and set's the values to 0 if so. So dont check species here. s% center_h1 = center_avg_x(s,h1) s% surface_h1 = surface_avg_x(s,h1) s% center_he3 = center_avg_x(s,he3) @@ -304,7 +304,7 @@ subroutine do_report(s, ierr) if (s% stop_for_bad_nums) call mesa_error(__FILE__,__LINE__,'report') return end if - + if (s% u_flag) then v = s% u(k) else if (s% v_flag) then @@ -319,7 +319,7 @@ subroutine do_report(s, ierr) if (s% stop_for_bad_nums) call mesa_error(__FILE__,__LINE__,'report') return end if - + s% v_div_csound(k) = v/s% csound_face(k) if (is_bad(s% v_div_csound(k))) then ierr = -1 @@ -330,7 +330,7 @@ subroutine do_report(s, ierr) end if end do - + call set_phot_info(s) if (s% photosphere_r*Rsun >= s% r(1)) then @@ -353,10 +353,10 @@ subroutine do_report(s, ierr) s% delta_nu_sun*sqrt(s% star_mass)*pow3(s% Teff/s% astero_Teff_sun) / & pow(s% L_phot,0.75d0) end if - + call get_mass_info(s, s% dm, ierr) if (failed('get_mass_info')) return - + s% nu_max = s% nu_max_sun*s% star_mass/ & (pow2(s% photosphere_r)*sqrt(max(0d0,s% Teff)/s% astero_Teff_sun)) s% acoustic_cutoff = & @@ -416,12 +416,12 @@ subroutine do_report(s, ierr) if (s% m(k) < Msun * s% fe_core_mass) exit if(-velocity(k) > s% non_fe_core_infall) mass_sum = mass_sum + s% dm(k) end do - + if ((mass_sum > s% non_fe_core_infall_mass*msun) .and. & (s%m(k_min) <= s% he_core_mass * msun)) then s% non_fe_core_infall = -velocity(k_min) end if - + s% non_fe_core_rebound = maxval(velocity(s%he_core_k:s%fe_core_k),dim=1) end if @@ -457,7 +457,7 @@ subroutine set_mass_conv_core do k = j+1, s% n_conv_regions if (s% cz_bot_mass(k) - s% cz_top_mass(k-1) >= dm_limit) exit s% mass_conv_core = s% cz_top_mass(k)/Msun - end do + end do exit end if end do @@ -892,7 +892,7 @@ subroutine get_mass_info(s, cell_masses, ierr) s% star_mass_n14 = s% star_mass_n14 / Msun s% star_mass_o16 = s% star_mass_o16 / Msun s% star_mass_ne20 = s% star_mass_ne20 / Msun - + call get_core_info(s) call get_shock_info(s) @@ -991,7 +991,7 @@ subroutine get_mach1_location_info( & mach1_k = 0 return end if - + mach1_radius = r/Rsun mach1_k = k if (k < s% nz) then diff --git a/star/private/rotation_mix_info.f90 b/star/private/rotation_mix_info.f90 index f5341c0d3..a4d9d633d 100644 --- a/star/private/rotation_mix_info.f90 +++ b/star/private/rotation_mix_info.f90 @@ -259,13 +259,13 @@ subroutine set_rotation_mixing_info(s, ierr) end do !$OMP END PARALLEL DO if (failed('set_rotation_mixing_info instabilities', ierr)) return - + if (s% D_omega_flag .and. s% doing_finish_load_model) then do k=1,nz s% D_omega(k) = 0d0 end do else if (s% D_omega_flag) then - + do k=1,nz if (s% q(k) <= s% max_q_for_D_omega_zero_in_convection_region .and. & s% mixing_type(k) == convective_mixing) then @@ -302,7 +302,7 @@ subroutine set_rotation_mixing_info(s, ierr) call mesa_error(__FILE__,__LINE__,'rotation mix') end if end do - + if (s% smooth_D_omega > 0) then call smooth_for_rotation(s, s% D_omega, s% smooth_D_omega, smooth_work(1:nz,1)) do k=1,nz @@ -312,9 +312,9 @@ subroutine set_rotation_mixing_info(s, ierr) end if end do end if - + if (s% D_omega_mixing_rate > 0d0 .and. s% dt > 0) then - call mix_D_omega + call mix_D_omega do k=1,nz if (is_bad(s% D_omega(k))) then write(*,2) 'after mix_D_omega s% D_omega(k)', k, s% D_omega(k) @@ -322,9 +322,9 @@ subroutine set_rotation_mixing_info(s, ierr) end if end do end if - + end if - + if (s% D_omega_flag) then do k=1,nz if (is_bad(s% D_omega(k))) then @@ -337,8 +337,8 @@ subroutine set_rotation_mixing_info(s, ierr) contains - - + + subroutine mix_D_omega integer :: i, k, nz real(dp), dimension(:), allocatable :: & ! work vectors @@ -347,13 +347,13 @@ subroutine mix_D_omega dt, rate, d_ddt_dm1, d_ddt_d00, d_ddt_dp1, m, & d_dt, d_dt_in, d_dt_out include 'formats' - + nz = s% nz dt = s% dt if (dt == 0) return - + allocate(sig(nz), rhs(nz), d(nz), du(nz), dl(nz), bp(nz), vp(nz), xp(nz), x(nz)) - + rate = min(s% D_omega_mixing_rate, 1d0/dt) do k=2,nz-1 if (s% D_omega(k) == 0 .or. s% D_omega(k+1) == 0) then @@ -365,11 +365,11 @@ subroutine mix_D_omega sig(k) = 0 else sig(k) = rate*dt - end if + end if end do sig(1) = 0 sig(nz) = 0 - + do k=1,nz if (k < nz) then d_dt_in = sig(k)*(s% D_omega(k+1) - s% D_omega(k)) @@ -394,10 +394,10 @@ subroutine mix_D_omega else du(k) = 0 end if - if (k > 1) dl(k-1) = -d_ddt_dm1 + if (k > 1) dl(k-1) = -d_ddt_dm1 end do dl(nz) = 0 - + ! solve tridiagonal bp(1) = d(1) vp(1) = rhs(1) @@ -412,7 +412,7 @@ subroutine mix_D_omega xp(i) = (vp(i) - du(i)*xp(i+1))/bp(i) x(i) = xp(i) end do - + do k=2,nz if (is_bad(x(k))) then return @@ -420,9 +420,9 @@ subroutine mix_D_omega call mesa_error(__FILE__,__LINE__,'mix_D_omega') end if end do - + ! update D_omega - + do k=2,nz s% D_omega(k) = s% D_omega(k) + x(k) if (is_bad(s% D_omega(k))) then @@ -432,7 +432,7 @@ subroutine mix_D_omega if (s% D_omega(k) < 0d0) s% D_omega(k) = 0d0 end do s% D_omega(1) = 0d0 - + end subroutine mix_D_omega @@ -465,7 +465,7 @@ subroutine setup(ierr) grav => s% grav visc => s% D_visc Ri => s% richardson_number - + allocate( & csound(nz), rho(nz), T(nz), P(nz), cp(nz), cv(nz), chiRho(nz), abar(nz), zbar(nz), & opacity(nz), kap_cond(nz), gamma1(nz), mu_alt(nz), omega(nz), cell_dr(nz), eps_nuc(nz), enu(nz), L_neu(nz), & @@ -1236,14 +1236,14 @@ subroutine set_ST(s, & xmagnn = xmagnt*xmagft ! N^2 xmagwn = xmagw/sqrt(xmagnn) ! omega/N xmagkr2n = xkap/(xmagrn*xmagrn*sqrt(xmagnn)) ! kappa/(r^2 N) - + !xmagq1 = pow(xmager2w*xmagwn*pow3(xeta/xkap)/pow7(xmagwn),0.25D0) ! q_1 if(xmagwn > 1d-42) then ! fix from rob xmagq1 = pow(xmager2w*xmagwn*pow3(xeta/xkap)/pow7(xmagwn),0.25D0) ! q_1 else xmagq1 = 0d0 end if - + xmagwa1 = sqrt(xmagq)*xmagw*pow(xmagwn*xmagkr2n,0.125D0) ! \omega_A xmags1a = xmagdn*pow2(xmagw*xmagrn)*xmagq*sqrt(xmagwn*xmagkr2n) ! S_1a xmags1b = xmagdn*pow2(xmagw)*pow2(xmagrn)*pow3(xmagq)*pow4(xmagwn) ! S_1b diff --git a/star/private/rsp.f90 b/star/private/rsp.f90 index bc03ea35d..1b4a449d6 100644 --- a/star/private/rsp.f90 +++ b/star/private/rsp.f90 @@ -31,15 +31,15 @@ module rsp use utils_lib, only: mesa_error implicit none - + private public :: rsp_setup_part1, rsp_setup_part2, rsp_one_step, & build_rsp_model, rsp_total_energy_integrals, do1_rsp_build - + contains - - - subroutine do1_rsp_build(s,ierr) + + + subroutine do1_rsp_build(s,ierr) ! call from other_rsp_build_model after changing params. ! can change rsp_* params; but cannot change nz or net. ! multiple calls are ok to search. @@ -50,7 +50,7 @@ subroutine do1_rsp_build(s,ierr) integer :: k include 'formats' call init_def(s) - call init_for_rsp_eos_and_kap(s) + call init_for_rsp_eos_and_kap(s) s% rsp_period = 0d0 call do_rsp_build(s,ierr) if (ierr /= 0) return @@ -81,7 +81,7 @@ subroutine build_rsp_model(s,ierr) integer, intent(out) :: ierr include 'formats' NSTART = 1 - s% nz = s% RSP_nz + s% nz = s% RSP_nz if (s% job% change_initial_net) then call do_micro_change_net(s, s% job% new_net_name, ierr) else @@ -90,10 +90,10 @@ subroutine build_rsp_model(s,ierr) if (ierr /= 0) then write(*,*) 'failed in do_micro_change_net' return - end if + end if s% tau_factor = s% RSP_surface_tau/s% tau_base call init_def(s) - call init_allocate(s,s% nz) + call init_allocate(s,s% nz) call allocate_star_info_arrays(s, ierr) if (ierr /= 0) then write(*,*) 'failed in allocate_star_info_arrays' @@ -104,7 +104,7 @@ subroutine build_rsp_model(s,ierr) write(*,*) 'failed in set_RSP_flag' return end if - call init_for_rsp_eos_and_kap(s) + call init_for_rsp_eos_and_kap(s) s% rsp_period = 0d0 if (s% RSP_use_atm_grey_with_kap_for_Psurf) then s% tau_factor = s% RSP_tau_surf_for_atm_grey_with_kap/s% tau_base @@ -121,7 +121,7 @@ subroutine build_rsp_model(s,ierr) if (ierr /= 0) then write(*,*) 'failed in do_rsp_build' return - end if + end if end if if (.not. s% use_RSP_new_start_scheme) & call set_random_velocities(s) @@ -138,28 +138,28 @@ subroutine build_rsp_model(s,ierr) write(*,1) 'dt', s% dt return end if - call finish_build_rsp_model(s, ierr) + call finish_build_rsp_model(s, ierr) write(*,2) 'nz', s%nz - write(*,1) 'T(nz)', s% T(s%nz) - write(*,1) 'L_center/Lsun', s% L_center/Lsun - write(*,1) 'R_center/Rsun', s% R_center/Rsun - write(*,1) 'M_center/Msun', s% M_center/Msun - write(*,1) 'L(1)/Lsun', s% L(1)/Lsun - write(*,1) 'R(1)/Rsun', s% r(1)/Rsun - write(*,1) 'M(1)/Msun', s% m(1)/Msun - write(*,1) 'v(1)/1d5', s% v(1)/1d5 - write(*,1) 'tau_factor', s% tau_factor - write(*,1) 'tau_base', s% tau_base - write(*,*) + write(*,1) 'T(nz)', s% T(s%nz) + write(*,1) 'L_center/Lsun', s% L_center/Lsun + write(*,1) 'R_center/Rsun', s% R_center/Rsun + write(*,1) 'M_center/Msun', s% M_center/Msun + write(*,1) 'L(1)/Lsun', s% L(1)/Lsun + write(*,1) 'R(1)/Rsun', s% r(1)/Rsun + write(*,1) 'M(1)/Msun', s% m(1)/Msun + write(*,1) 'v(1)/1d5', s% v(1)/1d5 + write(*,1) 'tau_factor', s% tau_factor + write(*,1) 'tau_base', s% tau_base + write(*,*) end subroutine build_rsp_model - + subroutine finish_build_rsp_model(s,ierr) use star_utils, only: & normalize_dqs, set_qs, set_m_and_dm, set_dm_bar, set_m_grav_and_grav, & store_rho_in_xh, store_T_in_xh, store_r_in_xh type (star_info), pointer :: s - integer, intent(out) :: ierr + integer, intent(out) :: ierr integer :: i, k, j include 'formats' do i=1,NZN @@ -203,7 +203,7 @@ subroutine finish_build_rsp_model(s,ierr) call set_dm_bar(s, s% nz, s% dm, s% dm_bar) end subroutine finish_build_rsp_model - + subroutine set_random_velocities(s) use star_utils, only: rand type (star_info), pointer :: s @@ -216,9 +216,9 @@ subroutine set_random_velocities(s) end do write(*,*) 'set random velocities' s% RSP_have_set_velocities = .true. - end if + end if end subroutine set_random_velocities - + subroutine rsp_setup_part1(s,restart,ierr) ! called by finish_load_model before set_vars @@ -259,17 +259,17 @@ subroutine rsp_setup_part1(s,restart,ierr) if (.not. s% job% create_RSP_model) then call init_def(s) call init_allocate(s,s% nz) - call get_XYZ(s, s% xa(:,1), s% RSP_X, Y, s% RSP_Z) + call get_XYZ(s, s% xa(:,1), s% RSP_X, Y, s% RSP_Z) call init_for_rsp_eos_and_kap(s) IWORK=0 NZN = s% nz ELSTA = s% L(1) - RSTA = s% r(1) + RSTA = s% r(1) s% rsp_dt = s% dt_next if (s% max_timestep > 0d0 .and. s% rsp_dt > s% max_timestep) & s% rsp_dt = s% max_timestep rsp_tau_factor = s% tau_factor - s% rsp_period = s% rsp_dt*dble(s% RSP_target_steps_per_cycle) + s% rsp_period = s% rsp_dt*dble(s% RSP_target_steps_per_cycle) s% RSP_have_set_velocities = .true. call copy_from_xh_to_rsp(s,-1) do k=1,NZN @@ -294,11 +294,11 @@ subroutine rsp_setup_part1(s,restart,ierr) end if rsp_min_dr_div_cs = 1d99 rsp_min_rad_diff_time = 1d99 - call begin_calculation(s,restart,ierr) - end if + call begin_calculation(s,restart,ierr) + end if s% tau_factor = rsp_tau_factor end subroutine rsp_setup_part1 - + subroutine rsp_setup_part2(s, restart, ierr) use hydro_vars, only: set_Teff @@ -316,7 +316,7 @@ subroutine rsp_setup_part2(s, restart, ierr) ierr = 0 nz = s% nz call finish_after_build_model(s) - call copy_results(s) + call copy_results(s) call set_Teff(s, ierr) if (ierr /= 0) then if (s% report_ierr) & @@ -339,30 +339,30 @@ end subroutine rsp_setup_part2 subroutine get_LINA_info(s,ierr) use rsp_lina, only: do_LINA - type (star_info), pointer :: s - integer, intent(out) :: ierr - + type (star_info), pointer :: s + integer, intent(out) :: ierr + real(dp), allocatable :: VEL(:,:) real(dp), allocatable, dimension(:) :: & M, DM, DM_BAR, R, Vol, T, RSP_Et, Lr integer :: NMODES, I, k, sz real(dp) :: amix1, amix2, velkm - + include 'formats' ierr = 0 - + if (s% RSP_kick_vsurf_km_per_sec == 0d0) then write(*,*) 'skip calling LINA since RSP_kick_vsurf_km_per_sec = 0' return end if - + sz = NZN+1 - + allocate(VEL(sz,15), & M(sz), DM(sz), DM_BAR(sz), R(sz), Vol(sz), T(sz), RSP_Et(sz), Lr(sz)) - + do i=1,NZN - k = NZN+1-i + k = NZN+1-i M(i) = s% m(k) DM(i) = s% dm(k) DM_BAR(i) = s% dm_bar(k) @@ -371,8 +371,8 @@ subroutine get_LINA_info(s,ierr) T(i) = s% T(k) RSP_Et(i) = s% RSP_Et(k) Lr(i) = 4d0*pi*s% r(k)**2*s% Fr(k) - end do - + end do + NMODES = s% RSP_nmodes call do_LINA(s, s% RSP_L*SUNL, NZN, NMODES, VEL, & @@ -386,41 +386,41 @@ subroutine get_LINA_info(s,ierr) s% rsp_LINA_periods(I)/86400.d0, & s% rsp_LINA_growth_rates(I) enddo - + s% rsp_period = & s% rsp_LINA_periods(s% RSP_mode_for_setting_PERIODLIN + 1) - + amix1 = s% RSP_fraction_1st_overtone amix2 = s% RSP_fraction_2nd_overtone velkm = s% RSP_kick_vsurf_km_per_sec s% v_center = 0d0 do i=1,NZN - k = NZN+1-i + k = NZN+1-i s% v(k)=1.0d5*VELKM* & ((1.0d0-AMIX1-AMIX2)*vel(i,1)+AMIX1*vel(i,2)+AMIX2*vel(i,3)) end do - + s% RSP_have_set_velocities = .true. - - end subroutine get_LINA_info + + end subroutine get_LINA_info subroutine rsp_one_step(s,ierr) use brunt, only: do_brunt_N2 use rsp_step, only: rsp_set_Teff, & turn_off_time_weighting, turn_on_time_weighting - type (star_info), pointer :: s - integer, intent(out) :: ierr + type (star_info), pointer :: s + integer, intent(out) :: ierr integer :: k, j, k_max_abs_rel_hse_err real(dp) :: hse_err, max_abs_rel_hse_err logical :: restart - + include 'formats' ierr = 0 s% RSP_just_set_velocities = .false. if (.not. s% RSP_have_set_velocities) then - + max_abs_rel_hse_err = 0d0 k_max_abs_rel_hse_err = 0 do k=2,s% nz @@ -433,14 +433,14 @@ subroutine rsp_one_step(s,ierr) end do s% need_to_save_profiles_now = .true. - s% RSP_just_set_velocities = .true. - + s% RSP_just_set_velocities = .true. + write(*,3) 'relaxation max_abs_rel_hse_err, days', s% model_number, k_max_abs_rel_hse_err, & max_abs_rel_hse_err, s% time/(24*3600) - - if (.not. s% use_other_RSP_linear_analysis) then - call get_LINA_info(s,ierr) - else + + if (.not. s% use_other_RSP_linear_analysis) then + call get_LINA_info(s,ierr) + else ! must set gradT before calling since gyre needs it. ! Y_face is superadiabatic gradient do k=1,NZN @@ -465,41 +465,41 @@ subroutine rsp_one_step(s,ierr) if (s% report_ierr) & write(*,*) 'other_rsp_linear_analysis ierr', ierr return - end if - s% RSP_have_set_velocities = .true. - end if - + end if + s% RSP_have_set_velocities = .true. + end if + PERIODLIN = s% rsp_period s% rsp_dt = s% rsp_period/dble(s% rsp_target_steps_per_cycle) - s% dt = s% rsp_dt - + s% dt = s% rsp_dt + s% cumulative_energy_error_old = 0d0 s% time = 0d0 s% time_old = 0d0 write(*,*) 'automatically resets age and cumulative energy error info when sets velocities' s% need_to_save_profiles_now = .true. - + call set_random_velocities(s) - - end if - + + end if + s% do_history_file = s% RSP_have_set_velocities ! don't write history entries until set velocities !call turn_on_time_weighting(s) - + if (s% dt > s% RSP_max_dt .and. s% RSP_max_dt > 0d0) then s% dt = s% RSP_max_dt end if - - call do1_step(s,ierr) + + call do1_step(s,ierr) if (ierr /= 0) return - - call copy_results(s) + + call copy_results(s) call rsp_set_Teff(s) if (s% RSP_write_map) call add_to_map - + contains - + subroutine add_to_map use profile_getval, only: get_profile_val integer :: i, k, NPCH1, NPCH2, IP, n, io @@ -537,7 +537,7 @@ subroutine add_to_map s% need_to_set_history_names_etc = .true. s% star_history_name = s% RSP_map_history_filename FASE0 = s% time - endif + endif FASE=(s% time-FASE0)/s% rsp_period !write(*,4) 'add to map', s% model_number, IP, NPCH2, FASE do k=1,NZN,s% RSP_map_zone_interval ! gnuplot pm3d map @@ -565,12 +565,12 @@ subroutine add_to_map write(*,*) ' close ' // trim(fname) done_writing_map = .true. end if - 778 format(d16.10,1x,i3,14(1x,d16.10)) + 778 format(d16.10,1x,i3,14(1x,d16.10)) end subroutine add_to_map - + end subroutine rsp_one_step - - + + subroutine read_map_specs(s,ierr) use utils_lib use utils_def @@ -584,7 +584,7 @@ subroutine read_map_specs(s,ierr) include 'formats' ierr = 0 - + filename = s% RSP_map_columns_filename if (len_trim(filename) == 0) filename = 'map_columns.list' open(newunit=iounit, file=trim(filename), action='read', status='old', iostat=ierr) @@ -596,7 +596,7 @@ subroutine read_map_specs(s,ierr) n = 0 i = 0 col = 0 - + num_map_cols = 0 do @@ -625,20 +625,20 @@ subroutine read_map_specs(s,ierr) map_col_names(col) = trim(string) map_ids(col) = id end do - + num_map_cols = col close(iounit) - + contains subroutine error ierr = -1 close(iounit) end subroutine error - + end subroutine read_map_specs - + subroutine do1_step(s,ierr) type (star_info), pointer :: s @@ -647,9 +647,9 @@ subroutine do1_step(s,ierr) real(dp) :: dr_div_cs, r_in, r_00, max_dt, target_dt, total_radiation include 'formats' - + ID=ID+1 - + target_dt = min( & s% rsp_period/dble(s% RSP_target_steps_per_cycle), & s% dt*s% max_timestep_factor) @@ -684,9 +684,9 @@ subroutine do1_step(s,ierr) if (s% stop_for_bad_nums) call mesa_error(__FILE__,__LINE__,'do1_step 1') s% dt = max_dt end if - + if (s% force_timestep > 0d0) s% dt = s% force_timestep ! overrides everything else - + if (is_bad(s% dt) .or. s% dt <= 0d0) then write(*,1) 'dt', s% dt write(*,1) 'RSP_max_dt_times_min_dr_div_cs', s% RSP_max_dt_times_min_dr_div_cs @@ -694,14 +694,14 @@ subroutine do1_step(s,ierr) write(*,1) 'rsp_min_rad_diff_time', rsp_min_rad_diff_time call mesa_error(__FILE__,__LINE__,'do1_step 2') end if - + ierr = 0 - call HYD(s,ierr) + call HYD(s,ierr) if (ierr /= 0) return ! s% dt might have been reduced by retries in HYD s% time = s% time_old + s% dt s% rsp_dt = s% dt ! will be used to set dt for next step - + ! set this here for use in next step. to avoid restart problems. rsp_min_dr_div_cs = 1d99 i_min_dr_div_cs = -1 @@ -718,20 +718,20 @@ subroutine do1_step(s,ierr) i_min_dr_div_cs = i end if end do - + rsp_min_rad_diff_time = 1d99 i_min_rad_diff_time = -1 if (s% RSP_max_dt_times_min_rad_diff_time > 0d0) then rsp_min_rad_diff_time = dt_for_radiative_diffusion(i_min_rad_diff_time) end if - - call calculate_work_integrals(s) + + call calculate_work_integrals(s) call calculate_energies(s,total_radiation) call gather_pulse_statistics(s) if (s% RSP_max_num_periods < 0 .or. & s% rsp_num_periods < s% RSP_max_num_periods) return call get_GRPDV(s) - + contains real(dp) function dt_for_radiative_diffusion(i_min_rad_diff_time) @@ -760,20 +760,20 @@ real(dp) function dt_for_radiative_diffusion(i_min_rad_diff_time) end do i_min_rad_diff_time = NZN-k_min_dt+1 dt_for_radiative_diffusion = min_dt - end function dt_for_radiative_diffusion - + end function dt_for_radiative_diffusion + end subroutine do1_step - - + + subroutine gather_pulse_statistics(s) ! assumes have set EKMAX and EKMIN - ! updates LMAX, LMIN, RMAX, RMIN, + ! updates LMAX, LMIN, RMAX, RMIN, ! s% rsp_GREKM, s% rsp_GREKM_avg_abs, s% rsp_DeltaR, s% rsp_DeltaMAG type (star_info), pointer :: s logical :: cycle_complete include 'formats' if(s% L(1)/SUNL>LMAX) LMAX=s% L(1)/SUNL - if(s% L(1)/SUNL1.0d-10) T0=TE_start-(TE_start-TET)*ULL/(ULL-UN) if (min_PERIOD > 0d0 .and. T0-TT1 < min_PERIOD) return if (s% r(1)/SUNR - RMIN < s% RSP_min_deltaR_for_periods) return - if(FIRST==1)then + if(FIRST==1)then cycle_complete = .true. s% rsp_num_periods=s% rsp_num_periods+1 s% rsp_period=T0-TT1 @@ -1018,7 +1018,7 @@ subroutine check_cycle_completed(s,cycle_complete) run_num_iters_prev_period = s% total_num_solver_iterations run_num_retries_prev_period = s% num_retries TT1=T0 - INSIDE=1 + INSIDE=1 VMAX = 0d0 else write(*,*) 'first maximum radius, period calculations start at model, day', & @@ -1028,7 +1028,7 @@ subroutine check_cycle_completed(s,cycle_complete) ID=0 endif end subroutine check_cycle_completed - - + + end module rsp - + diff --git a/star/private/rsp_build.f90 b/star/private/rsp_build.f90 index 3b3159a27..871078385 100644 --- a/star/private/rsp_build.f90 +++ b/star/private/rsp_build.f90 @@ -32,9 +32,9 @@ module rsp_build use rsp_eval_eos_and_kap, only: X, Y, Z use rsp_lina, only: mesa_eos_kap, do_LINA use rsp_relax_env, only: EOP, RELAX_ENV - + implicit none - + private public :: do_rsp_build @@ -46,34 +46,34 @@ module rsp_build real(dp), pointer, dimension(:) :: & M, DM, DM_BAR, R, Vol, T, w, Et, E, P, Lr, Lc, Hp_face, Y_face, K, CPS, QQS logical, parameter :: RSP_eddi = .true. ! use Eddington approx at surface - + contains - - + + subroutine do_rsp_build(s,ierr) !use rsp_create_env, only: do_rsp_create_env - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(out) :: ierr - integer :: NZT ! warst. z joniz./il. warstw - real(dp) :: TH0 ! temp. warstwy jonizacji + integer :: NZT ! warst. z joniz./il. warstw + real(dp) :: TH0 ! temp. warstwy jonizacji real(dp) :: Mass,L real(dp) :: H,dmN integer :: NMODES ! ilosc modow rozwazanych (N=NMODES) - integer :: NDIM1,NDIM2 ! maks. ilosc modow/warstw - real(dp) :: VEL0(15) + integer :: NDIM1,NDIM2 ! maks. ilosc modow/warstw + real(dp) :: VEL0(15) integer :: I,J,kk,NSEQ real(dp) :: GEFF,MBOL character (len=250) FILENAME - + integer :: IO,II real(dp) :: SS, AA, BB real(dp), allocatable :: TA(:), VEL(:,:), TEMP(:) real(dp) :: TAUTEFF, TAUATTEFF logical RELAX real(dp) :: amix1, amix2 - + ierr = 0 - + if (.not. associated(M)) then allocate( & M(NZN+1), DM(NZN+1), DM_BAR(NZN+1), T(NZN+1), E(NZN+1), w(NZN+1), & @@ -81,13 +81,13 @@ subroutine do_rsp_build(s,ierr) Lr(NZN+1), Lc(NZN+1), Hp_face(NZN+1), Y_face(NZN+1), K(NZN+1), & CPS(NZN+1), QQS(NZN+1)) end if - + allocate(TA(NZN+1),VEL(NZN+1,15),TEMP(NZN)) TH0 = s% RSP_T_anchor TIN = s% RSP_T_inner NZT = s% RSP_nz_outer - FSUB = s% RSP_dq_1_factor + FSUB = s% RSP_dq_1_factor ddmfac = 1d0 ! s% RSP_ddmfac hhfac = 1.02d0 ! s% RSP_hhfac nmodes = s% RSP_nmodes @@ -95,7 +95,7 @@ subroutine do_rsp_build(s,ierr) EFL02 = EFL0*EFL0 ! START MAIN CYCLE - + ! INITIALIZE ARRAYS NDIM1=15 !max. number of modes NDIM2=NZN+1 @@ -138,20 +138,20 @@ subroutine do_rsp_build(s,ierr) ALF = 1.0d-6 ! PRECISIONS PREC = 1d-10 - + EMR = s% RSP_mass ELR = s% RSP_L TE = s% RSP_Teff Mass=EMR*SUNM - L=ELR*SUNL - + L=ELR*SUNL + if (s% RSP_trace_RSP_build_model) then write(*,*) '*** build initial model ***' write(*,'(a9,f15.5)') 'M/Msun', EMR write(*,'(a9,f15.5)') 'L/Lsun', ELR write(*,'(a9,f15.5)') ' Teff', TE end if - + call STAH(s,Mass,L,TE,H,dmN,TH0,NZT,NZN,ierr) if (ierr /= 0) return @@ -172,7 +172,7 @@ subroutine do_rsp_build(s,ierr) if(w(I)<=EFL02) w(I)=EFL02 !write(*,*) NZN-I+1, sqrt(w(i)) enddo - + ! NOTE: w(I) now holds Et = w**2 ! watch out @@ -181,7 +181,7 @@ subroutine do_rsp_build(s,ierr) M, DM, DM_BAR, R, Vol, T, w, ierr) if (ierr /= 0) return end if - + ! optical depth. just for output. TA(NZN) = s% tau_factor*s% tau_base SS=TA(NZN) @@ -218,17 +218,17 @@ subroutine do_rsp_build(s,ierr) AA=(T(IO)-T(II))/(TA(IO)-TA(II)) BB=T(IO)-AA*TA(IO) TAUATTEFF=(TE-BB)/AA - + call cleanup_for_LINA(s, M, DM, DM_BAR, R, Vol, T, w, P, ierr) 1 format(1X,1P,5D26.16) GEFF=G*Mass/R(NZN)**2 - MBOL=-2.5d0*dlog10(ELR)+4.79d0 - + MBOL=-2.5d0*dlog10(ELR)+4.79d0 + if(NMODES==0) goto 11 ! jesli masz liczyc tylko static envelope - - if (.not. (s% use_RSP_new_start_scheme .or. s% use_other_RSP_linear_analysis)) then + + if (.not. (s% use_RSP_new_start_scheme .or. s% use_other_RSP_linear_analysis)) then if (s% RSP_trace_RSP_build_model) write(*,*) '*** linear analysis ***' do I=1,NZN ! LINA changes Et, so make a work copy for it Et(I) = w(I) @@ -251,21 +251,21 @@ subroutine do_rsp_build(s,ierr) enddo close(15) s% RSP_have_set_velocities = .true. - else + else PERS(1:NMODES) = 0d0 VEL0(1:NMODES) = 0d0 do I=1,NZN do j=1,nmodes VEL(I,J) = 0d0 end do - enddo + enddo end if 11 continue - + 5568 format(1X,1P,5E15.6) - 444 format(F6.3,tr2,f8.2,tr2,f7.2,tr2,d9.3) + 444 format(F6.3,tr2,f8.2,tr2,f7.2,tr2,d9.3) if (s% RSP_trace_RSP_build_model) then write(*,*) '*** done creating initial model ***' write(*,'(A)') @@ -283,7 +283,7 @@ subroutine do_rsp_build(s,ierr) s% v(kk)=0d0 end do s% L_center=L - if(ALFA==0.d0) EFL0=0.d0 + if(ALFA==0.d0) EFL0=0.d0 s% rsp_period=s% RSP_default_PERIODLIN if (is_bad(s% rsp_period)) then write(*,1) 'rsp_period', s% rsp_period @@ -291,24 +291,24 @@ subroutine do_rsp_build(s,ierr) end if amix1 = s% RSP_fraction_1st_overtone amix2 = s% RSP_fraction_2nd_overtone - if((AMIX1+AMIX2)>1.d0) write(*,*) 'AMIX DO NOT ADD UP RIGHT' - if (.not. s% use_RSP_new_start_scheme) then - PERIODLIN=PERS(s% RSP_mode_for_setting_PERIODLIN+1) - s% rsp_period=PERIODLIN + if((AMIX1+AMIX2)>1.d0) write(*,*) 'AMIX DO NOT ADD UP RIGHT' + if (.not. s% use_RSP_new_start_scheme) then + PERIODLIN=PERS(s% RSP_mode_for_setting_PERIODLIN+1) + s% rsp_period=PERIODLIN s% v_center = 0d0 do I=1,NZN s% v(NZN+1-i)=1.0d5*s% RSP_kick_vsurf_km_per_sec* & ((1.0d0-AMIX1-AMIX2)*VEL(I,1)+AMIX1*VEL(I,2)+AMIX2*VEL(I,3)) - enddo + enddo end if - + end subroutine do_rsp_build subroutine STAH(s,MX,L,TE,H0,dmN0,TH0,NZT,NZN,ierr) ! INTEGRATE STATIC ENVELOPE ! CONVECTIVE FLUX INCLUDED (WUCHTERL & FEUCHTINGER 1998) - ! TURBULENT PRESSERE AND OVERSHOOTING NEGLECTED + ! TURBULENT PRESSERE AND OVERSHOOTING NEGLECTED ! (ALPHA_P = ALPHA_T = 0) ! DIFFUSION APPROXIMATION FOR RADIATIVE TRANSFER ! HYDROGEN ZONE DEPTH (NZT, IN ZONES), AND TEMPERATURE(TH0) FIXED @@ -320,7 +320,7 @@ subroutine STAH(s,MX,L,TE,H0,dmN0,TH0,NZT,NZN,ierr) integer, intent(in) :: NZT integer, intent(inout) :: NZN integer, intent(out) :: ierr - + real(dp) :: dmN,dm_0,H,Psurf,DDT real(dp) :: GPF real(dp) :: F2,F1,D,HH,TT,dmL @@ -333,7 +333,7 @@ subroutine STAH(s,MX,L,TE,H0,dmN0,TH0,NZT,NZN,ierr) logical :: adjusting_dmN, in_photosphere, in_outer_env, & have_dmN_too_large, have_dmN_too_small, & have_H_too_large, have_H_too_small, have_T - + include 'formats' ierr = 0 IG = 0 @@ -351,15 +351,15 @@ subroutine STAH(s,MX,L,TE,H0,dmN0,TH0,NZT,NZN,ierr) have_dmN_too_small = .false. have_H_too_large = .false. have_H_too_small = .false. - + TH0_tol = s% RSP_T_anchor_tolerance TIN_tol = s% RSP_T_inner_tolerance - + call ZNVAR(s,H,dmN,L,TE,MX,ierr) if (ierr /= 0) return dmN_cnt = 1 H_cnt = 1 - + start_from_top_loop: do if (s% RSP_trace_RSP_build_model) write(*,*) 'call setup_outer_zone' call setup_outer_zone(ierr) @@ -368,7 +368,7 @@ subroutine STAH(s,MX,L,TE,H0,dmN0,TH0,NZT,NZN,ierr) call store_N zone_loop: do R_1=pow(R_1**3-3.d0*V_0*dm_0/P4,1.d0/3.d0) - N=N-1 + N=N-1 if (s% RSP_trace_RSP_build_model) write(*,*) 'zone_loop', N, T_0, TIN if (N==0 .or. T_0 >= TIN) then if (s% RSP_trace_RSP_build_model) write(*,*) 'call next_H' @@ -381,7 +381,7 @@ subroutine STAH(s,MX,L,TE,H0,dmN0,TH0,NZT,NZN,ierr) s% M_center = s% mstar - s% xmstar ! this is how it is set when read file s% L_center = s% RSP_L*SUNL s% R_center = pow(r(1)**3 - Vol(1)*dm(1)/P43, 1d0/3d0) - s% v_center = 0 + s% v_center = 0 if (s% RSP_trace_RSP_build_model) & write(*,*) ' inner dm growth scale', HH exit start_from_top_loop ! done @@ -404,10 +404,10 @@ subroutine STAH(s,MX,L,TE,H0,dmN0,TH0,NZT,NZN,ierr) have_T = get_T(ierr) if (ierr /= 0) return if (.not. have_T) then - call failed + call failed DDT = dmN/1.d3 dmN = dmN-DDT - cycle start_from_top_loop + cycle start_from_top_loop end if if (s% RSP_trace_RSP_build_model) write(*,*) 'call get_V' call get_V(ierr) @@ -431,18 +431,18 @@ subroutine STAH(s,MX,L,TE,H0,dmN0,TH0,NZT,NZN,ierr) end if ! one last repeat with final dmN !if (s% RSP_trace_RSP_build_model) write(*,*) 'cycle start_from_top_loop', dmN_cnt, dmN/SUNM - cycle start_from_top_loop + cycle start_from_top_loop end if if (s% RSP_trace_RSP_build_model) write(*,*) 'call store_N' call store_N - end do zone_loop + end do zone_loop end do start_from_top_loop - - s% R_center=R_1; H0=H; dmN0=dmN + + s% R_center=R_1; H0=H; dmN0=dmN if(N/=0) call change_NZN - + contains - + subroutine report_location_of_photosphere real(dp) :: tau, dtau integer :: i @@ -458,7 +458,7 @@ subroutine report_location_of_photosphere end if end do end subroutine report_location_of_photosphere - + subroutine setup_outer_zone(ierr) use rsp_eval_eos_and_kap, only: get_surf_P_T_kap integer, intent(out) :: ierr @@ -469,13 +469,13 @@ subroutine setup_outer_zone(ierr) dm_bar_0=(dm_0/2.d0) if(.not.RSP_eddi) then ! EXACT GREY RELATION WE=TE**4 - T4_0=WE*sqrt(3.d0)/4.d0 !0.4330127018d0 + T4_0=WE*sqrt(3.d0)/4.d0 !0.4330127018d0 T_0= pow(sqrt(3.d0)/4.d0,0.25d0)*TE !0.811194802d0*TE else ! EDDINGTON APPROXIMATION WE=TE**4 T4_0=WE*0.5d0 ! T4_0=WE*1.0d0/2.d0 T_0=pow(0.5d0, 0.25d0)*TE ! T_0= pow(1.0d0/2.d0,0.25d0)*TE - endif + endif RM=sqrt(L/(P4*SIG*WE)) R_1=RM if (s% RSP_use_atm_grey_with_kap_for_Psurf) then @@ -504,7 +504,7 @@ subroutine setup_outer_zone(ierr) Lr_0=L N=NZN end subroutine setup_outer_zone - + subroutine get_V(ierr) integer, intent(out) :: ierr ierr = 0 @@ -514,7 +514,7 @@ subroutine get_V(ierr) if (ierr /= 0) return if(N/=NZN)then call CFLUX(HP_0,IGR_0,Lc_0,w_0,GPF,N) - if(Lc_0>=L) then + if(Lc_0>=L) then write(*,*) 'trouble!',I stop endif @@ -572,16 +572,16 @@ subroutine next_H ! same scheme as next_dmN. bound and bisect. return end if end if - ! search using bounds. keep it simple. + ! search using bounds. keep it simple. ! just bisect since for H too large, stop short of target cell HH = 0.5d0*(H_too_large + H_too_small) !write(*,*) 'next_H HH, HH_prev', HH, HH_prev !if (abs(HH - HH_prev) < 1d-6*HH) call mesa_error(__FILE__,__LINE__,'next_H') end subroutine next_H - + subroutine store_N real(dp) :: dtau - R(N) = R_1 + R(N) = R_1 P(N) = P_0 Vol(N) = V_0 E(N) = E_0 @@ -606,8 +606,8 @@ subroutine store_N end if tau_sum = tau_sum + dtau end subroutine store_N - - subroutine setup_next_zone + + subroutine setup_next_zone P_1 = P_0 V_1 = V_0 OP_1 = OP_0 @@ -629,24 +629,24 @@ subroutine setup_next_zone if (s% RSP_testing) write(*,*) 'nz outer', NZN-N, T_1, TH0 end if dm_0=dm_0*H - end if + end if dm_bar_0=(dm_0+dmL)/2.d0 - P_0=P_1+G*M_0*dm_bar_0/(P4*R_1**4) + P_0=P_1+G*M_0*dm_bar_0/(P4*R_1**4) end subroutine setup_next_zone - + real(dp) function eval_T_residual(ierr) integer, intent(out) :: ierr call EOP(s,0, & - T_0,P_0,V_0,E_0,CP_0,QQ_0,SVEL_0,OP_0,ierr) - if (ierr /= 0) return + T_0,P_0,V_0,E_0,CP_0,QQ_0,SVEL_0,OP_0,ierr) + if (ierr /= 0) return call CFLUX(HP_0,IGR_0,Lc_0,w_0,GPF,N) TT=4.d0*SIG*P4**2*R_1**4/(3.d0*dm_bar_0*L) T4_0 = T_0**4 Lr_0=TT*(T4_0/OP_0-T4_1/OP_1)/ & (1.d0-dlog(OP_0/OP_1)/dlog(T4_0/T4_1))*L - eval_T_residual = (Lr_0 + Lc_0)/L - 1d0 + eval_T_residual = (Lr_0 + Lc_0)/L - 1d0 end function eval_T_residual - + real(dp) function get_T_residual(lnT, dfdx, lrpar, rpar, lipar, ipar, ierr) ! returns with ierr = 0 if was able to evaluate f and df/dx at x ! if df/dx not available, it is okay to set it to 0 @@ -656,13 +656,13 @@ real(dp) function get_T_residual(lnT, dfdx, lrpar, rpar, lipar, ipar, ierr) real(dp), intent(out) :: dfdx integer, intent(inout), pointer :: ipar(:) ! (lipar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) - integer, intent(out) :: ierr + integer, intent(out) :: ierr ierr = 0 dfdx = 0 T_0 = exp(lnT) get_T_residual = eval_T_residual(ierr) end function get_T_residual - + logical function get_T_estimate() use num_lib, only: safe_root_with_brackets real(dp) :: Tmax, epsx, epsy, residual, lnT, & @@ -700,7 +700,7 @@ logical function get_T_estimate() dfdx, lrpar, rpar, lipar, ipar, ierr) get_T_estimate = .true. end function get_T_estimate - + logical function get_T(ierr) integer, intent(out) :: ierr real(dp) :: Prad @@ -723,11 +723,11 @@ logical function get_T(ierr) Lc_loop1: do ! reduce T if Lc >= L call EOP(s,N, & - T_0,P_0,V_0,E_0,CP_0,QQ_0,SVEL_0,OP_0,ierr) - if (ierr /= 0) return + T_0,P_0,V_0,E_0,CP_0,QQ_0,SVEL_0,OP_0,ierr) + if (ierr /= 0) return call CFLUX(HP_0,IGR_0,Lc_0,w_0,GPF,N) if(Lc_00.5d0) + do while (abs(D/T4_0)>0.5d0) D=(T4_0/2.d0)*(D/abs(D)) end do T4_0 = T4_0-D @@ -774,28 +774,28 @@ logical function get_T(ierr) end do Lc_loop Lr_0=TT*(T4_0/OP_0-T4_1/OP_1)/ & (1.d0-dlog(OP_0/OP_1)/dlog(T4_0/T4_1))*L - F2=(Lr_0+Lc_0)/L-1.d0 + F2=(Lr_0+Lc_0)/L-1.d0 if(ABS(F2)1 .or. IG > 54) then - write(*,*) 'zone ',N,'IGR= ',IGR_0 + write(*,*) 'zone ',N,'IGR= ',IGR_0 stop end if dmN=dmN/4.d0 write(*,*) 'PHOENIX CONDITION' IG=IG+1 end subroutine failed - + subroutine prepare_for_new_H ITIN = ITIN+1 ! STRATOWE WARTOSCI DLA ITERACJI PONIZEJ TH0 @@ -837,7 +837,7 @@ subroutine change_NZN Lc(I) = Lc(I+N) Lr(I) = Lr(I+N) w(I) = w(I+N) - end do + end do end subroutine change_NZN end subroutine STAH @@ -857,8 +857,8 @@ subroutine ZNVAR(s,H,dmN,L,TE,M,ierr) if(.not.RSP_eddi) then ! EXACT GREY RELATION T0= pow(sqrt(3.d0)/4.d0,0.25d0)*TE !0.811194802d0*TE else ! EDDINGTON APPROXIMATION - T0= pow(0.5d0, 0.25d0)*TE ! T0= pow(1.0d0/2.d0,0.25d0)*TE - endif + T0= pow(0.5d0, 0.25d0)*TE ! T0= pow(1.0d0/2.d0,0.25d0)*TE + endif if (s% RSP_use_Prad_for_Psurf) then Psurf = crad*T0*T0*T0*T0/3d0 else @@ -879,13 +879,13 @@ subroutine ZNVAR(s,H,dmN,L,TE,M,ierr) ! P = Psurf + G*M*dtau/(R^2*kap) ! kap depends on P, so need to solve this implicit equation iteratively. ! once find P and kap, can evaluate dm = 4*pi*R^2*dtau/kap - + ! note that since T0 is fixed, we can only change P by changing Pgas. ! for most cases this is not a problem since Prad << Pgas. ! but for massive blue stars, we can have Prad >> Pgas. ! to handle both cases well, we need to iterate on Pgas instead of P ! that will let us make sure we don't create guesses that imply Pgas < 0. - + dtau = TAU0 ! s% RSP_outer_dtau_target ! make rough initial guess for opacity based on T0 if (T0 < 4700d0) then @@ -917,12 +917,12 @@ subroutine ZNVAR(s,H,dmN,L,TE,M,ierr) V = exp(lnV + dlnV) !write(*,*) 'T0, new V, P, kap, residual, dP_dV', i, T0, V, P, kap, residual, dP_dV end do - + !write(*,*) 'V, P, kap, residual', i, V, P, kap, residual - + dmN = 4*pi*R**2*dtau/kap if (s% RSP_testing) write(*,*) 'initial dmN', dmN/SUNM - !stop + !stop end subroutine ZNVAR @@ -955,10 +955,10 @@ subroutine CFLUX(HP_0,IGR_0,Lc_0,OMEGA_0,GPF,N) POM2=0.5d0*(CP_0+CP_1) GG=POM*POM2*IGR_0 GPF=GG/FF - + ! BOTTOM BOUNDARY CONDITION FOR CONVECTION - if(N<=IBOTOM)then + if(N<=IBOTOM)then Lc_0=0.d0 OMEGA_0=0.d0 return @@ -991,5 +991,5 @@ subroutine CFLUX(HP_0,IGR_0,Lc_0,OMEGA_0,GPF,N) endif end subroutine CFLUX - + end module rsp_build diff --git a/star/private/rsp_def.f90 b/star/private/rsp_def.f90 index 66ff8a63c..403cdec8b 100644 --- a/star/private/rsp_def.f90 +++ b/star/private/rsp_def.f90 @@ -33,56 +33,56 @@ module rsp_def store_rho_in_xh, get_rho_and_lnd_from_xh implicit none - + integer, parameter :: MAX_NZN = 1501 - + real(dp), parameter :: f_Edd_isotropic = 1d0/3d0, f_Edd_free_stream = 1d0 real(dp) :: rsp_tau_factor, rsp_min_dr_div_cs, rsp_min_rad_diff_time, Psurf_from_atm integer :: i_min_dr_div_cs, i_min_rad_diff_time - + real(dp), pointer, dimension(:) :: & dVol_dr_00, dVol_dr_in, & d_egas_dVol, d_egas_dT, d_egas_dr_00, d_egas_dr_in, & - d_Pg_dVol, d_Pg_dT, d_Pg_dr_00, d_Pg_dr_in, & + d_Pg_dVol, d_Pg_dT, d_Pg_dr_00, d_Pg_dr_in, & dK_dVol, dK_dT, dK_dr_00, dK_dr_in, & dQQ_dVol, dQQ_dT, dQQ_dr_00, dQQ_dr_in, & dCp_dVol, dCp_dT, dCp_dr_00, dCp_dr_in, & - d_Pr_dVol, d_Pr_der, d_Pr_dr_00, d_Pr_dr_in, & + d_Pr_dVol, d_Pr_der, d_Pr_dr_00, d_Pr_dr_in, & dHp_dr_out, dHp_dr_00, dHp_dr_in, & dHp_dVol_00, dHp_dVol_out, & dHp_dT_00, dHp_dT_out, & dHp_der_00, dHp_der_out, & - + dY_dr_in, dY_dr_00, dY_dr_out, & dY_dVol_00, dY_dVol_out, & dY_dT_00, dY_dT_out, & dY_der_00, dY_der_out, & - + dPII_dr_in, dPII_dr_00, dPII_dr_out, & dPII_dVol_00, dPII_dVol_out, & dPII_dT_00, dPII_dT_out, & dPII_der_00, dPII_der_out, & - + d_Pvsc_dr_00, d_Pvsc_dr_in, & d_Pvsc_dVol, d_Pvsc_dT, d_Pvsc_der, & - + dPtrb_dr_00, dPtrb_dr_in, dPtrb_dVol_00, dPtrb_dw_00, & - - dChi_dr_in2, dChi_dr_in, dChi_dr_00, dChi_dr_out, & + + dChi_dr_in2, dChi_dr_in, dChi_dr_00, dChi_dr_out, & dChi_dVol_in, dChi_dVol_00, dChi_dVol_out, & dChi_dT_in, dChi_dT_00, dChi_dT_out, & dChi_der_in, dChi_der_00, dChi_der_out, & dChi_dw_00, & - + dEq_dr_out, dEq_dr_00, dEq_dr_in, dEq_dr_in2, & dEq_dVol_out, dEq_dVol_00, dEq_dVol_in, & dEq_dT_out, dEq_dT_00, dEq_dT_in, & dEq_der_out, dEq_der_00, dEq_der_in, & dEq_dw_00, & - - dC_dr_in2, dC_dr_in, dC_dr_00, dC_dr_out, & + + dC_dr_in2, dC_dr_in, dC_dr_00, dC_dr_out, & dC_dVol_in, dC_dVol_00, dC_dVol_out, & dC_dT_in, dC_dT_00, dC_dT_out, & dC_der_in, dC_der_00, dC_der_out, & @@ -96,13 +96,13 @@ module rsp_def integer, parameter :: NV=5 integer, parameter :: HD_DIAG=2*NV+1, LD_HD=4*NV+1, LD_ABB=6*NV+1, LPSZ=NV*MAX_NZN+1 real(dp) DX(LPSZ), HR(LPSZ), HD(LD_HD, LPSZ), ABB(LD_ABB, LPSZ) - integer IPVT(LPSZ) - + integer IPVT(LPSZ) + integer, parameter :: LD_LLL = 4*MAX_NZN real(dp), dimension(LD_LLL, LD_LLL) :: LLL, VLx, VRx integer :: ISORTx(LD_LLL) real(dp) :: WORKx(4*LD_LLL), WRx(LD_LLL), WIx(LD_LLL) - + ! for rsp_eval_eos_and_kap real(dp), pointer :: xa(:) real(dp) :: X, Z, Y, abar, zbar, z53bar, XC, XN, XO, Xne @@ -115,17 +115,17 @@ module rsp_def PDVWORK, FASE0 real(dp), pointer, dimension(:) :: & PPP0, PPQ0, PPT0, PPC0, VV0, & - WORK, WORKQ, WORKT, WORKC + WORK, WORKQ, WORKT, WORKC integer :: INSIDE, IWORK, ID, NSTART, FIRST, & run_num_retries_prev_period, prev_cycle_run_num_steps, & run_num_iters_prev_period - + ! for maps logical :: writing_map, done_writing_map integer, parameter :: max_map_cols = 200 integer :: map_ids(max_map_cols), num_map_cols character(256) :: map_col_names(max_map_cols) - + ! marsaglia and zaman random number generator. period is 2**43 with ! 900 million different sequences. the state of the generator (for restarts) integer, parameter :: rn_u_len=97 @@ -133,28 +133,28 @@ module rsp_def real(dp) :: rn_u(rn_u_len), rn_c, rn_cd, rn_cm ! from const - real(dp) :: G, SIG, SUNL, SUNM, SUNR, CL, P43, P4 - + real(dp) :: G, SIG, SUNL, SUNM, SUNR, CL, P43, P4 + ! these are set from inlist real(dp) :: ALFA, ALFAP, ALFAM, ALFAT, ALFAS, ALFAC, CEDE, GAMMAR real(dp) :: THETA, THETAT, THETAQ, THETAU, THETAE, WTR, WTC, WTT, GAM real(dp) :: THETA1, THETAT1, THETAQ1, THETAU1, THETAE1, WTR1, WTC1, WTT1, GAM1 real(dp) :: EFL0, CQ, ZSH, kapE_factor, kapP_factor integer :: NZN, IBOTOM - + contains - - + + subroutine init_def(s) use const_def, only: standard_cgrav, boltz_sigma, & Lsun, Msun, Rsun use utils_lib, only: mkdir, folder_exists type (star_info), pointer :: s - + P4=4.d0*PI P43=P4/3.d0 - + G=standard_cgrav SIG=boltz_sigma SUNL=Lsun @@ -176,7 +176,7 @@ subroutine init_def(s) ALFAC = ALFAC*(1.d0/2.d0)*sqrt(2.d0/3.d0) CEDE = CEDE*(8.d0/3.d0)*sqrt(2.d0/3.d0) GAMMAR = GAMMAR*2.d0*sqrt(3.d0) - + call turn_on_time_weighting(s) CQ = s% RSP_cq @@ -184,16 +184,16 @@ subroutine init_def(s) EFL0 = s% RSP_efl0 kapE_factor = 1d0 ! s% RSP_kapE_factor kapP_factor = 1d0 ! s% RSP_kapP_factor - + if (ALFA == 0.d0) EFL0=0.d0 - + writing_map = .false. if(.not. folder_exists(trim(s% log_directory))) call mkdir(trim(s% log_directory)) - + end subroutine init_def - - + + subroutine turn_off_time_weighting(s) type (star_info), pointer :: s THETA = 1d0 @@ -215,8 +215,8 @@ subroutine turn_off_time_weighting(s) THETAE1=0d0 THETAU1=0d0 end subroutine turn_off_time_weighting - - + + subroutine turn_on_time_weighting(s) type (star_info), pointer :: s THETA = s% RSP_theta @@ -238,8 +238,8 @@ subroutine turn_on_time_weighting(s) THETAE1=1.d0-THETAE THETAU1=1.d0-THETAU end subroutine turn_on_time_weighting - - + + subroutine init_allocate(s,nz) !use rsp_eddfac, only: eddfac_allocate type (star_info), pointer :: s @@ -255,33 +255,33 @@ subroutine init_allocate(s,nz) allocate(xa(s% species), & dVol_dr_00(n), dVol_dr_in(n), & d_egas_dVol(n), d_egas_dT(n), d_egas_dr_00(n), d_egas_dr_in(n), & - d_Pg_dVol(n), d_Pg_dT(n), d_Pg_dr_00(n), d_Pg_dr_in(n), & - d_Pr_dVol(n), d_Pr_der(n), d_Pr_dr_00(n), d_Pr_dr_in(n), & + d_Pg_dVol(n), d_Pg_dT(n), d_Pg_dr_00(n), d_Pg_dr_in(n), & + d_Pr_dVol(n), d_Pr_der(n), d_Pr_dr_00(n), d_Pr_dr_in(n), & dK_dVol(n), dK_dT(n), dK_dr_00(n), dK_dr_in(n), & dQQ_dVol(n), dQQ_dT(n), dQQ_dr_00(n), dQQ_dr_in(n), & dCp_dVol(n), dCp_dT(n), dCp_dr_00(n), dCp_dr_in(n), & dHp_dr_out(n), dHp_dr_00(n), dHp_dr_in(n), & dHp_dVol_00(n), dHp_dVol_out(n), & - dHp_dT_00(n), dHp_dT_out(n), dHp_der_00(n), dHp_der_out(n), & + dHp_dT_00(n), dHp_dT_out(n), dHp_der_00(n), dHp_der_out(n), & dY_dr_in(n), dY_dr_00(n), dY_dr_out(n), & dY_dVol_00(n), dY_dVol_out(n), & - dY_dT_00(n), dY_dT_out(n), dY_der_00(n), dY_der_out(n), & + dY_dT_00(n), dY_dT_out(n), dY_der_00(n), dY_der_out(n), & dPII_dr_in(n), dPII_dr_00(n), dPII_dr_out(n), & dPII_dVol_00(n), dPII_dVol_out(n), & - dPII_dT_00(n), dPII_dT_out(n), dPII_der_00(n), dPII_der_out(n), & - d_Pvsc_dr_00(n), d_Pvsc_dr_in(n), d_Pvsc_dVol(n), d_Pvsc_dT(n), d_Pvsc_der(n), & - dPtrb_dr_00(n), dPtrb_dr_in(n), dPtrb_dVol_00(n), dPtrb_dw_00(n), & - dChi_dr_in2(n), dChi_dr_in(n), dChi_dr_00(n), dChi_dr_out(n), & + dPII_dT_00(n), dPII_dT_out(n), dPII_der_00(n), dPII_der_out(n), & + d_Pvsc_dr_00(n), d_Pvsc_dr_in(n), d_Pvsc_dVol(n), d_Pvsc_dT(n), d_Pvsc_der(n), & + dPtrb_dr_00(n), dPtrb_dr_in(n), dPtrb_dVol_00(n), dPtrb_dw_00(n), & + dChi_dr_in2(n), dChi_dr_in(n), dChi_dr_00(n), dChi_dr_out(n), & dChi_dVol_in(n), dChi_dVol_00(n), dChi_dVol_out(n), & dChi_dT_in(n), dChi_dT_00(n), dChi_dT_out(n), & dChi_der_in(n), dChi_der_00(n), dChi_der_out(n), & - dChi_dw_00(n), & + dChi_dw_00(n), & dEq_dr_out(n), dEq_dr_00(n), dEq_dr_in(n), dEq_dr_in2(n), & dEq_dVol_out(n), dEq_dVol_00(n), dEq_dVol_in(n), & dEq_dT_out(n), dEq_dT_00(n), dEq_dT_in(n), & dEq_der_out(n), dEq_der_00(n), dEq_der_in(n), & - dEq_dw_00(n), & - dC_dr_in2(n), dC_dr_in(n), dC_dr_00(n), dC_dr_out(n), & + dEq_dw_00(n), & + dC_dr_in2(n), dC_dr_in(n), dC_dr_00(n), dC_dr_out(n), & dC_dVol_in(n), dC_dVol_00(n), dC_dVol_out(n), & dC_dT_in(n), dC_dT_00(n), dC_dT_out(n), & dC_der_in(n), dC_der_00(n), dC_der_out(n), dC_dw_00(n), & @@ -291,41 +291,41 @@ subroutine init_allocate(s,nz) PPP0(n), PPQ0(n), PPT0(n), PPC0(n), VV0(n), & WORK(n), WORKQ(n), WORKT(n), WORKC(n)) end subroutine init_allocate - - + + subroutine init_free(s) type (star_info), pointer :: s deallocate(xa, & dVol_dr_00, dVol_dr_in, & d_egas_dVol, d_egas_dT, d_egas_dr_00, d_egas_dr_in, & - d_Pg_dVol, d_Pg_dT, d_Pg_dr_00, d_Pg_dr_in, & - d_Pr_dVol, d_Pr_der, d_Pr_dr_00, d_Pr_dr_in, & + d_Pg_dVol, d_Pg_dT, d_Pg_dr_00, d_Pg_dr_in, & + d_Pr_dVol, d_Pr_der, d_Pr_dr_00, d_Pr_dr_in, & dK_dVol, dK_dT, dK_dr_00, dK_dr_in, & dQQ_dVol, dQQ_dT, dQQ_dr_00, dQQ_dr_in, & dCp_dVol, dCp_dT, dCp_dr_00, dCp_dr_in, & dHp_dr_out, dHp_dr_00, dHp_dr_in, & dHp_dVol_00, dHp_dVol_out, & dHp_dT_00, dHp_dT_out, & - dHp_der_00, dHp_der_out, & + dHp_der_00, dHp_der_out, & dY_dr_in, dY_dr_00, dY_dr_out, & dY_dVol_00, dY_dVol_out, & - dY_dT_00, dY_dT_out, dY_der_00, dY_der_out, & + dY_dT_00, dY_dT_out, dY_der_00, dY_der_out, & dPII_dr_in, dPII_dr_00, dPII_dr_out, & dPII_dVol_00, dPII_dVol_out, & - dPII_dT_00, dPII_dT_out, dPII_der_00, dPII_der_out, & - d_Pvsc_dr_00, d_Pvsc_dr_in, d_Pvsc_dVol, d_Pvsc_dT, d_Pvsc_der, & - dPtrb_dr_00, dPtrb_dr_in, dPtrb_dVol_00, dPtrb_dw_00, & - dChi_dr_in2, dChi_dr_in, dChi_dr_00, dChi_dr_out, & + dPII_dT_00, dPII_dT_out, dPII_der_00, dPII_der_out, & + d_Pvsc_dr_00, d_Pvsc_dr_in, d_Pvsc_dVol, d_Pvsc_dT, d_Pvsc_der, & + dPtrb_dr_00, dPtrb_dr_in, dPtrb_dVol_00, dPtrb_dw_00, & + dChi_dr_in2, dChi_dr_in, dChi_dr_00, dChi_dr_out, & dChi_dVol_in, dChi_dVol_00, dChi_dVol_out, & dChi_dT_in, dChi_dT_00, dChi_dT_out, & dChi_der_in, dChi_der_00, dChi_der_out, & - dChi_dw_00, & + dChi_dw_00, & dEq_dr_out, dEq_dr_00, dEq_dr_in, dEq_dr_in2, & dEq_dVol_out, dEq_dVol_00, dEq_dVol_in, & dEq_dT_out, dEq_dT_00, dEq_dT_in, & dEq_der_out, dEq_der_00, dEq_der_in, & - dEq_dw_00, & - dC_dr_in2, dC_dr_in, dC_dr_00, dC_dr_out, & + dEq_dw_00, & + dC_dr_in2, dC_dr_in, dC_dr_00, dC_dr_out, & dC_dVol_in, dC_dVol_00, dC_dVol_out, & dC_dT_in, dC_dT_00, dC_dT_out, & dC_der_in, dC_der_00, dC_der_out, dC_dw_00, & @@ -335,41 +335,41 @@ subroutine init_free(s) PPP0, PPQ0, PPT0, PPC0, VV0, & WORK, WORKQ, WORKT, WORKC) end subroutine init_free - - + + real(dp) function rsp_phase_time0() rsp_phase_time0 = TT1 end function rsp_phase_time0 - - + + real(dp) function rsp_WORK(s, k) type (star_info), pointer :: s integer, intent(in) :: k rsp_WORK = WORK(k) end function rsp_WORK - - + + real(dp) function rsp_WORKQ(s, k) type (star_info), pointer :: s integer, intent(in) :: k rsp_WORKQ = WORKQ(k) end function rsp_WORKQ - - + + real(dp) function rsp_WORKT(s, k) type (star_info), pointer :: s integer, intent(in) :: k rsp_WORKT = WORKT(k) end function rsp_WORKT - - + + real(dp) function rsp_WORKC(s, k) type (star_info), pointer :: s integer, intent(in) :: k rsp_WORKC = WORKC(k) end function rsp_WORKC - - + + subroutine rsp_photo_out(s, iounit) type (star_info), pointer :: s integer, intent(in) :: iounit @@ -400,15 +400,15 @@ subroutine rsp_photo_out(s, iounit) PPP0(1:n), PPQ0(1:n), PPT0(1:n), PPC0(1:n), VV0(1:n), & WORK(1:n), WORKQ(1:n), WORKT(1:n), WORKC(1:n) end subroutine rsp_photo_out - - + + subroutine rsp_photo_in(s, iounit, ierr) type (star_info), pointer :: s integer, intent(in) :: iounit integer, intent(out) :: ierr integer :: n include 'formats' - call init_def(s) + call init_def(s) ierr = 0 read(iounit, iostat=ierr) NZN if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'read failed in rsp_photo_in') @@ -443,8 +443,8 @@ subroutine rsp_photo_in(s, iounit, ierr) writing_map = .false. end if end subroutine rsp_photo_in - - + + subroutine finish_after_build_model(s) type (star_info), pointer :: s integer :: k @@ -455,8 +455,8 @@ subroutine finish_after_build_model(s) s% Prad(k) = s% f_Edd(k)*s% erad(k)/s% Vol(k) end do end subroutine finish_after_build_model - - + + subroutine finish_rsp_photo_in(s) use star_utils, only: set_rmid type (star_info), pointer :: s @@ -488,8 +488,8 @@ subroutine finish_rsp_photo_in(s) call mesa_error(__FILE__,__LINE__,'finish_rsp_photo_in') end if end subroutine finish_rsp_photo_in - - + + subroutine set_build_vars(s, & m, dm, dm_bar, r, Vol, T, RSP_Et, Lr, Lc) type (star_info), pointer :: s @@ -516,8 +516,8 @@ subroutine set_build_vars(s, & end if end do end subroutine set_build_vars - - + + subroutine set_star_vars(s, ierr) type (star_info), pointer :: s integer, intent(out) :: ierr @@ -525,7 +525,7 @@ subroutine set_star_vars(s, ierr) integer :: k include 'formats' ierr = 0 - sum_dm = 0d0 + sum_dm = 0d0 do k=1, NZN sum_dm = sum_dm + s% dm(k) end do @@ -546,17 +546,17 @@ subroutine set_star_vars(s, ierr) end if end if call set_qs(s, s% nz, s% q, s% dq, ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in set_qs') + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in set_qs') s% m(1) = s% mstar do k=2,s% nz s% dm(k-1) = s% dq(k-1)*s% xmstar s% m(k) = s% m(k-1) - s% dm(k-1) end do k = s% nz - s% dm(k) = s% m(k) - s% m_center - call set_dm_bar(s, s% nz, s% dm, s% dm_bar) + s% dm(k) = s% m(k) - s% m_center + call set_dm_bar(s, s% nz, s% dm, s% dm_bar) do k=1, NZN - + if (k==NZN) then s% Vol(k)=P43/s% dm(k)*(s% r(k)**3 - s% R_center**3) s% rmid(k) = 0.5d0*(s% r(k) + s% R_center) @@ -567,26 +567,26 @@ subroutine set_star_vars(s, ierr) if (is_bad(s% Vol(k)))then write(*, 2) 's% Vol(k)', k, s% Vol(k) call mesa_error(__FILE__,__LINE__,'set_star_vars') - end if - + end if + s% rho(k) = 1d0/s% Vol(k) call store_rho_in_xh(s, k, s% rho(k)) call get_rho_and_lnd_from_xh(s, k, s% rho(k), s% lnd(k)) - s% Vol(k) = 1d0/s% rho(k) + s% Vol(k) = 1d0/s% rho(k) call store_T_in_xh(s, k, s% T(k)) call get_T_and_lnT_from_xh(s, k, s% T(k), s% lnT(k)) - + call store_r_in_xh(s, k, s% r(k)) call get_r_and_lnR_from_xh(s, k, s% r(k), s% lnR(k)) s% RSP_Et(k) = s% RSP_w(k)*s% RSP_w(k) - s% xh(s% i_Et_RSP, k) = s% RSP_Et(k) - s% xh(s% i_v, k) = s% v(k) + s% xh(s% i_Et_RSP, k) = s% RSP_Et(k) + s% xh(s% i_v, k) = s% v(k) end do end subroutine set_star_vars - - + + subroutine copy_from_xh_to_rsp(s, nz_new) ! do this when load a file use star_utils, only: get_T_and_lnT_from_xh, get_r_and_lnR_from_xh type (star_info), pointer :: s @@ -631,7 +631,7 @@ end subroutine copy_from_xh_to_rsp subroutine check_for_T_or_P_inversions(s,str) - type (star_info), pointer :: s + type (star_info), pointer :: s character (len=*), intent(in) :: str integer :: k logical :: okay @@ -655,7 +655,7 @@ end subroutine check_for_T_or_P_inversions subroutine check_R(s,str) - type (star_info), pointer :: s + type (star_info), pointer :: s character (len=*), intent(in) :: str integer :: k include 'formats' @@ -673,8 +673,8 @@ subroutine check_R(s,str) end if end do end subroutine check_R - - + + subroutine rsp_dump_for_debug(s) type (star_info), pointer :: s integer :: k @@ -711,12 +711,12 @@ subroutine rsp_dump_for_debug(s) write(*,2) 's% erad(k)', k, s% erad(k) write(*,2) 's% Prad(k)', k, s% Prad(k) write(*,2) 's% Fr(k)', k, s% Fr(k) - !write(*,2) '', k, + !write(*,2) '', k, end do - !call mesa_error(__FILE__,__LINE__,'rsp_dump_for_debug') + !call mesa_error(__FILE__,__LINE__,'rsp_dump_for_debug') end subroutine rsp_dump_for_debug - - + + subroutine cleanup_for_LINA( & s, M, DM, DM_BAR, R, Vol, T, RSP_Et, Peos, ierr) use star_utils, only: normalize_dqs, set_qs, set_m_and_dm, set_dm_bar @@ -724,14 +724,14 @@ subroutine cleanup_for_LINA( & real(dp), intent(inout), dimension(:) :: & M, DM, DM_BAR, R, Vol, T, RSP_Et, Peos integer, intent(out) :: ierr - + integer :: I, k - + include 'formats' - + ! get do i=1,NZN - k = NZN+1-i + k = NZN+1-i s% m(k) = M(i) s% dq(k) = DM(i)/s% xmstar s% r(k) = R(i) @@ -741,9 +741,9 @@ subroutine cleanup_for_LINA( & s% Peos(k) = Peos(i) s% Prad(k) = crad*s% T(k)**4/3d0 s% Pgas(k) = s% Peos(k) - s% Prad(k) - end do + end do s% dq(s% nz) = (s% m(NZN) - s% M_center)/s% xmstar - + ! fix if (.not. s% do_normalize_dqs_as_part_of_set_qs) then call normalize_dqs(s, NZN, s% dq, ierr) @@ -767,10 +767,10 @@ subroutine cleanup_for_LINA( & s% Lt(1:s% nz) = 0d0 s% csound(1:s% nz) = 0d0 call copy_results(s) - + ! put back do i=1,NZN - k = NZN+1-i + k = NZN+1-i M(i) = s% m(k) DM(i) = s% dm(k) DM_BAR(i) = s% dm_bar(k) @@ -778,11 +778,11 @@ subroutine cleanup_for_LINA( & Vol(i) = s% Vol(k) T(i) = s% T(k) RSP_Et(i) = s% RSP_w(k)**2 - end do - + end do + end subroutine cleanup_for_LINA - - + + subroutine copy_results(s) use star_utils, only: set_rmid, store_r_in_xh, & get_r_and_lnR_from_xh, store_r_in_xh, & @@ -792,32 +792,32 @@ subroutine copy_results(s) integer :: i, k, ierr real(dp) :: RSP_efl0_2 real(qp) :: q1, q2, q3, q4 - + RSP_efl0_2 = EFL0**2 do i=1, NZN - + k = NZN+1 - i s% xh(s% i_v,k) = s% v(k) s% xh(s% i_erad_RSP,k) = s% erad(k) s% xh(s% i_Fr_RSP,k) = s% Fr(k) - + ! sqrt(w**2) /= original w, so need to redo s% RSP_Et(k) = s% RSP_w(k)**2 - s% xh(s% i_Et_RSP,k) = s% RSP_Et(k) + s% xh(s% i_Et_RSP,k) = s% RSP_Et(k) s% RSP_w(k) = sqrt(s% xh(s% i_Et_RSP,k)) - + ! exp(log(r)) /= original r, so need to redo call store_r_in_xh(s, k, s% r(k)) call get_r_and_lnR_from_xh(s, k, s% r(k), s% lnR(k)) - + ! exp(log(T)) /= original T, so need to redo call store_T_in_xh(s, k, s% T(k)) call get_T_and_lnT_from_xh(s, k, s% T(k), s% lnT(k)) - + s% Peos(k) = s% Pgas(k) + s% Prad(k) if (k > 1) s% gradT(k) = & s% Y_face(k) + 0.5d0*(s% grada(k-1) + s% grada(k)) - + end do s% gradT(1) = s% gradT(2) @@ -826,9 +826,9 @@ subroutine copy_results(s) write(*,*) 'copy_results failed in set_rmid' call mesa_error(__FILE__,__LINE__,'copy_results') end if - - do i=1, NZN - k = NZN+1 - i + + do i=1, NZN + k = NZN+1 - i ! revise Vol and rho using revised r if (i==1) then s% Vol(k)=P43/s% dm(k)*(s% r(k)**3 - s% R_center**3) @@ -839,7 +839,7 @@ subroutine copy_results(s) q4 = q1*(q2**3 - q3**3) s% Vol(k) = dble(q4) end if - s% rho(k) = 1d0/s% Vol(k) + s% rho(k) = 1d0/s% Vol(k) call store_rho_in_xh(s, k, s% rho(k)) call get_rho_and_lnd_from_xh(s, k, s% rho(k), s% lnd(k)) s% Vol(k) = 1d0/s% rho(k) @@ -848,9 +848,9 @@ subroutine copy_results(s) s% mixing_type(k) = convective_mixing else s% mixing_type(k) = no_mixing - end if + end if end do - + ! set some things for mesa output reporting i = 1 s% rho_face(i) = s% rho(i) @@ -861,7 +861,7 @@ subroutine copy_results(s) s% P_face_ad(i)%val = 0.5d0*(s% Peos(i) + s% Peos(i-1)) s% csound_face(i) = 0.5d0*(s% csound(i) + s% csound(i-1)) end do - + ! these are necessary to make files consistent with photos. s% R_center = pow(s% r(NZN)**3 - s% Vol(NZN)*s% dm(NZN)/P43, 1d0/3d0) s% M_center = s% mstar - s% xmstar @@ -870,4 +870,4 @@ end subroutine copy_results end module rsp_def - + diff --git a/star/private/rsp_eval_eos_and_kap.f90 b/star/private/rsp_eval_eos_and_kap.f90 index 1ef81b9ef..989c70966 100644 --- a/star/private/rsp_eval_eos_and_kap.f90 +++ b/star/private/rsp_eval_eos_and_kap.f90 @@ -9,7 +9,7 @@ ! by the Free Software Foundation; either version 2 of the License, or ! (at your option) any later version. ! -! MESA is distributed in the hope that it will be useful, +! MESA is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU Library General Public License for more details. @@ -42,10 +42,10 @@ module rsp_eval_eos_and_kap integer :: species integer, pointer, dimension(:) :: net_iso, chem_id integer :: eos_handle, kap_handle - + contains - - + + subroutine restart_rsp_eos_and_kap(s) type (star_info), pointer :: s eos_handle = s% eos_handle @@ -54,23 +54,23 @@ subroutine restart_rsp_eos_and_kap(s) chem_id => s% chem_id species = s% species end subroutine restart_rsp_eos_and_kap - + subroutine init_for_rsp_eos_and_kap(s) use adjust_xyz, only: get_xa_for_standard_metals type (star_info), pointer :: s - + integer :: i, iz, ierr real(dp) :: initial_z, initial_y, initial_x, & initial_h1, initial_h2, initial_he3, initial_he4, & xsol_he3, xsol_he4, z2bar, ye, mass_correction, sumx include 'formats' - ierr = 0 + ierr = 0 eos_handle = s% eos_handle kap_handle = s% kap_handle net_iso => s% net_iso chem_id => s% chem_id species = s% species - + initial_x = max(0d0, min(1d0, s% RSP_X)) initial_z = max(0d0, min(1d0, s% RSP_Z)) initial_y = max(0d0,1d0 - (initial_x + initial_z)) @@ -145,13 +145,13 @@ subroutine init_for_rsp_eos_and_kap(s) write(*,1) 'init_for_rsp_eos_and_kap X', X write(*,1) 'Y', Y write(*,1) 'Z', Z - - - - - - - + + + + + + + write(*,1) 'abar', abar write(*,1) 'zbar', zbar write(*,1) 'XC', XC @@ -164,8 +164,8 @@ subroutine init_for_rsp_eos_and_kap(s) write(*,*) trim(s% net_name) call mesa_error(__FILE__,__LINE__,'init_for_rsp_eos_and_kap') end subroutine init_for_rsp_eos_and_kap - - + + subroutine eval_mesa_eos_and_kap(& s,k,T_in,V, & Pg,d_Pg_dV,d_Pg_dT,Pr,d_Pr_dT, & @@ -185,8 +185,8 @@ subroutine eval_mesa_eos_and_kap(& egas,d_egas_dV,d_egas_dT,erad,d_erad_dV,d_erad_dT, & CSND,CP,CPV,CPT,Q,QV,QT,OP,OPV,OPT,ierr) end subroutine eval_mesa_eos_and_kap - - + + subroutine eval1_mesa_eos_and_kap( & s,k,skip_kap,T_in,V, & Pgas,d_Pg_dV,d_Pg_dT,Prad,d_Pr_dT, & @@ -204,7 +204,7 @@ subroutine eval1_mesa_eos_and_kap( & egas,d_egas_dV,d_egas_dT,erad,d_erad_dV,d_erad_dT, & CSND,CP,CPV,CPT,Q,QV,QT,OP,OPV,OPT integer, intent(out) :: ierr - + integer :: j real(dp) :: logT, logRho, T, Rho, E, dE_dV, dE_dT, & lnfree_e, d_lnfree_e_dlnRho, d_lnfree_e_dlnT, & @@ -214,13 +214,13 @@ subroutine eval1_mesa_eos_and_kap( & real(dp) :: d_dxa(num_eos_d_dxa_results,s% species) include 'formats' - + rho = 1d0/V T = T_in logRho = log10(rho) dlnd_dV = -rho - logT = log10(T) - + logT = log10(T) + if (k > 0 .and. k <= s% nz) then call store_rho_in_xh(s, k, rho) call get_rho_and_lnd_from_xh(s, k, s% rho(k), s% lnd(k)) @@ -253,10 +253,10 @@ subroutine eval1_mesa_eos_and_kap( & if (ierr == 0) then Prad = crad*T**4/3d0 Pgas = exp(res(i_lnPgas)) - CSND = sqrt(max(0d0, res(i_gamma1)*(Prad+Pgas)/Rho)) + CSND = sqrt(max(0d0, res(i_gamma1)*(Prad+Pgas)/Rho)) end if end if - + if (ierr /= 0) then !$omp critical (rsp_eval_eos_and_kap_1) if (k > 0 .and. k < s% nz) call write_eos_call_info(s,k) @@ -274,7 +274,7 @@ subroutine eval1_mesa_eos_and_kap( & !return call mesa_error(__FILE__,__LINE__,'RSP failed in get_eos') end if - + if (skip_kap) then OP=0; OPV=0; OPT=0 else @@ -282,55 +282,55 @@ subroutine eval1_mesa_eos_and_kap( & V, logRho, dlnd_dV, T, logT, species, chem_id, net_iso, xa, & res, d_dlnd, d_dlnT, OP, OPV, OPT, ierr) end if - + lnfree_e = res(i_lnfree_e) d_lnfree_e_dlnRho = d_dlnd(i_lnfree_e) d_lnfree_e_dlnT = d_dlnT(i_lnfree_e) - + Prad = crad*T**4/3d0 ! erg/cm^2 d_Pr_dT = 4d0*Prad/T erad = 3d0*Prad/rho ! 3*Prad*V erg/gm d_erad_dT = 3d0*d_Pr_dT/rho d_erad_dV = 3d0*Prad - + E = exp(res(i_lnE)) dE_dV = E*d_dlnd(i_lnE)*dlnd_dV dE_dT = E*d_dlnT(i_lnE)/T egas = E - erad d_egas_dV = dE_dV - d_erad_dV d_egas_dT = dE_dT - d_erad_dT - + Pgas = exp(res(i_lnPgas)) d_Pg_dV = Pgas*d_dlnd(i_lnPgas)*dlnd_dV d_Pg_dT = Pgas*d_dlnT(i_lnPgas)/T - + CP = res(i_Cp) CPV = d_dlnd(i_Cp)*dlnd_dV CPT = d_dlnT(i_Cp)/T - + chiT = res(i_chiT) dchiT_dlnd = d_dlnd(i_chiT) dchiT_dlnT = d_dlnT(i_chiT) - + chiRho = res(i_chiRho) dchiRho_dlnd = d_dlnd(i_chiRho) dchiRho_dlnT = d_dlnT(i_chiRho) - + Q = chiT/(rho*T*chiRho) ! thermal expansion coefficient dQ_dlnd = Q*(dchiT_dlnd/chiT - dchiRho_dlnd/chiRho - 1d0) dQ_dlnT = Q*(dchiT_dlnT/chiT - dchiRho_dlnT/chiRho - 1d0) QV = dQ_dlnd*dlnd_dV QT = dQ_dlnT/T - + if (is_bad(egas) .or. egas <= 0d0) then ierr = -1 return end if - + end subroutine eval1_mesa_eos_and_kap - - + + subroutine eval1_mesa_eosDEgas_and_kap( & s, k, skip_kap, egas, V, T, Pgas, CSND, CP, Q, OP, ierr) use star_utils, only: write_eos_call_info @@ -342,21 +342,21 @@ subroutine eval1_mesa_eosDEgas_and_kap( & real(dp), intent(in) :: egas, V real(dp), intent(out) :: T, Pgas, CSND, CP, Q, OP integer, intent(out) :: ierr - + integer :: j, eos_calls real(dp) :: rho, logRho, dlnd_dV, egas_tol, logT, & logT_guess, logT_tol, new_erad, new_egas, OPV, OPT real(dp), dimension(num_eos_basic_results) :: & res, d_dlnd, d_dlnT real(dp) :: d_dxa(num_eos_d_dxa_results, species) - + include 'formats' ierr = 0 rho = 1d0/V logRho = log10(rho) dlnd_dV = -rho - + if (egas <= 0d0 .or. is_bad(egas)) then !$OMP critical (RSP_eosDEgas) write(*,2) 'egas', k, egas @@ -388,7 +388,7 @@ subroutine eval1_mesa_eosDEgas_and_kap( & new_erad = crad*T**4/rho new_egas = exp(res(i_lnE)) - new_erad if (is_bad(new_egas) .or. new_egas <= 0d0 .or. & - abs(new_egas - egas) > 1d3*egas_tol) then + abs(new_egas - egas) > 1d3*egas_tol) then !$OMP critical (RSP_eosDEgas) write(*,1) 'logRho', s% lnd(k)/ln10 write(*,1) 'logT_guess', logT_guess @@ -434,7 +434,7 @@ subroutine eval1_mesa_eosDEgas_and_kap( & ierr = -1 return end if - + if (ierr /= 0) then !$OMP critical (RSP_eosDEgas) if (k > 0 .and. k < s% nz) call write_eos_call_info(s,k) @@ -453,7 +453,7 @@ subroutine eval1_mesa_eosDEgas_and_kap( & return call mesa_error(__FILE__,__LINE__,'RSP failed in eval1_mesa_eosDEgas_and_kap') end if - + if (skip_kap) then OP=0 else @@ -461,14 +461,14 @@ subroutine eval1_mesa_eosDEgas_and_kap( & V, logRho, dlnd_dV, T, logT, species, chem_id, net_iso, xa, & res, d_dlnd, d_dlnT, OP, OPV, OPT, ierr) end if - + Pgas = exp(res(i_lnPgas)) CP = res(i_Cp) Q = res(i_chiT)/(rho*T*res(i_chiRho)) ! thermal expansion coefficient - + end subroutine eval1_mesa_eosDEgas_and_kap - - + + subroutine eval1_mesa_eosDE_and_kap( & ! for eos, energy = egas + erad s, k, skip_kap, energy, V, T, Pgas, CSND, CP, Q, OP, ierr) use star_utils, only: write_eos_call_info @@ -480,14 +480,14 @@ subroutine eval1_mesa_eosDE_and_kap( & ! for eos, energy = egas + erad real(dp), intent(in) :: energy, V real(dp), intent(out) :: T, Pgas, CSND, CP, Q, OP integer, intent(out) :: ierr - + integer :: j, eos_calls real(dp) :: rho, logRho, dlnd_dV, logE, logE_want, logE_tol, logT, & logT_guess, logT_tol, new_erad, new_egas, OPV, OPT real(dp), dimension(num_eos_basic_results) :: & res, d_dlnd, d_dlnT real(dp) :: d_dxa(num_eos_d_dxa_results, species) - + include 'formats' ierr = 0 @@ -495,7 +495,7 @@ subroutine eval1_mesa_eosDE_and_kap( & ! for eos, energy = egas + erad logRho = log10(rho) logE_want = log10(energy) dlnd_dV = -rho - + if (energy <= 0d0 .or. is_bad(energy)) then !$OMP critical (RSP_eosDE) write(*,2) 'energy', k, energy @@ -515,7 +515,7 @@ subroutine eval1_mesa_eosDE_and_kap( & ! for eos, energy = egas + erad logT_guess = s% lnT(k)/ln10 logT_tol = 1d-11 logE_tol = 1d-11 - + call solve_eos_given_DE( & s, k, xa, & logRho, logE_want, logT_guess, logT_tol, logE_tol, & @@ -528,7 +528,7 @@ subroutine eval1_mesa_eosDE_and_kap( & ! for eos, energy = egas + erad new_erad = crad*T**4/rho new_egas = exp(res(i_lnE)) - new_erad logE = res(i_lnE)/ln10 - if (is_bad(logE) .or. logE <= -20d0) then + if (is_bad(logE) .or. logE <= -20d0) then !$OMP critical (RSP_eosDE) write(*,1) 'logRho', s% lnd(k)/ln10 write(*,1) 'Z', Z @@ -566,7 +566,7 @@ subroutine eval1_mesa_eosDE_and_kap( & ! for eos, energy = egas + erad ierr = -1 return end if - + if (ierr /= 0) then !$OMP critical (RSP_eosDE) if (k > 0 .and. k < s% nz) call write_eos_call_info(s,k) @@ -584,7 +584,7 @@ subroutine eval1_mesa_eosDE_and_kap( & ! for eos, energy = egas + erad return call mesa_error(__FILE__,__LINE__,'RSP failed in eval1_mesa_eosDE_and_kap') end if - + if (skip_kap) then OP=0 else @@ -592,14 +592,14 @@ subroutine eval1_mesa_eosDE_and_kap( & ! for eos, energy = egas + erad V, logRho, dlnd_dV, T, logT, species, chem_id, net_iso, xa, & res, d_dlnd, d_dlnT, OP, OPV, OPT, ierr) end if - + Pgas = exp(res(i_lnPgas)) CP = res(i_Cp) Q = res(i_chiT)/(rho*T*res(i_chiRho)) ! thermal expansion coefficient - + end subroutine eval1_mesa_eosDE_and_kap - - + + subroutine eval1_kap(s, k, skip_kap, & V, logRho, dlnd_dV, T, logT, species, chem_id, net_iso, xa, & res, d_dlnd, d_dlnT, OP, OPV, OPT, ierr) @@ -608,27 +608,27 @@ subroutine eval1_kap(s, k, skip_kap, & logical, intent(in) :: skip_kap integer, intent(in) :: species integer, pointer :: chem_id(:), net_iso(:) - real(dp), intent(in) :: xa(:) + real(dp), intent(in) :: xa(:) real(dp), intent(in) :: V, logRho, T, logT, dlnd_dV real(dp), intent(in), dimension(num_eos_basic_results) :: res, d_dlnd, d_dlnT real(dp), intent(out) :: OP, OPV, OPT integer, intent(out) :: ierr - + real(dp) :: lnfree_e, d_lnfree_e_dlnRho, d_lnfree_e_dlnT, & eta, d_eta_dlnRho, d_eta_dlnT, & frac_Type2, opacity, dlnkap_dlnd, dlnkap_dlnT, opacity_factor real(dp) :: kap_fracs(num_kap_fracs), dlnkap_dxa(s% species) - + include 'formats' ierr = 0 - + if (s% RSP_kap_density_factor > 0d0) then OP = s% RSP_kap_density_factor*V OPV = s% RSP_kap_density_factor OPT = 0d0 return end if - + lnfree_e = res(i_lnfree_e) d_lnfree_e_dlnRho = d_dlnd(i_lnfree_e) d_lnfree_e_dlnT = d_dlnT(i_lnfree_e) @@ -698,17 +698,17 @@ subroutine eval1_kap(s, k, skip_kap, & if (k > 0 .and. k <= s% nz) then s% opacity(k) = opacity end if - + end subroutine eval1_kap - - + + subroutine eval1_mesa_T_given_DP(s, k, Vol, P, T_guess, T, ierr) use eos_support, only: solve_eos_given_DP type (star_info), pointer :: s integer, intent(in) :: k real(dp), intent(in) :: Vol, P, T_guess real(dp), intent(out) :: T - integer, intent(out) :: ierr + integer, intent(out) :: ierr real(dp) :: rho, logRho, logP, logT_guess, & logT_tol, logP_tol, logT real(dp), dimension(num_eos_basic_results) :: & @@ -729,23 +729,23 @@ subroutine eval1_mesa_T_given_DP(s, k, Vol, P, T_guess, T, ierr) ierr) T = exp10(logT) end subroutine eval1_mesa_T_given_DP - - + + subroutine eval1_mesa_Rho_given_PT(s, k, P, T, rho_guess, rho, ierr) use eos_support, only: solve_eos_given_PT type (star_info), pointer :: s integer, intent(in) :: k real(dp), intent(in) :: P, T, rho_guess real(dp), intent(out) :: rho - integer, intent(out) :: ierr - + integer, intent(out) :: ierr + real(dp) :: logT, logP, logRho_guess, logRho, & logRho_tol, logP_tol real(dp), dimension(num_eos_basic_results) :: & res, d_dlnd, d_dlnT real(dp) :: d_dxa(num_eos_d_dxa_results, species) integer :: iter - + include 'formats' ierr = 0 @@ -764,7 +764,7 @@ subroutine eval1_mesa_Rho_given_PT(s, k, P, T, rho_guess, rho, ierr) s, k, xa, & logT, logP, logRho_guess, logRho_tol, logP_tol, & logRho, res, d_dlnd, d_dlnT, d_dxa, & - ierr) + ierr) if (ierr == 0) exit logRho_tol = logRho_tol*3d0 logP_tol = logP_tol*3d0 @@ -782,22 +782,22 @@ subroutine eval1_mesa_Rho_given_PT(s, k, P, T, rho_guess, rho, ierr) write(*,2) 'logP', k, logP write(*,2) 'logRho_guess', k, logRho_guess end if - + end subroutine eval1_mesa_Rho_given_PT - - + + real(dp) function eval1_gamma_PT_getRho(s, k, P, T, ierr) use eos_lib, only: eos_gamma_PT_get type (star_info), pointer :: s integer, intent(in) :: k real(dp), intent(in) :: P, T - integer, intent(out) :: ierr + integer, intent(out) :: ierr real(dp), dimension(num_eos_basic_results) :: & res, d_dlnd, d_dlnT real(dp) :: logP, logT, logRho, rho, gamma include 'formats' logP = log10(P) - logT = log10(T) + logT = log10(T) gamma = 5d0/3d0 call eos_gamma_PT_get( & eos_handle, abar, P, logP, T, logT, gamma, & @@ -816,16 +816,16 @@ subroutine get_surf_P_T_kap(s, & type (star_info), pointer :: s real(dp), intent(in) :: M, R, L, tau, kap_guess real(dp), intent(out) :: T, P, kap, Teff - integer, intent(out) :: ierr - + integer, intent(out) :: ierr + real(dp) :: & lnT, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, & lnP, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap - + ierr = 0 call get_atm_PT_legacy_grey_and_kap( & - s, tau, L, R, M, s% cgrav(1), .TRUE., & + s, tau, L, R, M, s% cgrav(1), .TRUE., & Teff, kap, & lnT, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, & lnP, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap, & @@ -833,14 +833,14 @@ subroutine get_surf_P_T_kap(s, & T = exp(lnT) P = exp(lnP) - + end subroutine get_surf_P_T_kap subroutine update_eos_and_kap(s,kk,ierr) type (star_info), pointer :: s - integer, intent(in) :: kk - integer, intent(out) :: ierr + integer, intent(in) :: kk + integer, intent(out) :: ierr real(dp) :: & T,V,Pgas,d_Pg_dV,d_Pg_dT,Prad,d_Pr_dT, & egas,d_egas_dV,d_egas_dT,erad,d_erad_dV,d_erad_dT, & @@ -851,14 +851,14 @@ subroutine update_eos_and_kap(s,kk,ierr) s,kk,T,V, & Pgas,d_Pg_dV,d_Pg_dT,Prad,d_Pr_dT, & egas,d_egas_dV,d_egas_dT,erad,d_erad_dV,d_erad_dT, & - CSND,CP,CPV,CPT,Q,QV,QT,OP,OPV,OPT,ierr) + CSND,CP,CPV,CPT,Q,QV,QT,OP,OPV,OPT,ierr) end subroutine update_eos_and_kap subroutine set_Rho_for_new_Pgas(s,kk,ierr) type (star_info), pointer :: s - integer, intent(in) :: kk - integer, intent(out) :: ierr + integer, intent(in) :: kk + integer, intent(out) :: ierr real(dp) :: & other_value, other_tol, logRho_bnd1, other_at_bnd1, & logRho_bnd2, other_at_bnd2, logRho_guess, logRho_result, logRho_tol @@ -866,9 +866,9 @@ subroutine set_Rho_for_new_Pgas(s,kk,ierr) res, d_dlnd, d_dlnT real(dp), dimension(num_eos_d_dxa_results, species) :: d_dxa integer :: max_iter, which_other, eos_calls - + include 'formats' - ierr = 0 + ierr = 0 max_iter = 100 which_other = i_lnPgas other_value = log(s% Pgas(kk)) @@ -881,7 +881,7 @@ subroutine set_Rho_for_new_Pgas(s,kk,ierr) logRho_guess = log10(s% rho(kk)) call store_T_in_xh(s, kk, s% T(kk)) call get_T_and_lnT_from_xh(s, kk, s% T(kk), s% lnT(kk)) - + call eosDT_get_Rho( & eos_handle, & species, chem_id, net_iso, xa, & @@ -891,19 +891,19 @@ subroutine set_Rho_for_new_Pgas(s,kk,ierr) logRho_result, res, d_dlnd, d_dlnT, & d_dxa, eos_calls, ierr) if (ierr /= 0) return - + s% lnd(kk) = logRho_result*ln10 s% xh(s% i_lnd,kk) = s% lnd(kk) s% rho(kk) = exp(s% lnd(kk)) s% Vol(kk) = 1d0/s% rho(kk) - + end subroutine set_Rho_for_new_Pgas subroutine set_T_for_new_egas(s,kk,ierr) ! uses s% T(kk), s% egas(kk) and s% lnd(kk) type (star_info), pointer :: s - integer, intent(in) :: kk - integer, intent(out) :: ierr + integer, intent(in) :: kk + integer, intent(out) :: ierr real(dp) :: & egas_tol, logT_bnd1, egas_at_bnd1, new_egas, egas_want, & @@ -912,9 +912,9 @@ subroutine set_T_for_new_egas(s,kk,ierr) ! uses s% T(kk), s% egas(kk) and s% ln res, d_dlnd, d_dlnT real(dp) :: d_dxa(num_eos_d_dxa_results, species) integer :: max_iter, eos_calls - + include 'formats' - ierr = 0 + ierr = 0 max_iter = 100 egas_want = s% egas(kk) egas_tol = egas_want*1d-12 @@ -924,7 +924,7 @@ subroutine set_T_for_new_egas(s,kk,ierr) ! uses s% T(kk), s% egas(kk) and s% ln logT_bnd2 = arg_not_provided egas_at_bnd2 = arg_not_provided logT_guess = log10(s% T(kk)) - + call eosDT_get_T( & eos_handle, & species, chem_id, net_iso, xa, & @@ -934,13 +934,13 @@ subroutine set_T_for_new_egas(s,kk,ierr) ! uses s% T(kk), s% egas(kk) and s% ln logT_result, res, d_dlnd, d_dlnT, & d_dxa, eos_calls, ierr) if (ierr /= 0) return - + call store_lnT_in_xh(s, kk, logT_result*ln10) call get_T_and_lnT_from_xh(s, kk, s% T(kk), s% lnT(kk)) - + new_egas = exp(res(i_lnE)) - crad*s% T(kk)**4/s% rho(kk) if (is_bad(new_egas) .or. new_egas <= 0d0 .or. & - abs(new_egas - egas_want) > 1d3*egas_tol) then + abs(new_egas - egas_want) > 1d3*egas_tol) then write(*,1) 'logRho', s% lnd(kk)/ln10 write(*,1) 'logT_guess', logT_guess write(*,1) 'egas_want', egas_want @@ -969,14 +969,14 @@ subroutine set_T_for_new_egas(s,kk,ierr) ! uses s% T(kk), s% egas(kk) and s% ln abs(new_egas - egas_want), egas_tol call mesa_error(__FILE__,__LINE__,'set_T_for_new_egas') end if - + end subroutine set_T_for_new_egas subroutine set_T_for_new_Pgas(s,kk,ierr) type (star_info), pointer :: s - integer, intent(in) :: kk - integer, intent(out) :: ierr + integer, intent(in) :: kk + integer, intent(out) :: ierr real(dp) :: & other_value, other_tol, logT_bnd1, other_at_bnd1, & logT_bnd2, other_at_bnd2, logT_guess, logT_result, logT_tol @@ -984,9 +984,9 @@ subroutine set_T_for_new_Pgas(s,kk,ierr) res, d_dlnd, d_dlnT real(dp), dimension(num_eos_d_dxa_results, species) :: d_dxa integer :: max_iter, which_other, eos_calls - + include 'formats' - ierr = 0 + ierr = 0 max_iter = 100 which_other = i_lnPgas other_value = log(s% Pgas(kk)) @@ -997,7 +997,7 @@ subroutine set_T_for_new_Pgas(s,kk,ierr) logT_bnd2 = arg_not_provided other_at_bnd2 = arg_not_provided logT_guess = log10(s% T(kk)) - + call eosDT_get_T( & eos_handle, & species, chem_id, net_iso, xa, & @@ -1007,7 +1007,7 @@ subroutine set_T_for_new_Pgas(s,kk,ierr) logT_result, res, d_dlnd, d_dlnT, & d_dxa, eos_calls, ierr) if (ierr /= 0) return - + call store_lnT_in_xh(s, kk, logT_result*ln10) call get_T_and_lnT_from_xh(s, kk, s% T(kk), s% lnT(kk)) @@ -1017,9 +1017,9 @@ end subroutine set_T_for_new_Pgas subroutine set_T_for_new_energy(s,kk,logT_tol,other_tol,ierr) use eos_lib, only: eosDT_get_T type (star_info), pointer :: s - integer, intent(in) :: kk - real(dp), intent(in) :: logT_tol, other_tol - integer, intent(out) :: ierr + integer, intent(in) :: kk + real(dp), intent(in) :: logT_tol, other_tol + integer, intent(out) :: ierr real(dp) :: & other_value, logT_bnd1, other_at_bnd1, & logT_bnd2, other_at_bnd2, logT_guess, logT_result @@ -1027,7 +1027,7 @@ subroutine set_T_for_new_energy(s,kk,logT_tol,other_tol,ierr) res, d_dlnd, d_dlnT real(dp), dimension(num_eos_d_dxa_results, species) :: d_dxa integer :: max_iter, which_other, eos_calls - ierr = 0 + ierr = 0 max_iter = 100 which_other = i_lnE other_value = log(s% energy(kk)) @@ -1038,7 +1038,7 @@ subroutine set_T_for_new_energy(s,kk,logT_tol,other_tol,ierr) logT_bnd2 = arg_not_provided other_at_bnd2 = arg_not_provided logT_guess = log10(s% T(kk)) - + call eosDT_get_T( & eos_handle, & species, chem_id, net_iso, xa, & @@ -1048,12 +1048,12 @@ subroutine set_T_for_new_energy(s,kk,logT_tol,other_tol,ierr) logT_result, res, d_dlnd, d_dlnT, & d_dxa, eos_calls, ierr) if (ierr /= 0) return - + call store_lnT_in_xh(s, kk, logT_result*ln10) call get_T_and_lnT_from_xh(s, kk, s% T(kk), s% lnT(kk)) - end subroutine set_T_for_new_energy + end subroutine set_T_for_new_energy end module rsp_eval_eos_and_kap - + diff --git a/star/private/rsp_lina.f90 b/star/private/rsp_lina.f90 index e578307f8..a9037b3b1 100644 --- a/star/private/rsp_lina.f90 +++ b/star/private/rsp_lina.f90 @@ -28,15 +28,15 @@ module rsp_lina use utils_lib, only: is_bad, mesa_error use const_def, only: dp, crad use rsp_def - + implicit none - + private public :: mesa_eos_kap, SORT, do_LINA - + contains - + subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & M, DM, DM_BAR, R, Vol, T, Et, Lr, ierr) @@ -51,7 +51,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & real(dp), intent(inout), dimension(:) :: & M, DM, DM_BAR, R, Vol, T, Et, Lr integer, intent(out) :: ierr - + real(dp), dimension(15) :: OMEG, EK real(dp), allocatable, dimension(:) :: & E, P, Lc, Hp_face, Y_face, K, CPS, QQS, & @@ -95,7 +95,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & QWK,QWKEV,PHR,PHT,PHL,PHU,PHC,ZZZ complex(8), allocatable, dimension(:,:) :: & VRR,VRT,VRL,VRC,DVRR,DVRT,DVRL,DVRC,VRU - + real(dp) :: FFXM,FFX0,FFXP,FFY0,FFYP,FF,POM1 real(dp) :: IGR1,IGR1XM,IGR1X0,IGR1XP,IGR1Y0,IGR1YP real(dp) :: IGR2,IGR2XM,IGR2X0,IGR2XP,IGR2Y0,IGR2YP @@ -115,12 +115,12 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & real(dp) :: PSIG,TEMI,TEMM,TEM1 real(dp) :: NORMC real(dp) :: QCHECK(15),ETOIEV(15),QWKPT(1000,15),ETOIPT(15),SGR(15) - real(dp) :: EFL02 + real(dp) :: EFL02 real(dp) :: ETOI(15) - + !write(*,'(a55,i12,99(1pd26.16))') 'start LINA s% w(2)**2', & ! 2, s% w(2)**2, Et(NZN-1) - + if (.false.) then write(*,*) 'L0', L0 do I=1,NZN @@ -136,7 +136,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & end do call mesa_error(__FILE__,__LINE__,'do_LINA') end if - + ierr = 0 EFL02 = EFL0*EFL0 n = NZN+1 @@ -226,7 +226,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & endif ! LOOP 1 .. EOS - + !$OMP PARALLEL DO PRIVATE(I,T1,op_err) SCHEDULE(dynamic,2) do 1 I=1,NZN @@ -240,20 +240,20 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & if (ierr /= 0) cycle T1=P43/dm(I) - DVR(I)=3.d0*T1*R(I)**2 - if(I==1) goto 2 - DVRM(I)=-3.d0*T1*R(max(1,I-1))**2 + DVR(I)=3.d0*T1*R(I)**2 + if(I==1) goto 2 + DVRM(I)=-3.d0*T1*R(max(1,I-1))**2 ! bp: max(1,i-1) to prevent bogus warning from gfortran goto 3 2 DVRM(I)=-3.d0*T1*s% R_center**2 3 continue - dP_dr_00(I) =DPV(I)*DVR(I) + dP_dr_00(I) =DPV(I)*DVR(I) dP_dr_in(I)=DPV(I)*DVRM(I) dCp_dr_00(I) =CPV(I)*DVR(I) dCp_dr_in(I)=CPV(I)*DVRM(I) dQQ_dr_00(I) =QQV(I)*DVR(I) dQQ_dr_in(I)=QQV(I)*DVRM(I) - + 1 continue !$OMP END PARALLEL DO if (ierr /= 0) return @@ -274,20 +274,20 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & Hp_face(I)=POM2 dHp_dr_in(I)=POM*(P(I)*DVRM(I)+Vol(I)*dP_dr_in(I)) dHp_dr_00(I)=2.d0*Hp_face(I)/R(I)+POM*(P(I)*DVR(I)+Vol(I)*dP_dr_00(I) & - +P(I+1)*DVRM(I+1)+Vol(I+1)*dP_dr_in(I+1)) + +P(I+1)*DVRM(I+1)+Vol(I+1)*dP_dr_in(I+1)) dHp_dr_out(I)=POM*(P(I+1)*DVR(I+1)+Vol(I+1)*dP_dr_00(I+1)) dHp_dT_00(I)=POM*Vol(I)*dP_dT_00(I) dHp_dT_out(I)=POM*Vol(I+1)*dP_dT_00(I+1) enddo POM=(R(NZN)**2)/(2.d0*G*M(NZN)) Hp_face(NZN)=POM*P(NZN)*Vol(NZN) - dHp_dr_in(NZN)=POM*(P(NZN)*DVRM(NZN)+Vol(NZN)*dP_dr_in(NZN)) + dHp_dr_in(NZN)=POM*(P(NZN)*DVRM(NZN)+Vol(NZN)*dP_dr_in(NZN)) dHp_dr_00(NZN)=2.d0*Hp_face(NZN)/R(NZN)+POM* & (P(NZN)*DVR(NZN)+Vol(NZN)*dP_dr_00(NZN)) dHp_dr_out(NZN)=0.d0 dHp_dT_00(NZN)=POM*Vol(NZN)*dP_dT_00(NZN) dHp_dT_out(NZN)=0.d0 - + !call mesa_error(__FILE__,__LINE__,'Hp_face') do I=1,NZN-1 @@ -326,7 +326,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & dY_dT_00(I)=IGR1*IGR2Y0+IGR2*IGR1Y0 dY_dT_out(I)=IGR1*IGR2YP+IGR2*IGR1YP enddo - + !call mesa_error(__FILE__,__LINE__,'IGRS') do I=1,NZN-1 @@ -341,7 +341,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & ((DEV(I+1)+P(I+1))*DVRM(I+1)+Vol(I+1)*dP_dr_in(I+1)) & /T(I+1)) FFXM=POM* ((DEV(I) +P(I) )*DVRM(I) +Vol(I)*dP_dr_in(I))/T(I) - + POM=ALFAS*ALFA POM2=0.5d0*(CPS(I)+CPS(I+1)) GG=POM*POM2*Y_face(I) @@ -358,12 +358,12 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & PII(I)=POM*GG DPIIZ0(I)=0.d0 dPII_dr_00(I)=POM*GGX0 - dPII_dr_in(I)=POM*GGXM + dPII_dr_in(I)=POM*GGXM dPII_dr_out(I)=POM*GGXP dPII_dT_00(I)=POM*GGY0 dPII_dT_out(I)=POM*GGYP enddo - + !call mesa_error(__FILE__,__LINE__,'LINA') do I=IBOTOM+1,NZN-1 @@ -473,7 +473,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & +TEM1*T(I)**3*(2.d0*Vol(I)*DVR(I) & -Vol(I)**2*( 1.d0/CPS(I)*dCp_dr_00(I) & +1.d0/K(I)*dK_dV_00(I)*DVR(I))) & - /(CPS(I)*K(I)) + /(CPS(I)*K(I)) d_dampR_dr_in(I)=d_dampR_dr_in(I) & +TEM1*T(I)**3*(2.d0*Vol(I)*DVRM(I) & @@ -488,7 +488,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & /(CPS(I)*K(I)) endif - + dC_dr_00(I) =dsrc_dr_00(I) -d_damp_dr_00(I) -d_dampR_dr_00(I) dC_dr_out(I) =dsrc_dr_out(I) -d_damp_dr_out(I) -d_dampR_dr_out(I) dC_dr_in(I) =dsrc_dr_in(I) -d_damp_dr_in(I) -d_dampR_dr_in(I) @@ -497,9 +497,9 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & dC_dT_00(I) =dsrc_dT_00(I) -d_damp_dT_00(I) -d_dampR_dT_00(I) dC_dT_out(I) =dsrc_dT_out(I) -d_damp_dT_out(I) -d_dampR_dT_out(I) dC_dw_00(I) =dsrc_dw_00(I) -d_damp_dw_00(I) -d_dampR_dw_00(I) - + enddo - + !call mesa_error(__FILE__,__LINE__,'LINA') do I=IBOTOM,NZN-1 @@ -572,8 +572,8 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & +Lt(I)/Hp_face(I)*dHp_dr_out(I) DLTY0(I)=Lt(I)/Hp_face(I)*dHp_dT_00(I) DLTYP(I)=Lt(I)/Hp_face(I)*dHp_dT_out(I) - DLTZ0(I)=-POM*POM2*1.5d0*sqrt(Et(I) )/dm_bar(I) - DLTZP(I)= POM*POM2*1.5d0*sqrt(Et(I+1))/dm_bar(I) + DLTZ0(I)=-POM*POM2*1.5d0*sqrt(Et(I) )/dm_bar(I) + DLTZP(I)= POM*POM2*1.5d0*sqrt(Et(I+1))/dm_bar(I) endif enddo @@ -603,12 +603,12 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & EVUU0(I)= POM*POM1*POM2/R(I) EVUUM(I)=-POM*POM1*POM2/R(I-1) else -! Kollath et al. 2002 EDDY VISCOSITY pressure +! Kollath et al. 2002 EDDY VISCOSITY pressure POM=-(16.d0/3.d0)*PI*ALFA*abs(ALFAM)*sqrt(Et(I)) POM1=1.d0/Vol(I)**2/dm(I) POM2=(R(I)**3+R(I-1)**3)*(Hp_face(I)+Hp_face(I-1))*0.25d0 EVUU0(I)= POM*POM1*POM2/R(I) - EVUUM(I)=-POM*POM1*POM2/R(I-1) + EVUUM(I)=-POM*POM1*POM2/R(I-1) endif enddo @@ -673,7 +673,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & dC_dT_in(NZN) = 0.d0 dC_dT_00(NZN) = 0.d0 dC_dT_out(NZN) = 0.d0 - dC_dw_00(NZN) = 0.d0 + dC_dw_00(NZN) = 0.d0 EVUU0(NZN)= 0.d0 EVUUM(NZN)= 0.d0 @@ -725,7 +725,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & DLK= (T3/K(I)) *(W_00*BW/K(I) -T2) !dL(i)/dK(i) DLKP=-(T3/K(I+1))*(W_out*BW/K(I+1)-T2) !dL(i)/dK(i+1) DLRP= DLKP*dK_dV_00(I+1)*DVR(I+1) - DLRM= DLK *dK_dV_00(I) *DVRM(I) + DLRM= DLK *dK_dV_00(I) *DVRM(I) DLR= 4.d0*T1*T2/R(I)+DLK*dK_dV_00(I)*DVR(I)+DLKP*dK_dV_00(I+1)*DVRM(I+1) DLTP=4.d0*(T3/T(I+1))*(W_out*BW/K(I+1)-T2*BK/BW)+DLKP*dK_dT_00(I+1) DLT=-4.d0*(T3/T(I))*(W_00*BW/K(I)-T2*BK/BW)+DLK*dK_dT_00(I) @@ -759,7 +759,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & ELTP(I) = DLTP +DFCYP +DLTYP(I) ELT(I) = DLT +DFCY0 +DLTY0(I) ELZ0(I) = DFCZ0 +DLTZ0(I) - ELZP(I) = DFCZP +DLTZP(I) + ELZP(I) = DFCZP +DLTZP(I) ! CALC ENERGY EQUATION(I) T2=P4/dm(I) @@ -839,7 +839,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & MU01(I) = 0.d0 MZ01(I) = 0.d0 endif - + 5 continue do I=1,NZN3 @@ -856,7 +856,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & ! ENERGY EQUATION ! (c_v)(dT/dt) = - (p+(de/dV)_T)(dV/dR)U - (dLr/dm) ! TURBULENT ENERGY EQUATION -! (de_t/dt) = +! (de_t/dt) = ! SEE CODE DOCUMENTATION FOR LINEARIZATION ! ! EIGENVALUE PROBLEM: LLL*X=SIGMA*X @@ -919,29 +919,29 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & if(IC-7>=1) LLL(IC,IC-7) = CX10(I) if(IC-3>=1) LLL(IC,IC-3) = CX00(I) if(IC+1<=NZN3) LLL(IC,IC+1) = CX01(I) - - if(IC-6>=1) LLL(IC,IC-6) = CU10(I) - if(IC-2>=1) LLL(IC,IC-2) = CU00(I) - if(IC-5>=1) LLL(IC,IC-5) = CY10(I) - if(IC-1>=1) LLL(IC,IC-1) = CY00(I) + if(IC-6>=1) LLL(IC,IC-6) = CU10(I) + if(IC-2>=1) LLL(IC,IC-2) = CU00(I) + + if(IC-5>=1) LLL(IC,IC-5) = CY10(I) + if(IC-1>=1) LLL(IC,IC-1) = CY00(I) if(IC+3<=NZN3) LLL(IC,IC+3) = CY01(I) - if(IC-4>=1) LLL(IC,IC-4) = CZ10(I) + if(IC-4>=1) LLL(IC,IC-4) = CZ10(I) LLL(IC,IC) = CZ00(I) if(IC+4<=NZN3) LLL(IC,IC+4) = CZ01(I) - + IF (IE+4 <= NZN3) then if(LLL(IE,IE+4)<0.d0)then !write(*,*) 'rerrrrrrrrrrrrrrrrrrrrrrrr',i endif endif enddo - + if (s% RSP_trace_RSP_build_model) & write(*,*) 'waiting for DGEEV to solve eigenvalue problem....' call DGEEV('n','v',NZN3,LLL,LD_LLL,WRx,WIx,VLx,LD_VL,VRx,LD_VR, & - WORKx,4*NZN3,INFO) + WORKx,4*NZN3,INFO) if(INFO/=0)then write(*,*) 'FAILED!' write(*,*) 'LAPACK/DGEEV error, ierr= ',INFO @@ -994,7 +994,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & VRx(4*NZN-3,ISORTx(IMI+J-1)+1)**2) !surface value VTTS(J)=VRx(4*NZN-3,ISORTx(IMI+J-1))+(0.d0,1.d0)* & VRx(4*NZN-3,ISORTx(IMI+J-1)+1) - + SCALE(J)=R(NZN)/VTTS(J) ! PERS(J) IS THE PERIOD OF THE MODE J (IN SECONDS) OMEG(J)=WIx(IMI+J-1) @@ -1010,7 +1010,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & ! SEE LAPACK USERS GUIDE FOR CONSTRUCTION OF EIGENVECTORS ! VRR(I,J) IS THE dR EIGENVECTOR OF THE MODE J -! dR_i +! dR_i VRR(I,J)=VRx(4*I-3,ISORTx(IMI+J-1))+(0.d0,1.d0)* & VRx(4*I-3,ISORTx(IMI+J-1)+1) ! DVRR(I,J) IS SCALED dR/R EIGENVECTOR OF THE MODE (J) @@ -1018,7 +1018,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & DVRR(I,J)=VRR(I,J)/R(I)*SCALE(J) PHR(I,J)=datan2(aimag(DVRR(I,J)),dble(DVRR(I,J))) -! VRT(I,J) IS THE dT EIGENVECTOR OF THE MODE J +! VRT(I,J) IS THE dT EIGENVECTOR OF THE MODE J ! dT_i VRT(I,J)=VRx(4*I-1,ISORTx(IMI+J-1))+(0.d0,1.d0)* & VRx(4*I-1,ISORTx(IMI+J-1)+1) @@ -1027,7 +1027,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & DVRT(I,J)=VRT(I,J)/T(I)*SCALE(J) PHT(I,J)=datan2(aimag(DVRT(I,J)),dble(DVRT(I,J))) -! VRC(I,J) IS THE dT EIGENVECTOR OF THE MODE J +! VRC(I,J) IS THE dT EIGENVECTOR OF THE MODE J ! dOMEGA_i VRC(I,J)=VRx(4*I,ISORTx(IMI+J-1))+(0.d0,1.d0)* & VRx(4*I,ISORTx(IMI+J-1)+1) @@ -1037,7 +1037,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & if(NORMC0.d0)then QWKEV(I,J)=PI*dm(I)*aimag(conjg(DPEV)*(DV_0/R(I)**3- & 3.d0*Vol(I)/R(I)**4*VRR(I,J)*SCALE(J))) @@ -1075,7 +1075,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & SGRP=SGRP+QWK(I,J)+QWKEV(I,J)+QWKPT(I,J) if(QWK(I,J)+QWKEV(I,J)+QWKPT(I,J)<0.d0) & SGRM=SGRM+abs(QWK(I,J)+QWKEV(I,J)+QWKPT(I,J)) - + VEL(I,J)=abs(VRR(I,J))/VRRS(J) if(abs(PHR(I,J))>1.57d0)VEL(I,J)=-VEL(I,J) enddo @@ -1112,7 +1112,7 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & ! CALCULATE LUMINOSITY EIGENFUNCTIONS do I=1,NZN -! VRL(I,J) IS THE dL EIGENVECTOR OF THE MODE J +! VRL(I,J) IS THE dL EIGENVECTOR OF THE MODE J ! dL_i VRL(I,J)= ELT(I)*VRT(I,J) & +ELR(I)*VRR(I,J) & @@ -1167,17 +1167,17 @@ subroutine do_LINA(s, L0, NZN, NMODES, VEL, PERS, ETO, & 26 format('control: f: (',1P,D15.8,' , ',D15.8,'), abs(f):',D15.8) enddo - + !write(*,'(a55,i12,99(1pd26.16))') 'end LINA s% w(2)**2 Et', & ! 2, s% w(2)**2, Et(NZN-1) return end subroutine do_LINA - - + + SUBROUTINE mesa_eos_kap (s,k,G,H, & !input: temp,volume & P,PV,PT,E,EV,ET,CP,CPV,dCp_dT_00, & - Q,QV,QT,OP,OPV,OPT,ierr) + Q,QV,QT,OP,OPV,OPT,ierr) use rsp_eval_eos_and_kap, only : eval_mesa_eos_and_kap implicit none type (star_info), pointer :: s @@ -1202,7 +1202,7 @@ SUBROUTINE mesa_eos_kap (s,k,G,H, & !input: temp,volume & Pgas,d_Pg_dV,d_Pg_dT,Prad,d_Pr_dT,& egas,d_egas_dV,d_egas_dT,erad,d_erad_dV,d_erad_dT, & cs,CP,CPV,dCp_dT_00, & - Q,QV,QT,OP,OPV,OPT,ierr) + Q,QV,QT,OP,OPV,OPT,ierr) if (ierr /= 0) return E = egas + erad EV = d_egas_dV + d_erad_dV @@ -1225,7 +1225,7 @@ subroutine SORT(N,RA,RB,ISORT) real(dp) :: RA(N),RB(N) integer :: L,IR,I,J,RRI real(dp) :: RRA,RRB - + do I=1,N ISORT(I)=I enddo @@ -1276,5 +1276,5 @@ subroutine SORT(N,RA,RB,ISORT) goto 10 end subroutine SORT - + end module rsp_lina diff --git a/star/private/rsp_relax_env.f90 b/star/private/rsp_relax_env.f90 index b76d479ef..83a88cc7d 100644 --- a/star/private/rsp_relax_env.f90 +++ b/star/private/rsp_relax_env.f90 @@ -31,12 +31,12 @@ module rsp_relax_env use rsp_def use rsp_eval_eos_and_kap, only: X, Y, Z use rsp_lina, only: mesa_eos_kap - + implicit none - + private public :: EOP, RELAX_ENV - + contains @@ -54,7 +54,7 @@ subroutine EOP(s,k,T,P,V,E,CP,QQ,SVEL,OP,ierr) data PRECEQ/5.d-13/ if(P<=0.d0) goto 100 !negative pressure, stop - + ierr = 0 Prad = Radiation_Pressure(T) if (P <= Prad) then @@ -83,13 +83,13 @@ subroutine EOP(s,k,T,P,V,E,CP,QQ,SVEL,OP,ierr) call mesa_error(__FILE__,__LINE__,'EOP') end if V = 1d0/rho ! initial guess to be improved below - + !write(*,*) 'eval1_mesa_Rho_given_PT', k !write(*,*) 'P', P !write(*,*) 'T', T !write(*,*) 'rho_guess', rho_guess !write(*,*) 'V', 0, V - + I=0 ! NEWTON-RAPHSON ITERATION (TO MAKE P1->P) 1 I=I+1 @@ -110,9 +110,9 @@ subroutine EOP(s,k,T,P,V,E,CP,QQ,SVEL,OP,ierr) return stop end if - + !write(*,*) 'V', I, V - + if(abs(F2)CFIDDLE) DDT=CFIDDLE*dmN*(DDT/abs(DDT)) -! CHECK IF ALFA ITERATION IS FINISHED +! CHECK IF ALFA ITERATION IS FINISHED if(abs(DDT/dmN)= max_dmN_cnt) then write(*,*) 'RELAX_ENV has reached max num allowed tries for outer dm', max_dmN_cnt ierr = -1 @@ -464,9 +464,9 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & 24 TNL = TT dmNL = dmN dmN_cnt = dmN_cnt + 1 - + if (s% RSP_relax_adjust_inner_mass_distribution) then - + dmN = dmN-DDT if(IOP>=1) then @@ -477,12 +477,12 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & do I=1,100 POM=1.d0/(NZN-NZT+1)*dlog10(1.d0-SUMM/AONE*(1.d0-HAHA)) if(dabs(HAHA-10.d0**POM)<1d-10) goto 22 - HAHA=10.d0**POM + HAHA=10.d0**POM enddo write(*,*) 'NO CONVERGENCE IN RELAX_ENV ITERATION FOR H' stop 22 continue - HAHA=10.d0**POM + HAHA=10.d0**POM ! SET NEW MASS DISTRIBUTION do I=NZN,1,-1 if(I==NZN) then @@ -495,11 +495,11 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & if(I0) ! (SEEMS UNNECESSARY) do I=IBOTOM+1,NZN-1 -! if((Y_face(I)+Y_face(I-1))>0.d0.and.Et(I)==0.d0) +! if((Y_face(I)+Y_face(I-1))>0.d0.and.Et(I)==0.d0) ! x Et(I)=1.d+6!1.d-6 if(ALFA==0.d0) Et(I)=0.d0 enddo @@ -656,7 +656,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & ((DEV(I+1)+P(I+1))*DVRM(I+1)+Vol(I+1)*dP_dr_in(I+1)) & /T(I+1)) FFXM=POM* ((DEV(I) +P(I) )*DVRM(I) +Vol(I)*dP_dr_in(I))/T(I) - + POM=ALFAS*ALFA POM2=0.5d0*(CPS(I)+CPS(I+1)) GG=POM*POM2*Y_face(I) @@ -666,14 +666,14 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & GGY0=POM*(POM2*dY_dT_00(I)+Y_face(I)*0.5d0*dCp_dT_00(I)) GGYP=POM*(POM2*dY_dT_out(I)+Y_face(I)*0.5d0*dCp_dT_00(I+1)) GPF=GG/FF - + ! corelation PI defined without e_t POM=1.d0 PII(I)=POM*GG DPIIZ0(I)=0.d0 dPII_dr_00(I)=POM*GGX0 - dPII_dr_in(I)=POM*GGXM + dPII_dr_in(I)=POM*GGXM dPII_dr_out(I)=POM*GGXP dPII_dT_00(I)=POM*GGY0 dPII_dT_out(I)=POM*GGYP @@ -688,7 +688,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & TEM1=POM2*POM3*0.5d0 TEMI=-PII(I)/Hp_face(I)**2 TEMM=-PII(I-1)/Hp_face(I-1)**2 - + ! X -> w ! Y -> T ! Z -> R @@ -790,7 +790,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & +TEM1*T(I)**3*(2.d0*Vol(I)*DVR(I) & -Vol(I)**2*( 1.d0/CPS(I)*dCp_dr_00(I) & +1.d0/K(I)*dK_dV_00(I)*DVR(I))) & - /(CPS(I)*K(I)) + /(CPS(I)*K(I)) d_dampR_dr_in(I)=d_dampR_dr_in(I) & +TEM1*T(I)**3*(2.d0*Vol(I)*DVRM(I) & @@ -866,7 +866,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & endif endif end if - + ! TURBULENT LUMINOSITY if(I=NZN.or. & ALFAT==0.d0.or.ALFA==0.d0)then @@ -901,8 +901,8 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & +Lt(I)/Hp_face(I)*dHp_dr_out(I) DLTY0(I)=Lt(I)/Hp_face(I)*dHp_dT_00(I) DLTYP(I)=Lt(I)/Hp_face(I)*dHp_dT_out(I) - DLTZ0(I)=-POM*POM2*1.5d0*sqrt(Et(I) )/dm_bar(I) - DLTZP(I)= POM*POM2*1.5d0*sqrt(Et(I+1))/dm_bar(I) + DLTZ0(I)=-POM*POM2*1.5d0*sqrt(Et(I) )/dm_bar(I) + DLTZP(I)= POM*POM2*1.5d0*sqrt(Et(I+1))/dm_bar(I) endif enddo @@ -978,7 +978,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & dC_dT_00(NZN) = 0.d0 dC_dT_out(NZN) = 0.d0 dC_dw_00(NZN) = 0.d0 - + if(ALFA==0.d0) then !RADIATIVE CASE SOURCE(I) = 0.d0 DAMP(I) = 0.d0 @@ -995,7 +995,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & ! INITIALIZE HD(11,3*NZN) - do I=1,3*NZN + do I=1,3*NZN do J=1,11 HD(J,I)=0.d0 enddo @@ -1032,7 +1032,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & DLK= (T3/K(I)) *(W_00*BW/K(I) -T2) !dL(i)/dK(i) DLKP=-(T3/K(I+1))*(W_out*BW/K(I+1)-T2) !dL(i)/dK(i+1) DLRP= DLKP*dK_dV_00(I+1)*DVR(I+1) - DLRM= DLK *dK_dV_00(I) *DVRM(I) + DLRM= DLK *dK_dV_00(I) *DVRM(I) DLR= 4.d0*T1*T2/R(I)+DLK*dK_dV_00(I)*DVR(I)+DLKP*dK_dV_00(I+1)*DVRM(I+1) DLTP=4.d0*(T3/T(I+1))*(W_out*BW/K(I+1)-T2*BK/BW)+DLKP*dK_dT_00(I+1) DLT=-4.d0*(T3/T(I))*(W_00*BW/K(I)-T2*BK/BW)+DLK*dK_dT_00(I) @@ -1062,7 +1062,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & HD(8,IW) = (DLR +DLCX0(I)+DLTX0(I))/L0 !X(i) HD(11,IW) = (DLRP+DLCXP(I)+DLTXP(I))/L0 !X(i+1) HD(7,IW) = ( DLCZ0(I)+DLTZ0(I))/L0 !Z(i) - HD(10,IW) = ( DLCZP(I)+DLTZP(I))/L0 !Z(i+1) + HD(10,IW) = ( DLCZP(I)+DLTZP(I))/L0 !Z(i+1) ! CALC MOMEMTUM EQUATION(I) T1=-P4*(R(I)**2)/dm_bar(I) if(I==NZN) then @@ -1088,7 +1088,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & HD(9,IR)= 0.d0 HD(6,IR)= +T1*(-dP_dr_00(I))+4.d0*G*M(I)/(R(I)**3) 112 continue - + ! CALC CONVECTIVE ENERGY EQUATION if(I<=IBOTOM.or.I==NZN.or.ALFA==0.d0)then do J=1,11 @@ -1123,15 +1123,15 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & ! SET ANCHOR T(NZN)=CONST if(I==NZN) then do j=1,11 - HD(J,IW) = 0.d0 + HD(J,IW) = 0.d0 enddo ! SET dT(NZN)=0 - HD(6,IW) = 1.d0 - HR(IW) = 0.d0 + HD(6,IW) = 1.d0 + HR(IW) = 0.d0 ! SET DERIVATIVES d(*)/dT(NZN)=0 IN ZONE/ITERFACE NZN - HD(4,IR) = 0.d0 - HD(5,IC) = 0.d0 - endif + HD(4,IR) = 0.d0 + HD(5,IC) = 0.d0 + endif if(I==NZN-1)then ! SET DERIVATIVES d(*)/dT(NZN)=0 IN ZONE/ITERFACE NZN-1 HD(9,IW) = 0.d0 @@ -1147,16 +1147,16 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & do I=1,3*NZN+1 ABB(J,I)=0.0d0 enddo - enddo - do J=1,5 + enddo + do J=1,5 do I=1,3*NZN+1-J ABB(11-J,I+J)=HD(6+J,I) !upper diagonals ABB(11+J,I)=HD(6-J,I+J) !lower diagonals - enddo + enddo enddo do I=1,3*NZN+1 ABB(11,I)=HD(6,I) - enddo + enddo !- LAPACK call DGBTRF(3*NZN,3*NZN,5,5,ABB,LD_ABB,IPVT,INFO) @@ -1165,7 +1165,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & open(61,file='x.dat',status='unknown') write(61,'(F6.3,tr2,f8.2,tr2,f7.2,tr2,d9.3)')EMR,ELR,TE-0.5d0, & gam - close(61) + close(61) open(61,file='logic.dat',status='unknown') write(61,'(I1)') 3 close(61) @@ -1175,7 +1175,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & if(INFO/=0) then write(*,*) 'hyd: LAPACK/dgbtrs problem no., iter.',INFO,II stop - endif + endif !- do I=1,3*NZN,1 DX(I) = HR(I) @@ -1197,7 +1197,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & if(Et(I)>(1.d-20)*EFL02) XXC=dabs(DX(IC)/Et(I)) XXR=((DX(IR-3)-DX(IR))/(R(I)-R(I-1)))/DXH XXT=dabs(DX(IW)/T(I))/DXH - + if (XXC > XX_max) then XX_max = XXC XX_max_val = Et(I) @@ -1219,7 +1219,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & i_XX_max = i var_XX_max = 3 end if - + EZH=1.d0/dmax1(1.d0/EZH,XXR,XXT,XXC) 14 continue @@ -1232,7 +1232,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & do 103 I=1,NZN IW=1+3*(I-1) IR=IW+2 - IC=IW+1 + IC=IW+1 T(I) = T(I) +EZH*DX(IW)/2d0 R(I) = R(I) +EZH*DX(IR)/2d0 Et(I) = Et(I)+EZH*DX(IC)/2d0 @@ -1260,7 +1260,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & endif 102 continue - + write(*,'(A)') write(*,*) ' NO CONVERGENCE IN RELAX_ENV, ITERATION: ',II write(*,*) ' try increasing RSP_relax_dm_tolerance', s% RSP_relax_dm_tolerance @@ -1295,7 +1295,7 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & !open(15,file='ss_lin.dat',status='unknown') do J=1,NZN IR=4+3*(J-1) - IW=2+3*(J-1) + IW=2+3*(J-1) PB=P(J)+PTURB(J) if (J == NZN) then PPB = 0 @@ -1321,8 +1321,8 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & endif if (J > IBOTOM .and. J < NZN) then ELB=Lt(J) - ELMB=Lt(J-1) - T1=(ELB-ELMB)/dm(J) + ELMB=Lt(J-1) + T1=(ELB-ELMB)/dm(J) T2=SOURCE(J)-DAMP(J)-DAMPR(J) if ((T2/=0.d0).and.(T1/=0.d0))then if (dabs(T1-T2)/max(T1,T2)>MAXC)then @@ -1336,8 +1336,8 @@ subroutine RELAX_ENV(s, L0, TH0, TE, NZT, NZN, & if (MAXW/=-1d0)write(*,*) 'MAX DIFFERENCE W: ',MAXW,' ZONE: ',IMAXW if (MAXC/=-1d0)write(*,*) 'MAX DIFFERENCE C: ',MAXC,' ZONE: ',IMAXC end if - return + return end subroutine RELAX_ENV - + end module rsp_relax_env diff --git a/star/private/rsp_step.f90 b/star/private/rsp_step.f90 index 22a0750a8..93a637362 100644 --- a/star/private/rsp_step.f90 +++ b/star/private/rsp_step.f90 @@ -30,7 +30,7 @@ module rsp_step use utils_lib, only: is_bad implicit none - + private public :: calculate_energies, init_HYD, HYD, & turn_off_time_weighting, turn_on_time_weighting, & @@ -40,14 +40,14 @@ module rsp_step calc_PII_face, calc_Pvsc, calc_Pturb, calc_Chi, calc_Eq, & calc_source_sink, acceleration_eqn, calc_cell_equations, & T_form_of_calc_Fr, calc_Lc, calc_Lt, rsp_set_Teff - + logical, parameter :: call_is_bad = .false. - + integer, parameter :: i_var_Vol = 99 ! for remeshing tests with dfridr - + integer, parameter :: & i_var_T = 2, i_var_w = 3, i_var_er = 4, i_var_Fr = 5, i_var_R = 6, & ! R must be last - + i_r_dr_in2 = 1, & i_r_dT_in = 2, & i_r_dw_in = 3, & @@ -58,77 +58,77 @@ module rsp_step i_r_dr_00 = i_r_dr_in + NV, & i_r_dr_out = i_r_dr_00 + NV, & i_r_dr_out2 = i_r_dr_out + NV, & - + i_r_dT_00 = i_r_dT_in + NV, & i_r_dT_out = i_r_dT_00 + NV, & i_r_dT_out2 = i_r_dT_out + NV, & - + i_r_dw_00 = i_r_dw_in + NV, & i_r_dw_out = i_r_dw_00 + NV, & i_r_dw_out2 = i_r_dw_out + NV, & - + i_r_der_00 = i_r_der_in + NV, & i_r_der_out = i_r_der_00 + NV, & i_r_der_out2 = i_r_der_out + NV, & - + i_r_dFr_00 = i_r_dFr_in + NV, & i_r_dFr_out = i_r_dFr_00 + NV, & i_r_dFr_out2 = i_r_dFr_out + NV, & - + i_T_dT_in2 = 1, & i_T_dw_in2 = 2, & i_T_der_in2 = 3, & i_T_dFr_in2 = 4, & i_T_dr_in2 = 5, & - + i_T_dT_in = i_T_dT_in2 + NV, & i_T_dT_00 = i_T_dT_in + NV, & i_T_dT_out = i_T_dT_00 + NV, & i_T_dT_out2 = i_T_dT_out + NV, & - + i_T_dw_in = i_T_dw_in2 + NV, & i_T_dw_00 = i_T_dw_in + NV, & i_T_dw_out = i_T_dw_00 + NV, & - + i_T_der_in = i_T_der_in2 + NV, & i_T_der_00 = i_T_der_in + NV, & i_T_der_out = i_T_der_00 + NV, & - + i_T_dFr_in = i_T_dFr_in2 + NV, & i_T_dFr_00 = i_T_dFr_in + NV, & i_T_dFr_out = i_T_dFr_00 + NV, & - + i_T_dr_in = i_T_dr_in2 + NV, & i_T_dr_00 = i_T_dr_in + NV, & i_T_dr_out = i_T_dr_00 + NV, & - + i_w_dw_in2 = 1, & i_w_der_in2 = 2, & i_w_dFr_in2 = 3, & i_w_dr_in2 = 4, & i_w_dT_in = 5, & - + i_w_dw_in = i_w_dw_in2 + NV, & i_w_dw_00 = i_w_dw_in + NV, & i_w_dw_out = i_w_dw_00 + NV, & i_w_dw_out2 = i_w_dw_out + NV, & - + i_w_der_in = i_w_der_in2 + NV, & i_w_der_00 = i_w_der_in + NV, & i_w_der_out = i_w_der_00 + NV, & - + i_w_dFr_in = i_w_dFr_in2 + NV, & i_w_dFr_00 = i_w_dFr_in + NV, & i_w_dFr_out = i_w_dFr_00 + NV, & - + i_w_dr_in = i_w_dr_in2 + NV, & i_w_dr_00 = i_w_dr_in + NV, & i_w_dr_out = i_w_dr_00 + NV, & - + i_w_dT_00 = i_w_dT_in + NV, & i_w_dT_out = i_w_dT_00 + NV, & i_w_dT_out2 = i_w_dT_out + NV, & - + i_er_der_in2 = 1, & i_er_dFr_in2 = 2, & i_er_dr_in2 = 3, & @@ -139,7 +139,7 @@ module rsp_step i_er_der_00 = i_er_der_in + NV, & i_er_der_out = i_er_der_00 + NV, & i_er_der_out2 = i_er_der_out + NV, & - + i_er_dFr_in = i_er_dFr_in2 + NV, & i_er_dFr_00 = i_er_dFr_in + NV, & i_er_dFr_out = i_er_dFr_00 + NV, & @@ -147,15 +147,15 @@ module rsp_step i_er_dr_in = i_er_dr_in2 + NV, & i_er_dr_00 = i_er_dr_in + NV, & i_er_dr_out = i_er_dr_00 + NV, & - + i_er_dT_00 = i_er_dT_in + NV, & i_er_dT_out = i_er_dT_00 + NV, & i_er_dT_out2 = i_er_dT_out + NV, & - + i_er_dw_00 = i_er_dw_in + NV, & i_er_dw_out = i_er_dw_00 + NV, & i_er_dw_out2 = i_er_dw_out + NV, & - + i_Fr_dFr_in2 = 1, & i_Fr_dr_in2 = 2, & i_Fr_dT_in = 3, & @@ -170,22 +170,22 @@ module rsp_step i_Fr_dr_in = i_Fr_dr_in2 + NV, & i_Fr_dr_00 = i_Fr_dr_in + NV, & i_Fr_dr_out = i_Fr_dr_00 + NV, & - + i_Fr_dT_00 = i_Fr_dT_in + NV, & i_Fr_dT_out = i_Fr_dT_00 + NV, & i_Fr_dT_out2 = i_Fr_dT_out + NV, & - + i_Fr_dw_00 = i_Fr_dw_in + NV, & i_Fr_dw_out = i_Fr_dw_00 + NV, & i_Fr_dw_out2 = i_Fr_dw_out + NV, & - + i_Fr_der_00 = i_Fr_der_in + NV, & i_Fr_der_out = i_Fr_der_00 + NV, & i_Fr_der_out2 = i_Fr_der_out + NV - + integer :: iter, min_k_for_turbulent_flux - - + + contains @@ -201,7 +201,7 @@ subroutine HYD(s,ierr) integer(8) :: time0 logical :: converged, dbg_msg, trace include 'formats' - + ierr = 0 dbg_msg = s% report_solver_progress trace = s% trace_evolve @@ -213,11 +213,11 @@ subroutine HYD(s,ierr) .and. s% solver_test_partials_dx_0 > 0 & .and. s% solver_test_partials_iter_number > 0 & .and. test_partials_k > 0) then - iter_for_dfridr = s% solver_test_partials_iter_number + iter_for_dfridr = s% solver_test_partials_iter_number s% solver_test_partials_var = 0 s% solver_test_partials_val = 0 s% solver_test_partials_dval_dx = 0 - end if + end if nz = s% nz i_min = 1 i_max = nz @@ -240,7 +240,7 @@ subroutine HYD(s,ierr) else min_k_for_turbulent_flux = 0 end if - + if (s% v_center > s% v(nz) .and. s% v_center > 0d0) then ! compressing innermost cell dt_max = 1d-2*(s% r(nz) - s% r_center)/(s% v_center - s% v(nz)) if (s% dt > dt_max) then @@ -275,8 +275,8 @@ subroutine HYD(s,ierr) call set_1st_iter_R_using_v_start(s) s% R_center = s% R_center + s% dt*s% v_center ! write(*,3) 'RSP HYD w', 22, 0, s% RSP_w(22) - - iter_loop: do iter = 1, max_iters + + iter_loop: do iter = 1, max_iters s% solver_iter = iter if (iter == iter_for_dfridr) then s% solver_test_partials_k = test_partials_k @@ -288,7 +288,7 @@ subroutine HYD(s,ierr) if (converged) then s% num_solver_iterations = iter - 1 s% solver_test_partials_k = test_partials_k - return + return end if if (s% doing_timing) call start_time(s, time0, total) call solve_for_corrections(s,iter) @@ -299,15 +299,15 @@ subroutine HYD(s,ierr) ! write(*,3) 'RSP HYD w', 22, iter, s% RSP_w(22) if (iter == 1) cycle iter_loop converged = (abs(DXXT) < PREC2 .and. abs(DXXC) < PREC2) - end do iter_loop + end do iter_loop call doing_retry end do retry_loop - + write(*,*) ' NO CONVERGENCE IN HYD, TIME STEP: ',s% model_number stop - + contains - + subroutine set_min_k_for_turbulent_flux real(dp) :: tau, rmid integer :: k @@ -322,17 +322,17 @@ subroutine set_min_k_for_turbulent_flux end if end do end subroutine set_min_k_for_turbulent_flux - + subroutine doing_retry include 'formats' if (num_tries == max_retries+1) then write(*,*) 'NO CONVERGENCE IN HYD, TIME STEP num tries, max allowed', & s% model_number, num_tries, max_retries+1 call mesa_error(__FILE__,__LINE__,'RSP: step num_retries = RSP_max_retries_per_step') - end if + end if call restore_start_vars(s) s% R_center = R_center_start - s% dt = s% dt/2.d0 + s% dt = s% dt/2.d0 s% num_retries = s% num_retries + 1 if (s% max_number_retries < 0) return if (s% num_retries > s% max_number_retries) then @@ -340,7 +340,7 @@ subroutine doing_retry call mesa_error(__FILE__,__LINE__,'RSP: num_retries > max_number_retries') end if end subroutine doing_retry - + subroutine write_msg include 'formats' !if (EZH < 1d0) write(*,3) 'undercorrection factor', s% model_number, iter, EZH @@ -351,26 +351,26 @@ subroutine write_msg 'erad', kE_max, DXXE, s% erad(max(1,kE_max)), & 'Fr', kL_max, DXXL, s% Fr(max(1,kL_max)) end subroutine write_msg - + subroutine check_partial integer :: i_var real(dp) :: dvardx_0, dx_0, dvardx, xdum, err include 'formats' - i_var = s% solver_test_partials_var + i_var = s% solver_test_partials_var dvardx_0 = s% solver_test_partials_dval_dx ! analytic partial if (i_var <= 0) then write(*,2) 'need to set test_partials_var', i_var call mesa_error(__FILE__,__LINE__,'check_partial') - end if + end if dx_0 = get1_val(i_var, s% solver_test_partials_k) dx_0 = s% solver_test_partials_dx_0*max(1d-99, abs(dx_0)) dvardx = dfridr(dx_0,err) xdum = (dvardx - dvardx_0)/max(abs(dvardx_0),1d-50) write(*,1) 'analytic numeric err rel_diff',dvardx_0,dvardx,err,xdum !write(*,*) - call mesa_error(__FILE__,__LINE__,'check_partial') - end subroutine check_partial - + call mesa_error(__FILE__,__LINE__,'check_partial') + end subroutine check_partial + real(dp) function get1_val(i_var,k) result(val) integer, intent(in) :: i_var, k include 'formats' @@ -386,13 +386,13 @@ real(dp) function get1_val(i_var,k) result(val) val = s% Fr(k) else if (i_var == i_var_Vol) then val = s% Vol(k) - else + else write(*,2) 'bad value for solver_test_partials_var', i_var call mesa_error(__FILE__,__LINE__,'solver_test_partials') end if end function get1_val - - subroutine store1_val(i_var, k, val) + + subroutine store1_val(i_var, k, val) integer, intent(in) :: i_var, k real(dp), intent(in) :: val include 'formats' @@ -411,7 +411,7 @@ subroutine store1_val(i_var, k, val) s% Fr(k) = val else if (i_var == i_var_Vol) then s% Vol(k) = val - else + else write(*,2) 'bad value for solver_test_partials_var', i_var call mesa_error(__FILE__,__LINE__,'solver_test_partials') end if @@ -490,10 +490,10 @@ real(dp) function dfridr(hx,err) end if end do end function dfridr - + end subroutine HYD - - + + real(dp) function get_Psurf(s,ierr) result(P_surf) use rsp_eval_eos_and_kap, only: get_surf_P_T_kap type (star_info), pointer :: s @@ -540,15 +540,15 @@ subroutine calculate_energies(s,total_radiation) ETHE = ETHE + (s% egas(k)+s% erad(k))*s% dm(k) ECON = ECON + s% RSP_w(k)**2*s% dm(k) EKIN = EKIN + cell_specific_KE(s,k,d_dv00,d_dvp1)*s% dm(k) - EGRV = EGRV + cell_specific_PE(s,k,d_dlnR00,d_dlnRp1)*s% dm(k) - - !EKIN = EKIN + 0.5d0*s% v(k)**2*s% dm_bar(k) + EGRV = EGRV + cell_specific_PE(s,k,d_dlnR00,d_dlnRp1)*s% dm(k) + + !EKIN = EKIN + 0.5d0*s% v(k)**2*s% dm_bar(k) !if (k < NZN) then ! EGRV = EGRV - s% cgrav(k) * (s%m(k)-0.5d0*s%dm(k))*s%dm(k)/(0.5d0*(s%r(k)+s%r(k+1))) !else ! EGRV = EGRV - s% cgrav(k) * (s%m(k)-0.5d0*s%dm(k))*s%dm(k)/(0.5d0*(s%r(k)+s%r_center)) !end if - + enddo if (s% RSP_hydro_only) then total_radiation = 0d0 @@ -589,7 +589,7 @@ subroutine set_1st_iter_R_using_v_start(s) type (star_info), pointer :: s real(dp) :: EH1,EHJT integer :: k - include 'formats' + include 'formats' EHJT = 1.d0 do k = 1,NZN if (k /= NZN) then @@ -614,12 +614,12 @@ subroutine rsp_set_Teff(s) type (star_info), pointer :: s real(dp) :: r, m, v, L, T_phot, cs, kap, logg, ysum integer :: k_phot - include 'formats' + include 'formats' call get_phot_info(s,r,m,v,L,T_phot,cs,kap,logg,ysum,k_phot) s% Teff = atm_Teff(L,r) end subroutine rsp_set_Teff - - + + subroutine set_f_Edd(s, ierr) type (star_info), pointer :: s integer, intent(out) :: ierr @@ -628,8 +628,8 @@ subroutine set_f_Edd(s, ierr) s% g_Edd = 0.5d0 s% f_Edd(1:NZN) = f_Edd_isotropic end subroutine set_f_Edd - - + + subroutine save_start_vars(s) type (star_info), pointer :: s integer :: I, k @@ -655,8 +655,8 @@ subroutine save_start_vars(s) s% COUPL_start(k) = s% COUPL(k) end do end subroutine save_start_vars - - + + subroutine restore_start_vars(s) type (star_info), pointer :: s integer :: I, k @@ -681,10 +681,10 @@ subroutine restore_start_vars(s) s% Lc(k) = s% Lc_start(k) s% Lt(k) = s% Lt_start(k) s% COUPL(k) = s% COUPL_start(k) - end do + end do end subroutine restore_start_vars - - + + subroutine eval_vars(s,iter,i_min,i_max,ierr) use star_utils, only: start_time, update_time type (star_info), pointer :: s @@ -727,10 +727,10 @@ subroutine eval_vars(s,iter,i_min,i_max,ierr) call calc_source_sink(s,i) end do !$OMP END PARALLEL DO - call zero_boundaries(s) + call zero_boundaries(s) end subroutine eval_vars - - + + subroutine eval_eqns(s,P_surf) type (star_info), pointer :: s real(dp), intent(in) :: P_surf @@ -770,15 +770,15 @@ subroutine do1_specific_volume(s,i) end if dVol_dr_00(i) = 3.d0*T1*s% r(k)**2 end subroutine do1_specific_volume - - + + subroutine solve_for_corrections(s,iter) type (star_info), pointer :: s integer, intent(in) :: iter integer :: i, j, info, IR, IT, IW, IE, IL, N logical :: okay include 'formats' - + !if (s% model_number >= s% max_model_number-1 .and. iter == 1) then !if (.false. .and. s% model_number == s% max_model_number) then !.and. iter == 1) then if (.false.) then @@ -791,7 +791,7 @@ subroutine solve_for_corrections(s,iter) IW = i_var_w + NV*(i-1) IE = i_var_er + NV*(i-1) IL = i_var_Fr + NV*(i-1) - + if (is_bad(HR(IR))) then write(*,4) 'HR(IR)', iter, i, IR, HR(IR) okay = .false. @@ -808,9 +808,9 @@ subroutine solve_for_corrections(s,iter) write(*,4) 'HR(IL)', iter, i, IL, HR(IL) okay = .false. end if - + if (.not. okay) call mesa_error(__FILE__,__LINE__,'solve_for_corrections') - + do j = 1,LD_HD if (is_bad(HD(j,IR))) then write(*,5) 'HD(j,IR)', iter, i, j, IR, HD(j,IR) @@ -832,9 +832,9 @@ subroutine solve_for_corrections(s,iter) write(*,5) 'HD(j,IL)', iter, i, j, IL, HD(j,IL) okay = .false. end if - + if (.not. okay) call mesa_error(__FILE__,__LINE__,'solve_for_corrections') - + end do cycle @@ -843,34 +843,34 @@ subroutine solve_for_corrections(s,iter) write(*,3) 'HR(IT)', iter, i, HR(IT) write(*,3) 'HR(IW)', iter, i, HR(IW) write(*,3) 'HR(IL)', iter, i, HR(IL) - + do j = 1,13 write(*,5) 'HD(j,IR)', iter, j, IR, i, HD(j,IR) end do - + do j = 1,13 write(*,5) 'HD(j,IT)', iter, j, IT, i, HD(j,IT) end do - + do j = 1,13 write(*,5) 'HD(j,IW)', iter, j, IW, i, HD(j,IW) end do - + write(*,3) 'HR(IE)', iter, i, HR(IE) do j = 1,13 write(*,5) 'HD(j,IE)', iter, j, IE, i, HD(j,IE) end do - + do j = 1,13 write(*,5) 'HD(j,IL)', iter, j, IL, i, HD(j,IL) end do - + end do !call mesa_error(__FILE__,__LINE__,'solve_for_corrections') end if - + N = NV*NZN+1 - + if (.false.) then ! check HR and HD for NaN's do I = 1,N if (is_bad(HR(I))) then @@ -887,37 +887,37 @@ subroutine solve_for_corrections(s,iter) end do end do end if - + do J = 1,2*NV ! translate hd into band storage of LAPACK do I = 1,N ABB(J,I) = 0.0d0 end do - end do - do J = 1,2*NV + end do + do J = 1,2*NV do I = 1,N - J ABB(LD_HD - J,I + J) = HD(HD_DIAG + J,I) ! upper diagonals - end do + end do end do - do J = 1,2*NV + do J = 1,2*NV do I = 1,N - J ABB(LD_HD + J,I) = HD(HD_DIAG - J,I + J) ! lower diagonals - end do + end do end do do I = 1,N ABB(LD_HD,I) = HD(HD_DIAG,I) - end do - + end do + call DGBTRF(N,N,2*NV,2*NV,ABB,LD_ABB,IPVT,INFO) if (INFO/= 0) then write(*,*) 'hyd: LAPACK/dgbtrf problem',INFO stop end if - + call DGBTRS('n',N,2*NV,2*NV,1,ABB,LD_ABB,IPVT,HR,N,INFO) if (INFO/= 0) then write(*,*) 'hyd: LAPACK/dgbtrs problem',INFO stop - end if + end if do I = 1,N DX(I) = HR(I) @@ -931,7 +931,7 @@ subroutine solve_for_corrections(s,iter) end subroutine solve_for_corrections - + subroutine apply_corrections(s, & DXH, XXT, XXC, XXE, XXL, EZH, & kT_max, kW_max, kE_max, kL_max) @@ -965,39 +965,39 @@ subroutine apply_corrections(s, & end if else XXC = 0d0 - end if + end if if (i == 1) then DXR = -DX(IR) XXR = (DXR/(s% r(k) - s% r_center))/DXH if (XXR > XXRM) then DXRM = DXR/(s% r(k) - s% r_center) XXRM = XXR; kRM = k; iRM = IR - end if - else + end if + else DXR = DX(IR-NV) - DX(IR) XXR = (DXR/(s% r(k) - s% r(k+1)))/DXH if (XXR > XXRM) then DXRM = DXR/(s% r(k) - s% r(k+1)) XXRM = XXR; kRM = k; iRM = IR - end if - end if + end if + end if XXE = abs(DX(IE)/s% erad(k))/DXH if (XXE > XXEM) then XXEM = XXE; kEM = k; iEM = IE - end if + end if XXL = abs(DX(IL)/s% Fr(k))/DXH if (XXL > XXLM) then XXLM = XXL; kLM = k; iLM = IL - end if + end if XXT = abs(DX(IT)/s% T(k))/DXH if (XXT > XXTM) then XXTM = XXT; kTM = k; iTM = IT - end if - EZH1 = EZH + end if + EZH1 = EZH EZH = 1.d0/max(1.d0/EZH,XXR,XXT,XXC,XXE) if (EZH1 /= EZH) kEZH = k end do - + if (EZH < 1d0 .and. s% RSP_report_undercorrections) then write(*,'(i6, 2x, i3, 6(4x, a, 1x, i4, 1x, 1pe10.3))') & s% model_number, iter, & @@ -1069,7 +1069,7 @@ subroutine apply_corrections(s, & kL_max = k; XXL = DX(IL)/s% Fr(k) end if end do - + end subroutine apply_corrections @@ -1090,8 +1090,8 @@ subroutine do1_eos_and_kap(s,i,ierr) erad, d_erad_dVol, d_erad_dT, & s% csound(k), s% Cp(k), dCp_dVol(I), dCp_dT(I), & s% QQ(k), dQQ_dVol(I), dQQ_dT(I), & - s% opacity(k), dK_dVol(I), dK_dT(I),ierr) - if (ierr /= 0) return + s% opacity(k), dK_dVol(I), dK_dT(I),ierr) + if (ierr /= 0) return d_Pg_dr_00(I) = d_Pg_dVol(I)*dVol_dr_00(I) d_Pg_dr_in(I) = d_Pg_dVol(I)*dVol_dr_in(I) d_egas_dr_00(I) = d_egas_dVol(I)*dVol_dr_00(I) @@ -1111,8 +1111,8 @@ subroutine do1_eos_and_kap(s,i,ierr) end if end if end subroutine do1_eos_and_kap - - + + subroutine calc_Prad(s,i) type (star_info), pointer :: s integer, intent(in) :: i @@ -1130,7 +1130,7 @@ subroutine calc_Prad(s,i) !test_partials = (k == s% solver_test_partials_k) test_partials = .false. - + if (test_partials) then s% solver_test_partials_val = s% Prad(k) s% solver_test_partials_var = i_var_er @@ -1138,63 +1138,63 @@ subroutine calc_Prad(s,i) write(*,*) 'calc_Prad', s% solver_test_partials_var write(*,2) 'erad Prad f_Edd', k, s% erad(k), s% Prad(k), s% f_Edd(k) end if - + end subroutine calc_Prad subroutine calc_Hp_face(s,i) type (star_info), pointer :: s - integer, intent(in) :: I + integer, intent(in) :: I real(dp) :: POM integer :: k logical :: test_partials include 'formats' k = NZN+1-i if (I < NZN) then - + POM = (s% r(k)**2)/(2.d0*s% cgrav(k)*s% m(k)) s% Hp_face(k) = POM*( & (s% Pgas(k) + s% Prad(k))*s% Vol(k) & + (s% Pgas(k-1) + s% Prad(k-1))*s% Vol(k-1)) - + dHp_dVol_00(I) = POM*( & + s% Vol(k)*(d_Pg_dVol(i) + d_Pr_dVol(i)) & + s% Pgas(k) + s% Prad(k)) dHp_dVol_out(I) = POM*( & + s% Vol(k-1)*(d_Pg_dVol(i+1) + d_Pr_dVol(i+1)) & + s% Pgas(k-1) + s% Prad(k-1)) - + dHp_dr_in(I) = POM*( & (s% Pgas(k) + s% Prad(k))*dVol_dr_in(I) & - + (d_Pg_dr_in(I) + d_Pr_dr_in(I))*s% Vol(k)) ! + + (d_Pg_dr_in(I) + d_Pr_dr_in(I))*s% Vol(k)) ! dHp_dr_00(I) = 2.d0*s% Hp_face(k)/s% r(k) + POM*( & (s% Pgas(k) + s% Prad(k))*dVol_dr_00(I) & + (d_Pg_dr_00(I) + d_Pr_dr_00(I))*s% Vol(k) & + (s% Pgas(k-1) + s% Prad(k-1))*dVol_dr_in(i+1) & - + (d_Pg_dr_in(i+1) + d_Pr_dr_in(i+1))*s% Vol(k-1)) ! + + (d_Pg_dr_in(i+1) + d_Pr_dr_in(i+1))*s% Vol(k-1)) ! dHp_dr_out(I) = POM*( & (s% Pgas(k-1) + s% Prad(k-1))*dVol_dr_00(i+1) & - + (d_Pg_dr_00(i+1) + d_Pr_dr_00(i+1))*s% Vol(k-1)) ! - - dHp_dT_00(I) = POM*s% Vol(k)*d_Pg_dT(I) ! - dHp_dT_out(I) = POM*s% Vol(k-1)*d_Pg_dT(I+1) ! - - dHp_der_00(I) = POM*s% Vol(k)*d_Pr_der(I) ! - dHp_der_out(I) = POM*s% Vol(k-1)*d_Pr_der(I+1) ! + + (d_Pg_dr_00(i+1) + d_Pr_dr_00(i+1))*s% Vol(k-1)) ! + + dHp_dT_00(I) = POM*s% Vol(k)*d_Pg_dT(I) ! + dHp_dT_out(I) = POM*s% Vol(k-1)*d_Pg_dT(I+1) ! + + dHp_der_00(I) = POM*s% Vol(k)*d_Pr_der(I) ! + dHp_der_out(I) = POM*s% Vol(k-1)*d_Pr_der(I+1) ! else ! surface - + POM = (s% r(k)**2)/(s% cgrav(k)*s% M(k)) s% Hp_face(k) = POM*(s% Pgas(k) + s% Prad(k))*s% Vol(k) - + dHp_dVol_00(I) = POM*( & + s% Vol(k)*(d_Pg_dVol(i) + d_Pr_dVol(i)) & + s% Pgas(k) + s% Prad(k)) dHp_dVol_out(I) = 0d0 - + dHp_dr_in(i) = POM*( & (s% Pgas(k) + s% Prad(k))*dVol_dr_in(i) & - + (d_Pg_dr_in(i) + d_Pr_dr_in(i))*s% Vol(k)) + + (d_Pg_dr_in(i) + d_Pr_dr_in(i))*s% Vol(k)) dHp_dr_00(i) = 2.d0*s% Hp_face(k)/s% r(k) + POM*( & (s% Pgas(k) + s% Prad(k))*dVol_dr_00(i) & + (d_Pg_dr_00(i) + d_Pr_dr_00(i))*s% Vol(k)) @@ -1203,7 +1203,7 @@ subroutine calc_Hp_face(s,i) dHp_dT_out(i) = 0.d0 dHp_der_00(i) = POM*s% Vol(k)*d_Pr_der(i) dHp_der_out(i) = 0.d0 - + end if !test_partials = (k-1 == s% solver_test_partials_k) @@ -1216,11 +1216,11 @@ subroutine calc_Hp_face(s,i) end if end subroutine calc_Hp_face - - + + subroutine calc_Y_face(s,i) type (star_info), pointer :: s - integer, intent(in) :: I + integer, intent(in) :: I real(dp) :: POM, POM2, & Y1, d_Y1_dr_00, d_Y1_dr_in, d_Y1_dr_out, & d_Y1_dVol_00, d_Y1_dVol_out, & @@ -1241,75 +1241,75 @@ subroutine calc_Y_face(s,i) 0.5d0*(s% QQ(k)/s% Cp(k)+ s% QQ(k-1)/s% Cp(k-1))* & ((s% Pgas(k-1) + s% Prad(k-1)) - (s% Pgas(k) + s% Prad(k))) & - (s% lnT(k-1) - s% lnT(k)) - + d_Y1_dVol_00 = & - POM*(d_Pg_dVol(i) + d_Pr_dVol(i)) & + POM2*(dQQ_dVol(i) - s% QQ(k)*dCp_dVol(i)/s% Cp(k))/s% Cp(k) d_Y1_dVol_out = & + POM*(d_Pg_dVol(i+1) + d_Pr_dVol(i+1)) & + POM2*(dQQ_dVol(i+1) - s% QQ(k-1)*dCp_dVol(i+1)/s% Cp(k-1))/s% Cp(k-1) - + d_Y1_dr_00 = & POM2*( & (dQQ_dr_00(I) - s% QQ(k)/s% Cp(k)*dCp_dr_00(I))/s% Cp(k)& +(dQQ_dr_in(i+1) - s% QQ(k-1)/s% Cp(k-1)*dCp_dr_in(i+1))/s% Cp(k-1)) & + POM*(d_Pg_dr_in(i+1) - d_Pg_dr_00(I) + d_Pr_dr_in(i+1) - d_Pr_dr_00(I)) - + d_Y1_dr_in = & POM2*(dQQ_dr_in(I) - s% QQ(k)/s% Cp(k)*dCp_dr_in(I))/s% Cp(k) & + POM*(- d_Pg_dr_in(I) - d_Pr_dr_in(I)) - + d_Y1_dr_out = & POM2*(dQQ_dr_00(i+1) - s% QQ(k-1)/s% Cp(k-1)*dCp_dr_00(i+1))/s% Cp(k-1) & + POM*(d_Pg_dr_00(i+1) + d_Pr_dr_00(i+1)) - + d_Y1_dT_00 = & POM2*(dQQ_dT(I) - s% QQ(k)/s% Cp(k)*dCp_dT(I))/s% Cp(k) & - POM*d_Pg_dT(I) & + 1.d0/s% T(k) - + d_Y1_dT_out = & POM2*(dQQ_dT(i+1) - s% QQ(k-1)/s% Cp(k-1)*dCp_dT(i+1))/s% Cp(k-1) & + POM*d_Pg_dT(I+1) & - 1.d0/s% T(k-1) - + d_Y1_der_00 = -POM*d_Pr_der(I) - + d_Y1_der_out = POM*d_Pr_der(I+1) POM = 2.d0/(s% Vol(k) + s% Vol(k-1)) POM2 = 8.d0*PI*(s% r(k)**2)/s% dm_bar(k)*s% Hp_face(k) Y2 = 4.d0*PI*(s% r(k)**2)*s% Hp_face(k)*POM/s% dm_bar(k) - + d_Y2_dVol_00 = & - + Y2/s% Hp_face(k)*dHp_dVol_00(i) & + + Y2/s% Hp_face(k)*dHp_dVol_00(i) & - POM2/(s% Vol(k) + s% Vol(k-1))**2 d_Y2_dVol_out = & - + Y2/s% Hp_face(k)*dHp_dVol_out(i) & + + Y2/s% Hp_face(k)*dHp_dVol_out(i) & - POM2/(s% Vol(k) + s% Vol(k-1))**2 - + d_Y2_dr_00 = 2.d0*Y2/s% r(k) & + Y2/s% Hp_face(k)*dHp_dr_00(I) & - POM2/(s% Vol(k) + s% Vol(k-1))**2*(dVol_dr_00(I) + dVol_dr_in(i+1)) - + d_Y2_dr_in = - POM2/(s% Vol(k) & + s% Vol(k-1))**2*dVol_dr_in(I) & + Y2/s% Hp_face(k)*dHp_dr_in(I) - + d_Y2_dr_out = - POM2/(s% Vol(k) & + s% Vol(k-1))**2*dVol_dr_00(i+1) & + Y2/s% Hp_face(k)*dHp_dr_out(I) - + d_Y2_dT_00 = Y2/s% Hp_face(k)*dHp_dT_00(I) - + d_Y2_dT_out = Y2/s% Hp_face(k)*dHp_dT_out(I) - + d_Y2_der_00 = Y2/s% Hp_face(k)*dHp_der_00(I) - + d_Y2_der_out = Y2/s% Hp_face(k)*dHp_der_out(I) s% Y_face(k) = Y1*Y2 - + if (k==-35 .and. iter == 1) then write(*,3) 'RSP Y_face Y1 Y2', k, s% solver_iter, s% Y_face(k), Y1, Y2 write(*,3) 'Peos', k, s% solver_iter, s% Pgas(k) + s% Prad(k) @@ -1324,16 +1324,16 @@ subroutine calc_Y_face(s,i) write(*,3) 'lgd', k-1, s% solver_iter, log(1d0/s% Vol(k-1))/ln10 end if - dY_dr_00(I) = Y1*d_Y2_dr_00 + Y2*d_Y1_dr_00 ! - dY_dr_in(I) = Y1*d_Y2_dr_in + Y2*d_Y1_dr_in ! - dY_dr_out(I) = Y1*d_Y2_dr_out + Y2*d_Y1_dr_out ! - dY_dVol_00(I) = Y1*d_Y2_dVol_00 + Y2*d_Y1_dVol_00 ! - dY_dVol_out(I) = Y1*d_Y2_dVol_out + Y2*d_Y1_dVol_out ! - dY_dT_00(I) = Y1*d_Y2_dT_00 + Y2*d_Y1_dT_00 ! - dY_dT_out(I) = Y1*d_Y2_dT_out + Y2*d_Y1_dT_out ! - dY_der_00(I) = Y1*d_Y2_der_00 + Y2*d_Y1_der_00 ! - dY_der_out(I) = Y1*d_Y2_der_out + Y2*d_Y1_der_out ! - + dY_dr_00(I) = Y1*d_Y2_dr_00 + Y2*d_Y1_dr_00 ! + dY_dr_in(I) = Y1*d_Y2_dr_in + Y2*d_Y1_dr_in ! + dY_dr_out(I) = Y1*d_Y2_dr_out + Y2*d_Y1_dr_out ! + dY_dVol_00(I) = Y1*d_Y2_dVol_00 + Y2*d_Y1_dVol_00 ! + dY_dVol_out(I) = Y1*d_Y2_dVol_out + Y2*d_Y1_dVol_out ! + dY_dT_00(I) = Y1*d_Y2_dT_00 + Y2*d_Y1_dT_00 ! + dY_dT_out(I) = Y1*d_Y2_dT_out + Y2*d_Y1_dT_out ! + dY_der_00(I) = Y1*d_Y2_der_00 + Y2*d_Y1_der_00 ! + dY_der_out(I) = Y1*d_Y2_der_out + Y2*d_Y1_der_out ! + if (call_is_bad) then if (is_bad(s% Y_face(k))) then !$omp critical (rsp_step_2) @@ -1349,7 +1349,7 @@ subroutine calc_Y_face(s,i) !$omp end critical (rsp_step_2) end if end if - + else s% Y_face(k) = 0 dY_dr_00(I) = 0 @@ -1371,10 +1371,10 @@ subroutine calc_Y_face(s,i) s% solver_test_partials_dval_dx = dY_dVol_00(I) write(*,*) 'calc_Y_face', s% solver_test_partials_var end if - + end subroutine calc_Y_face - + subroutine calc_PII_face(s,i) type (star_info), pointer :: s integer, intent(in) :: I @@ -1386,7 +1386,7 @@ subroutine calc_PII_face(s,i) if (k == 1 .or. k == s% nz .or. ALFA == 0d0) then s% PII(k) = 0 dPII_dr_00(I) = 0 - dPII_dr_in(I) = 0 + dPII_dr_in(I) = 0 dPII_dr_out(I) = 0 dPII_dVol_00(I) = 0 dPII_dVol_out(I) = 0 @@ -1394,7 +1394,7 @@ subroutine calc_PII_face(s,i) dPII_dT_out(I) = 0 dPII_der_00(I) = 0 dPII_der_out(I) = 0 - else + else POM = ALFAS*ALFA POM2 = 0.5d0*(s% Cp(k) + s% Cp(k-1)) s% PII(k) = POM*POM2*s% Y_face(k) @@ -1403,18 +1403,18 @@ subroutine calc_PII_face(s,i) POM*(POM2*dY_dVol_00(I) + s% Y_face(k)*0.5d0*dCp_dVol(I)) dPII_dVol_out(I) = & POM*(POM2*dY_dVol_out(I) + s% Y_face(k)*0.5d0*dCp_dVol(I+1)) - dPII_dr_in(I) = & ! + dPII_dr_in(I) = & ! POM*(POM2*dY_dr_in(I) + s% Y_face(k)*0.5d0*dCp_dr_in(I)) - dPII_dr_00(I) = & ! + dPII_dr_00(I) = & ! POM*(POM2*dY_dr_00(I) + s% Y_face(k)*0.5d0*(dCp_dr_00(I) + dCp_dr_in(i+1))) - dPII_dr_out(I) = & ! + dPII_dr_out(I) = & ! POM*(POM2*dY_dr_out(I) + s% Y_face(k)*0.5d0*dCp_dr_00(i+1)) - dPII_dT_00(I) = & ! + dPII_dT_00(I) = & ! POM*(POM2*dY_dT_00(I) + s% Y_face(k)*0.5d0*dCp_dT(I)) - dPII_dT_out(I) = & ! + dPII_dT_out(I) = & ! POM*(POM2*dY_dT_out(I) + s% Y_face(k)*0.5d0*dCp_dT(i+1)) - dPII_der_00(I) = POM*POM2*dY_der_00(I) ! - dPII_der_out(I) = POM*POM2*dY_der_out(I) ! + dPII_der_00(I) = POM*POM2*dY_der_00(I) ! + dPII_der_out(I) = POM*POM2*dY_der_out(I) ! end if !test_partials = (k-1 == s% solver_test_partials_k) @@ -1425,13 +1425,13 @@ subroutine calc_PII_face(s,i) s% solver_test_partials_dval_dx = dPII_dVol_out(I) write(*,*) 'calc_PII_face', s% solver_test_partials_var end if - + end subroutine calc_PII_face - - + + subroutine calc_Pvsc(s,i) type (star_info), pointer :: s - integer, intent(in) :: I + integer, intent(in) :: I real(dp) :: & dv, dv1, P, dP_dT, dP_der, dP_dr_in, dP_dr_00, V, sqrt_PV, & d_PV_dT, d_PV_der, d_PV_dr_in, d_PV_dr_00, & @@ -1479,35 +1479,35 @@ subroutine calc_Pvsc(s,i) d_PV_der = dP_der*V d_PV_dr_in = dP_dr_in*V + P*dVol_dr_in(I) d_PV_dr_00 = dP_dr_00*V + P*dVol_dr_00(I) - + d_sqrt_PV_dT = 0.5d0*d_PV_dT/sqrt_PV d_sqrt_PV_dVol = 0.5d0*d_PV_dVol/sqrt_PV d_sqrt_PV_der = 0.5d0*d_PV_der/sqrt_PV d_sqrt_PV_dr_in = 0.5d0*d_PV_dr_in/sqrt_PV d_sqrt_PV_dr_00 = 0.5d0*d_PV_dr_00/sqrt_PV - + dv1 = dv dv = dv - ZSH*sqrt_PV - + d_dv_dT = - ZSH*d_sqrt_PV_dT d_dv_dVol = - ZSH*d_sqrt_PV_dVol d_dv_der = - ZSH*d_sqrt_PV_der - + d_dv_dr_in = 2d0/s% dt - ZSH*d_sqrt_PV_dr_in ! not used if I == 1 d_dv_dr_00 = -2d0/s% dt - ZSH*d_sqrt_PV_dr_00 - + ! Pvsc = CQ*P*(dv1/sqrt_PV - cut)^2 eqn 3.60 ! = CQ*P*((dv1 - cut*sqrt_PV)/sqrt_PV)^2 ! = CQ*P/(P*V)*dv^2 ! = CQ/V*dv^2 - + s% Pvsc(k) = CQ/V*dv**2 d_Pvsc_dVol(i) = -s% Pvsc(k)/V + 2d0*d_dv_dVol*CQ/V*dv d_Pvsc_dT(i) = CQ/V*2d0*dv*d_dv_dT d_Pvsc_der(i) = CQ/V*2d0*dv*d_dv_der d_Pvsc_dr_in(i) = CQ/V*2d0*dv*d_dv_dr_in - CQ*dv**2*dVol_dr_in(I)/V**2 d_Pvsc_dr_00(i) = CQ/V*2d0*dv*d_dv_dr_00 - CQ*dv**2*dVol_dr_00(I)/V**2 - + !test_partials = (k == s% solver_test_partials_k) test_partials = .false. if (test_partials) then @@ -1518,13 +1518,13 @@ subroutine calc_Pvsc(s,i) end if end subroutine calc_Pvsc - + subroutine check_omega(s,i) type (star_info), pointer :: s - integer, intent(in) :: i + integer, intent(in) :: i real(dp) :: SOURS, DAMPS, DAMPRS, DELTA, SOL, POM, POM2, POM3, POM4, w_start integer :: k - include 'formats' + include 'formats' if (I > IBOTOM .and. I < NZN .and. ALFA /= 0d0) then ! JAK OKRESLIC OMEGA DLA PIERWSZEJ ITERACJI k = NZN+1-i @@ -1535,7 +1535,7 @@ subroutine check_omega(s,i) SOURS = POM*POM2 DAMPS = (CEDE/ALFA)/((s% Hp_face(k) + s% Hp_face(k+1))*0.5d0) POM3 = (GAMMAR**2)/(ALFA**2)*4.d0*SIG - POM4 = (s% T(k)**3)*(s% Vol(k)**2)/(s% Cp(k)*s% opacity(k)) + POM4 = (s% T(k)**3)*(s% Vol(k)**2)/(s% Cp(k)*s% opacity(k)) DAMPRS = POM3*POM4/((s% Hp_face(k)**2 + s% Hp_face(k+1)**2)*0.5d0) DELTA = DAMPRS**2 + 4.d0*DAMPS*SOURS if (k==-35) then @@ -1563,11 +1563,11 @@ subroutine check_omega(s,i) end if end if end subroutine check_omega - - + + subroutine calc_Pturb(s,i) ! TURBULENT PRESSURE (ZONE) type (star_info), pointer :: s - integer, intent(in) :: I + integer, intent(in) :: I real(dp) :: TEM1, Vol integer :: k logical :: test_partials @@ -1598,11 +1598,11 @@ subroutine calc_Pturb(s,i) ! TURBULENT PRESSURE (ZONE) write(*,*) 'calc_Pturb', s% solver_test_partials_var end if end subroutine calc_Pturb - - + + subroutine calc_Chi(s,i) ! eddy viscosity (Kuhfuss 1986) type (star_info), pointer :: s - integer, intent(in) :: I + integer, intent(in) :: I real(dp) :: POM, POM1, POM2, POM3, POM4, & POMT1, POMT2, POMT3, POMT4, Vol integer :: k @@ -1610,14 +1610,14 @@ subroutine calc_Chi(s,i) ! eddy viscosity (Kuhfuss 1986) include 'formats' k = NZN+1-i if (ALFA == 0d0 .or. I <= IBOTOM .or. I >= NZN) then - s% Chi(k) = 0 - dChi_dT_out(I) = 0 + s% Chi(k) = 0 + dChi_dT_out(I) = 0 dChi_dT_00(I) = 0 dChi_dT_in(I) = 0 - dChi_der_out(I) = 0 + dChi_der_out(I) = 0 dChi_der_00(I) = 0 dChi_der_in(I) = 0 - dChi_dw_00(I) = 0 + dChi_dw_00(I) = 0 dChi_dr_out(I) = 0 dChi_dr_00(I) = 0 dChi_dr_in(I) = 0 @@ -1626,7 +1626,7 @@ subroutine calc_Chi(s,i) ! eddy viscosity (Kuhfuss 1986) !s% profile_extra(k,3) = 0 !s% profile_extra(k,4) = 0 else - POM = (16.d0/3.d0)*PI*ALFA*ALFAM/s% dm(k) + POM = (16.d0/3.d0)*PI*ALFA*ALFAM/s% dm(k) Vol = s% Vol(k) POM1 = s% RSP_w(k)/Vol**2 POM2 = 0.5d0*(s% r(k)**6 + s% r(k+1)**6) @@ -1659,7 +1659,7 @@ subroutine calc_Chi(s,i) ! eddy viscosity (Kuhfuss 1986) !$omp end critical (rsp_step_3) end if end if - + dChi_dVol_out(I) = & POMT4*0.5d0*dHp_dVol_out(I) dChi_dVol_00(I) = & @@ -1668,29 +1668,29 @@ subroutine calc_Chi(s,i) ! eddy viscosity (Kuhfuss 1986) dChi_dVol_in(I) = & POMT4*0.5d0*dHp_dVol_00(i-1) - dChi_dT_out(I) = POMT4*0.5d0*dHp_dT_out(I) ! - dChi_dT_00(I) = POMT4*0.5d0*(dHp_dT_00(I) + dHp_dT_out(i-1)) ! - dChi_dT_in(I) = POMT4*0.5d0*dHp_dT_00(i-1) ! + dChi_dT_out(I) = POMT4*0.5d0*dHp_dT_out(I) ! + dChi_dT_00(I) = POMT4*0.5d0*(dHp_dT_00(I) + dHp_dT_out(i-1)) ! + dChi_dT_in(I) = POMT4*0.5d0*dHp_dT_00(i-1) ! + + dChi_der_out(I) = POMT4*0.5d0*(dHp_der_out(I)) ! + dChi_der_00(I) = POMT4*0.5d0*(dHp_der_00(I) + dHp_der_out(i-1)) ! + dChi_der_in(I) = POMT4*0.5d0*(dHp_der_00(i-1)) ! - dChi_der_out(I) = POMT4*0.5d0*(dHp_der_out(I)) ! - dChi_der_00(I) = POMT4*0.5d0*(dHp_der_00(I) + dHp_der_out(i-1)) ! - dChi_der_in(I) = POMT4*0.5d0*(dHp_der_00(i-1)) ! + dChi_dw_00(I) = POMT1/Vol**2 ! - dChi_dw_00(I) = POMT1/Vol**2 ! - - dChi_dr_out(I) = POMT4*0.5d0*(dHp_dr_out(I)) ! + dChi_dr_out(I) = POMT4*0.5d0*(dHp_dr_out(I)) ! dChi_dr_00(I) = & - - 2.d0*s% Chi(k)/Vol*dVol_dr_00(I) & ! + - 2.d0*s% Chi(k)/Vol*dVol_dr_00(I) & ! + POMT2*3.d0*s% r(k)**5 & + POMT3*(2.d0/s% dt/s% r(k) - s% v(k)/s% r(k)**2) & + POMT4*0.5d0*(dHp_dr_00(I) + dHp_dr_out(i-1)) dChi_dr_in(I) = & - - 2.d0*s% Chi(k)/Vol*dVol_dr_in(I) & ! + - 2.d0*s% Chi(k)/Vol*dVol_dr_in(I) & ! + POMT2*3.d0*s% r(k+1)**5 & - POMT3*(2.d0/s% dt/s% r(k+1) - s% v(k+1)/s% r(k+1)**2) & + POMT4*0.5d0*(dHp_dr_in(I) + dHp_dr_00(i-1)) - dChi_dr_in2(I) = POMT4*0.5d0*dHp_dr_in(i-1) ! - + dChi_dr_in2(I) = POMT4*0.5d0*dHp_dr_in(i-1) ! + if (call_is_bad) then if (is_bad(dChi_dr_in(I))) then !$omp critical (rsp_step_4) @@ -1709,13 +1709,13 @@ subroutine calc_Chi(s,i) ! eddy viscosity (Kuhfuss 1986) !$omp end critical (rsp_step_4) end if end if - + end if - + !if (k==194) then ! write(*,2) 'RSP Chi', k, s% Chi(k) !end if - + !test_partials = (k-1 == s% solver_test_partials_k) test_partials = .false. if (test_partials) then @@ -1729,7 +1729,7 @@ end subroutine calc_Chi subroutine calc_Eq(s,i) type (star_info), pointer :: s - integer, intent(in) :: I + integer, intent(in) :: I real(dp) :: RRI, RRM, UUI, UUM, POM, POM2 integer :: k logical :: test_partials @@ -1752,38 +1752,38 @@ subroutine calc_Eq(s,i) dEq_der_in(I) = 0 dEq_dw_00(I) = 0 else - + RRI = 0.5d0*(s% r(k) + s% r_start(k)) RRM = 0.5d0*(s% r(k+1) + s% r_start(k+1)) UUI = 0.5d0*(s% v(k) + s% v_start(k)) UUM = 0.5d0*(s% v(k+1) + s% v_start(k+1)) - + POM = P4/s% dm(k)*(UUI/RRI - UUM/RRM) POM2 = P4/s% dm(k)*(THETAU*s% Chi(k) + THETAU1*s% Chi_start(k)) - + s% Eq(k) = POM*(THETAU*s% Chi(k) + THETAU1*s% Chi_start(k)) - + POM = POM*THETAU dEq_dVol_out(I) = POM*THETAU*dChi_dVol_out(i) dEq_dVol_00(I) = POM*THETAU*dChi_dVol_00(i) dEq_dVol_in(I) = POM*THETAU*dChi_dVol_in(i) - - dEq_dr_out(I) = POM*dChi_dr_out(I) ! - dEq_dr_00(I) = POM*dChi_dr_00(I) & ! + + dEq_dr_out(I) = POM*dChi_dr_out(I) ! + dEq_dr_00(I) = POM*dChi_dr_00(I) & ! + POM2*(1.d0/(RRI*s% dt) - 0.5d0*UUI/(RRI**2)) - dEq_dr_in(I) = POM*dChi_dr_in(I) & ! + dEq_dr_in(I) = POM*dChi_dr_in(I) & ! - POM2*(1.d0/(RRM*s% dt) - 0.5d0*UUM/(RRM**2)) - dEq_dr_in2(I) = POM*dChi_dr_in2(I) ! - dEq_dT_out(I) = POM*dChi_dT_out(I) ! - dEq_dT_00(I) = POM*dChi_dT_00(I) ! - dEq_dT_in(I) = POM*dChi_dT_in(I) ! - dEq_der_out(I) = POM*dChi_der_out(I) ! - dEq_der_00(I) = POM*dChi_der_00(I) ! - dEq_der_in(I) = POM*dChi_der_in(I) ! - dEq_dw_00(I) = POM*dChi_dw_00(I) ! - end if - + dEq_dr_in2(I) = POM*dChi_dr_in2(I) ! + dEq_dT_out(I) = POM*dChi_dT_out(I) ! + dEq_dT_00(I) = POM*dChi_dT_00(I) ! + dEq_dT_in(I) = POM*dChi_dT_in(I) ! + dEq_der_out(I) = POM*dChi_der_out(I) ! + dEq_der_00(I) = POM*dChi_der_00(I) ! + dEq_der_in(I) = POM*dChi_der_in(I) ! + dEq_dw_00(I) = POM*dChi_dw_00(I) ! + end if + !test_partials = (k+1 == s% solver_test_partials_k) test_partials = .false. if (test_partials) then @@ -1793,11 +1793,11 @@ subroutine calc_Eq(s,i) write(*,*) 'calc_Eq', s% solver_test_partials_var end if end subroutine calc_Eq - - + + subroutine calc_source_sink(s,i) type (star_info), pointer :: s - integer, intent(in) :: I + integer, intent(in) :: I real(dp) :: POM, POM2, POM3, POM4, TEM1, TEMI, TEMM, & dsrc_dr_in2, dsrc_dr_in, dsrc_dr_00, dsrc_dr_out, & dsrc_dVol_out, dsrc_dVol_00, dsrc_dVol_in, & @@ -1825,20 +1825,20 @@ subroutine calc_source_sink(s,i) s% SOURCE(k) = 0 s% DAMP(k) = 0 s% DAMPR(k) = 0 - s% COUPL(k) = 0 + s% COUPL(k) = 0 else ! SOURCE TERM POM = 0.5d0*(s% PII(k)/s% Hp_face(k) + s% PII(k+1)/s% Hp_face(k+1)) QQ_div_Cp = s% QQ(k)/s% Cp(k) POM2 = s% T(k)*(s% Pgas(k) + s% Prad(k))*QQ_div_Cp - POM3 = s% RSP_w(k) + POM3 = s% RSP_w(k) s% SOURCE(k) = POM*POM2*POM3 - + ! P*QQ/Cp = grad_ad if (k==-109) write(*,3) 'w grada PII_00 PII_p1 SOURCE', k, s% solver_iter, & s% RSP_w(k), (s% Pgas(k) + s% Prad(k))*QQ_div_Cp, s% PII(k), & s% PII(k+1), s% SOURCE(k) - + TEM1 = POM2*POM3*0.5d0 TEMI = - s% PII(k)/s% Hp_face(k)**2 TEMM = - s% PII(k+1)/s% Hp_face(k+1)**2 @@ -1902,7 +1902,7 @@ subroutine calc_source_sink(s,i) + s% T(k)*s% QQ(k)*d_Pg_dT(I) & + s% T(k)*(s% Pgas(k) + s% Prad(k))*dQQ_dT(I) & - s% T(k)*(s% Pgas(k) + s% Prad(k))*s% QQ(k)/s% Cp(k)*dCp_dT(I)) - + dsrc_der_00 = dsrc_der_00 & + POM/s% Cp(k)*s% T(k)*s% QQ(k)*d_Pr_der(I) @@ -1919,9 +1919,9 @@ subroutine calc_source_sink(s,i) POM = (CEDE/ALFA)*(s% RSP_w(k)**3 - EFL0**3) POM2 = 0.5d0*(s% Hp_face(k) + s% Hp_face(k+1)) s% DAMP(k) = POM/POM2 - + TEM1 = - 0.5d0*POM/POM2**2 - + d_damp_dVol_out = TEM1*dHp_dVol_out(I) d_damp_dVol_00 = TEM1*(dHp_dVol_00(I) + dHp_dVol_out(i-1)) d_damp_dVol_in = TEM1*dHp_dVol_00(i-1) @@ -1936,7 +1936,7 @@ subroutine calc_source_sink(s,i) d_damp_der_out = TEM1*dHp_der_out(I) d_damp_der_in = TEM1*dHp_der_00(i-1) d_damp_dw_00 = 3.0d0*(CEDE/ALFA)/POM2*s% RSP_w(k)**2 - + ! RADIATIVE DAMP TERM if (GAMMAR == 0.d0)then s% DAMPR(k) = 0.d0 @@ -1954,7 +1954,7 @@ subroutine calc_source_sink(s,i) d_dampR_der_in = 0.d0 d_dampR_der_00 = 0.d0 d_dampR_dw_00 = 0.d0 - else + else POM = (GAMMAR**2)/(ALFA**2)*4.d0*SIG POM2a = s% T(k)**3*s% Vol(k)**2 POM2b = 1d0/(s% Cp(k)*s% opacity(k)) @@ -1962,7 +1962,7 @@ subroutine calc_source_sink(s,i) POM3 = s% RSP_w(k)**2 POM4 = 0.5d0*(s% Hp_face(k)**2 + s% Hp_face(k+1)**2) s% DAMPR(k) = POM*POM2*POM3/POM4 - + TEM1 = - s% DAMPR(k)/POM4 d_POM2a_dVol_00 = 2d0*s% T(k)**3*s% Vol(k) @@ -1972,25 +1972,25 @@ subroutine calc_source_sink(s,i) d_POM4_dVol_00 = & s% Hp_face(k)*dHp_dVol_00(I) + & s% Hp_face(k+1)*dHp_dVol_out(I-1) - + d_dampR_dVol_out = TEM1*s% Hp_face(k)*dHp_dVol_out(I) d_dampR_dVol_00 = POM*POM3*( & d_POM2_dVol_00 - POM2*d_POM4_dVol_00/POM4)/POM4 - + d_dampR_dVol_in = TEM1*s% Hp_face(k+1)*dHp_dVol_00(i-1) - + d_dampR_dr_out = TEM1*s% Hp_face(k)*dHp_dr_out(I) d_dampR_dr_00 = TEM1*(s% Hp_face(k)*dHp_dr_00(I) & + s% Hp_face(k+1)*dHp_dr_out(i-1)) d_dampR_dr_in = TEM1*(s% Hp_face(k)*dHp_dr_in(I) & + s% Hp_face(k+1)*dHp_dr_00(i-1)) d_dampR_dr_in2 = TEM1*s% Hp_face(k+1)*dHp_dr_in(i-1) - + d_dampR_dT_out = TEM1*s% Hp_face(k)*dHp_dT_out(I) d_dampR_dT_00 = TEM1*(s% Hp_face(k)*dHp_dT_00(I) & + s% Hp_face(k+1)*dHp_dT_out(i-1)) d_dampR_dT_in = TEM1*s% Hp_face(k+1)*dHp_dT_00(i-1) - + d_dampR_der_out = TEM1*s% Hp_face(k)*dHp_der_out(I) d_dampR_der_00 = TEM1*(s% Hp_face(k)*dHp_der_00(I) & + s% Hp_face(k+1)*dHp_der_out(i-1)) @@ -2003,7 +2003,7 @@ subroutine calc_source_sink(s,i) + TEM1*s% T(k)**3*(2.d0*s% Vol(k)*dVol_dr_00(I) & - s% Vol(k)**2*(1.d0/s% Cp(k)*dCp_dr_00(I) & + 1.d0/s% opacity(k)*dK_dr_00(I))) & - /(s% Cp(k)*s% opacity(k)) + /(s% Cp(k)*s% opacity(k)) d_dampR_dr_in = d_dampR_dr_in & + TEM1*s% T(k)**3*(& @@ -2019,22 +2019,22 @@ subroutine calc_source_sink(s,i) /(s% Cp(k)*s% opacity(k)) end if - + s% COUPL(k) = s% SOURCE(k) - s% DAMP(k) - s% DAMPR(k) - dC_dr_00(I) = dsrc_dr_00 - d_damp_dr_00 - d_dampR_dr_00 ! - dC_dr_out(I) = dsrc_dr_out - d_damp_dr_out - d_dampR_dr_out ! - dC_dr_in(I) = dsrc_dr_in - d_damp_dr_in - d_dampR_dr_in ! - dC_dr_in2(I) = dsrc_dr_in2 - d_damp_dr_in2 - d_dampR_dr_in2 ! - dC_dVol_00(I) = dsrc_dVol_00 - d_damp_dVol_00 - d_dampR_dVol_00 ! - dC_dVol_out(I) = dsrc_dVol_out - d_damp_dVol_out - d_dampR_dVol_out ! - dC_dVol_in(I) = dsrc_dVol_in - d_damp_dVol_in - d_dampR_dVol_in ! - dC_dT_00(I) = dsrc_dT_00 - d_damp_dT_00 - d_dampR_dT_00 ! - dC_dT_out(I) = dsrc_dT_out - d_damp_dT_out - d_dampR_dT_out ! - dC_dT_in(I) = dsrc_dT_in - d_damp_dT_in - d_dampR_dT_in ! - dC_der_00(I) = dsrc_der_00 - d_damp_der_00 - d_dampR_der_00 ! - dC_der_out(I) = dsrc_der_out - d_damp_der_out - d_dampR_der_out ! - dC_der_in(I) = dsrc_der_in - d_damp_der_in - d_dampR_der_in ! - dC_dw_00(I) = dsrc_dw_00 - d_damp_dw_00 - d_dampR_dw_00 ! + dC_dr_00(I) = dsrc_dr_00 - d_damp_dr_00 - d_dampR_dr_00 ! + dC_dr_out(I) = dsrc_dr_out - d_damp_dr_out - d_dampR_dr_out ! + dC_dr_in(I) = dsrc_dr_in - d_damp_dr_in - d_dampR_dr_in ! + dC_dr_in2(I) = dsrc_dr_in2 - d_damp_dr_in2 - d_dampR_dr_in2 ! + dC_dVol_00(I) = dsrc_dVol_00 - d_damp_dVol_00 - d_dampR_dVol_00 ! + dC_dVol_out(I) = dsrc_dVol_out - d_damp_dVol_out - d_dampR_dVol_out ! + dC_dVol_in(I) = dsrc_dVol_in - d_damp_dVol_in - d_dampR_dVol_in ! + dC_dT_00(I) = dsrc_dT_00 - d_damp_dT_00 - d_dampR_dT_00 ! + dC_dT_out(I) = dsrc_dT_out - d_damp_dT_out - d_dampR_dT_out ! + dC_dT_in(I) = dsrc_dT_in - d_damp_dT_in - d_dampR_dT_in ! + dC_der_00(I) = dsrc_der_00 - d_damp_der_00 - d_dampR_der_00 ! + dC_der_out(I) = dsrc_der_out - d_damp_der_out - d_dampR_der_out ! + dC_der_in(I) = dsrc_der_in - d_damp_der_in - d_dampR_der_in ! + dC_dw_00(I) = dsrc_dw_00 - d_damp_dw_00 - d_dampR_dw_00 ! !test_partials = (k == s% solver_test_partials_k) test_partials = .false. @@ -2063,7 +2063,7 @@ subroutine zero_boundaries(s) dEq_dT_in(I) = 0.d0 dEq_dT_00(I) = 0.d0 dEq_dT_out(I) = 0.d0 - dEq_dw_00(I) = 0.d0! - + dEq_dw_00(I) = 0.d0! - s% Chi(k) = 0.d0 dChi_dr_in2(I) = 0.d0 dChi_dr_in(I) = 0.d0 @@ -2072,7 +2072,7 @@ subroutine zero_boundaries(s) dChi_dT_in(I) = 0.d0 dChi_dT_00(I) = 0.d0 dChi_dT_out(I) = 0.d0 - dChi_dw_00(I) = 0.d0! - + dChi_dw_00(I) = 0.d0! - s% COUPL(k) = 0.d0 dC_dr_00(I) = 0.d0 dC_dr_out(I) = 0.d0 @@ -2081,11 +2081,11 @@ subroutine zero_boundaries(s) dC_dT_in(I) = 0.d0 dC_dT_00(I) = 0.d0 dC_dT_out(I) = 0.d0 - dC_dw_00(I) = 0.d0! - + dC_dw_00(I) = 0.d0! - s% Ptrb(k) = 0.d0 - dPtrb_dr_00(I) = 0.d0 + dPtrb_dr_00(I) = 0.d0 dPtrb_dr_in(I) = 0.d0 - dPtrb_dw_00(I) = 0.d0! - + dPtrb_dw_00(I) = 0.d0! - end do do I = NZN,NZN k = NZN+1-i @@ -2097,7 +2097,7 @@ subroutine zero_boundaries(s) dEq_dT_in(I) = 0.d0 dEq_dT_00(I) = 0.d0 dEq_dT_out(I) = 0.d0 - dEq_dw_00(I) = 0.d0! - + dEq_dw_00(I) = 0.d0! - s% Chi(k) = 0.d0 dChi_dr_in2(I) = 0.d0 dChi_dr_in(I) = 0.d0 @@ -2106,7 +2106,7 @@ subroutine zero_boundaries(s) dChi_dT_in(I) = 0.d0 dChi_dT_00(I) = 0.d0 dChi_dT_out(I) = 0.d0 - dChi_dw_00(I) = 0.d0! - + dChi_dw_00(I) = 0.d0! - s% COUPL(k) = 0.d0 dC_dr_00(I) = 0.d0 dC_dr_out(I) = 0.d0 @@ -2115,15 +2115,15 @@ subroutine zero_boundaries(s) dC_dT_in(I) = 0.d0 dC_dT_00(I) = 0.d0 dC_dT_out(I) = 0.d0 - dC_dw_00(I) = 0.d0! - + dC_dw_00(I) = 0.d0! - s% Ptrb(k) = 0.d0 dPtrb_dr_00(I) = 0.d0 dPtrb_dr_in(I) = 0.d0 - dPtrb_dw_00(I) = 0.d0! - + dPtrb_dw_00(I) = 0.d0! - end do end subroutine zero_boundaries - + subroutine calc_Lt(s,i,Lt_00, & dLt_dr_00, dLt_dr_in, dLt_dr_out, & dLt_dVol_00, dLt_dVol_out, & @@ -2131,7 +2131,7 @@ subroutine calc_Lt(s,i,Lt_00, & dLt_der_00, dLt_der_out, & dLt_dw_00, dLt_dw_out) type (star_info), pointer :: s - integer, intent(in) :: I + integer, intent(in) :: I real(dp), intent(out) :: & Lt_00, & dLt_dr_00, dLt_dr_in, dLt_dr_out, & @@ -2151,11 +2151,11 @@ subroutine calc_Lt(s,i,Lt_00, & dLt_dr_00 = 0.d0 dLt_dr_in = 0.d0 dLt_dr_out = 0.d0 - dLt_dVol_00 = 0.d0 + dLt_dVol_00 = 0.d0 dLt_dVol_out = 0.d0 - dLt_dT_00 = 0.d0 + dLt_dT_00 = 0.d0 dLt_dT_out = 0.d0 - dLt_der_00 = 0.d0 + dLt_der_00 = 0.d0 dLt_der_out = 0.d0 dLt_dw_00 = 0.d0 dLt_dw_out = 0.d0 @@ -2164,36 +2164,36 @@ subroutine calc_Lt(s,i,Lt_00, & POM = - 2.d0/3.d0*ALFA*ALFAT*(P4*(s% r(k)**2))**2 rho2_face = 0.5d0*(1.d0/s% Vol(k)**2 + 1.d0/s% Vol(k-1)**2) POM2 = s% Hp_face(k)*rho2_face - Lt_00 = POM*POM2*POM3 - + Lt_00 = POM*POM2*POM3 + TEM1 = Lt_00/s% Hp_face(k) TEM2 = Lt_00/POM2*s% Hp_face(k) - + d_POM2_dVol_00 = dHp_dVol_00(i)*rho2_face - s% Hp_face(k)/s% Vol(k)**3 d_POM2_dVol_out = dHp_dVol_out(i)*rho2_face - s% Hp_face(k)/s% Vol(k-1)**3 dLt_dVol_00 = POM*POM3*d_POM2_dVol_00 dLt_dVol_out = POM*POM3*d_POM2_dVol_out - - dLt_dr_00 = 4.d0*Lt_00/s% r(k) & ! + + dLt_dr_00 = 4.d0*Lt_00/s% r(k) & ! - TEM2/s% Vol(k)**3*dVol_dr_00(I) & - TEM2/s% Vol(k-1)**3*dVol_dr_in(i+1) & + TEM1*dHp_dr_00(I) dLt_dr_in = & - - TEM2/s% Vol(k)**3*dVol_dr_in(I) & ! + - TEM2/s% Vol(k)**3*dVol_dr_in(I) & ! + TEM1*dHp_dr_in(I) dLt_dr_out = & - - TEM2/s% Vol(k-1)**3*dVol_dr_00(i+1) & ! + - TEM2/s% Vol(k-1)**3*dVol_dr_00(i+1) & ! + TEM1*dHp_dr_out(I) - dLt_dT_00 = TEM1*dHp_dT_00(I) ! - dLt_dT_out = TEM1*dHp_dT_out(I) ! - dLt_der_00 = TEM1*dHp_der_00(I) ! - dLt_der_out = TEM1*dHp_der_out(I) ! - TEM1 = POM*POM2*3.0d0/s% dm_bar(k) - dLt_dw_00 = -TEM1*s% RSP_w(k)**2 ! - dLt_dw_out = TEM1*s% RSP_w(k-1)**2 ! + dLt_dT_00 = TEM1*dHp_dT_00(I) ! + dLt_dT_out = TEM1*dHp_dT_out(I) ! + dLt_der_00 = TEM1*dHp_der_00(I) ! + dLt_der_out = TEM1*dHp_der_out(I) ! + TEM1 = POM*POM2*3.0d0/s% dm_bar(k) + dLt_dw_00 = -TEM1*s% RSP_w(k)**2 ! + dLt_dw_out = TEM1*s% RSP_w(k-1)**2 ! end if if (i > 0) s% Lt(k) = Lt_00 - + !test_partials = (k-1 == s% solver_test_partials_k) test_partials = .false. if (test_partials) then @@ -2203,8 +2203,8 @@ subroutine calc_Lt(s,i,Lt_00, & write(*,*) 'calc_Lt', s% solver_test_partials_var end if end subroutine calc_Lt - - + + subroutine calc_Lc(s,i,Lc_00, & dLc_dr_in, dLc_dr_00, dLc_dr_out, & dLc_dVol_00, dLc_dVol_out, & @@ -2212,7 +2212,7 @@ subroutine calc_Lc(s,i,Lc_00, & dLc_der_00, dLc_der_out, & dLc_dw_00, dLc_dw_out) type (star_info), pointer :: s - integer, intent(in) :: I + integer, intent(in) :: I real(dp), intent(out) :: & Lc_00, dLc_dr_in, dLc_dr_00, dLc_dr_out, & dLc_dVol_00, dLc_dVol_out, & @@ -2224,7 +2224,7 @@ subroutine calc_Lc(s,i,Lc_00, & logical :: test_partials include 'formats' k = NZN+1-i - if (I <= IBOTOM .or. I == NZN .or. ALFA == 0d0)then + if (I <= IBOTOM .or. I == NZN .or. ALFA == 0d0)then Lc_00 = 0.d0 !DODANE SMOLEC dLc_dr_in = 0.d0 dLc_dr_00 = 0.d0 @@ -2236,7 +2236,7 @@ subroutine calc_Lc(s,i,Lc_00, & dLc_der_00 = 0.d0 dLc_der_out = 0.d0 dLc_dw_00 = 0.d0 - dLc_dw_out = 0.d0! - + dLc_dw_out = 0.d0! - else if (s% RSP_w(k) < EFL0*1d-8)then Lc_00 = 0.d0 dLc_dr_00 = 0.d0 @@ -2251,50 +2251,50 @@ subroutine calc_Lc(s,i,Lc_00, & dLc_dw_00 = 0.d0 dLc_dw_out = 0.d0 else - + POM3 = 0.5d0*(s% RSP_w(k) + s% RSP_w(k-1)) POM = P4*(s% r(k)**2)*(ALFAC/ALFAS)* & 0.5d0*(s% T(k)/s% Vol(k) + s% T(k-1)/s% Vol(k-1)) - Lc_00 = POM*s% PII(k)*POM3 - - dLc_dw_00 = POM*s% PII(k)*0.5d0 ! + Lc_00 = POM*s% PII(k)*POM3 + + dLc_dw_00 = POM*s% PII(k)*0.5d0 ! if (I >= NZN - 1) then dLc_dw_out = 0.d0 else - dLc_dw_out = POM*s% PII(k)*0.5d0 ! + dLc_dw_out = POM*s% PII(k)*0.5d0 ! end if - + POM2 = P4*(s% r(k)**2)*s% PII(k)*POM3*0.5d0*(ALFAC/ALFAS) POM = POM*POM3 - - dLc_dr_00 = & ! + + dLc_dr_00 = & ! POM*dPII_dr_00(I) & + 2.d0*Lc_00/s% r(k) & - POM2*(s% T(k)/(s% Vol(k)**2)*dVol_dr_00(I) + & s% T(k-1)/(s% Vol(k-1)**2)*dVol_dr_in(i+1)) dLc_dr_in = & POM*dPII_dr_in(I) & - - POM2*s% T(k)/(s% Vol(k)**2)*dVol_dr_in(I) ! + - POM2*s% T(k)/(s% Vol(k)**2)*dVol_dr_in(I) ! dLc_dr_out = & POM*dPII_dr_out(I) & - - POM2*s% T(k-1)/(s% Vol(k-1)**2)*dVol_dr_00(i+1) ! + - POM2*s% T(k-1)/(s% Vol(k-1)**2)*dVol_dr_00(i+1) ! dLc_dVol_00 = & POM*dPII_dVol_00(I) & - - POM2*s% T(k)/(s% Vol(k)**2) ! + - POM2*s% T(k)/(s% Vol(k)**2) ! dLc_dVol_out = & POM*dPII_dVol_out(I) & - - POM2*s% T(k-1)/(s% Vol(k-1)**2) ! - - dLc_dT_00 = POM*dPII_dT_00(I) + POM2/s% Vol(k) ! - dLc_dT_out = POM*dPII_dT_out(I) + POM2/s% Vol(k-1) ! - - dLc_der_00 = POM*dPII_der_00(I) ! - dLc_der_out = POM*dPII_der_out(I) ! - - end if - + - POM2*s% T(k-1)/(s% Vol(k-1)**2) ! + + dLc_dT_00 = POM*dPII_dT_00(I) + POM2/s% Vol(k) ! + dLc_dT_out = POM*dPII_dT_out(I) + POM2/s% Vol(k-1) ! + + dLc_der_00 = POM*dPII_der_00(I) ! + dLc_der_out = POM*dPII_der_out(I) ! + + end if + if (i > 0) s% Lc(k) = Lc_00 !test_partials = (k-1 == s% solver_test_partials_k) @@ -2306,17 +2306,17 @@ subroutine calc_Lc(s,i,Lc_00, & write(*,*) 'calc_Lc', s% solver_test_partials_var end if end subroutine calc_Lc - + ! in diffusion limit, radiative flux equation reduces to Fr calculated from d_erad_dm as below. ! note that can have nonequilibrium diffusion regime with different T for gas and photons. ! this happens when absorption mean opacity is different than Planck mean opacity. - subroutine calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A + subroutine calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A dFr_dr_out, dFr_dr_00, dFr_dr_in, & dFr_dVol_out, dFr_dVol_00, & dFr_dT_out, dFr_dT_00, & dFr_der_out, dFr_der_00) type (star_info), pointer :: s - integer, intent(in) :: I + integer, intent(in) :: I real(dp), intent(out) :: & Fr_00, dFr_dr_out, dFr_dr_00, dFr_dr_in, & dFr_dVol_out, dFr_dVol_00, & @@ -2332,9 +2332,9 @@ subroutine calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A integer :: k logical :: test_partials include 'formats' - + k = NZN+1-i - + if (i < 1) then if (s% RSP_hydro_only) then Fr_00 = 0d0 @@ -2343,7 +2343,7 @@ subroutine calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A end if Fr_00 = Fr_00/(4d0*pi*s% r_center**2) dFr_dr_out = 0 - dFr_dr_00 = 0 + dFr_dr_00 = 0 dFr_dr_in = 0 dFr_dVol_out = 0 dFr_dVol_00 = 0 @@ -2353,14 +2353,14 @@ subroutine calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A dFr_der_00 = 0 return end if - + Prad_factor = 3d0/crad ! 3d0 to cancel the 1/3d0 factor in CL below W_00 = Prad_factor*s% Prad(k) ! replaces s% T(k)**4 d_W_00_dVol_00 = Prad_factor*d_Pr_dVol(i) d_W_00_dr_in = Prad_factor*d_Pr_dr_in(i) d_W_00_dr_00 = Prad_factor*d_Pr_dr_00(i) - d_W_00_der_00 = Prad_factor*d_Pr_der(i) - + d_W_00_der_00 = Prad_factor*d_Pr_der(i) + if (k == 1) then ! surface Fr1 = s% g_Edd*4d0*SIG Fr_00 = Fr1*W_00 ! s% T(k)**4 => W_00 @@ -2375,14 +2375,14 @@ subroutine calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A dFr_der_00 = Fr1*d_W_00_der_00 return end if - + W_out = Prad_factor*s% Prad(k-1) ! replaces s% T(k-1)**4 d_W_out_dVol_out = Prad_factor*d_Pr_dVol(i+1) d_W_out_dr_00 = Prad_factor*d_Pr_dr_in(i+1) d_W_out_dr_out = Prad_factor*d_Pr_dr_00(i+1) d_W_out_der_out = Prad_factor*d_Pr_der(i+1) - - BW = log(W_out/W_00) + + BW = log(W_out/W_00) if (abs(BW) < 1d-30) then Fr_00 = 0 dFr_dr_out = 0 @@ -2396,21 +2396,21 @@ subroutine calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A dFr_der_00 = 0 return end if - + kap_00 = s% opacity(k) kap_out = s% opacity(k-1) BK = log(kap_out/kap_00) Fr1 = -CL*s% r(k)**2/(4d0*pi*s% dm_bar(k)) ! CL = 4d0*(4d0*PI)**2*SIG/3d0 - + Fr2a = W_out/kap_out - W_00/kap_00 d_Fr2a_dW_00 = -1d0/kap_00 d_Fr2a_dW_out = 1d0/kap_out - + Fr2b = 1d0 - BK/BW d_Fr2b_dW_00 = -BK/BW**2/W_00 d_Fr2b_dW_out = BK/BW**2/W_out - + Fr2 = Fr2a/Fr2b Fr_00 = Fr1*Fr2 d_Fr_dW_00 = Fr1*(d_Fr2a_dW_00 - Fr2*d_Fr2b_dW_00)/Fr2b @@ -2419,19 +2419,19 @@ subroutine calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A Fr3 = Fr1/(BW - BK) d_Fr_dK_00 = (Fr3/kap_00)*(W_00*BW/kap_00 - Fr2) d_Fr_dK_out = -(Fr3/kap_out)*(W_out*BW/kap_out - Fr2) - - dFr_dr_in = & ! + + dFr_dr_in = & ! + d_Fr_dK_00*dK_dr_in(i) & + d_Fr_dW_00*d_W_00_dr_in - dFr_dr_00 = 2d0*Fr_00/s% r(k) & ! + dFr_dr_00 = 2d0*Fr_00/s% r(k) & ! + d_Fr_dK_00*dK_dr_00(i) & + d_Fr_dK_out*dK_dr_in(i+1) & + d_Fr_dW_00*d_W_00_dr_00 & + d_Fr_dW_out*d_W_out_dr_00 - dFr_dr_out = & ! + dFr_dr_out = & ! + d_Fr_dK_out*dK_dr_00(i+1) & + d_Fr_dW_out*d_W_out_dr_out - + dFr_dVol_00 = & + d_Fr_dK_00*dK_dVol(i) & + d_Fr_dW_00*d_W_00_dVol_00 @@ -2439,16 +2439,16 @@ subroutine calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A + d_Fr_dK_out*dK_dVol(i+1) & + d_Fr_dW_out*d_W_out_dVol_out - dFr_dT_out = & ! + dFr_dT_out = & ! + d_Fr_dK_out*dK_dT(i+1) - dFr_dT_00 = & ! + dFr_dT_00 = & ! + d_Fr_dK_00*dK_dT(i) - - dFr_der_out = & ! + + dFr_der_out = & ! + d_Fr_dW_out*d_W_out_der_out - dFr_der_00 = & ! + dFr_der_00 = & ! + d_Fr_dW_00*d_W_00_der_00 - + !test_partials = (k-1 == s% solver_test_partials_k) test_partials = .false. if (test_partials) then @@ -2457,7 +2457,7 @@ subroutine calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A s% solver_test_partials_dval_dx = dFr_dVol_out write(*,*) 'calc_Fr', s% solver_test_partials_var end if - + if (call_is_bad) then if (is_bad(Fr_00)) then !$omp critical (rsp_step_5) @@ -2481,7 +2481,7 @@ subroutine calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A !$omp end critical (rsp_step_5) end if end if - + end subroutine calc_Fr @@ -2499,7 +2499,7 @@ subroutine rsp_calc_XP(s, P_surf, i, with_Prad, & ! time weighted combined press logical :: test_partials integer :: k include 'formats' - + k = NZN+1-i if (k == 0) then ! pressure outside of surface if (s% RSP_use_atm_grey_with_kap_for_Psurf) then @@ -2523,7 +2523,7 @@ subroutine rsp_calc_XP(s, P_surf, i, with_Prad, & ! time weighted combined press else Prad_factor = 0d0 end if - + XP = THETA*(s% Pgas(k) + Prad_factor*s% Prad(k)) & + THETA1*(s% Pgas_start(k) + Prad_factor*s% Prad_start(k)) & + THETAQ*s% Pvsc(k) + THETAQ1*s% Pvsc_start(k) & @@ -2532,18 +2532,18 @@ subroutine rsp_calc_XP(s, P_surf, i, with_Prad, & ! time weighted combined press THETA*(d_Pg_dVol(i) + Prad_factor*d_Pr_dVol(i)) & + THETAQ*d_Pvsc_dVol(i) & + THETAT*dPtrb_dVol_00(i) - d_XP_dT_00 = THETA*d_Pg_dT(i) + THETAQ*d_Pvsc_dT(i) ! - d_XP_der_00 = THETA*Prad_factor*d_Pr_der(i) ! - d_XP_dw_00 = THETAT*dPtrb_dw_00(i) ! - d_XP_dr_in = & ! + d_XP_dT_00 = THETA*d_Pg_dT(i) + THETAQ*d_Pvsc_dT(i) ! + d_XP_der_00 = THETA*Prad_factor*d_Pr_der(i) ! + d_XP_dw_00 = THETAT*dPtrb_dw_00(i) ! + d_XP_dr_in = & ! THETA*(d_Pg_dr_in(i) + Prad_factor*d_Pr_dr_in(i)) & + THETAQ*d_Pvsc_dr_in(i) & + THETAT*dPtrb_dr_in(i) - d_XP_dr_00 = & ! + d_XP_dr_00 = & ! THETA*(d_Pg_dr_00(i) + Prad_factor*d_Pr_dr_00(i)) & + THETAQ*d_Pvsc_dr_00(i) & + THETAT*dPtrb_dr_00(i) - + if (call_is_bad) then if (is_bad(XP)) then !$omp critical (rsp_step_6) @@ -2568,10 +2568,10 @@ subroutine rsp_calc_XP(s, P_surf, i, with_Prad, & ! time weighted combined press s% solver_test_partials_var = i_var_Vol s% solver_test_partials_dval_dx = d_XP_dVol_00 write(*,*) 'rsp_calc_XP', s% solver_test_partials_var - end if + end if end subroutine rsp_calc_XP - - + + subroutine calc_equations(s,i,P_surf) type (star_info), pointer :: s integer, intent(in) :: i @@ -2579,17 +2579,17 @@ subroutine calc_equations(s,i,P_surf) call calc_face_equations(s,i,P_surf) call calc_cell_equations(s,i,P_surf,.true.,.true.,.true.) end subroutine calc_equations - - + + subroutine calc_face_equations(s,i,P_surf) type (star_info), pointer :: s integer, intent(in) :: i real(dp), intent(in) :: P_surf call acceleration_eqn(s,i,P_surf) - call Fr_eqn(s,i) + call Fr_eqn(s,i) end subroutine calc_face_equations - - + + subroutine calc_cell_equations( & s, i, P_surf, do_etot, do_eturb, do_erad) type (star_info), pointer :: s @@ -2608,17 +2608,17 @@ subroutine calc_cell_equations( & dLt_in_dVol_in, dLt_in_dVol_00, & dLt_in_dT_in, dLt_in_dT_00, & dLt_in_der_in, dLt_in_der_00, & - dLt_in_dw_in, dLt_in_dw_00 + dLt_in_dw_in, dLt_in_dw_00 include 'formats' - + ! HR = -residual - ! partials of residual go in HD + ! partials of residual go in HD k = NZN+1-i - call get_Lt - + call get_Lt + if (do_etot) call total_energy_eqn(s, i, P_surf, & Lt_00, Lt_00_start, Lt_in, Lt_in_start, & dLt_00_dr_00, dLt_00_dr_in, dLt_00_dr_out, & @@ -2630,8 +2630,8 @@ subroutine calc_cell_equations( & dLt_in_dVol_in, dLt_in_dVol_00, & dLt_in_dT_in, dLt_in_dT_00, & dLt_in_der_in, dLt_in_der_00, & - dLt_in_dw_in, dLt_in_dw_00) - + dLt_in_dw_in, dLt_in_dw_00) + if (do_eturb) call turbulent_energy_eqn(s, i, & Lt_00, Lt_00_start, Lt_in, Lt_in_start, & dLt_00_dr_00, dLt_00_dr_in, dLt_00_dr_out, & @@ -2643,20 +2643,20 @@ subroutine calc_cell_equations( & dLt_in_dVol_in, dLt_in_dVol_00, & dLt_in_dT_in, dLt_in_dT_00, & dLt_in_der_in, dLt_in_der_00, & - dLt_in_dw_in, dLt_in_dw_00) - + dLt_in_dw_in, dLt_in_dw_00) + if (do_erad) call erad_eqn(s,i) - + if (I == 1) call inner_boundary_eqn - + contains - - subroutine inner_boundary_eqn - HR(1) = 0.d0 - HD(1:LD_HD,1) = 0.d0 - HD(i_r_dr_00,1) = 1.d0 - end subroutine inner_boundary_eqn - + + subroutine inner_boundary_eqn + HR(1) = 0.d0 + HD(1:LD_HD,1) = 0.d0 + HD(i_r_dr_00,1) = 1.d0 + end subroutine inner_boundary_eqn + subroutine get_Lt integer :: k k = NZN+1-i @@ -2665,7 +2665,7 @@ subroutine get_Lt dLt_in_dVol_in, dLt_in_dVol_00, & dLt_in_dT_in, dLt_in_dT_00, & dLt_in_der_in, dLt_in_der_00, & - dLt_in_dw_in, dLt_in_dw_00) + dLt_in_dw_in, dLt_in_dw_00) call calc_Lt(s,i,Lt_00, & dLt_00_dr_00, dLt_00_dr_in, dLt_00_dr_out, & dLt_00_dVol_00, dLt_00_dVol_out, & @@ -2673,7 +2673,7 @@ subroutine get_Lt dLt_00_der_00, dLt_00_der_out, & dLt_00_dw_00, dLt_00_dw_out) if (I == NZN) then - Lt_00_start = 0.d0 + Lt_00_start = 0.d0 else Lt_00_start = s% Lt_start(k) end if @@ -2681,12 +2681,12 @@ subroutine get_Lt Lt_in_start = 0 else Lt_in_start = s% Lt_start(k+1) - end if - end subroutine get_Lt + end if + end subroutine get_Lt end subroutine calc_cell_equations - - + + subroutine acceleration_eqn(s, i, P_surf) type (star_info), pointer :: s integer, intent(in) :: i @@ -2718,27 +2718,27 @@ subroutine acceleration_eqn(s, i, P_surf) logical :: test_partials, use_Prad include 'formats' - + use_Prad = .true. ! s% RSP_accel_eqn_use_Prad_instead_of_Fr_term - + dvdt_factor = 1d0 k = NZN+1-i IR = i_var_R + NV*(i-1) - HD(1:LD_HD,IR) = 0.d0 - + HD(1:LD_HD,IR) = 0.d0 + dt = s% dt !if (s% use_compression_outer_BC .and. I == NZN) then ! call mesa_error(__FILE__,__LINE__,'no rsp support for use_compression_outer_BC') !end if - + ! XP doesn't include Prad for acceleration equation ! instead introduce term using Fr - + call rsp_calc_XP(s, P_surf, i+1, use_Prad, & XP_out, dXP_out_dVol_out, dXP_out_dT_out, dXP_out_der_out, & dXP_out_dw_out, dXP_out_dr_00, dXP_out_dr_out) - + call rsp_calc_XP(s, P_surf, i, use_Prad, & XP_00, dXP_00_dVol_00, dXP_00_dT_00, dXP_00_der_00, & dXP_00_dw_00, dXP_00_dr_in, dXP_00_dr_00) @@ -2750,7 +2750,7 @@ subroutine acceleration_eqn(s, i, P_surf) dv_dr = 2d0/dt dXP_dm = (XP_out - XP_00)/dm_bar grav = - s% cgrav(k)*s% m(k)/(s% r(k)*s% r_start(k)) - + R_00 = 0.5d0*(s% r(k) + s% r_start(k)) Uq1 = P4/(dm_bar*R_00) d_Uq1_dr_00 = -Uq1*0.5d0/R_00 @@ -2767,7 +2767,7 @@ subroutine acceleration_eqn(s, i, P_surf) d_Chi_00_dr_in2 = THETAU*dChi_dr_in2(i) d_Chi_00_dr_in = THETAU*dChi_dr_in(i) d_Chi_00_dr_00 = THETAU*dChi_dr_00(i) - d_Chi_00_dr_out = THETAU*dChi_dr_out(i) + d_Chi_00_dr_out = THETAU*dChi_dr_out(i) if (I == NZN) then Chi_out = 0d0 d_Chi_out_dVol_00 = 0d0 @@ -2783,7 +2783,7 @@ subroutine acceleration_eqn(s, i, P_surf) d_Chi_out_dr_out = 0d0 d_Chi_out_dr_out2 = 0d0 else - Chi_out = THETAU*s% Chi(k-1) + THETAU1*s% Chi_start(k-1) + Chi_out = THETAU*s% Chi(k-1) + THETAU1*s% Chi_start(k-1) d_Chi_out_dVol_00 = THETAU*dChi_dVol_in(i+1) d_Chi_out_dT_00 = THETAU*dChi_dT_in(i+1) d_Chi_out_dT_out = THETAU*dChi_dT_00(i+1) @@ -2795,10 +2795,10 @@ subroutine acceleration_eqn(s, i, P_surf) d_Chi_out_dr_in = THETAU*dChi_dr_in2(i+1) d_Chi_out_dr_00 = THETAU*dChi_dr_in(i+1) d_Chi_out_dr_out = THETAU*dChi_dr_00(i+1) - d_Chi_out_dr_out2 = THETAU*dChi_dr_out(i+1) - end if + d_Chi_out_dr_out2 = THETAU*dChi_dr_out(i+1) + end if - s% Uq(k) = Uq1*(Chi_out - Chi_00) + s% Uq(k) = Uq1*(Chi_out - Chi_00) d_Uq_dVol_00 = Uq1*(d_Chi_out_dVol_00 - d_Chi_00_dVol_00) d_Uq_dT_in = -Uq1*d_Chi_00_dT_in d_Uq_dT_00 = Uq1*(d_Chi_out_dT_00 - d_Chi_00_dT_00) @@ -2807,9 +2807,9 @@ subroutine acceleration_eqn(s, i, P_surf) d_Uq_der_in = -Uq1*d_Chi_00_der_in d_Uq_der_00 = Uq1*(d_Chi_out_der_00 - d_Chi_00_der_00) d_Uq_der_out = Uq1*(d_Chi_out_der_out - d_Chi_00_der_out) - d_Uq_der_out2 = Uq1*d_Chi_out_der_out2 + d_Uq_der_out2 = Uq1*d_Chi_out_der_out2 d_Uq_dw_00 = -Uq1*d_Chi_00_dw_00 - d_Uq_dw_out = Uq1*d_Chi_out_dw_out + d_Uq_dw_out = Uq1*d_Chi_out_dw_out d_Uq_dr_in2 = -Uq1*d_Chi_00_dr_in2 d_Uq_dr_in = Uq1*(d_Chi_out_dr_in - d_Chi_00_dr_in) d_Uq_dr_00 = & @@ -2855,36 +2855,36 @@ subroutine acceleration_eqn(s, i, P_surf) d_Fr_term_dr_00 = Fr_term*d_kap_dr_00/kap_face d_Fr_term_dr_out = Fr_term*d_kap_dr_out/kap_face end if - + residual = & dvdt_factor*(s% v(k) - s% v_start(k))/dt & + area*dXP_dm - grav - s% Uq(k) - Fr_term HR(IR) = -residual - + !s% xtra1_array(k) = s% Pgas(k) + s% Prad(k) !s% xtra2_array(k) = s% Vol(k) !s% xtra3_array(k) = s% T(k) !s% xtra4_array(k) = s% v(k) !s% xtra5_array(k) = s% RSP_w(k)**2 !s% xtra6_array(k) = s% r(k) - + HD(i_r_dFr_00,IR) = - d_Fr_term_dFr_00 HD(i_r_dT_in,IR) = & - d_Uq_dT_in HD(i_r_dT_00,IR) = & - + A_dm*(-dXP_00_dT_00) & + + A_dm*(-dXP_00_dT_00) & - d_Uq_dT_00 & - d_Fr_term_dT_00 HD(i_r_dT_out,IR) = & - + A_dm*dXP_out_dT_out & + + A_dm*dXP_out_dT_out & - d_Uq_dT_out & - d_Fr_term_dT_out - HD(i_r_dT_out2,IR) = & + HD(i_r_dT_out2,IR) = & - d_Uq_dT_out2 - + HD(i_r_dr_in2,IR) = - d_Uq_dr_in2 - HD(i_r_dr_in,IR) = & ! + HD(i_r_dr_in,IR) = & ! + A_dm*(-dXP_00_dr_in) & - d_Uq_dr_in & - d_Fr_term_dr_in @@ -2901,59 +2901,59 @@ subroutine acceleration_eqn(s, i, P_surf) + A_dm*dXP_out_dr_out & - d_Uq_dr_out & - d_Fr_term_dr_out - HD(i_r_dr_out2,IR) = & ! + HD(i_r_dr_out2,IR) = & ! - d_Uq_dr_out2 HD(i_r_der_in,IR) = & - d_Uq_der_in HD(i_r_der_00,IR) = & - + A_dm*(-dXP_00_der_00) & + + A_dm*(-dXP_00_der_00) & - d_Uq_der_00 HD(i_r_der_out,IR) = & - + A_dm*dXP_out_der_out & + + A_dm*dXP_out_der_out & - d_Uq_der_out - HD(i_r_der_out2,IR) = & + HD(i_r_der_out2,IR) = & - d_Uq_der_out2 - HD(i_r_dw_in,IR) = 0.d0 + HD(i_r_dw_in,IR) = 0.d0 if (I <= IBOTOM .or. I == NZN) then - HD(i_r_dw_00,IR) = 0.d0 - else + HD(i_r_dw_00,IR) = 0.d0 + else HD(i_r_dw_00,IR) = & - + A_dm*(-dXP_00_dw_00) & + + A_dm*(-dXP_00_dw_00) & - d_Uq_dw_00 end if if (I <= IBOTOM - 1 .or. I >= NZN - 1) then - HD(i_r_dw_out,IR) = 0.d0 + HD(i_r_dw_out,IR) = 0.d0 else HD(i_r_dw_out,IR) = & + A_dm*dXP_out_dw_out & - d_Uq_dw_out end if - HD(i_r_dw_out2,IR) = 0.0d0 - + HD(i_r_dw_out2,IR) = 0.0d0 + !call check_is_bad - - !HD(i_r_dr_in2,IR) ! + + !HD(i_r_dr_in2,IR) ! !HD(i_r_dr_in,IR) ! ok !HD(i_r_dr_00,IR) ! ok !HD(i_r_dr_out,IR) ! ok - !HD(i_r_dr_out2,IR) ! - + !HD(i_r_dr_out2,IR) ! + !HD(i_r_dT_in,IR) ! 0 !HD(i_r_dT_00,IR) ! ok !HD(i_r_dT_out,IR) ! need 1d-3 like for er !HD(i_r_dT_out2,IR) ! 0 - + ! NOTE: may need solver_test_partials_dx_0 = 1d-3 for er - !HD(i_r_der_in,IR) ! + !HD(i_r_der_in,IR) ! !HD(i_r_der_00,IR) ! 0 !HD(i_r_der_out,IR) ! 0 - !HD(i_r_der_out2,IR) ! - - !HD(i_r_dw_00,IR) ! - !HD(i_r_dw_out,IR) ! + !HD(i_r_der_out2,IR) ! + + !HD(i_r_dw_00,IR) ! + !HD(i_r_dw_out,IR) ! !test_partials = (k == s% solver_test_partials_k) test_partials = .false. @@ -2963,10 +2963,10 @@ subroutine acceleration_eqn(s, i, P_surf) s% solver_test_partials_var = i_var_r s% solver_test_partials_dval_dx = i_r_dr_00 write(*,*) 'acceleration_eqn', s% solver_test_partials_var - end if - + end if + contains - + subroutine check_is_bad include 'formats' if (is_bad(residual)) then @@ -3099,8 +3099,8 @@ subroutine check_is_bad end subroutine check_is_bad end subroutine acceleration_eqn - - + + subroutine total_energy_eqn(s, i, P_surf, & Lt_00, Lt_00_start, Lt_in, Lt_in_start, & dLt_00_dr_00, dLt_00_dr_in, dLt_00_dr_out, & @@ -3112,7 +3112,7 @@ subroutine total_energy_eqn(s, i, P_surf, & dLt_in_dVol_in, dLt_in_dVol_00, & dLt_in_dT_in, dLt_in_dT_00, & dLt_in_der_in, dLt_in_der_00, & - dLt_in_dw_in, dLt_in_dw_00) + dLt_in_dw_in, dLt_in_dw_00) type (star_info), pointer :: s integer, intent(in) :: i real(dp), intent(in) :: P_surf, & @@ -3126,7 +3126,7 @@ subroutine total_energy_eqn(s, i, P_surf, & dLt_in_dVol_in, dLt_in_dVol_00, & dLt_in_dT_in, dLt_in_dT_00, & dLt_in_der_in, dLt_in_der_00, & - dLt_in_dw_in, dLt_in_dw_00 + dLt_in_dw_in, dLt_in_dw_00 integer :: IT, k real(dp) :: dt, dm, residual, erad, erad_tw, DV, dt_div_dm, & area_00, area_00_start, area_in, area_in_start, & @@ -3137,12 +3137,12 @@ subroutine total_energy_eqn(s, i, P_surf, & dLc_in_dVol_in, dLc_in_dVol_00, & dLc_in_dT_in, dLc_in_dT_00, & dLc_in_der_in, dLc_in_der_00, & - dLc_in_dw_in, dLc_in_dw_00, & + dLc_in_dw_in, dLc_in_dw_00, & dLc_00_dr_00, dLc_00_dr_in, dLc_00_dr_out, & dLc_00_dVol_00, dLc_00_dVol_out, & dLc_00_dT_00, dLc_00_dT_out, & dLc_00_der_00, dLc_00_der_out, & - dLc_00_dw_00, dLc_00_dw_out, & + dLc_00_dw_00, dLc_00_dw_out, & XP_00, dXP_00_dr_00, dXP_00_dr_in, & dXP_00_dVol_00, dXP_00_dT_00, dXP_00_der_00, dXP_00_dw_00, & u_div_r, d_u_div_r_dr_00, d_u_div_r_dr_in, u_div_r_factor @@ -3160,28 +3160,28 @@ subroutine total_energy_eqn(s, i, P_surf, & dLc_in_dVol_in, dLc_in_dVol_00, & dLc_in_dT_in, dLc_in_dT_00, & dLc_in_der_in, dLc_in_der_00, & - dLc_in_dw_in, dLc_in_dw_00) + dLc_in_dw_in, dLc_in_dw_00) call calc_Lc(s, i, Lc_00, & dLc_00_dr_in, dLc_00_dr_00, dLc_00_dr_out, & dLc_00_dVol_00, dLc_00_dVol_out, & dLc_00_dT_00, dLc_00_dT_out, & dLc_00_der_00, dLc_00_der_out, & - dLc_00_dw_00, dLc_00_dw_out) + dLc_00_dw_00, dLc_00_dw_out) if (I == NZN) then - Lc_00_start = 0.d0 + Lc_00_start = 0.d0 else Lc_00_start = s% Lc_start(k) end if if (i == 1) then Lc_in_start = 0 else - Lc_in_start = s% Lc_start(k+1) - end if - + Lc_in_start = s% Lc_start(k+1) + end if + area_00 = 4d0*pi*s% r(k)**2 Lr_00 = s% Fr(k)*area_00 - d_Lr_00_dFr_00 = area_00 + d_Lr_00_dFr_00 = area_00 d_Lr_00_dr_00 = 2d0*Lr_00/s% r(k) area_00_start = 4d0*pi*s% r_start(k)**2 Lr_00_start = s% Fr_start(k)*area_00_start @@ -3191,30 +3191,30 @@ subroutine total_energy_eqn(s, i, P_surf, & else Lr_in = s% L_center end if - d_Lr_in_dFr_in = 0d0 - d_Lr_in_dr_in = 0d0 - Lr_in_start = Lr_in + d_Lr_in_dFr_in = 0d0 + d_Lr_in_dr_in = 0d0 + Lr_in_start = Lr_in else area_in = 4d0*pi*s% r(k+1)**2 Lr_in = s% Fr(k+1)*area_in - d_Lr_in_dFr_in = area_in + d_Lr_in_dFr_in = area_in d_Lr_in_dr_in = 2d0*Lr_in/s% r(k+1) area_in_start = 4d0*pi*s% r_start(k+1)**2 Lr_in_start = s% Fr_start(k+1)*area_in_start - end if - + end if + L_00 = & WTR*Lr_00 + WTC*Lc_00 + WTT*Lt_00 + & WTR1*Lr_00_start + WTC1*Lc_00_start + WTT1*Lt_00_start L_in = & WTR*Lr_in + WTC*Lc_in + WTT*Lt_in + & WTR1*Lr_in_start + WTC1*Lc_in_start + WTT1*Lt_in_start - + dt = s% dt dm = s% dm(k) dt_div_dm = dt/dm DV = s% Vol(k) - s% Vol_start(k) - + if (s% f_Edd(k) == f_Edd_isotropic .or. k == NZN) then u_div_r = 0d0 d_u_div_r_dr_00 = 0d0 @@ -3226,10 +3226,10 @@ subroutine total_energy_eqn(s, i, P_surf, & d_u_div_r_dr_in = 0.5d0*(2d0/dt - s% v(k+1)/s% r(k+1))/s% r(k+1) u_div_r_factor = dt*(1d0 - 3d0*s% f_Edd(k)) end if - + erad = s% erad(k) erad_tw = THETAE*erad + THETAE1*s% erad_start(k) - + call rsp_calc_XP(s, P_surf, i, .true., & XP_00, dXP_00_dVol_00, dXP_00_dT_00, dXP_00_der_00, & dXP_00_dw_00, dXP_00_dr_in, dXP_00_dr_00) @@ -3255,20 +3255,20 @@ subroutine total_energy_eqn(s, i, P_surf, & - dt_div_dm*WTT*dLt_in_dr_in2 & - dt*dEq_dr_in2(I) HD(i_T_dr_in,IT) = & - + d_egas_dr_in(i) & + + d_egas_dr_in(i) & - dt_div_dm*WTR*d_Lr_in_dr_in & + dt_div_dm*WTC*(dLc_00_dr_in - dLc_in_dr_in) & + dt_div_dm*WTT*(dLt_00_dr_in - dLt_in_dr_in) & - + dVol_dr_in(I)*XP_00 & + + dVol_dr_in(I)*XP_00 & + DV*dXP_00_dr_in & + erad_tw*u_div_r_factor*d_u_div_r_dr_in & - - dt*dEq_dr_in(I) + - dt*dEq_dr_in(I) HD(i_T_dr_00,IT) = & - + d_egas_dr_00(i) & + + d_egas_dr_00(i) & + dt_div_dm*WTR*d_Lr_00_dr_00 & + dt_div_dm*WTC*(dLc_00_dr_00 - dLc_in_dr_00) & + dt_div_dm*WTT*(dLt_00_dr_00 - dLt_in_dr_00) & - + dVol_dr_00(I)*XP_00 & + + dVol_dr_00(I)*XP_00 & + DV*dXP_00_dr_00 & + erad_tw*u_div_r_factor*d_u_div_r_dr_00 & - dt*dEq_dr_00(I) @@ -3280,59 +3280,59 @@ subroutine total_energy_eqn(s, i, P_surf, & HD(i_T_dT_in,IT) = & - dt_div_dm*WTC*dLc_in_dT_in & - dt_div_dm*WTT*dLt_in_dT_in & - - dt*dEq_dT_in(I) + - dt*dEq_dT_in(I) HD(i_T_dT_00,IT) = & - d_egas_dT(i) & - + DV*dXP_00_dT_00 & + d_egas_dT(i) & + + DV*dXP_00_dT_00 & + dt_div_dm*WTC*(dLc_00_dT_00 - dLc_in_dT_00) & + dt_div_dm*WTT*(dLt_00_dT_00 - dLt_in_dT_00) & - dt*dEq_dT_00(I) - HD(i_T_dT_out,IT) = & ! + HD(i_T_dT_out,IT) = & ! + dt_div_dm*WTC*dLc_00_dT_out & + dt_div_dm*WTT*dLt_00_dT_out & - - dt*dEq_dT_out(I) + - dt*dEq_dT_out(I) HD(i_T_der_in,IT) = & - dt_div_dm*WTC*dLc_in_der_in & - dt_div_dm*WTT*dLt_in_der_in & - - dt*dEq_der_in(I) + - dt*dEq_der_in(I) HD(i_T_der_00,IT) = & - 1d0 & - + DV*dXP_00_der_00 & + 1d0 & + + DV*dXP_00_der_00 & + dt_div_dm*WTC*(dLc_00_der_00 - dLc_in_der_00) & + dt_div_dm*WTT*(dLt_00_der_00 - dLt_in_der_00) & + THETAE*u_div_r_factor*u_div_r & - dt*dEq_der_00(I) - HD(i_T_der_out,IT) = & ! + HD(i_T_der_out,IT) = & ! + dt_div_dm*WTC*dLc_00_der_out & + dt_div_dm*WTT*dLt_00_der_out & - - dt*dEq_der_out(I) - + - dt*dEq_der_out(I) + if (I <= IBOTOM + 1) then - HD(i_T_dw_in,IT) = 0.d0 + HD(i_T_dw_in,IT) = 0.d0 else - HD(i_T_dw_in,IT) = & + HD(i_T_dw_in,IT) = & - dt_div_dm*WTC*dLc_in_dw_in & - - dt_div_dm*WTT*dLt_in_dw_in - end if + - dt_div_dm*WTT*dLt_in_dw_in + end if if (I <= IBOTOM .or. I == NZN) then - HD(i_T_dw_00,IT) = 0.d0 + HD(i_T_dw_00,IT) = 0.d0 else HD(i_T_dw_00,IT) = & - 2.d0*s% RSP_w(k) & + 2.d0*s% RSP_w(k) & + dt_div_dm*WTC*(dLc_00_dw_00 - dLc_in_dw_00) & + dt_div_dm*WTT*(dLt_00_dw_00 - dLt_in_dw_00) & + DV*dXP_00_dw_00 & - - dt*dEq_dw_00(I) - end if + - dt*dEq_dw_00(I) + end if if (I <= IBOTOM - 1 .or. I >= NZN - 1) then HD(i_T_dw_out,IT) = 0.d0 else HD(i_T_dw_out,IT) = & - dt_div_dm*WTT*dLt_00_dw_out & + dt_div_dm*WTT*dLt_00_dw_out & + dt_div_dm*WTC*dLc_00_dw_out end if - + if (i == -6 .and. s% model_number == s% max_model_number) then write(*,5) 'HD(i_T_dw_00,IT)', k, i, iter, s% model_number, HD(i_T_dw_00,IT) write(*,5) 's% RSP_w(k)', k, i, iter, s% model_number, s% RSP_w(k) @@ -3349,22 +3349,22 @@ subroutine total_energy_eqn(s, i, P_surf, & write(*,5) 'dEq_dw_00(I)', k, i, iter, s% model_number, dEq_dw_00(I) endif - !HD(i_T_dr_in2,IT) ! + !HD(i_T_dr_in2,IT) ! !HD(i_T_dr_in,IT) ! ok !HD(i_T_dr_00,IT) ! ok - !HD(i_T_dr_out,IT) ! + !HD(i_T_dr_out,IT) ! !HD(i_T_dT_in,IT) ! 0 !HD(i_T_dT_00,IT) ! ok !HD(i_T_dT_out,IT) ! 0 - !HD(i_T_der_in,IT) ! + !HD(i_T_der_in,IT) ! !HD(i_T_der_00,IT) ! ok - !HD(i_T_der_out,IT) ! - - !HD(i_T_dw_in,IT) ! - !HD(i_T_dw_00,IT) ! - !HD(i_T_dw_out,IT) ! + !HD(i_T_der_out,IT) ! + + !HD(i_T_dw_in,IT) ! + !HD(i_T_dw_00,IT) ! + !HD(i_T_dw_out,IT) ! !test_partials = (k+1 == s% solver_test_partials_k) test_partials = .false. @@ -3374,11 +3374,11 @@ subroutine total_energy_eqn(s, i, P_surf, & s% solver_test_partials_var = i_var_r s% solver_test_partials_dval_dx = HD(i_T_dr_00,IT) write(*,*) 'total_energy_eqn', s% solver_test_partials_var - end if + end if end subroutine total_energy_eqn - - + + subroutine turbulent_energy_eqn(s, i, & Lt_00, Lt_00_start, Lt_in, Lt_in_start, & dLt_00_dr_00, dLt_00_dr_in, dLt_00_dr_out, & @@ -3390,7 +3390,7 @@ subroutine turbulent_energy_eqn(s, i, & dLt_in_dVol_in, dLt_in_dVol_00, & dLt_in_dT_in, dLt_in_dT_00, & dLt_in_der_in, dLt_in_der_00, & - dLt_in_dw_in, dLt_in_dw_00) + dLt_in_dw_in, dLt_in_dw_00) type (star_info), pointer :: s integer, intent(in) :: i real(dp), intent(in) :: & @@ -3412,11 +3412,11 @@ subroutine turbulent_energy_eqn(s, i, & include 'formats' k = NZN+1-i - - IW = i_var_w + NV*(i-1) - HD(1:LD_HD,IW) = 0.d0 - if (ALFA == 0d0 .or. I <= IBOTOM .or. I == NZN) then + IW = i_var_w + NV*(i-1) + HD(1:LD_HD,IW) = 0.d0 + + if (ALFA == 0d0 .or. I <= IBOTOM .or. I == NZN) then HD(i_w_dw_00,IW) = 1.d0 HR(IW) = 0.d0 return @@ -3424,7 +3424,7 @@ subroutine turbulent_energy_eqn(s, i, & L_00 = WTT*Lt_00 + WTT1*Lt_00_start L_in = WTT*Lt_in + WTT1*Lt_in_start - + dt = s% dt dm = s% dm(k) dt_div_dm = dt/dm @@ -3437,7 +3437,7 @@ subroutine turbulent_energy_eqn(s, i, & + DV*Ptrb_tw & - dt*(GAM*s% COUPL(k) + GAM1*s% COUPL_start(k) + s% Eq(k)) HR(IW) = -residual - + if (k==-35) then write(*,3) 'RSP w dEt PdV dtC dtEq', k, iter, & s% RSP_w(k), s% RSP_w(k)**2 - s% RSP_w_start(k)**2, DV*Ptrb_tw, & @@ -3451,36 +3451,36 @@ subroutine turbulent_energy_eqn(s, i, & !write(*,2) 'RSP PII_00 PII_p1 Hp_00 Hp_p1', k, & ! s% PII(k), s% PII(k+1), s% Hp_face(k), s% Hp_face(k+1) end if - - HD(i_w_dw_in2,IW) = 0.d0 - HD(i_w_dw_in,IW) = - dt_div_dm*WTT*dLt_in_dw_in + + HD(i_w_dw_in2,IW) = 0.d0 + HD(i_w_dw_in,IW) = - dt_div_dm*WTT*dLt_in_dw_in HD(i_w_dw_00,IW) = & - 2.d0*s% RSP_w(k) & + 2.d0*s% RSP_w(k) & - dt*GAM*dC_dw_00(I) & - dt*dEq_dw_00(I) & + dt_div_dm*WTT*(dLt_00_dw_00 - dLt_in_dw_00) & + DV*THETAT*dPtrb_dw_00(I) - HD(i_w_dw_out,IW) = dt_div_dm*WTT*dLt_00_dw_out - HD(i_w_dw_out2,IW) = 0.d0 + HD(i_w_dw_out,IW) = dt_div_dm*WTT*dLt_00_dw_out + HD(i_w_dw_out2,IW) = 0.d0 HD(i_w_dr_in2,IW) = & - - dt*GAM*dC_dr_in2(I) & + - dt*GAM*dC_dr_in2(I) & - dt_div_dm*WTT*dLt_in_dr_in2 & - - dt*dEq_dr_in2(I) + - dt*dEq_dr_in2(I) HD(i_w_dr_in,IW) = & - - dt*GAM*dC_dr_in(I) & + - dt*GAM*dC_dr_in(I) & - dt*dEq_dr_in(I) & + dt_div_dm*WTT*(dLt_00_dr_in - dLt_in_dr_in) & + DV*THETAT*dPtrb_dr_in(I) & + (THETAT*s% Ptrb(k) + THETAT1*s% Ptrb_start(k))*dVol_dr_in(I) HD(i_w_dr_00,IW) = & - - dt*GAM*dC_dr_00(I) & + - dt*GAM*dC_dr_00(I) & - dt*dEq_dr_00(I) & + dt_div_dm*WTT*(dLt_00_dr_00 - dLt_in_dr_00) & + DV*THETAT*dPtrb_dr_00(I) & + (THETAT*s% Ptrb(k) + THETAT1*s% Ptrb_start(k))*dVol_dr_00(I) HD(i_w_dr_out,IW) = & - - dt*GAM*dC_dr_out(I) & + - dt*GAM*dC_dr_out(I) & + dt_div_dm*WTT*dLt_00_dr_out & - dt*dEq_dr_out(I) @@ -3488,19 +3488,19 @@ subroutine turbulent_energy_eqn(s, i, & HD(i_w_dT_in,IW) = 0.d0 else HD(i_w_dT_in,IW) = & - - dt_div_dm*WTT*dLt_in_dT_in & + - dt_div_dm*WTT*dLt_in_dT_in & - dt*dEq_dT_in(I) & - - dt*GAM*dC_dT_in(I) + - dt*GAM*dC_dT_in(I) end if HD(i_w_dT_00,IW) = & - - dt*GAM*dC_dT_00(I) & + - dt*GAM*dC_dT_00(I) & - dt*dEq_dT_00(I) & + dt_div_dm*WTT*(dLt_00_dT_00 - dLt_in_dT_00) - if (I <= IBOTOM - 1 .or. I >= NZN - 1) then + if (I <= IBOTOM - 1 .or. I >= NZN - 1) then HD(i_w_dT_out,IW) = 0.d0 else HD(i_w_dT_out,IW) = & - - dt*GAM*dC_dT_out(I) & + - dt*GAM*dC_dT_out(I) & + dt_div_dm*WTT*dLt_00_dT_out & - dt*dEq_dT_out(I) end if @@ -3509,40 +3509,40 @@ subroutine turbulent_energy_eqn(s, i, & HD(i_w_der_in,IW) = 0.d0 else HD(i_w_der_in,IW) = & - - dt_div_dm*WTT*dLt_in_der_in & + - dt_div_dm*WTT*dLt_in_der_in & - dt*dEq_der_in(I) & - - dt*GAM*dC_der_in(I) + - dt*GAM*dC_der_in(I) end if HD(i_w_der_00,IW) = & - - dt*GAM*dC_der_00(I) & + - dt*GAM*dC_der_00(I) & - dt*dEq_der_00(I) & + dt_div_dm*WTT*(dLt_00_der_00 - dLt_in_der_00) - if (I <= IBOTOM - 1 .or. I >= NZN - 1) then + if (I <= IBOTOM - 1 .or. I >= NZN - 1) then HD(i_w_der_out,IW) = 0.d0 else HD(i_w_der_out,IW) = & - - dt*GAM*dC_der_out(I) & + - dt*GAM*dC_der_out(I) & + dt_div_dm*WTT*dLt_00_der_out & - dt*dEq_der_out(I) end if - !HD(i_w_dw_in,IW) ! - !HD(i_w_dw_00,IW) ! - !HD(i_w_dw_out,IW) ! - - !HD(i_w_dr_in2,IW) ! - !HD(i_w_dr_in,IW) ! - !HD(i_w_dr_00,IW) ! - !HD(i_w_dr_out,IW) ! - - !HD(i_w_dT_in,IW) ! - !HD(i_w_dT_00,IW) ! - !HD(i_w_dT_out,IW) ! - - !HD(i_w_der_in,IW) ! - !HD(i_w_der_00,IW) ! - !HD(i_w_der_out,IW) ! - + !HD(i_w_dw_in,IW) ! + !HD(i_w_dw_00,IW) ! + !HD(i_w_dw_out,IW) ! + + !HD(i_w_dr_in2,IW) ! + !HD(i_w_dr_in,IW) ! + !HD(i_w_dr_00,IW) ! + !HD(i_w_dr_out,IW) ! + + !HD(i_w_dT_in,IW) ! + !HD(i_w_dT_00,IW) ! + !HD(i_w_dT_out,IW) ! + + !HD(i_w_der_in,IW) ! + !HD(i_w_der_00,IW) ! + !HD(i_w_der_out,IW) ! + !test_partials = (k+1 == s% solver_test_partials_k) test_partials = .false. @@ -3551,22 +3551,22 @@ subroutine turbulent_energy_eqn(s, i, & s% solver_test_partials_var = i_var_r s% solver_test_partials_dval_dx = HD(i_w_dr_00,IW) write(*,*) 'turbulent_energy_eqn', s% solver_test_partials_var - end if - + end if + end subroutine turbulent_energy_eqn - - subroutine erad_eqn(s, i) + + subroutine erad_eqn(s, i) use const_def, only: crad, clight type (star_info), pointer :: s integer, intent(in) :: i include 'formats' - + call T_form_of_erad_eqn(s, i) end subroutine erad_eqn - - + + subroutine Fr_eqn(s, i) use const_def, only: clight type (star_info), pointer :: s @@ -3575,22 +3575,22 @@ subroutine Fr_eqn(s, i) real(dp) :: residual include 'formats' - + if (s% RSP_hydro_only) then k = NZN+1-i IL = i_var_Fr + NV*(i-1) - HD(1:LD_HD,IL) = 0d0 + HD(1:LD_HD,IL) = 0d0 residual = - s% Fr(k) ! want Fr = 0d0 HR(IL) = -residual HD(i_Fr_dFr_00,IL) = -1d0 return end if - + call T_form_of_Fr_eqn(s,i) end subroutine Fr_eqn - - + + subroutine d_Prad_dm_Fr_eqn(s,i) type (star_info), pointer :: s integer, intent(in) :: i @@ -3607,26 +3607,26 @@ subroutine d_Prad_dm_Fr_eqn(s,i) k = NZN+1-i IL = i_var_Fr + NV*(i-1) - HD(1:LD_HD,IL) = 0d0 + HD(1:LD_HD,IL) = 0d0 call calc_Fr(s, i, Fr_00, & dFr_dr_out, dFr_dr_00, dFr_dr_in, & dFr_dVol_out, dFr_dVol_00, & dFr_dT_out, dFr_dT_00, & dFr_der_out, dFr_der_00) - - residual = Fr_00 - s% Fr(k) + + residual = Fr_00 - s% Fr(k) HR(IL) = -residual - + HD(i_Fr_der_00,IL) = dFr_der_00 HD(i_Fr_der_out,IL) = dFr_der_out - HD(i_Fr_dr_in,IL) = dFr_dr_in ! - HD(i_Fr_dr_00,IL) = dFr_dr_00 ! - HD(i_Fr_dr_out,IL) = dFr_dr_out ! + HD(i_Fr_dr_in,IL) = dFr_dr_in ! + HD(i_Fr_dr_00,IL) = dFr_dr_00 ! + HD(i_Fr_dr_out,IL) = dFr_dr_out ! HD(i_Fr_dT_00,IL) = dFr_dT_00 HD(i_Fr_dT_out,IL) = dFr_dT_out HD(i_Fr_dFr_00,IL) = -1d0 - + !test_partials = (k == s% solver_test_partials_k) test_partials = .false. @@ -3635,11 +3635,11 @@ subroutine d_Prad_dm_Fr_eqn(s,i) s% solver_test_partials_var = i_var_er s% solver_test_partials_dval_dx = dFr_der_00 write(*,*) 'd_Prad_dm_Fr_eqn', s% solver_test_partials_var - end if - + end if + end subroutine d_Prad_dm_Fr_eqn - + subroutine T_form_of_erad_eqn(s,i) type (star_info), pointer :: s integer, intent(in) :: i @@ -3650,21 +3650,21 @@ subroutine T_form_of_erad_eqn(s,i) include 'formats' k = NZN+1-i - IE = i_var_er + NV*(i-1) - HD(1:LD_HD,IE) = 0.d0 - + IE = i_var_er + NV*(i-1) + HD(1:LD_HD,IE) = 0.d0 + T = s% T(k) V = s% Vol(k) erad_expected = crad*T**4*V ! ergs/gm residual = erad_expected - s% erad(k) - + HR(IE) = -residual - + HD(i_er_der_00,IE) = -1d0 HD(i_er_dT_00,IE) = 4d0*crad*T**3*V HD(i_er_dr_00,IE) = crad*T**4*dVol_dr_00(i) HD(i_er_dr_in,IE) = crad*T**4*dVol_dr_in(i) - + !test_partials = (k == s% solver_test_partials_k) test_partials = .false. @@ -3673,15 +3673,15 @@ subroutine T_form_of_erad_eqn(s,i) s% solver_test_partials_var = i_var_T s% solver_test_partials_dval_dx = HD(i_er_dT_00,IE) write(*,*) 'T_form_of_erad_eqn', s% solver_test_partials_var - end if + end if end subroutine T_form_of_erad_eqn - - - subroutine T_form_of_calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A + + + subroutine T_form_of_calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A dFr_dr_out, dFr_dr_in, dFr_dr_00, & dFr_dT_out, dFr_dT_00, dFr_dVol_00) type (star_info), pointer :: s - integer, intent(in) :: I + integer, intent(in) :: I real(dp), intent(out) :: & Fr_00, dFr_dr_out, dFr_dr_in, & dFr_dr_00, dFr_dT_out, dFr_dT_00, dFr_dVol_00 @@ -3697,7 +3697,7 @@ subroutine T_form_of_calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A Fr_00 = s% L_center end if Fr_00 = Fr_00/(4d0*pi*s% r_center**2) - dFr_dr_00 = 0 + dFr_dr_00 = 0 dFr_dT_00 = 0 dFr_dK_00 = 0 dFr_dK_out = 0 @@ -3706,7 +3706,7 @@ subroutine T_form_of_calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A dFr_dT_out = 0 else if (i == NZN) then Fr_00 = 2d0*SIG*s% T(k)**4 !EDDI - dFr_dT_00 = 4.d0*Fr_00/s% T(k) + dFr_dT_00 = 4.d0*Fr_00/s% T(k) dFr_dK_00 = 0 dFr_dK_out = 0 dFr_dr_out = 0 @@ -3715,7 +3715,7 @@ subroutine T_form_of_calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A dFr_dT_out = 0 else Fr_00 = 0d0 - dFr_dr_00 = 0d0 + dFr_dr_00 = 0d0 dFr_dT_00 = 0d0 dFr_dK_00 = 0d0 dFr_dK_out = 0d0 @@ -3734,19 +3734,19 @@ subroutine T_form_of_calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A T3 = T1/(BW - BK) !rs radiative luminosity derivatives dFr_dK_00 = (T3/s% opacity(k))*(W*BW/s% opacity(k) - T2) - dFr_dK_out = -(T3/s% opacity(k-1))*(WP*BW/s% opacity(k-1) - T2) - dFr_dr_out = dFr_dK_out*dK_dr_00(i+1) ! - dFr_dr_in = dFr_dK_00*dK_dr_in(I) ! - dFr_dr_00 = 2d0*Fr_00/s% r(k) & ! + dFr_dK_out = -(T3/s% opacity(k-1))*(WP*BW/s% opacity(k-1) - T2) + dFr_dr_out = dFr_dK_out*dK_dr_00(i+1) ! + dFr_dr_in = dFr_dK_00*dK_dr_in(I) ! + dFr_dr_00 = 2d0*Fr_00/s% r(k) & ! + dFr_dK_00*dK_dr_00(I) & + dFr_dK_out*dK_dr_in(i+1) - dFr_dT_out = & ! + dFr_dT_out = & ! 4.d0*(T3/s% T(k-1))*(WP*BW/s% opacity(k-1) & - T2*BK/BW) + dFr_dK_out*dK_dT(i+1) - dFr_dT_00 = & ! + dFr_dT_00 = & ! - 4.d0*(T3/s% T(k))*(W*BW/s% opacity(k) - T2*BK/BW) & + dFr_dK_00*dK_dT(I) - + if (call_is_bad) then if (is_bad(dFr_dT_out + dFr_dT_00)) then write(*,3) 'dFr_dT_out', i, k, dFr_dT_out @@ -3767,10 +3767,10 @@ subroutine T_form_of_calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A call mesa_error(__FILE__,__LINE__,'T_form_of_calc_Fr') end if end if - - dFr_dVol_00 = dFr_dK_00*dK_dVol(I) + + dFr_dVol_00 = dFr_dK_00*dK_dVol(I) end if - + !test_partials = (k-1 == s% solver_test_partials_k) test_partials = .false. if (test_partials) then @@ -3780,8 +3780,8 @@ subroutine T_form_of_calc_Fr(s, i, Fr_00, & !rs Stellingwerf 1975, Appendix A write(*,*) 'T_form_of_calc_Fr', s% solver_test_partials_var end if end subroutine T_form_of_calc_Fr - - + + subroutine T_form_of_Fr_eqn(s,i) type (star_info), pointer :: s integer, intent(in) :: i @@ -3795,15 +3795,15 @@ subroutine T_form_of_Fr_eqn(s,i) k = NZN+1-i IL = i_var_Fr + NV*(i-1) - HD(1:LD_HD,IL) = 0d0 + HD(1:LD_HD,IL) = 0d0 call T_form_of_calc_Fr(s, i, Fr_00, & dFr_00_dr_out, dFr_00_dr_in, dFr_00_dr_00, & dFr_00_dT_out, dFr_00_dT_00, dFr_dVol_00) - - residual = Fr_00 - s% Fr(k) + + residual = Fr_00 - s% Fr(k) HR(IL) = -residual - + HD(i_Fr_dFr_00,IL) = -1d0 HD(i_Fr_dr_in,IL) = dFr_00_dr_in HD(i_Fr_dr_00,IL) = dFr_00_dr_00 @@ -3818,7 +3818,7 @@ subroutine T_form_of_Fr_eqn(s,i) s% solver_test_partials_var = i_var_T s% solver_test_partials_dval_dx = HD(i_Fr_dT_00,IL) write(*,*) 'T_form_of_Fr_eqn', s% solver_test_partials_var - end if + end if end subroutine T_form_of_Fr_eqn diff --git a/star/private/set_flags.f90 b/star/private/set_flags.f90 index c31f86fc5..12e7d6565 100644 --- a/star/private/set_flags.f90 +++ b/star/private/set_flags.f90 @@ -33,7 +33,7 @@ module set_flags implicit none contains - + subroutine set_v_flag(id, v_flag, ierr) integer, intent(in) :: id @@ -48,7 +48,7 @@ subroutine set_v_flag(id, v_flag, ierr) ierr = 0 call get_star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% v_flag .eqv. v_flag) return nz = s% nz @@ -95,7 +95,7 @@ subroutine set_v_flag(id, v_flag, ierr) end if call set_chem_names(s) - + if (v_flag .and. s% u_flag) then ! turn off u_flag when turn on v_flag call set_u_flag(id, .false., ierr) end if @@ -187,7 +187,7 @@ subroutine set_u_flag(id, u_flag, ierr) end if call set_chem_names(s) - + if (u_flag .and. s% v_flag) then ! turn off v_flag when turn on u_flag call set_v_flag(id, .false., ierr) end if @@ -312,13 +312,13 @@ subroutine set_RSP2_flag(id, RSP2_flag, ierr) ierr = 0 call get_star_ptr(id, s, ierr) if (ierr /= 0) return - + !write(*,*) 'set_RSP2_flag previous s% RSP2_flag', s% RSP2_flag !write(*,*) 'set_RSP2_flag new RSP2_flag', RSP2_flag if (s% RSP2_flag .eqv. RSP2_flag) return nz = s% nz - + s% RSP2_flag = RSP2_flag nvar_hydro_old = s% nvar_hydro @@ -329,14 +329,14 @@ subroutine set_RSP2_flag(id, RSP2_flag, ierr) call set_var_info(s, ierr) if (ierr /= 0) return - + write(*,*) 'set_RSP2 variables and equations' if (.false.) then do i=1,s% nvar_hydro write(*,'(i3,2a20)') i, trim(s% nameofequ(i)), trim(s% nameofvar(i)) end do end if - + call update_nvar_allocs(s, nvar_hydro_old, s% nvar_chem, ierr) if (ierr /= 0) return @@ -344,7 +344,7 @@ subroutine set_RSP2_flag(id, RSP2_flag, ierr) if (ierr /= 0) return if (RSP2_flag) then - call insert1(s% i_w) + call insert1(s% i_w) if (s% RSP_flag) then do k=1,nz s% xh(s% i_w,k) = sqrt(max(0d0,s% xh(s% i_Et_RSP,k))) @@ -363,23 +363,23 @@ subroutine set_RSP2_flag(id, RSP2_flag, ierr) end if call set_chem_names(s) - + if (.not. RSP2_flag) return - + if (s% RSP_flag) then ! turn off RSP_flag when turn on RSP2_flag call set_RSP_flag(id, .false., ierr) if (ierr /= 0) return end if - + call set_v_flag(s% id, .true., ierr) if (ierr /= 0) return - + call set_vars(s, s% dt, ierr) if (ierr /= 0) return call set_RSP2_vars(s,ierr) if (ierr /= 0) return - + if (s% RSP2_remesh_when_load) then write(*,*) 'doing automatic remesh for RSP2' call remesh_for_RSP2(s,ierr) @@ -387,14 +387,14 @@ subroutine set_RSP2_flag(id, RSP2_flag, ierr) call set_qs(s, nz, s% q, s% dq, ierr) if (ierr /= 0) return call set_m_and_dm(s) - call set_dm_bar(s, nz, s% dm, s% dm_bar) + call set_dm_bar(s, nz, s% dm, s% dm_bar) call set_vars(s, s% dt, ierr) ! redo after remesh_for_RSP2 if (ierr /= 0) return end if - - - - contains + + + + contains subroutine insert1(i_var) integer, intent(in) :: i_var @@ -408,7 +408,7 @@ subroutine insert1(i_var) call insert(s% xh_old,i_var) end if end subroutine insert1 - + subroutine remove1(i_remove) integer, intent(in) :: i_remove call del(s% xh,i_remove) @@ -494,10 +494,10 @@ subroutine set_RSP_flag(id, RSP_flag, ierr) end if call set_chem_names(s) - + if (RSP_flag) call set_v_flag(s% id, .true., ierr) - contains + contains subroutine insert1(i_var) integer, intent(in) :: i_var @@ -510,7 +510,7 @@ subroutine insert1(i_var) call insert(s% xh_old,i_var) end if end subroutine insert1 - + subroutine remove1(i_remove) integer, intent(in) :: i_remove call del(s% xh,i_remove) @@ -561,7 +561,7 @@ subroutine set_w_div_wc_flag(id, w_div_wc_flag, ierr) ierr = 0 call get_star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% w_div_wc_flag .eqv. w_div_wc_flag) return nz = s% nz @@ -631,7 +631,7 @@ subroutine set_j_rot_flag(id, j_rot_flag, ierr) ierr = 0 call get_star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% j_rot_flag .eqv. j_rot_flag) return nz = s% nz @@ -716,7 +716,7 @@ subroutine set_am_nu_rot_flag(id, am_nu_rot_flag, ierr) s% am_nu_rot_flag = am_nu_rot_flag s% am_nu_rot(1:s% nz) = 0 end subroutine set_am_nu_rot_flag - + subroutine set_rotation_flag(id, rotation_flag, ierr) integer, intent(in) :: id diff --git a/star/private/solve_omega_mix.f90 b/star/private/solve_omega_mix.f90 index f8e31675f..64109e52a 100644 --- a/star/private/solve_omega_mix.f90 +++ b/star/private/solve_omega_mix.f90 @@ -332,7 +332,7 @@ integer function do_solve_omega_mix(s, dt_total) subroutine do_alloc(ierr) use alloc, only: non_crit_get_quad_array - integer, intent(out) :: ierr + integer, intent(out) :: ierr call do_work_arrays(.true.,ierr) call non_crit_get_quad_array(s, du, nz, nz_alloc_extra, 'solve_omega_mix', ierr) @@ -368,7 +368,7 @@ end subroutine do_alloc subroutine dealloc use alloc, only: non_crit_return_quad_array call do_work_arrays(.false.,ierr) - + call non_crit_return_quad_array(s, du, 'solve_omega_mix') call non_crit_return_quad_array(s, d, 'solve_omega_mix') call non_crit_return_quad_array(s, dl, 'solve_omega_mix') @@ -383,10 +383,10 @@ subroutine dealloc call non_crit_return_quad_array(s, X_1, 'solve_omega_mix') call non_crit_return_quad_array(s, rhs, 'solve_omega_mix') call non_crit_return_quad_array(s, del, 'solve_omega_mix') - + end subroutine dealloc - - + + subroutine do_work_arrays(alloc_flag, ierr) use alloc, only: work_array logical, intent(in) :: alloc_flag diff --git a/star/private/solver_support.f90 b/star/private/solver_support.f90 index bcc59a195..87f421e7d 100644 --- a/star/private/solver_support.f90 +++ b/star/private/solver_support.f90 @@ -135,7 +135,7 @@ subroutine eval_equations(s, nvar, ierr) end if if (ierr /= 0) return - + if (.not. s% stop_for_bad_nums) return cnt = 0 @@ -154,7 +154,7 @@ subroutine eval_equations(s, nvar, ierr) end if end do end do - + if (cnt > 0) then ierr = -1 return @@ -188,23 +188,23 @@ subroutine sizequ(s, nvar, equ_norm, equ_max, k_max, j_max, ierr) ! equ = residu integer :: j, k, num_terms, n, nz, nvar_hydro, nvar_chem, skip_eqn1, skip_eqn2, skip_eqn3 real(dp) :: sumequ, absq - + logical :: dbg include 'formats' ierr = 0 - + equ_norm = 0d0 equ_max = 0d0 k_max = 0 j_max = 0 - + dbg = s% solver_check_everything nvar_hydro = min(nvar, s% nvar_hydro) nvar_chem = s% nvar_chem - + nz = s% nz n = nz num_terms = 0 @@ -286,13 +286,13 @@ subroutine sizequ(s, nvar, equ_norm, equ_max, k_max, j_max, ierr) ! equ = residu equ_norm = sumequ/num_terms if (dbg) write(*,4) trim(s% nameofequ(j_max)) // ' sizequ equ_max norm', & k_max, s% solver_iter, s% model_number, equ_max, equ_norm - + if (dbg) call dump_equ - + return call dump_equ call mesa_error(__FILE__,__LINE__,'sizequ') - + contains subroutine dump_equ @@ -376,7 +376,7 @@ subroutine sizeB(s, nvar, B, max_correction, correction_norm, max_zone, max_var, skip3 = s% i_w end if skip4 = s% i_Hp - + skip5 = 0 max_zone = 0 @@ -406,7 +406,7 @@ subroutine sizeB(s, nvar, B, max_correction, correction_norm, max_zone, max_var, j == skip3 .or. & j == skip4 .or. & j == skip5 .or. & - j == s% i_alpha_RTI) cycle + j == s% i_alpha_RTI) cycle var_loop if (check_for_bad_nums) then if (is_bad_num(B(j,k)*s% correction_weight(j,k))) then found_bad_num = .true. @@ -418,16 +418,16 @@ subroutine sizeB(s, nvar, B, max_correction, correction_norm, max_zone, max_var, j, k, B(j,k)*s% correction_weight(j,k) call mesa_error(__FILE__,__LINE__,'sizeB') end if - + max_zone = k max_var = j exit cell_loop - - cycle + + cycle var_loop end if end if if (j > nvar_hydro) then - if (s% xa_start(j-nvar_hydro,k) < x_limit) cycle + if (s% xa_start(j-nvar_hydro,k) < x_limit) cycle var_loop end if abs_corr = abs(B(j,k)*s% correction_weight(j,k)) @@ -707,9 +707,9 @@ subroutine Bdomain(s, nvar, B, correction_factor, ierr) trim(chem_isos% name(s% chem_id(bad_j))), bad_k, & s% model_number, s% solver_iter, min_alpha end if - + contains - + subroutine clip_so_non_negative(i,minval) integer, intent(in) :: i real(dp), intent(in) :: minval @@ -858,17 +858,17 @@ subroutine set_vars_for_solver(s, nvar, nzlo, nzhi, dt, ierr) xh_start => s% xh_start xa_start => s% xa_start - + report_dx = & s% solver_test_partials_dx_0 > 0d0 .and. & s% solver_test_partials_k > 0 .and. & s% solver_call_number == s% solver_test_partials_call_number .and. & s% solver_test_partials_iter_number == s% solver_iter .and. & len_trim(s% solver_test_partials_show_dx_var_name) > 0 - + if (report_dx) then k = s% solver_test_partials_k - i_var = lookup_nameofvar(s, s% solver_test_partials_show_dx_var_name) + i_var = lookup_nameofvar(s, s% solver_test_partials_show_dx_var_name) if (i_var > 0) then if (i_var > nvar_hydro) then dx_for_i_var = s% solver_dx(i_var,k) @@ -995,7 +995,7 @@ subroutine set_vars_for_solver(s, nvar, nzlo, nzhi, dt, ierr) end do end do end if - + if (s% solver_test_partials_k > 0 .and. & s% solver_test_partials_k <= nz) then k = s% solver_test_partials_k @@ -1022,7 +1022,7 @@ subroutine set_vars_for_solver(s, nvar, nzlo, nzhi, dt, ierr) end if return end if - + if (s% solver_test_partials_k > 0 .and. & s% solver_test_partials_k <= nz) then k = s% solver_test_partials_k @@ -1125,7 +1125,7 @@ subroutine set1(k,report,ierr) include 'formats' ierr = 0 v = 0 - + k_below_just_added = 1 do j=1,min(nvar, nvar_hydro) @@ -1134,7 +1134,7 @@ subroutine set1(k,report,ierr) end do if (do_lnT) then - + s% lnT(k) = x(i_lnT) s% T(k) = exp(s% lnT(k)) s% dxh_lnT(k) = s% solver_dx(i_lnT,k) @@ -1224,7 +1224,7 @@ subroutine set1(k,report,ierr) if (report) write(*,2) 'bad num Hp_face', k, s% Hp_face(k) end if end if - + if (do_v) then s% v(k) = x(i_v) s% dxh_v(k) = s% solver_dx(i_v,k) diff --git a/star/private/star_bcyclic.f90 b/star/private/star_bcyclic.f90 index a114f5fd6..47a232c9c 100644 --- a/star/private/star_bcyclic.f90 +++ b/star/private/star_bcyclic.f90 @@ -61,14 +61,14 @@ subroutine bcyclic_factor ( & character (len=1) :: equed real(dp) :: min_rcond_from_DGESVX, rpgfac integer :: k_min_rcond_from_DGESVX - + integer, allocatable :: factored(:) include 'formats' - + if (s% use_DGESVX_in_bcyclic .and. s% report_min_rcond_from_DGESXV) & min_rcond_from_DGESVX = 1d99 - + allocate(factored(nz)) do k=1,nz factored(k) = 0 @@ -141,13 +141,13 @@ subroutine bcyclic_factor ( & return end if - if (nstemp == 1) exit + if (nstemp == 1) exit factor_cycle nstemp = (nstemp+1)/2 nlevel = nlevel+1 ncycle = 2*ncycle - if (nlevel > maxlevels) exit + if (nlevel > maxlevels) exit factor_cycle end do factor_cycle !call cali_end_phase('factor_cycle') @@ -171,7 +171,7 @@ subroutine bcyclic_factor ( & call dealloc return end if - + do k=1,nz ! check that every cell factored exactly once if (factored(k) /= 1) then write(*,3) 'factored /= 1', k, factored(k) @@ -180,7 +180,7 @@ subroutine bcyclic_factor ( & end do call dealloc - + if (s% use_DGESVX_in_bcyclic .and. s% report_min_rcond_from_DGESXV) then write(*,4) 'DGESVX: k_min, iter, model, min rcond, rpgfac', & k_min_rcond_from_DGESVX, iter, s% model_number, min_rcond_from_DGESVX, rpgfac @@ -602,12 +602,12 @@ subroutine dense_factor(s, k, nvar, mtx, mtxF, ipivot, & integer, intent(out) :: ierr include 'formats' ierr = 0 - + if (s% use_DGESVX_in_bcyclic) then call factor_with_DGESVX return end if - + if (nvar == 4) then call my_getf2_n4(mtxF, ipivot, ierr) else if (nvar == 5) then @@ -615,9 +615,9 @@ subroutine dense_factor(s, k, nvar, mtx, mtxF, ipivot, & else call my_getf2(nvar, mtxF, nvar, ipivot, ierr) end if - + contains - + subroutine factor_with_DGESVX character (len=1) :: fact, trans integer, parameter :: nrhs = 0 @@ -633,7 +633,7 @@ subroutine factor_with_DGESVX a(i,j) = mtxF(i,j) end do end do - + if (s% use_equilibration_in_DGESVX) then fact = 'E' ! matrix A will be equilibrated, then copied to AF and factored else @@ -648,7 +648,7 @@ subroutine factor_with_DGESVX call DGESVX(fact, trans, nvar, nrhs, a, nvar, af, nvar, ipiv, & equed, r, c, b, nvar, x, nvar, rcond, ferr, berr, & work, iwork, ierr) - + if (ierr > 0 .and. ierr <= nvar) then ! singular write(*,3) 'singular matrix for DGESVX', k, ierr call mesa_error(__FILE__,__LINE__,'factor_with_DGESVX') @@ -657,7 +657,7 @@ subroutine factor_with_DGESVX write(*,2) 'DGESVX reports bad matrix conditioning: k, rcond', k, rcond ierr = 0 end if - + do i=1,nvar do j=1,nvar mtx(i,j) = a(i,j) @@ -667,7 +667,7 @@ subroutine factor_with_DGESVX col_scale_factors(i) = c(i) ipivot(i) = ipiv(i) end do - + if (s% report_min_rcond_from_DGESXV .and. rcond < min_rcond_from_DGESVX) then !$OMP CRITICAL (bcyclic_dense_factor_crit) min_rcond_from_DGESVX = rcond @@ -677,9 +677,9 @@ subroutine factor_with_DGESVX end if end subroutine factor_with_DGESVX - + end subroutine dense_factor - + subroutine bcyclic_solve ( & s, nvar, nz, lblk1, dblk1, ublk1, lblkF1, dblkF1, ublkF1, ipivot1, & @@ -704,7 +704,7 @@ subroutine bcyclic_solve ( & if (dbg) write(*,*) 'start bcyclic_solve' - + ! copy B to soln !$OMP PARALLEL DO SIMD do i=1,nvar*nz @@ -745,13 +745,13 @@ subroutine bcyclic_solve ( & return end if - if (nstemp == 1) exit + if (nstemp == 1) exit forward_cycle nstemp = (nstemp+1)/2 nlevel = nlevel+1 ncycle = 2*ncycle - if (nlevel > maxlevels) exit + if (nlevel > maxlevels) exit forward_cycle end do forward_cycle @@ -777,7 +777,7 @@ subroutine bcyclic_solve ( & nlevel = nlevel-1 if (nlevel < 1) then ierr = -1 - exit + exit back_cycle end if nstemp = nslevel(nlevel) call cycle_solve( & @@ -829,7 +829,7 @@ subroutine dense_solve(s, k, nvar, mtx, mtxF, ipivot, X_mtx, & integer :: i real(dp), pointer :: X(:) ierr = 0 - + if (s% use_DGESVX_in_bcyclic) then call solve_with_DGESVX return @@ -841,9 +841,9 @@ subroutine dense_solve(s, k, nvar, mtx, mtxF, ipivot, X_mtx, & row_scale_factors, col_scale_factors, equed, ierr) if (ierr /= 0) return end do - + contains - + subroutine solve_with_DGESVX character (len=1) :: fact, trans real(dp) :: rcond @@ -867,7 +867,7 @@ subroutine solve_with_DGESVX c(i) = col_scale_factors(i) ipiv(i) = ipivot(i) end do - + fact = 'F' ! factored trans = 'N' ! no transpose @@ -881,7 +881,7 @@ subroutine solve_with_DGESVX if (ierr /= 0) then write(*,2) 'solve_with_DGESVX failed', k end if - + do i=1,nvar !$OMP SIMD do j=1,nvar @@ -906,12 +906,12 @@ subroutine dense_solve1(s, k, nvar, X_vec, mtx, mtxF, ipivot, dbg, & integer, intent(out) :: ierr include 'formats' ierr = 0 - + if (s% use_DGESVX_in_bcyclic) then call solve1_with_DGESVX return end if - + if (nvar == 4) then call my_getrs1_n4(mtxF, ipivot, X_vec, ierr) else if (nvar == 5) then @@ -919,9 +919,9 @@ subroutine dense_solve1(s, k, nvar, X_vec, mtx, mtxF, ipivot, dbg, & else call my_getrs1(nvar, mtxF, nvar, ipivot, X_vec, nvar, ierr) end if - + contains - + subroutine solve1_with_DGESVX character (len=1) :: fact, trans real(dp) :: rcond @@ -945,7 +945,7 @@ subroutine solve1_with_DGESVX c(i) = col_scale_factors(i) ipiv(i) = ipivot(i) end do - + fact = 'F' ! factored trans = 'N' ! no transpose @@ -956,7 +956,7 @@ subroutine solve1_with_DGESVX call DGESVX(fact, trans, nvar, nrhs, a, nvar, af, nvar, ipiv, & equed, r, c, b, nvar, x, nvar, rcond, ferr, berr, & work, iwork, ierr) - + !$OMP SIMD do i=1,nvar X_vec(i) = x(i,1) diff --git a/star/private/star_history_def.f90 b/star/private/star_history_def.f90 index adbcc9950..9d7a883ed 100644 --- a/star/private/star_history_def.f90 +++ b/star/private/star_history_def.f90 @@ -195,7 +195,7 @@ module star_history_def integer, parameter :: h_log_avg_abs_v = h_avg_abs_v + 1 integer, parameter :: h_max_abs_v = h_log_avg_abs_v + 1 integer, parameter :: h_log_max_abs_v = h_max_abs_v + 1 - + integer, parameter :: h_total_internal_energy_after_adjust_mass = h_log_max_abs_v + 1 integer, parameter :: h_total_gravitational_energy_after_adjust_mass = & h_total_internal_energy_after_adjust_mass + 1 @@ -222,7 +222,7 @@ module star_history_def integer, parameter :: h_log_total_radial_kinetic_energy = h_log_total_turbulent_energy + 1 integer, parameter :: h_log_total_rotational_kinetic_energy = h_log_total_radial_kinetic_energy + 1 integer, parameter :: h_log_total_energy = h_log_total_rotational_kinetic_energy + 1 - + integer, parameter :: h_total_IE_div_IE_plus_KE = h_log_total_energy + 1 integer, parameter :: h_total_entropy = h_total_IE_div_IE_plus_KE + 1 @@ -277,13 +277,13 @@ module star_history_def integer, parameter :: h_log_LHe = h_log_LH + 1 integer, parameter :: h_power_photo = h_log_LHe + 1 integer, parameter :: h_Lnuc_photo = h_power_photo + 1 - + integer, parameter :: h_Lsurf_m = h_Lnuc_photo + 1 integer, parameter :: h_luminosity_ergs_s = h_Lsurf_m + 1 integer, parameter :: h_log_L_ergs_s = h_luminosity_ergs_s + 1 integer, parameter :: h_luminosity = h_log_L_ergs_s + 1 integer, parameter :: h_log_L = h_luminosity + 1 - + integer, parameter :: h_power_z_burn = h_log_L + 1 integer, parameter :: h_log_LZ = h_power_z_burn + 1 @@ -312,7 +312,7 @@ module star_history_def integer, parameter :: h_avg_skipped_setvars_per_step = h_logQ_min + 1 integer, parameter :: h_avg_setvars_per_step = h_avg_skipped_setvars_per_step + 1 integer, parameter :: h_avg_solver_setvars_per_step = h_avg_setvars_per_step + 1 - + integer, parameter :: h_num_retries = h_avg_solver_setvars_per_step + 1 integer, parameter :: h_h1_czb_mass = h_num_retries + 1 integer, parameter :: h_surf_c12_minus_o16 = h_h1_czb_mass + 1 @@ -499,14 +499,14 @@ module star_history_def integer, parameter :: h_min_t_eddy = h_log_total_angular_momentum + 1 integer, parameter :: h_elapsed_time = h_min_t_eddy + 1 - + integer, parameter :: h_num_hydro_merges = h_elapsed_time + 1 integer, parameter :: h_num_hydro_splits = h_num_hydro_merges + 1 - + integer, parameter :: h_RSP_DeltaR = h_num_hydro_splits + 1 integer, parameter :: h_RSP_DeltaMag = h_RSP_DeltaR + 1 integer, parameter :: h_RSP_GREKM = h_RSP_DeltaMag + 1 - + integer, parameter :: h_rsp_phase = h_RSP_GREKM + 1 integer, parameter :: h_rsp_period_in_days = h_rsp_phase + 1 integer, parameter :: h_rsp_num_periods = h_rsp_period_in_days + 1 @@ -515,7 +515,7 @@ module star_history_def integer, parameter :: h_total_num_solver_calls_made = h_total_num_solver_iterations + 1 integer, parameter :: h_total_num_solver_calls_converged = h_total_num_solver_calls_made + 1 integer, parameter :: h_total_num_solver_calls_failed = h_total_num_solver_calls_converged + 1 - + integer, parameter :: h_total_num_solver_relax_iterations = h_total_num_solver_calls_failed + 1 integer, parameter :: h_total_num_solver_relax_calls_made = h_total_num_solver_relax_iterations + 1 integer, parameter :: h_total_num_solver_relax_calls_converged = h_total_num_solver_relax_calls_made + 1 @@ -526,20 +526,20 @@ module star_history_def integer, parameter :: h_total_step_redos = h_total_step_retries + 1 integer, parameter :: h_total_steps_taken = h_total_step_redos + 1 integer, parameter :: h_total_steps_finished = h_total_steps_taken + 1 - + integer, parameter :: h_total_relax_step_attempts = h_total_steps_finished + 1 integer, parameter :: h_total_relax_step_retries = h_total_relax_step_attempts + 1 integer, parameter :: h_total_relax_step_redos = h_total_relax_step_retries + 1 integer, parameter :: h_total_relax_steps_taken = h_total_relax_step_redos + 1 integer, parameter :: h_total_relax_steps_finished = h_total_relax_steps_taken + 1 - + integer, parameter :: h_avg_num_solver_iters = h_total_relax_steps_finished + 1 integer, parameter :: h_num_solver_iterations = h_avg_num_solver_iters + 1 integer, parameter :: h_num_iters = h_num_solver_iterations + 1 integer, parameter :: h_photosphere_cell_density = h_num_iters + 1 integer, parameter :: h_photosphere_cell_log_density = h_photosphere_cell_density + 1 - + integer, parameter :: h_photosphere_cell_log_opacity = h_photosphere_cell_log_density + 1 integer, parameter :: h_photosphere_cell_opacity = h_photosphere_cell_log_opacity + 1 @@ -570,7 +570,7 @@ module star_history_def integer, parameter :: h_min_opacity = h_photosphere_r + 1 integer, parameter :: h_log_min_opacity = h_min_opacity + 1 - + integer, parameter :: h_delta_nu = h_log_min_opacity + 1 integer, parameter :: h_delta_Pg = h_delta_nu + 1 integer, parameter :: h_nu_max = h_delta_Pg + 1 @@ -627,7 +627,7 @@ module star_history_def integer, parameter :: h_tot_Et = h_log_tot_PE + 1 integer, parameter :: h_log_tot_Et = h_tot_Et + 1 - integer, parameter :: h_tot_IE_div_IE_plus_KE = h_log_tot_Et + 1 + integer, parameter :: h_tot_IE_div_IE_plus_KE = h_log_tot_Et + 1 integer, parameter :: h_burn_solver_maxsteps = h_tot_IE_div_IE_plus_KE + 1 integer, parameter :: h_rotation_solver_steps = h_burn_solver_maxsteps + 1 @@ -802,20 +802,20 @@ subroutine history_column_names_init(ierr) history_column_name(h_log_dt_sec) = 'log_dt_sec' history_column_name(h_time_step_days) = 'time_step_days' history_column_name(h_log_dt_days) = 'log_dt_days' - + history_column_name(h_power_h_burn) = 'power_h_burn' history_column_name(h_log_LH) = 'log_LH' - + history_column_name(h_power_he_burn) = 'power_he_burn' history_column_name(h_log_LHe) = 'log_LHe' - + history_column_name(h_power_photo) = 'power_photo' history_column_name(h_Lnuc_photo) = 'Lnuc_photo' - + history_column_name(h_power_z_burn) = 'power_z_burn' history_column_name(h_log_LZ) = 'log_LZ' - + history_column_name(h_luminosity) = 'luminosity' history_column_name(h_Lsurf_m) = 'Lsurf_m' history_column_name(h_log_L) = 'log_L' @@ -881,14 +881,14 @@ subroutine history_column_names_init(ierr) history_column_name(h_cumulative_energy_error) = 'cumulative_energy_error' history_column_name(h_rel_cumulative_energy_error) = 'rel_cumulative_energy_error' - + history_column_name(h_abs_rel_E_err) = 'abs_rel_E_err' history_column_name(h_log_rel_E_err) = 'log_rel_E_err' - + history_column_name(h_tot_E_equ_err) = 'tot_E_equ_err' history_column_name(h_tot_E_err) = 'tot_E_err' history_column_name(h_rel_E_err) = 'rel_E_err' - + history_column_name(h_rel_run_E_err) = 'rel_run_E_err' history_column_name(h_log_rel_run_E_err) = 'log_rel_run_E_err' history_column_name(h_log_rel_cumulative_energy_error) = 'log_rel_cumulative_energy_error' @@ -932,7 +932,7 @@ subroutine history_column_names_init(ierr) history_column_name(h_RSP_DeltaR) = 'rsp_DeltaR' history_column_name(h_RSP_DeltaMag) = 'rsp_DeltaMag' history_column_name(h_RSP_GREKM) = 'rsp_GREKM' - + history_column_name(h_rsp_phase) = 'rsp_phase' history_column_name(h_rsp_period_in_days) = 'rsp_period_in_days' history_column_name(h_rsp_num_periods) = 'rsp_num_periods' @@ -953,7 +953,7 @@ subroutine history_column_names_init(ierr) history_column_name(h_total_step_redos) = 'total_step_redos' history_column_name(h_total_steps_taken) = 'total_steps_taken' history_column_name(h_total_steps_finished) = 'total_steps_finished' - + history_column_name(h_total_relax_step_attempts) = 'total_relax_step_attempts' history_column_name(h_total_relax_step_retries) = 'total_relax_step_retries' history_column_name(h_total_relax_step_redos) = 'total_relax_step_redos' @@ -967,13 +967,13 @@ subroutine history_column_names_init(ierr) history_column_name(h_avg_skipped_setvars_per_step) = 'avg_skipped_setvars_per_step' history_column_name(h_avg_setvars_per_step) = 'avg_setvars_per_step' history_column_name(h_avg_solver_setvars_per_step) = 'avg_solver_setvars_per_step' - + history_column_name(h_num_retries) = 'num_retries' history_column_name(h_total_num_solver_iterations) = 'total_num_solver_iterations' - - - + + + history_column_name(h_h1_czb_mass) = 'h1_czb_mass' history_column_name(h_surf_c12_minus_o16) = 'surf_c12_minus_o16' history_column_name(h_surf_num_c12_div_num_o16) = 'surf_num_c12_div_num_o16' @@ -1203,7 +1203,7 @@ subroutine history_column_names_init(ierr) history_column_name(h_photosphere_cell_log_density) = 'photosphere_cell_log_density' history_column_name(h_photosphere_cell_density) = 'photosphere_cell_density' - + history_column_name(h_photosphere_cell_log_opacity) = 'photosphere_cell_log_opacity' history_column_name(h_photosphere_cell_opacity) = 'photosphere_cell_opacity' @@ -1304,14 +1304,14 @@ subroutine history_column_names_init(ierr) history_column_name(h_grav_dark_L_polar) = 'grav_dark_L_polar' history_column_name(h_grav_dark_Teff_polar) = 'grav_dark_Teff_polar' - + history_column_name(h_grav_dark_L_equatorial) = 'grav_dark_L_equatorial' history_column_name(h_grav_dark_Teff_equatorial) = 'grav_dark_Teff_equatorial' history_column_name(h_apsidal_constant_k2) = 'apsidal_constant_k2' history_column_name(h_phase_of_evolution) = 'phase_of_evolution' - + ! items corresponding to names on terminal output lines history_column_name(h_lg_Lnuc) = 'lg_Lnuc' history_column_name(h_H_rich) = 'H_rich' @@ -1338,7 +1338,7 @@ subroutine history_column_names_init(ierr) history_column_name(h_C_cntr) = 'C_cntr' history_column_name(h_retries) = 'retries' history_column_name(h_TDC_num_cells) = 'TDC_num_cells' - + cnt = 0 do i=1,h_col_id_max if (len_trim(history_column_name(i)) == 0) then diff --git a/star/private/star_job_ctrls_io.f90 b/star/private/star_job_ctrls_io.f90 index fffee3165..6f4d300be 100644 --- a/star/private/star_job_ctrls_io.f90 +++ b/star/private/star_job_ctrls_io.f90 @@ -135,7 +135,7 @@ module star_job_ctrls_io new_v_center, & dv_per_step, & relax_v_center_dt, & - + zero_alpha_RTI, & zero_initial_alpha_RTI, & @@ -216,7 +216,7 @@ module star_job_ctrls_io remove_surface_do_entropy, & remove_surface_turn_off_energy_sources_and_sinks, & remove_surface_by_relax_to_star_cut, & - + remove_initial_surface_at_cell_k, & remove_initial_surface_at_he_core_boundary, & remove_initial_surface_by_optical_depth, & @@ -292,53 +292,53 @@ module star_job_ctrls_io relax_mass_change_max_yrs_dt, & relax_mass_change_init_mdot, & relax_mass_change_final_mdot, & - + change_RTI_flag, & change_initial_RTI_flag, & new_RTI_flag, & - + change_RSP_flag, & change_initial_RSP_flag, & new_RSP_flag, & - + change_RSP2_flag, & change_initial_RSP2_flag, & change_RSP2_flag_at_model_number, & new_RSP2_flag, & create_RSP2_model, & - + change_w_div_wc_flag, & change_initial_w_div_wc_flag, & new_w_div_wc_flag, & - + change_j_rot_flag, & change_initial_j_rot_flag, & new_j_rot_flag, & - + create_RSP_model, & - + change_v_flag, & change_initial_v_flag, & new_v_flag, & - + change_D_omega_flag, & change_initial_D_omega_flag, & new_D_omega_flag, & - + change_am_nu_rot_flag, & change_initial_am_nu_rot_flag, & new_am_nu_rot_flag, & - + use_D_omega_for_am_nu_rot, & - + change_u_flag, & change_initial_u_flag, & new_u_flag, & - + change_reconstruction_flag, & change_initial_reconstruction_flag, & new_reconstruction_flag, & - + center_ye_limit_for_v_flag, & change_rotation_flag, & change_initial_rotation_flag, & @@ -346,7 +346,7 @@ module star_job_ctrls_io use_w_div_wc_flag_with_rotation, & use_j_rot_flag_with_rotation, & - + set_omega, & set_initial_omega, & set_omega_step_limit, & @@ -430,21 +430,21 @@ module star_job_ctrls_io limit_initial_dt, & years_for_initial_dt, & seconds_for_initial_dt, & - + set_initial_cumulative_energy_error, & set_cumulative_energy_error, & set_cumulative_energy_error_at_step, & set_cumulative_energy_error_each_step_if_age_less_than, & set_cumulative_energy_error_each_relax, & new_cumulative_energy_error, & - + change_net, & change_initial_net, & new_net_name, & change_small_net, & change_initial_small_net, & new_small_net_name, & - + h_he_net, & co_net, & adv_net, & @@ -452,7 +452,7 @@ module star_job_ctrls_io set_uniform_xa_from_file, & set_uniform_initial_xa_from_file, & file_for_uniform_xa, & - + mix_section, mix_initial_section, & mix_section_nzlo, mix_section_nzhi, & @@ -511,11 +511,11 @@ module star_job_ctrls_io chem_name2, & replace_element_nzlo, replace_element_nzhi, & do_special_test, & - + save_pulse_data_for_model_number, & save_pulse_data_when_terminate, & save_pulse_data_filename, & - + chem_isotopes_filename, & ionization_file_prefix, & ionization_Z1_suffix, & @@ -535,7 +535,7 @@ module star_job_ctrls_io color_file_names,& color_num_colors,& warn_run_star_extras, & - + report_garbage_collection, & num_steps_for_garbage_collection @@ -609,7 +609,7 @@ recursive subroutine read_star_job_file(s, filename, level, ierr) read_extra_star_job_inlist(i) = .false. extra(i) = extra_star_job_inlist_name(i) extra_star_job_inlist_name(i) = 'undefined' - + if (read_extra(i)) then call read_star_job_file(s, extra(i), level+1, ierr) if (ierr /= 0) return @@ -730,7 +730,7 @@ subroutine store_star_job_controls(s, ierr) s% job% new_v_center = new_v_center s% job% dv_per_step = dv_per_step s% job% relax_v_center_dt = relax_v_center_dt - + s% job% zero_alpha_RTI = zero_alpha_RTI s% job% zero_initial_alpha_RTI = zero_initial_alpha_RTI @@ -820,7 +820,7 @@ subroutine store_star_job_controls(s, ierr) s% job% remove_surface_by_v_surf_div_v_escape = remove_surface_by_v_surf_div_v_escape s% job% min_q_for_remove_surface_by_v_surf_div_v_escape = min_q_for_remove_surface_by_v_surf_div_v_escape s% job% max_q_for_remove_surface_by_v_surf_div_v_escape = max_q_for_remove_surface_by_v_surf_div_v_escape - + s% job% remove_surface_do_jrot = remove_surface_do_jrot s% job% remove_surface_do_entropy = remove_surface_do_entropy s% job% remove_surface_turn_off_energy_sources_and_sinks = remove_surface_turn_off_energy_sources_and_sinks @@ -904,7 +904,7 @@ subroutine store_star_job_controls(s, ierr) s% job% change_j_rot_flag = change_j_rot_flag s% job% change_initial_j_rot_flag = change_initial_j_rot_flag s% job% new_j_rot_flag = new_j_rot_flag - + s% job% create_RSP_model = create_RSP_model s% job% change_v_flag = change_v_flag @@ -925,7 +925,7 @@ subroutine store_star_job_controls(s, ierr) s% job% change_reconstruction_flag = change_reconstruction_flag s% job% change_initial_reconstruction_flag = change_initial_reconstruction_flag s% job% new_reconstruction_flag = new_reconstruction_flag - + s% job% center_ye_limit_for_v_flag = center_ye_limit_for_v_flag s% job% change_rotation_flag = change_rotation_flag s% job% change_initial_rotation_flag = change_initial_rotation_flag @@ -1015,21 +1015,21 @@ subroutine store_star_job_controls(s, ierr) s% job% limit_initial_dt = limit_initial_dt s% job% years_for_initial_dt = years_for_initial_dt s% job% seconds_for_initial_dt = seconds_for_initial_dt - + s% job% set_initial_cumulative_energy_error = set_initial_cumulative_energy_error s% job% set_cumulative_energy_error = set_cumulative_energy_error s% job% set_cumulative_energy_error_at_step = set_cumulative_energy_error_at_step s% job% set_cumulative_energy_error_each_step_if_age_less_than = set_cumulative_energy_error_each_step_if_age_less_than s% job% new_cumulative_energy_error = new_cumulative_energy_error s% job% set_cumulative_energy_error_each_relax = set_cumulative_energy_error_each_relax - + s% job% change_net = change_net s% job% change_initial_net = change_initial_net s% job% new_net_name = new_net_name s% job% change_small_net = change_small_net s% job% change_initial_small_net = change_initial_small_net s% job% new_small_net_name = new_small_net_name - + s% job% h_he_net = h_he_net s% job% co_net = co_net s% job% adv_net = adv_net @@ -1100,11 +1100,11 @@ subroutine store_star_job_controls(s, ierr) s% job% replace_element_nzlo = replace_element_nzlo s% job% replace_element_nzhi = replace_element_nzhi s% job% do_special_test = do_special_test - + s% job% save_pulse_data_for_model_number = save_pulse_data_for_model_number s% job% save_pulse_data_when_terminate = save_pulse_data_when_terminate s% job% save_pulse_data_filename = save_pulse_data_filename - + s% job% chem_isotopes_filename = chem_isotopes_filename s% job% ionization_file_prefix = ionization_file_prefix s% job% ionization_Z1_suffix = ionization_Z1_suffix @@ -1212,7 +1212,7 @@ subroutine set_star_job_controls_for_writing(s, ierr) create_pre_main_sequence_model = s% job% create_pre_main_sequence_model pre_ms_relax_to_start_radiative_core = s% job% pre_ms_relax_to_start_radiative_core pre_ms_relax_num_steps = s% job% pre_ms_relax_num_steps - pre_ms_min_steps_before_check_radiative_core = s% job% pre_ms_min_steps_before_check_radiative_core + pre_ms_min_steps_before_check_radiative_core = s% job% pre_ms_min_steps_before_check_radiative_core pre_ms_check_radiative_core_start = s% job% pre_ms_check_radiative_core_start pre_ms_check_radiative_core_stop = s% job% pre_ms_check_radiative_core_stop pre_ms_check_radiative_core_Lnuc_div_L_limit = s% job% pre_ms_check_radiative_core_Lnuc_div_L_limit @@ -1283,7 +1283,7 @@ subroutine set_star_job_controls_for_writing(s, ierr) new_v_center = s% job% new_v_center dv_per_step = s% job% dv_per_step relax_v_center_dt = s% job% relax_v_center_dt - + zero_alpha_RTI = s% job% zero_alpha_RTI zero_initial_alpha_RTI = s% job% zero_initial_alpha_RTI @@ -1358,12 +1358,12 @@ subroutine set_star_job_controls_for_writing(s, ierr) remove_surface_by_v_surf_div_v_escape = s% job% remove_surface_by_v_surf_div_v_escape min_q_for_remove_surface_by_v_surf_div_v_escape = s% job% min_q_for_remove_surface_by_v_surf_div_v_escape max_q_for_remove_surface_by_v_surf_div_v_escape = s% job% max_q_for_remove_surface_by_v_surf_div_v_escape - + remove_surface_do_jrot = s% job% remove_surface_do_jrot remove_surface_do_entropy = s% job% remove_surface_do_entropy remove_surface_turn_off_energy_sources_and_sinks = s% job% remove_surface_turn_off_energy_sources_and_sinks remove_surface_by_relax_to_star_cut = s% job% remove_surface_by_relax_to_star_cut - + remove_initial_surface_at_cell_k = s% job% remove_initial_surface_at_cell_k remove_initial_surface_at_he_core_boundary = s% job% remove_initial_surface_at_he_core_boundary remove_initial_surface_by_optical_depth = s% job% remove_initial_surface_by_optical_depth @@ -1566,21 +1566,21 @@ subroutine set_star_job_controls_for_writing(s, ierr) limit_initial_dt = s% job% limit_initial_dt years_for_initial_dt = s% job% years_for_initial_dt seconds_for_initial_dt = s% job% seconds_for_initial_dt - + set_initial_cumulative_energy_error = s% job% set_initial_cumulative_energy_error set_cumulative_energy_error = s% job% set_cumulative_energy_error set_cumulative_energy_error_at_step = s% job% set_cumulative_energy_error_at_step set_cumulative_energy_error_each_step_if_age_less_than = s% job% set_cumulative_energy_error_each_step_if_age_less_than new_cumulative_energy_error = s% job% new_cumulative_energy_error set_cumulative_energy_error_each_relax = s% job% set_cumulative_energy_error_each_relax - + change_net = s% job% change_net change_initial_net = s% job% change_initial_net new_net_name = s% job% new_net_name change_small_net = s% job% change_small_net change_initial_small_net = s% job% change_initial_small_net new_small_net_name = s% job% new_small_net_name - + h_he_net = s% job% h_he_net co_net = s% job% co_net adv_net = s% job% adv_net @@ -1651,11 +1651,11 @@ subroutine set_star_job_controls_for_writing(s, ierr) replace_element_nzlo = s% job% replace_element_nzlo replace_element_nzhi = s% job% replace_element_nzhi do_special_test = s% job% do_special_test - + save_pulse_data_for_model_number = s% job% save_pulse_data_for_model_number save_pulse_data_when_terminate = s% job% save_pulse_data_when_terminate save_pulse_data_filename = s% job% save_pulse_data_filename - + chem_isotopes_filename = s% job% chem_isotopes_filename ionization_file_prefix = s% job% ionization_file_prefix ionization_Z1_suffix = s% job% ionization_Z1_suffix @@ -1670,7 +1670,7 @@ subroutine set_star_job_controls_for_writing(s, ierr) num_special_rate_factors = s% job% num_special_rate_factors special_rate_factor = s% job% special_rate_factor filename_of_special_rate = s% job% filename_of_special_rate - + reaction_for_special_factor = s% job% reaction_for_special_factor color_num_files = s% job% color_num_files color_file_names = s% job% color_file_names @@ -1715,27 +1715,27 @@ subroutine get_star_job(s, name, val, ierr) character(len=*),intent(in) :: name character(len=*), intent(out) :: val integer, intent(out) :: ierr - + character(len(name)+1) :: upper_name character(len=512) :: str integer :: iounit,iostat,ind,i - + ierr = 0 ! First save current controls call set_star_job_controls_for_writing(s, ierr) if(ierr/=0) return - + ! Write namelist to temporay file open(newunit=iounit,status='scratch') write(iounit,nml=star_job) rewind(iounit) - + ! Namelists get written in captials upper_name = trim(StrUpCase(name))//'=' val = '' ! Search for name inside namelist - do + do read(iounit,'(A)',iostat=iostat) str ind = index(trim(str),trim(upper_name)) if( ind /= 0 ) then @@ -1746,36 +1746,36 @@ subroutine get_star_job(s, name, val, ierr) exit end if if(is_iostat_end(iostat)) exit - end do - + end do + if(len_trim(val) == 0 .and. ind==0 ) ierr = -1 - + close(iounit) - + end subroutine get_star_job - + subroutine set_star_job(s, name, val, ierr) type (star_info), pointer :: s character(len=*), intent(in) :: name, val character(len=len(name)+len(val)+12) :: tmp integer, intent(out) :: ierr - + ierr = 0 ! First save current star_job call set_star_job_controls_for_writing(s, ierr) if(ierr/=0) return - + tmp='' tmp = '&star_job '//trim(name)//'='//trim(val)//'/' - + ! Load into namelist read(tmp, nml=star_job) - + ! Add to star call store_star_job_controls(s, ierr) if(ierr/=0) return - + end subroutine set_star_job diff --git a/star/private/star_private_def.f90 b/star/private/star_private_def.f90 index dce0c3462..85b080f5c 100644 --- a/star/private/star_private_def.f90 +++ b/star/private/star_private_def.f90 @@ -53,7 +53,7 @@ subroutine star_private_def_init include 'formats' okay = .true. - + auto_diff_star_d1_names(1:auto_diff_star_num_vars) = '' auto_diff_star_d1_names(i_lnd_m1) = 'i_lnd_m1' auto_diff_star_d1_names(i_lnd_00) = 'i_lnd_00' @@ -112,10 +112,10 @@ subroutine star_private_def_init termination_code_str(t_star_mass_max_limit) = 'star_mass_max_limit' termination_code_str(t_remnant_mass_min_limit) = 'remnant_mass_min_limit' termination_code_str(t_ejecta_mass_max_limit) = 'ejecta_mass_max_limit' - + termination_code_str(t_star_species_mass_min_limit) = 'star_species_mass_min_limit' termination_code_str(t_star_species_mass_max_limit) = 'star_species_mass_max_limit' - + termination_code_str(t_xmstar_min_limit) = 'xmstar_min_limit' termination_code_str(t_xmstar_max_limit) = 'xmstar_max_limit' termination_code_str(t_envelope_mass_limit) = 'envelope_mass_limit' @@ -184,7 +184,7 @@ subroutine star_private_def_init termination_code_str(t_phase_IAMS) = 'phase_IAMS' termination_code_str(t_phase_TAMS) = 'phase_TAMS' termination_code_str(t_phase_He_Burn) = 'phase_He_Burn' - termination_code_str(t_phase_ZACHeB) = 'phase_ZACHeB' + termination_code_str(t_phase_ZACHeB) = 'phase_ZACHeB' termination_code_str(t_phase_TACHeB) = 'phase_TACHeB' termination_code_str(t_phase_TP_AGB) = 'phase_TP_AGB' termination_code_str(t_phase_C_Burn) = 'phase_C_Burn' @@ -352,11 +352,11 @@ subroutine alloc_star(id, ierr) s => star_handles(id) end subroutine alloc_star - - + + subroutine init_star_handles() integer :: i - + if (.not. have_initialized_star_handles) then do i = 1, max_star_handles star_handles(i)% id = i @@ -364,10 +364,10 @@ subroutine init_star_handles() end do have_initialized_star_handles = .true. end if - + end subroutine init_star_handles - - + + integer function find_next_star_id() integer :: id id = 0 @@ -377,11 +377,11 @@ integer function find_next_star_id() if (star_handles(id)% in_use .eqv. .false.) exit end do end if -!$omp end critical (star_handle_next) +!$omp end critical (star_handle_next) find_next_star_id = id end function find_next_star_id - - + + integer function how_many_allocated_star_ids() integer :: id how_many_allocated_star_ids = 0 @@ -392,7 +392,7 @@ integer function how_many_allocated_star_ids() end do end if end function how_many_allocated_star_ids - + subroutine free_star(s) @@ -557,8 +557,8 @@ subroutine stardata_init( & call get_compiler_version(compiler_name,compiler_version_name) call get_mesasdk_version(mesasdk_version_name,ierr) call date_and_time(date=date) - + end subroutine stardata_init - + end module star_private_def diff --git a/star/private/star_profile_def.f90 b/star/private/star_profile_def.f90 index 093b6fa74..27e07b230 100644 --- a/star/private/star_profile_def.f90 +++ b/star/private/star_profile_def.f90 @@ -142,7 +142,7 @@ module star_profile_def integer, parameter :: p_cell_internal_energy_fraction_start = p_dlogR + 1 integer, parameter :: p_cell_internal_energy_fraction = p_cell_internal_energy_fraction_start + 1 - + integer, parameter :: p_log_rel_E_err = p_cell_internal_energy_fraction + 1 integer, parameter :: p_ergs_error_integral = p_log_rel_E_err + 1 integer, parameter :: p_ergs_rel_error_integral = p_ergs_error_integral + 1 @@ -277,7 +277,7 @@ module star_profile_def integer, parameter :: p_eps_diffusion = p_log_eps_WD_sedimentation + 1 integer, parameter :: p_log_eps_diffusion = p_eps_diffusion + 1 - + integer, parameter :: p_log_e_field = p_log_eps_diffusion + 1 integer, parameter :: p_e_field = p_log_e_field + 1 integer, parameter :: p_log_g_field_element_diffusion = p_e_field + 1 @@ -348,7 +348,7 @@ module star_profile_def integer, parameter :: p_dkap_dlnrho_face = p_ye + 1 integer, parameter :: p_dkap_dlnT_face = p_dkap_dlnrho_face + 1 integer, parameter :: p_opacity = p_dkap_dlnt_face + 1 - + integer, parameter :: p_deps_dlnd_face = p_opacity + 1 integer, parameter :: p_deps_dlnT_face = p_deps_dlnd_face + 1 integer, parameter :: p_d_epsnuc_dlnd = p_deps_dlnT_face + 1 @@ -356,7 +356,7 @@ module star_profile_def integer, parameter :: p_d_lnepsnuc_dlnT = p_d_lnepsnuc_dlnd + 1 integer, parameter :: p_d_epsnuc_dlnT = p_d_lnepsnuc_dlnT + 1 integer, parameter :: p_eps_nuc_start = p_d_epsnuc_dlnT + 1 - integer, parameter :: p_signed_log_eps_nuc = p_eps_nuc_start + 1 + integer, parameter :: p_signed_log_eps_nuc = p_eps_nuc_start + 1 integer, parameter :: p_log_abs_eps_nuc = p_signed_log_eps_nuc + 1 @@ -380,7 +380,7 @@ module star_profile_def integer, parameter :: p_extra_grav = p_extra_omegadot + 1 integer, parameter :: p_extra_heat = p_extra_grav + 1 integer, parameter :: p_div_v = p_extra_heat + 1 - integer, parameter :: p_d_v_div_r_dm = p_div_v + 1 + integer, parameter :: p_d_v_div_r_dm = p_div_v + 1 integer, parameter :: p_d_v_div_r_dr = p_d_v_div_r_dm + 1 integer, parameter :: p_dvdt_grav = p_d_v_div_r_dr + 1 @@ -407,7 +407,7 @@ module star_profile_def integer, parameter :: p_eps_mdot = p_ergs_mdot + 1 integer, parameter :: p_dm_eps_grav = p_eps_mdot + 1 - + integer, parameter :: p_log_xm_div_delta_m = p_dm_eps_grav + 1 integer, parameter :: p_xm_div_delta_m = p_log_xm_div_delta_m + 1 integer, parameter :: p_eps_grav = p_xm_div_delta_m + 1 @@ -433,7 +433,7 @@ module star_profile_def integer, parameter :: p_log_mlt_Gamma = p_log_gradT_div_gradr + 1 integer, parameter :: p_log_mlt_vc = p_log_mlt_Gamma + 1 integer, parameter :: p_conv_vel_div_mlt_vc = p_log_mlt_vc + 1 - integer, parameter :: p_mlt_vc = p_conv_vel_div_mlt_vc + 1 + integer, parameter :: p_mlt_vc = p_conv_vel_div_mlt_vc + 1 integer, parameter :: p_mlt_D = p_mlt_vc + 1 integer, parameter :: p_mlt_gradT = p_mlt_D + 1 integer, parameter :: p_mlt_log_abs_Y = p_mlt_gradT + 1 @@ -466,12 +466,12 @@ module star_profile_def integer, parameter :: p_conv_vel = p_log_D_mix + 1 integer, parameter :: p_dt_times_conv_vel_div_mixing_length = p_conv_vel + 1 integer, parameter :: p_log_dt_times_conv_vel_div_mixing_length = p_dt_times_conv_vel_div_mixing_length + 1 - + integer, parameter :: p_log_lambda_RTI_div_Hrho = p_log_dt_times_conv_vel_div_mixing_length + 1 integer, parameter :: p_lambda_RTI = p_log_lambda_RTI_div_Hrho + 1 integer, parameter :: p_dPdr_info = p_lambda_RTI + 1 integer, parameter :: p_dRhodr_info = p_dPdr_info + 1 - + integer, parameter :: p_source_plus_alpha_RTI = p_dRhodr_info + 1 integer, parameter :: p_log_source_RTI = p_source_plus_alpha_RTI + 1 integer, parameter :: p_log_source_plus_alpha_RTI = p_log_source_RTI + 1 @@ -577,7 +577,7 @@ module star_profile_def integer, parameter :: p_total_energy_sign = p_cs_at_cell_bdy + 1 integer, parameter :: p_total_energy = p_total_energy_sign + 1 - + integer, parameter :: p_Ptrb = p_total_energy + 1 integer, parameter :: p_log_Ptrb = p_Ptrb + 1 integer, parameter :: p_log_w = p_log_Ptrb + 1 @@ -698,7 +698,7 @@ module star_profile_def integer, parameter :: p_tau_qhse = p_tau_conv + 1 integer, parameter :: p_tau_epsnuc = p_tau_qhse + 1 integer, parameter :: p_tau_cool = p_tau_epsnuc + 1 - + integer, parameter :: p_max_abs_xa_corr = p_tau_cool + 1 integer, parameter :: p_log_zFe = p_max_abs_xa_corr + 1 integer, parameter :: p_zFe = p_log_zFe + 1 @@ -709,7 +709,7 @@ module star_profile_def integer, parameter :: p_log_du_kick_div_du = p_RTI_du_diffusion_kick + 1 integer, parameter :: p_lum_rad_div_L_Edd_sub_fourPrad_div_PchiT = p_log_du_kick_div_du + 1 - + integer, parameter :: p_col_id_max = p_lum_rad_div_L_Edd_sub_fourPrad_div_PchiT character (len=maxlen_profile_column_name) :: profile_column_name(p_col_id_max) @@ -758,7 +758,7 @@ subroutine profile_column_names_init(ierr) profile_column_name(p_r_div_g) = 'r_div_g' profile_column_name(p_g_div_r) = 'g_div_r' profile_column_name(p_net_nuclear_energy) = 'net_nuclear_energy' - + profile_column_name(p_eps_nuc_plus_nuc_neu) = 'eps_nuc_plus_nuc_neu' profile_column_name(p_eps_nuc_minus_non_nuc_neu) = 'eps_nuc_minus_non_nuc_neu' profile_column_name(p_net_energy) = 'net_energy' @@ -930,7 +930,7 @@ subroutine profile_column_names_init(ierr) profile_column_name(p_rho_times_r3) = 'rho_times_r3' profile_column_name(p_v_times_t_div_r) = 'v_times_t_div_r' profile_column_name(p_v_div_r) = 'v_div_r' - + profile_column_name(p_log_c_div_tau) = 'log_c_div_tau' profile_column_name(p_log_v_escape) = 'log_v_escape' profile_column_name(p_v_div_v_escape) = 'v_div_v_escape' @@ -967,7 +967,7 @@ subroutine profile_column_names_init(ierr) profile_column_name(p_eps_diffusion) = 'eps_diffusion' profile_column_name(p_log_eps_diffusion) = 'log_eps_diffusion' - + profile_column_name(p_log_e_field) = 'log_e_field' profile_column_name(p_e_field) = 'e_field' profile_column_name(p_log_g_field_element_diffusion) = 'log_g_field_element_diffusion' @@ -1091,7 +1091,7 @@ subroutine profile_column_names_init(ierr) profile_column_name(p_ergs_eps_grav_plus_eps_mdot) = 'ergs_eps_grav_plus_eps_mdot' profile_column_name(p_ergs_mdot) = 'ergs_mdot' profile_column_name(p_eps_mdot) = 'eps_mdot' - + profile_column_name(p_log_xm_div_delta_m) = 'log_xm_div_delta_m' profile_column_name(p_xm_div_delta_m) = 'xm_div_delta_m' profile_column_name(p_eps_grav) = 'eps_grav' @@ -1152,7 +1152,7 @@ subroutine profile_column_names_init(ierr) profile_column_name(p_lambda_RTI) = 'lambda_RTI' profile_column_name(p_dPdr_info) = 'dPdr_info' profile_column_name(p_dRhodr_info) = 'dRhodr_info' - + profile_column_name(p_source_plus_alpha_RTI) = 'source_plus_alpha_RTI' profile_column_name(p_source_minus_alpha_RTI) = 'source_minus_alpha_RTI' profile_column_name(p_log_source_RTI) = 'log_source_RTI' @@ -1308,7 +1308,7 @@ subroutine profile_column_names_init(ierr) profile_column_name(p_cell_ie_div_star_ie) = 'cell_ie_div_star_ie' profile_column_name(p_log_cell_specific_IE) = 'log_cell_specific_IE' profile_column_name(p_log_cell_ie_div_star_ie) = 'log_cell_ie_div_star_ie' - + profile_column_name(p_cell_specific_PE) = 'cell_specific_PE' profile_column_name(p_cell_specific_KE) = 'cell_specific_KE' profile_column_name(p_cell_IE_div_IE_plus_KE) = 'cell_IE_div_IE_plus_KE' diff --git a/star/private/star_solver.f90 b/star/private/star_solver.f90 index 0d435bf01..b3e6204a6 100644 --- a/star/private/star_solver.f90 +++ b/star/private/star_solver.f90 @@ -171,7 +171,7 @@ subroutine do_solver_work include 'formats' err_msg = '' - + nz = s% nz AF(1:ldAF,1:neq) => AF1(1:ldAF*neq) @@ -198,7 +198,7 @@ subroutine do_solver_work call set_param_defaults dbg_msg = s% report_solver_progress - + if (gold_tolerances_level == 2) then tol_residual_norm = s% gold2_tol_residual_norm1 tol_max_residual = s% gold2_tol_max_residual1 @@ -229,7 +229,7 @@ subroutine do_solver_work else min_corr_coeff = s% corr_coeff_limit end if - + if (gold_tolerances_level == 2) then iter_for_resid_tol2 = s% gold2_iter_for_resid_tol2 iter_for_resid_tol3 = s% gold2_iter_for_resid_tol3 @@ -268,15 +268,15 @@ subroutine do_solver_work convergence_failure = .true. return end if - - call do_equations(ierr) + + call do_equations(ierr) if (ierr /= 0) then if (dbg_msg) & write(*, *) 'solver failure: eval_equations returned ierr', ierr convergence_failure = .true. return end if - + call sizequ(s, nvar, residual_norm, max_residual, max_resid_k, max_resid_j, ierr) if (ierr /= 0) then if (dbg_msg) & @@ -304,11 +304,11 @@ subroutine do_solver_work tiny_corr_cnt = 0 s% num_solver_iterations = 0 - + iter_loop: do while (.not. passed_tol_tests) if (dbg_msg .and. first_try) write(*, *) - + max_resid_j = -1 max_corr_j = -1 @@ -334,21 +334,21 @@ subroutine do_solver_work write(*,1) 'tol1 residual tolerances: norm, max', & tol_residual_norm, tol_max_residual end if - + call solver_test_partials(nvar, xder, ierr) if (ierr /= 0) then call write_msg('solver_test_partials returned ierr /= 0') convergence_failure = .true. exit iter_loop end if - + s% num_solver_iterations = s% num_solver_iterations + 1 if (s% model_number == 1 .and. & s% num_solver_iterations > 60 .and. & mod(s% num_solver_iterations,10) == 0) & write(*,*) 'first model is slow to converge: num tries', & s% num_solver_iterations - + if (.not. solve_equ()) then ! either singular or horribly ill-conditioned write(err_msg, '(a, i5, 3x, a)') 'info', ierr, 'bad_matrix' call oops(err_msg) @@ -400,7 +400,7 @@ subroutine do_solver_work if (correction_norm*correction_factor > s% scale_correction_norm) then correction_factor = min(correction_factor,s% scale_correction_norm/correction_norm) end if - + if (max_abs_correction*correction_factor > s% scale_max_correction) then temp_correction_factor = s% scale_max_correction/max_abs_correction end if @@ -445,7 +445,7 @@ subroutine do_solver_work slope = 0d0 end if - + f = 0d0 call adjust_correction( & min_corr_coeff, correction_factor, grad_f1, f, slope, coeff, err_msg, ierr) @@ -478,7 +478,7 @@ subroutine do_solver_work end if exit iter_loop end if - + if (is_bad_num(max_residual)) then call oops('max_residual is a a bad number (NaN or Infinity)') if (s% stop_for_bad_nums) then @@ -494,7 +494,7 @@ subroutine do_solver_work s% max_residual = max_residual resid_norm_min = min(residual_norm, resid_norm_min) max_resid_min = min(max_residual, max_resid_min) - + disabled_resid_tests = & tol_max_residual > 1d2 .and. tol_residual_norm > 1d2 pass_resid_tests = & @@ -511,7 +511,7 @@ subroutine do_solver_work passed_tol_tests = & (pass_resid_tests .and. pass_corr_tests_with_coeff) .or. & (disabled_resid_tests .and. pass_corr_tests_without_coeff) - + if (.not. passed_tol_tests) then if (iter >= max_tries) then @@ -617,20 +617,20 @@ subroutine do_solver_work first_try = .false. end do iter_loop - + if (max_residual > s% warning_limit_for_max_residual .and. .not. convergence_failure) & write(*,2) 'WARNING: max_residual > warning_limit_for_max_residual', & s% model_number, max_residual, s% warning_limit_for_max_residual end subroutine do_solver_work - - + + subroutine solver_test_partials(nvar, xder, ierr) ! create jacobian by using numerical differences for partial derivatives integer, intent(in) :: nvar real(dp), pointer, dimension(:,:) :: xder ! (nvar, nz) integer, intent(out) :: ierr - + integer :: j, k, k_lo, k_hi real(dp), dimension(:,:), pointer :: save_equ, save_dx logical :: testing_partial @@ -656,7 +656,7 @@ subroutine solver_test_partials(nvar, xder, ierr) save_equ(j,k) = equ(j,k) end do end do - + s% doing_check_partials = .true. ! let set_vars_for_solver know k_lo = s% solver_test_partials_k_low if (k_lo > 0 .and. k_lo <= s% nz) then @@ -672,7 +672,7 @@ subroutine solver_test_partials(nvar, xder, ierr) end do else k = s% solver_test_partials_k - call test_cell_partials(s, k, save_dx, save_equ, ierr) + call test_cell_partials(s, k, save_dx, save_equ, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed solver_test_partials') end if deallocate(save_dx, save_equ) @@ -713,8 +713,8 @@ subroutine oops(msg) call write_msg(full_msg) convergence_failure = .true. end subroutine oops - - + + subroutine do_equations(ierr) integer, intent(out) :: ierr call prepare_solver_matrix(nvar, xder, ierr) @@ -819,15 +819,15 @@ subroutine adjust_correction( & s% solver_adjust_iter = iter call apply_coeff(nvar, nz, dxsave, soln, coeff, skip_eval_f) - - call do_equations(ierr) + + call do_equations(ierr) if (ierr /= 0) then if (alam > min_corr_coeff .and. s% model_number == 1) then ! try again with smaller correction vector. ! need this to rescue create pre-main-sequence model in some nasty cases. alam = max(alam/10, min_corr_coeff) ierr = 0 - cycle + cycle search_loop end if write(err_msg,*) 'adjust_correction failed in eval_equations' if (dbg_msg .or. dbg_adjust) & @@ -856,7 +856,7 @@ subroutine adjust_correction( & if (alam > min_corr_coeff) then alam = max(alam/10, min_corr_coeff) ierr = 0 - cycle + cycle search_loop end if err_msg = 'equ norm is NaN or other bad num' ierr = -1 @@ -1011,13 +1011,13 @@ logical function solve_equ() if (s% doing_timing) then call start_time(s, time0, total_time) end if - + !$OMP PARALLEL DO SIMD do i=1,neq b1(i) = -equ1(i) end do !$OMP END PARALLEL DO SIMD - + if (s% use_DGESVX_in_bcyclic) then !$OMP PARALLEL DO SIMD do i = 1, nvar*nvar*nz @@ -1027,10 +1027,10 @@ logical function solve_equ() end do !$OMP END PARALLEL DO SIMD end if - + call factor_mtx(ierr) if (ierr == 0) call solve_mtx(ierr) - + if (s% use_DGESVX_in_bcyclic) then !$OMP PARALLEL DO SIMD do i = 1, nvar*nvar*nz @@ -1072,7 +1072,7 @@ subroutine solve_mtx(ierr) end subroutine solve_mtx - subroutine test_cell_partials(s, k, save_dx, save_equ, ierr) + subroutine test_cell_partials(s, k, save_dx, save_equ, ierr) use star_utils, only: lookup_nameofvar, lookup_nameofequ type (star_info), pointer :: s integer, intent(in) :: k @@ -1082,7 +1082,7 @@ subroutine test_cell_partials(s, k, save_dx, save_equ, ierr) include 'formats' ierr = 0 write(*,'(A)') - i_equ = lookup_nameofequ(s, s% solver_test_partials_equ_name) + i_equ = lookup_nameofequ(s, s% solver_test_partials_equ_name) if (i_equ == 0 .and. len_trim(s% solver_test_partials_equ_name) > 0) then if (s% solver_test_partials_equ_name == 'lnE') then ! testing eos i_equ = -1 @@ -1100,11 +1100,11 @@ subroutine test_cell_partials(s, k, save_dx, save_equ, ierr) i_equ = -7 else if (s% solver_test_partials_equ_name == 'grad_ad') then i_equ = -8 - end if + end if else if (i_equ /= 0) then write(*,1) 'equ name ' // trim(s% solver_test_partials_equ_name) end if - i_var = lookup_nameofvar(s, s% solver_test_partials_var_name) + i_var = lookup_nameofvar(s, s% solver_test_partials_var_name) if (i_var /= 0) write(*,1) 'var name ' // trim(s% solver_test_partials_var_name) if (i_var > s% nvar_hydro) then ! get index in xa i_var_xa_index = i_var - s% nvar_hydro @@ -1127,16 +1127,16 @@ subroutine test_cell_partials(s, k, save_dx, save_equ, ierr) do i_equ = 1, s% nvar_hydro call test_equ_partials(s, & i_equ, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & - k, save_dx, save_equ, ierr) + k, save_dx, save_equ, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed solver_test_partials') end do else call test_equ_partials(s, & i_equ, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & - k, save_dx, save_equ, ierr) + k, save_dx, save_equ, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed solver_test_partials') - end if - end subroutine test_cell_partials + end if + end subroutine test_cell_partials subroutine test_equ_partials(s, & @@ -1164,7 +1164,7 @@ subroutine test_equ_partials(s, & call test3_partials(s, & i_equ, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & k, save_dx, save_equ, ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed solver_test_partials') + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed solver_test_partials') end if else ! i_equ == 0 if (i_var /= 0) then @@ -1192,15 +1192,15 @@ subroutine test_equ_partials(s, & end if call test1_partial(s, & i_equ, s% solver_test_partials_var, s% solver_test_partials_dx_sink, & - j_var_xa_index, j_var_sink_xa_index, & + j_var_xa_index, j_var_sink_xa_index, & k, 0, s% solver_test_partials_dval_dx, save_dx, save_equ, ierr) end if if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed solver_test_partials') - end if + end if write(*,'(A)') end subroutine test_equ_partials - - + + subroutine get_lnE_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & dvardx0_m1, dvardx0_00, dvardx0_p1) @@ -1209,7 +1209,7 @@ subroutine get_lnE_partials(s, & integer, intent(in) :: k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index real(dp), intent(out) :: dvardx0_m1, dvardx0_00, dvardx0_p1 dvardx0_m1 = 0d0; dvardx0_00 = 0d0; dvardx0_p1 = 0d0 - if (i_var_xa_index > 0) then + if (i_var_xa_index > 0) then dvardx0_00 = s% d_eos_dxa(i_lnE,i_var_xa_index,k) - & s% d_eos_dxa(i_lnE,i_var_sink_xa_index,k) else if (i_var == s% i_lnd) then @@ -1218,8 +1218,8 @@ subroutine get_lnE_partials(s, & dvardx0_00 = s% Cv_for_partials(k)*s% T(k)/s% energy(k) end if end subroutine get_lnE_partials - - + + subroutine get_lnP_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & dvardx0_m1, dvardx0_00, dvardx0_p1) @@ -1228,7 +1228,7 @@ subroutine get_lnP_partials(s, & integer, intent(in) :: k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index real(dp), intent(out) :: dvardx0_m1, dvardx0_00, dvardx0_p1 dvardx0_m1 = 0d0; dvardx0_00 = 0d0; dvardx0_p1 = 0d0 - if (i_var_xa_index > 0) then + if (i_var_xa_index > 0) then dvardx0_00 = s% Pgas(k)/s% Peos(k) * & (s% d_eos_dxa(i_lnPgas,i_var_xa_index,k) - s% d_eos_dxa(i_lnPgas,i_var_sink_xa_index,k)) else if (i_var == s% i_lnd) then @@ -1237,8 +1237,8 @@ subroutine get_lnP_partials(s, & dvardx0_00 = s% chiT_for_partials(k) end if end subroutine get_lnP_partials - - + + subroutine get_grad_ad_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & dvardx0_m1, dvardx0_00, dvardx0_p1) @@ -1247,7 +1247,7 @@ subroutine get_grad_ad_partials(s, & integer, intent(in) :: k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index real(dp), intent(out) :: dvardx0_m1, dvardx0_00, dvardx0_p1 dvardx0_m1 = 0d0; dvardx0_00 = 0d0; dvardx0_p1 = 0d0 - if (i_var_xa_index > 0) then + if (i_var_xa_index > 0) then dvardx0_00 = & (s% d_eos_dxa(i_grad_ad,i_var_xa_index,k) - s% d_eos_dxa(i_grad_ad,i_var_sink_xa_index,k)) else if (i_var == s% i_lnd) then @@ -1256,8 +1256,8 @@ subroutine get_grad_ad_partials(s, & dvardx0_00 = s% d_eos_dlnT(i_grad_ad,k) end if end subroutine get_grad_ad_partials - - + + subroutine get_eps_nuc_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & dvardx0_m1, dvardx0_00, dvardx0_p1) @@ -1265,7 +1265,7 @@ subroutine get_eps_nuc_partials(s, & integer, intent(in) :: k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index real(dp), intent(out) :: dvardx0_m1, dvardx0_00, dvardx0_p1 dvardx0_m1 = 0d0; dvardx0_00 = 0d0; dvardx0_p1 = 0d0 - if (i_var > s% nvar_hydro) then + if (i_var > s% nvar_hydro) then dvardx0_00 = s% d_epsnuc_dx(i_var_xa_index,k) - s% d_epsnuc_dx(i_var_sink_xa_index,k) else if (i_var == s% i_lnd) then dvardx0_00 = s% d_epsnuc_dlnd(k) @@ -1273,8 +1273,8 @@ subroutine get_eps_nuc_partials(s, & dvardx0_00 = s% d_epsnuc_dlnT(k) end if end subroutine get_eps_nuc_partials - - + + subroutine get_non_nuc_neu_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & dvardx0_m1, dvardx0_00, dvardx0_p1) @@ -1282,7 +1282,7 @@ subroutine get_non_nuc_neu_partials(s, & integer, intent(in) :: k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index real(dp), intent(out) :: dvardx0_m1, dvardx0_00, dvardx0_p1 dvardx0_m1 = 0d0; dvardx0_00 = 0d0; dvardx0_p1 = 0d0 - if (i_var > s% nvar_hydro) then + if (i_var > s% nvar_hydro) then dvardx0_00 = 0d0 else if (i_var == s% i_lnd) then dvardx0_00 = s% d_nonnucneu_dlnd(k) @@ -1290,8 +1290,8 @@ subroutine get_non_nuc_neu_partials(s, & dvardx0_00 = s% d_nonnucneu_dlnT(k) end if end subroutine get_non_nuc_neu_partials - - + + subroutine get_gradT_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & dvardx0_m1, dvardx0_00, dvardx0_p1) @@ -1299,7 +1299,7 @@ subroutine get_gradT_partials(s, & integer, intent(in) :: k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index real(dp), intent(out) :: dvardx0_m1, dvardx0_00, dvardx0_p1 dvardx0_m1 = 0d0; dvardx0_00 = 0d0; dvardx0_p1 = 0d0 - if (i_var > s% nvar_hydro) then + if (i_var > s% nvar_hydro) then dvardx0_00 = 0d0 else if (i_var == s% i_lnd) then dvardx0_m1 = s% gradT_ad(k)%d1Array(i_lnd_m1) @@ -1315,8 +1315,8 @@ subroutine get_gradT_partials(s, & dvardx0_00 = s% gradT_ad(k)%d1Array(i_w_00) end if end subroutine get_gradT_partials - - + + subroutine get_mlt_vc_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & dvardx0_m1, dvardx0_00, dvardx0_p1) @@ -1324,7 +1324,7 @@ subroutine get_mlt_vc_partials(s, & integer, intent(in) :: k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index real(dp), intent(out) :: dvardx0_m1, dvardx0_00, dvardx0_p1 dvardx0_m1 = 0d0; dvardx0_00 = 0d0; dvardx0_p1 = 0d0 - if (i_var > s% nvar_hydro) then + if (i_var > s% nvar_hydro) then dvardx0_00 = 0d0 else if (i_var == s% i_lnd) then dvardx0_m1 = s% mlt_vc_ad(k)%d1Array(i_lnd_m1) @@ -1338,8 +1338,8 @@ subroutine get_mlt_vc_partials(s, & dvardx0_00 = s% mlt_vc_ad(k)%d1Array(i_L_00) end if end subroutine get_mlt_vc_partials - - + + subroutine get_opacity_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & dvardx0_m1, dvardx0_00, dvardx0_p1) @@ -1347,7 +1347,7 @@ subroutine get_opacity_partials(s, & integer, intent(in) :: k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index real(dp), intent(out) :: dvardx0_m1, dvardx0_00, dvardx0_p1 dvardx0_m1 = 0d0; dvardx0_00 = 0d0; dvardx0_p1 = 0d0 - if (i_var > s% nvar_hydro) then + if (i_var > s% nvar_hydro) then dvardx0_00 = 0d0 ! s% d_opacity_dx(i_var_xa_index,k) - s% d_opacity_dx(i_var_sink_xa_index,k) else if (i_var == s% i_lnd) then dvardx0_00 = s% d_opacity_dlnd(k) @@ -1397,24 +1397,24 @@ subroutine test3_partials(s, & else if (i_equ == -4) then ! 'lnP' call get_lnP_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & - dvardx0_m1, dvardx0_00, dvardx0_p1) + dvardx0_m1, dvardx0_00, dvardx0_p1) else if (i_equ == -5) then ! 'non_nuc_neu' call get_non_nuc_neu_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & - dvardx0_m1, dvardx0_00, dvardx0_p1) + dvardx0_m1, dvardx0_00, dvardx0_p1) else if (i_equ == -6) then ! 'gradT' call get_gradT_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & - dvardx0_m1, dvardx0_00, dvardx0_p1) + dvardx0_m1, dvardx0_00, dvardx0_p1) else if (i_equ == -7) then ! 'mlt_vc' call get_mlt_vc_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & - dvardx0_m1, dvardx0_00, dvardx0_p1) + dvardx0_m1, dvardx0_00, dvardx0_p1) else if (i_equ == -8) then ! 'grad_ad' call get_grad_ad_partials(s, & k, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & - dvardx0_m1, dvardx0_00, dvardx0_p1) - end if + dvardx0_m1, dvardx0_00, dvardx0_p1) + end if if (k > 1) then call test1_partial(s, & i_equ, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & @@ -1432,7 +1432,7 @@ subroutine test3_partials(s, & if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'test3_partials') end if end subroutine test3_partials - + subroutine test1_partial(s, & i_equ, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & @@ -1444,7 +1444,7 @@ subroutine test1_partial(s, & real(dp), intent(in) :: dvardx_0 real(dp), pointer, dimension(:,:) :: save_dx, save_equ character (len=3) :: k_off_str - integer, intent(out) :: ierr + integer, intent(out) :: ierr character (len = 32) :: equ_str real(dp) :: dx_0, err, dvardx, xdum, uncertainty include 'formats' @@ -1497,7 +1497,7 @@ subroutine test1_partial(s, & else if (uncertainty > 1d-7) then write(*, '(a5,1x)', advance='no') '?????' else - write(*, '(6x)', advance='no') + write(*, '(6x)', advance='no') end if if (i_equ > 0) then equ_str = s% nameofequ(i_equ) @@ -1531,7 +1531,7 @@ subroutine test1_partial(s, & ! k, safe_log10(xdum), 'log uncertainty', safe_log10(uncertainty), & ! 'analytic', dvardx_0, 'numeric', dvardx, & ! 'analytic/numeric', abs(dvardx_0)/max(1d-99,abs(dvardx)) - + else write(*,'(A)') write(*,1) 'analytic and numeric partials wrt ' // trim(s% nameofvar(i_var)), & @@ -1541,8 +1541,8 @@ subroutine test1_partial(s, & if (dvardx_0 /= 0d0) write(*,1) 'rel_diff', xdum end if end subroutine test1_partial - - + + real(dp) function dfridr_func(s, & i_equ, i_var, i_var_sink, i_var_xa_index, i_var_sink_xa_index, & k, k_off, delta_x, save_dx) result(val) @@ -1696,8 +1696,8 @@ subroutine set_xtras(x,num_xtra) end if end do end subroutine set_xtras - - + + subroutine store_mix_type_str(str, integer_string, i, k) character (len=5) :: str character (len=10) :: integer_string @@ -1720,36 +1720,36 @@ end subroutine store_mix_type_str subroutine write_msg(msg) use const_def, only: secyer character(*) :: msg - + integer :: k character (len=64) :: max_resid_str, max_corr_str character (len=5) :: max_resid_mix_type_str, max_corr_mix_type_str character (len=10) :: integer_string include 'formats' - + if (.not. dbg_msg) return - + if (max_resid_j < 0) then call sizequ(s, nvar, residual_norm, max_residual, max_resid_k, max_resid_j, ierr) end if - + if (max_resid_j > 0) then write(max_resid_str,*) 'max resid ' // trim(s% nameofequ(max_resid_j)) else max_resid_str = '' end if - + if (max_corr_j < 0) then call sizeB(s, nvar, B, & max_correction, correction_norm, max_corr_k, max_corr_j, ierr) end if - + if (max_corr_j > 0) then write(max_corr_str,*) 'max corr ' // trim(s% nameofvar(max_corr_j)) else max_corr_str = '' end if - + integer_string = '0123456789' k = max_corr_k call store_mix_type_str(max_corr_mix_type_str, integer_string, 1, k-2) @@ -1757,7 +1757,7 @@ subroutine write_msg(msg) call store_mix_type_str(max_corr_mix_type_str, integer_string, 3, k) call store_mix_type_str(max_corr_mix_type_str, integer_string, 4, k+1) call store_mix_type_str(max_corr_mix_type_str, integer_string, 5, k+2) - + k = max_resid_k call store_mix_type_str(max_resid_mix_type_str, integer_string, 1, k-2) call store_mix_type_str(max_resid_mix_type_str, integer_string, 2, k-1) @@ -1788,7 +1788,7 @@ subroutine write_msg(msg) ' ' // trim(msg) ! 'mix type ' // trim(max_corr_mix_type_str), & ! ' ' // trim(msg) - + if (is_bad(slope)) call mesa_error(__FILE__,__LINE__,'write_msg') end subroutine write_msg @@ -1909,7 +1909,7 @@ subroutine cleanup() nullify(equ, equ1, dxsave1,dxsave, ddxsave, B1, & soln1, grad_f1, rhs, xder, ddx, row_scale_factors1,& col_scale_factors1, save_ublk1, save_dblk1, save_lblk1,& - B, soln, grad_f,ipiv1, ublk1, dblk1, lblk1, ublkF1,dblkF1, lblkF1) + B, soln, grad_f,ipiv1, ublk1, dblk1, lblk1, ublkF1,dblkF1, lblkF1) end subroutine cleanup diff --git a/star/private/star_utils.f90 b/star/private/star_utils.f90 index 355369c10..93bf60fac 100644 --- a/star/private/star_utils.f90 +++ b/star/private/star_utils.f90 @@ -281,7 +281,7 @@ subroutine set_m_grav_and_grav(s) ! using mass_corrections end do end subroutine set_m_grav_and_grav - + subroutine get_r_and_lnR_from_xh(s, k, r, lnR, xh_in) type (star_info), pointer :: s integer, intent(in) :: k @@ -297,7 +297,7 @@ subroutine get_r_and_lnR_from_xh(s, k, r, lnR, xh_in) r = exp(lnR) end subroutine get_r_and_lnR_from_xh - + real(dp) function get_r_from_xh(s, k, xh_in) result(r) type (star_info), pointer :: s integer, intent(in) :: k @@ -311,7 +311,7 @@ real(dp) function get_r_from_xh(s, k, xh_in) result(r) r = exp(xh(s% i_lnR,k)) end function get_r_from_xh - + real(dp) function get_lnR_from_xh(s, k, xh_in) result(lnR) type (star_info), pointer :: s integer, intent(in) :: k @@ -323,7 +323,7 @@ real(dp) function get_lnR_from_xh(s, k, xh_in) result(lnR) xh => s% xh end if lnR = xh(s% i_lnR,k) - end function get_lnR_from_xh + end function get_lnR_from_xh subroutine store_r_in_xh(s, k, r, xh_in) type (star_info), pointer :: s @@ -339,7 +339,7 @@ subroutine store_r_in_xh(s, k, r, xh_in) xh(s% i_lnR,k) = log(r) end subroutine store_r_in_xh - + subroutine store_lnR_in_xh(s, k, lnR, xh_in) type (star_info), pointer :: s integer, intent(in) :: k @@ -354,7 +354,7 @@ subroutine store_lnR_in_xh(s, k, lnR, xh_in) xh(s% i_lnR,k) = lnR end subroutine store_lnR_in_xh - + subroutine get_T_and_lnT_from_xh(s, k, T, lnT, xh_in) type (star_info), pointer :: s integer, intent(in) :: k @@ -370,7 +370,7 @@ subroutine get_T_and_lnT_from_xh(s, k, T, lnT, xh_in) T = exp(lnT) end subroutine get_T_and_lnT_from_xh - + real(dp) function get_T_from_xh(s, k, xh_in) result(T) type (star_info), pointer :: s integer, intent(in) :: k @@ -384,7 +384,7 @@ real(dp) function get_T_from_xh(s, k, xh_in) result(T) T = exp(xh(s% i_lnT,k)) end function get_T_from_xh - + real(dp) function get_lnT_from_xh(s, k, xh_in) result(lnT) type (star_info), pointer :: s integer, intent(in) :: k @@ -398,7 +398,7 @@ real(dp) function get_lnT_from_xh(s, k, xh_in) result(lnT) lnT = xh(s% i_lnT,k) end function get_lnT_from_xh - + subroutine store_T_in_xh(s, k, T, xh_in) type (star_info), pointer :: s integer, intent(in) :: k @@ -413,7 +413,7 @@ subroutine store_T_in_xh(s, k, T, xh_in) xh(s% i_lnT,k) = log(T) end subroutine store_T_in_xh - + subroutine store_lnT_in_xh(s, k, lnT, xh_in) type (star_info), pointer :: s integer, intent(in) :: k @@ -428,7 +428,7 @@ subroutine store_lnT_in_xh(s, k, lnT, xh_in) xh(s% i_lnT,k) = lnT end subroutine store_lnT_in_xh - + subroutine get_rho_and_lnd_from_xh(s, k, rho, lnd, xh_in) type (star_info), pointer :: s integer, intent(in) :: k @@ -443,7 +443,7 @@ subroutine get_rho_and_lnd_from_xh(s, k, rho, lnd, xh_in) lnd = xh(s% i_lnd,k) rho = exp(lnd) end subroutine get_rho_and_lnd_from_xh - + subroutine store_rho_in_xh(s, k, rho, xh_in) type (star_info), pointer :: s @@ -459,7 +459,7 @@ subroutine store_rho_in_xh(s, k, rho, xh_in) xh(s% i_lnd,k) = log(rho) end subroutine store_rho_in_xh - + subroutine store_lnd_in_xh(s, k, lnd, xh_in) type (star_info), pointer :: s integer, intent(in) :: k @@ -620,7 +620,7 @@ subroutine set_qs(s, nz, q, dq, ierr) ! set q's using normalized dq's do k=nz, midq+1, -1 dqsum2 = dqsum2 + dq(k) q(k) = dqsum2 - end do + end do end subroutine set_qs @@ -922,7 +922,7 @@ real(dp) function get_tau_at_r(s, r, ierr) end do end function get_tau_at_r - + subroutine set_phot_info(s) use atm_lib, only: atm_black_body_T type (star_info), pointer :: s @@ -967,7 +967,7 @@ subroutine get_phot_info(s,r,m,v,L,T_phot,cs,kap,logg,ysum,k_phot) Tface_0, Tface_1 include 'formats' - + ! set values for surface as defaults in case phot not in model r = s% r(1) m = s% m(1) @@ -1099,12 +1099,12 @@ end subroutine interp_q subroutine set_abs_du_div_cs(s) type (star_info), pointer :: s - + integer :: k, nz, j real(dp) :: abs_du, cs include 'formats' nz = s% nz - + if (s% v_flag) then do k=2,nz abs_du = abs(s% v_start(k) - s% v_start(k-1)) @@ -1177,7 +1177,7 @@ subroutine get_shock_info(s) s% shock_entropy = 0d0 s% shock_tau = 0d0 s% shock_k = 0 - + if (s% u_flag) then v => s% u else if (s% v_flag) then @@ -1216,7 +1216,7 @@ subroutine get_shock_info(s) end if end do if (shock_radius < 0d0) return - + call get_shock_location_info( & s, .false., k-1, v, shock_radius, & s% shock_mass, & @@ -1292,7 +1292,7 @@ subroutine get_shock_location_info( & shock_k = 0 return end if - + shock_radius = r/Rsun shock_k = k if (k < s% nz) then @@ -1455,7 +1455,7 @@ subroutine unpack_residual_partials(s, k, nvar, i_eqn, & integer, intent(in) :: k, nvar, i_eqn type(auto_diff_real_star_order1) :: residual real(dp) :: d_dm1(nvar), d_d00(nvar), d_dp1(nvar) - + real(dp) :: val, dlnd_m1, dlnd_00, dlnd_p1, dlnT_m1, dlnT_00, dlnT_p1, & dw_m1, dw_00, dw_p1, & dlnR_m1, dlnR_00, dlnR_p1, & @@ -1476,8 +1476,8 @@ subroutine unpack_residual_partials(s, k, nvar, i_eqn, & dw_div_wc_m1, dw_div_wc_00, dw_div_wc_p1, & djrot_m1, djrot_00, djrot_p1, & dxtra1_m1, dxtra1_00, dxtra1_p1, & - dxtra2_m1, dxtra2_00, dxtra2_p1) - + dxtra2_m1, dxtra2_00, dxtra2_p1) + d_dm1 = 0; d_d00 = 0; d_dp1 = 0 call unpack1(s% i_lnd, dlnd_m1, dlnd_00, dlnd_p1) call unpack1(s% i_lnT, dlnT_m1, dlnT_00, dlnT_p1) @@ -1489,17 +1489,17 @@ subroutine unpack_residual_partials(s, k, nvar, i_eqn, & if (s% i_Hp /= 0) call unpack1(s% i_Hp, dHp_m1, dHp_00, dHp_p1) if (s% i_w_div_wc /= 0) call unpack1(s% i_w_div_wc, dw_div_wc_m1, dw_div_wc_00, dw_div_wc_p1) if (s% i_j_rot /= 0) call unpack1(s% i_j_rot, djrot_m1, djrot_00, djrot_p1) - + contains - + subroutine unpack1(j, dvar_m1, dvar_00, dvar_p1) integer, intent(in) :: j real(dp), intent(in) :: dvar_m1, dvar_00, dvar_p1 d_dm1(j) = dvar_m1 d_d00(j) = dvar_00 d_dp1(j) = dvar_p1 - end subroutine unpack1 - + end subroutine unpack1 + end subroutine unpack_residual_partials subroutine store_partials(s, k, i_eqn, nvar, d_dm1, d_d00, d_dp1, str, ierr) @@ -1523,8 +1523,8 @@ subroutine store_partials(s, k, i_eqn, nvar, d_dm1, d_d00, d_dp1, str, ierr) if (checking) call check_dequ(d_dp1(j),trim(str) // ' d_dp1') call ep1(s, i_eqn, j, k, nvar, d_dp1(j)) end if - end do - + end do + contains subroutine check_dequ(dequ, str) @@ -1542,7 +1542,7 @@ subroutine check_dequ(dequ, str) return end if end subroutine check_dequ - + end subroutine store_partials @@ -1753,7 +1753,7 @@ real(dp) function get_remnant_mass(s) get_remnant_mass = s% m(1) - get_ejecta_mass(s) end function get_remnant_mass - + real(dp) function get_ejecta_mass(s) use num_lib, only: find0 type (star_info), pointer :: s @@ -1765,7 +1765,7 @@ real(dp) function get_ejecta_mass(s) v_div_vesc_prev = 0d0 do k=1,s% nz if (s% u_flag) then - !v = s% u_face_ad(k)%val ! CANNOT USE u_face for this + !v = s% u_face_ad(k)%val ! CANNOT USE u_face for this ! approximate value is good enough for this estimate if (k == 1) then v = s% u(k) @@ -1969,14 +1969,14 @@ real(dp) function get_Lrad_div_Ledd(s,k) result(L_rad_div_Ledd) -(area*area*crad*(del_T4/del_m)/3)/(pi4*s% cgrav(j)*s% m_grav(j)) end function get_Lrad_div_Ledd - + real(dp) function cell_start_specific_KE(s,k) type (star_info), pointer :: s integer, intent(in) :: k cell_start_specific_KE = cell_start_specific_KE_qp(s,k) end function cell_start_specific_KE - + real(qp) function cell_start_specific_KE_qp(s,k) ! for consistency with dual cells at faces, use instead of **2 type (star_info), pointer :: s @@ -2005,7 +2005,7 @@ real(qp) function cell_start_specific_KE_qp(s,k) end if end function cell_start_specific_KE_qp - + real(dp) function cell_specific_KE(s,k,d_dv00,d_dvp1) type (star_info), pointer :: s integer, intent(in) :: k @@ -2013,7 +2013,7 @@ real(dp) function cell_specific_KE(s,k,d_dv00,d_dvp1) cell_specific_KE = cell_specific_KE_qp(s,k,d_dv00,d_dvp1) end function cell_specific_KE - + real(qp) function cell_specific_KE_qp(s,k,d_dv00,d_dvp1) ! for consistency with dual cells at faces, use instead of **2 type (star_info), pointer :: s @@ -2053,7 +2053,7 @@ real(qp) function cell_specific_KE_qp(s,k,d_dv00,d_dvp1) end if end function cell_specific_KE_qp - + real(dp) function cell_specific_PE(s,k,d_dlnR00,d_dlnRp1) type (star_info), pointer :: s integer, intent(in) :: k @@ -2061,7 +2061,7 @@ real(dp) function cell_specific_PE(s,k,d_dlnR00,d_dlnRp1) cell_specific_PE = cell_specific_PE_qp(s,k,d_dlnR00,d_dlnRp1) end function cell_specific_PE - + real(qp) function cell_specific_PE_qp(s,k,d_dlnR00,d_dlnRp1) ! for consistency with dual cells at faces, _cntr => (m(k)/r(k) + m(k+1)/r(k+1))/2 /= m_cntr/r_cntr ! i.e., use avg of m/r at faces of cell rather than ratio of cell center mass over cell center r. @@ -2109,14 +2109,14 @@ real(qp) function cell_specific_PE_qp(s,k,d_dlnR00,d_dlnRp1) end if end function cell_specific_PE_qp - + real(dp) function cell_start_specific_PE(s,k) type (star_info), pointer :: s integer, intent(in) :: k cell_start_specific_PE = cell_start_specific_PE_qp(s,k) end function cell_start_specific_PE - + real(dp) function cell_start_specific_PE_qp(s,k) ! for consistency with dual cells at faces, _cntr => (m(k)/r(k) + m(k+1)/r(k+1))/2 /= m_cntr/r_cntr ! i.e., use avg of m/r at faces of cell rather than ratio of cell center mass over cell center r. @@ -2157,7 +2157,7 @@ real(dp) function cell_start_specific_PE_qp(s,k) end if end function cell_start_specific_PE_qp - + real(dp) function cell_specific_rotational_energy(s,k) type (star_info), pointer :: s integer, intent(in) :: k @@ -2175,8 +2175,8 @@ end function cell_specific_rotational_energy subroutine get_dke_dt_dpe_dt(s, k, dt, & dke_dt, d_dkedt_dv00, d_dkedt_dvp1, & dpe_dt, d_dpedt_dlnR00, d_dpedt_dlnRp1, ierr) - type (star_info), pointer :: s - integer, intent(in) :: k + type (star_info), pointer :: s + integer, intent(in) :: k real(dp), intent(in) :: dt real(dp), intent(out) :: & dke_dt, d_dkedt_dv00, d_dkedt_dvp1, & @@ -2192,17 +2192,17 @@ subroutine get_dke_dt_dpe_dt(s, k, dt, & q1 = PE_new - PE_start dpe_dt = q1/dt ! erg/g/s d_dpedt_dlnR00 = dpe_dlnR00/dt - d_dpedt_dlnRp1 = dpe_dlnRp1/dt + d_dpedt_dlnRp1 = dpe_dlnRp1/dt ! rate of change in specific KE (erg/g/s) KE_start = cell_start_specific_KE_qp(s,k) KE_new = cell_specific_KE_qp(s,k,dke_dv00,dke_dvp1) q1 = KE_new - KE_start dke_dt = q1/dt ! erg/g/s d_dkedt_dv00 = dke_dv00/dt - d_dkedt_dvp1 = dke_dvp1/dt + d_dkedt_dvp1 = dke_dvp1/dt end subroutine get_dke_dt_dpe_dt - + real(dp) function eval_deltaM_total_from_profile( & deltaM, premesh_dm, profile) real(dp), intent(in) :: deltaM @@ -2226,7 +2226,7 @@ real(dp) function eval_deltaM_total_from_profile( & eval_deltaM_total_from_profile = total end function eval_deltaM_total_from_profile - + real(dp) function cell_specific_total_energy(s, k) result(cell_total) type (star_info), pointer :: s integer, intent(in) :: k @@ -2242,7 +2242,7 @@ real(dp) function cell_specific_total_energy(s, k) result(cell_total) if (s% rsp_flag) cell_total = cell_total + s% RSP_Et(k) end function cell_specific_total_energy - + subroutine eval_integrated_total_energy_profile(s, arr, direction, ierr) type (star_info), pointer :: s integer, intent(in) :: direction @@ -2266,7 +2266,7 @@ subroutine eval_integrated_total_energy_profile(s, arr, direction, ierr) do k=start+direction, finish, direction arr(k) = arr(k-direction) + cell_specific_total_energy(s,k) * s%dm(k) end do - + end subroutine eval_integrated_total_energy_profile subroutine eval_deltaM_total_energy_integrals( & @@ -2287,7 +2287,7 @@ subroutine eval_deltaM_total_energy_integrals( & integer :: k real(dp) :: dm, sum_dm, cell_total, cell1, d_dv00, d_dvp1, d_dlnR00, d_dlnRp1 include 'formats' - + total_internal_energy = 0d0 total_gravitational_energy = 0d0 total_radial_kinetic_energy = 0d0 @@ -2296,7 +2296,7 @@ subroutine eval_deltaM_total_energy_integrals( & sum_total = 0d0 if (klo < 1 .or. khi > s% nz .or. klo > khi) return - + sum_dm = 0 do k=klo,khi if (sum_dm >= deltaM) exit @@ -2337,7 +2337,7 @@ subroutine eval_deltaM_total_energy_integrals( & sum_total = total_internal_energy + total_gravitational_energy + & total_radial_kinetic_energy + total_turbulent_energy - + if (s% include_rotation_in_total_energy) & sum_total = sum_total + total_rotational_kinetic_energy @@ -2351,7 +2351,7 @@ subroutine eval_total_energy_profile(s, total_energy_profile) integer :: k real(dp) :: dm, cell_total, cell1, d_dv00, d_dvp1, d_dlnR00, d_dlnRp1 include 'formats' - + do k=1, s%nz cell_total = 0 dm = s% dm(k) @@ -2378,10 +2378,10 @@ subroutine eval_total_energy_profile(s, total_energy_profile) end if total_energy_profile(k) = cell_total end do - + end subroutine eval_total_energy_profile - + real(dp) function eval_cell_section_total_energy( & s, klo, khi) result(sum_total) type (star_info), pointer :: s @@ -2542,7 +2542,7 @@ logical function after_C_burn(s, c12_limit) after_C_burn = .true. end function after_C_burn - + integer function lookup_nameofvar(s, namestr) type (star_info), pointer :: s character (len=*), intent(in) :: namestr @@ -2556,7 +2556,7 @@ integer function lookup_nameofvar(s, namestr) end do end function lookup_nameofvar - + integer function lookup_nameofequ(s, namestr) type (star_info), pointer :: s character (len=*), intent(in) :: namestr @@ -2667,7 +2667,7 @@ subroutine threshold_smoothing (dd, dd_thresh, n, ns, preserve_sign, ddold) integer :: i integer :: i_a integer :: i_b - + include 'formats' ! Process regions @@ -2773,23 +2773,23 @@ subroutine set_phase_of_evolution(s) ! from evolve after call do_report any(s% burn_he_conv_region(1:s% num_conv_boundaries))) then s% phase_of_evolution = phase_TP_AGB else if (center_he4 <= 1d-4) then - s% phase_of_evolution = phase_TACHeB + s% phase_of_evolution = phase_TACHeB else if (s% center_eps_burn(i3alf) > 1d2) then s% phase_of_evolution = phase_ZACHeB else if (s% L_by_category(i3alf) > 1d2) then s% phase_of_evolution = phase_He_Burn else if (center_h1 <= 1d-6) then - s% phase_of_evolution = phase_TAMS + s% phase_of_evolution = phase_TAMS else if (center_h1 <= 0.3d0) then - s% phase_of_evolution = phase_IAMS + s% phase_of_evolution = phase_IAMS else if (s% L_nuc_burn_total >= s% L_phot*s% Lnuc_div_L_zams_limit) then s% phase_of_evolution = phase_ZAMS else if (s% log_center_temperature > 5d0) then s% phase_of_evolution = phase_PreMS else s% phase_of_evolution = phase_starting - end if - + end if + end subroutine set_phase_of_evolution @@ -2808,14 +2808,14 @@ subroutine set_rv_info(s,k) end if end subroutine set_rv_info - + subroutine show_matrix(s, dmat, nvar) type (star_info), pointer :: s integer, intent(in) :: nvar real(dp) :: dmat(nvar,nvar) integer :: i, j write(*,'(A)') - write(*,'(18x)', advance = 'no') + write(*,'(18x)', advance = 'no') do j = 1, nvar write(*,'(a15)', advance = 'no') s% nameofvar(j) end do @@ -2838,20 +2838,20 @@ subroutine e00(s,i,j,k,nvar,v) real(dp), intent(in) :: v logical, parameter :: dbg = .false. include 'formats' - + if (mdb .and. k==397 .and. v /= 0d0) & write(*,4) 'e00(i,j,k) ' // & trim(s% nameofequ(i)) // ' ' // trim(s% nameofvar(j)), i, j, k, v - + !if (j == s% i_lnd .and. k /= s% nz) return ! this variable is being held constant - + if (v == 0d0) return - + if (.false. .and. j == s% i_lnT .and. k == 30) then write(*,4) 'e00(i,j,k) ' // & trim(s% nameofequ(i)) // ' ' // trim(s% nameofvar(j)), i, j, k, v, s% x_scale(j,k) end if - + if (is_bad(v)) then !$omp critical (star_utils_e00_crit1) write(*,4) 'e00(i,j,k) ' // & @@ -2859,15 +2859,15 @@ subroutine e00(s,i,j,k,nvar,v) if (s% stop_for_bad_nums) call mesa_error(__FILE__,__LINE__,'1 e00') !$omp end critical (star_utils_e00_crit1) end if - + if (i <= 0 .or. j <= 0 .or. k <= 0 .or. k > s% nz) then write(*,4) 'bad i,j,k e00(i,j,k) ' // & trim(s% nameofequ(i)) // ' ' // trim(s% nameofvar(j)), i, j, k, v call mesa_error(__FILE__,__LINE__,'2 e00') end if - + if (j > nvar) return ! hybrid - + if (i > nvar) then !$omp critical (star_utils_e00_crit2) write(*,5) 'bad i e00(i,j,k) ' // & @@ -2892,18 +2892,18 @@ subroutine em1(s,i,j,k,nvar,v) logical, parameter :: dbg = .false. if (k == 1) return include 'formats' - + if (mdb .and. k==397 .and. v /= 0d0) & write(*,4) 'em1(i,j,k) ' // & trim(s% nameofequ(i)) // ' ' // trim(s% nameofvar(j)), i, j, k, v - + if (v == 0d0) return - + if (.false. .and. j == s% i_lnT .and. k == 31) then write(*,4) 'em1(i,j,k) ' // & trim(s% nameofequ(i)) // ' ' // trim(s% nameofvar(j)), i, j, k, v, s% x_scale(j,k-1) end if - + if (is_bad(v)) then !$omp critical (star_utils_em1_crit1) write(*,4) 'em1(i,j,k) ' // & @@ -2911,15 +2911,15 @@ subroutine em1(s,i,j,k,nvar,v) if (s% stop_for_bad_nums) call mesa_error(__FILE__,__LINE__,'em1') !$omp end critical (star_utils_em1_crit1) end if - + if (i <= 0 .or. j <= 0 .or. k <= 0 .or. k > s% nz) then write(*,4) 'bad i,j,k em1(i,j,k) ' // & trim(s% nameofequ(i)) // ' ' // trim(s% nameofvar(j)), i, j, k, v call mesa_error(__FILE__,__LINE__,'em1') end if - + if (j > nvar) return ! hybrid - + if (i > nvar) then write(*,5) 'bad i em1(i,j,k) ' // & trim(s% nameofequ(i)) // ' ' // trim(s% nameofvar(j)), & @@ -2941,18 +2941,18 @@ subroutine ep1(s,i,j,k,nvar,v) real(dp), intent(in) :: v logical, parameter :: dbg = .false. include 'formats' - + if (mdb .and. k==397 .and. v /= 0d0) & write(*,4) 'ep1(i,j,k) ' // & trim(s% nameofequ(i)) // ' ' // trim(s% nameofvar(j)), i, j, k, v - + if (v == 0d0) return - + if (.false. .and. j == s% i_lnT .and. k == 29) then write(*,4) 'ep1(i,j,k) ' // & trim(s% nameofequ(i)) // ' ' // trim(s% nameofvar(j)), i, j, k, v, s% x_scale(j,k+1) end if - + if (is_bad(v)) then !$omp critical (star_utils_ep1_crit1) write(*,4) 'ep1(i,j,k) ' // & @@ -2960,15 +2960,15 @@ subroutine ep1(s,i,j,k,nvar,v) if (s% stop_for_bad_nums) call mesa_error(__FILE__,__LINE__,'ep1') !$omp end critical (star_utils_ep1_crit1) end if - + if (i <= 0 .or. j <= 0 .or. k <= 0 .or. k > s% nz) then write(*,4) 'bad i,j,k ep1(i,j,k) ' // & trim(s% nameofequ(i)) // ' ' // trim(s% nameofvar(j)), i, j, k, v call mesa_error(__FILE__,__LINE__,'ep1') end if - + if (j > nvar) return - + if (i > nvar) then write(*,5) 'bad i ep1(i,j,k) ' // & trim(s% nameofequ(i)) // ' ' // trim(s% nameofvar(j)), & @@ -3137,8 +3137,8 @@ subroutine get1_lpp(k, nz, & end subroutine get1_lpp - - subroutine calc_Ptrb_ad_tw(s, k, Ptrb, Ptrb_div_etrb, ierr) + + subroutine calc_Ptrb_ad_tw(s, k, Ptrb, Ptrb_div_etrb, ierr) ! note: Ptrb_div_etrb is not time weighted ! erg cm^-3 = g cm^2 s^-2 cm^-3 = g cm^-1 s^-2 use auto_diff @@ -3187,7 +3187,7 @@ subroutine calc_Ptrb_ad_tw(s, k, Ptrb, Ptrb_div_etrb, ierr) !s% solver_test_partials_dval_dx = 0 ! d_residual_dr_00 write(*,*) 'calc_Ptrb_ad_tw', s% solver_test_partials_var end if - + end subroutine calc_Ptrb_ad_tw @@ -3195,7 +3195,7 @@ end subroutine calc_Ptrb_ad_tw subroutine calc_Ptot_ad_tw( & s, k, skip_Peos, skip_mlt_Pturb, Ptot_ad, d_Ptot_dxa, ierr) use auto_diff_support - type (star_info), pointer :: s + type (star_info), pointer :: s integer, intent(in) :: k logical, intent(in) :: skip_Peos, skip_mlt_Pturb type(auto_diff_real_star_order1), intent(out) :: Ptot_ad @@ -3207,10 +3207,10 @@ subroutine calc_Ptot_ad_tw( & Peos_ad, Pvsc_ad, Ptrb_ad, mlt_Pturb_ad, Ptrb_ad_div_etrb logical :: time_center include 'formats' - + ierr = 0 d_Ptot_dxa = 0d0 - + time_center = (s% using_velocity_time_centering .and. & s% include_P_in_velocity_time_centering) if (time_center) then @@ -3219,8 +3219,8 @@ subroutine calc_Ptot_ad_tw( & alfa = 1d0 end if beta = 1d0 - alfa - - Peos_ad = 0d0 + + Peos_ad = 0d0 if (.not. skip_Peos) then Peos_ad = wrap_peos_00(s, k) Peos_ad = alfa*Peos_ad + beta*s% Peos_start(k) @@ -3236,10 +3236,10 @@ subroutine calc_Ptot_ad_tw( & if (ierr /= 0) return ! NO TIME CENTERING FOR Pvsc: Pvsc_ad = alfa*Pvsc_ad + beta*s% Pvsc_start(k) end if - + Ptrb_ad = 0d0 if (s% RSP2_flag) then - call calc_Ptrb_ad_tw(s, k, Ptrb_ad, Ptrb_ad_div_etrb, ierr) + call calc_Ptrb_ad_tw(s, k, Ptrb_ad, Ptrb_ad_div_etrb, ierr) if (ierr /= 0) return ! note that Ptrb_ad is already time weighted end if @@ -3252,20 +3252,20 @@ subroutine calc_Ptot_ad_tw( & s% mlt_Pturb_factor*pow2(s% mlt_vc_old(k))*(s% rho_start(k-1) + s% rho_start(k))/6d0 mlt_Pturb_ad = alfa*mlt_Pturb_ad + beta*mlt_Pturb_start end if - end if - + end if + Ptot_ad = Peos_ad + Pvsc_ad + Ptrb_ad + mlt_Pturb_ad - + if (s% use_other_pressure) Ptot_ad = Ptot_ad + s% extra_pressure(k) end subroutine calc_Ptot_ad_tw - + subroutine get_Pvsc_ad(s, k, Pvsc, ierr) use auto_diff use auto_diff_support - type (star_info), pointer :: s - integer, intent(in) :: k + type (star_info), pointer :: s + integer, intent(in) :: k type(auto_diff_real_star_order1), intent(out) :: Pvsc integer, intent(out) :: ierr type(auto_diff_real_star_order1) :: v00, vp1, Peos, rho, & @@ -3291,11 +3291,11 @@ subroutine get_Pvsc_ad(s, k, Pvsc, ierr) if (Pvsc_start < 0d0) s% Pvsc_start(k) = s% Pvsc(k) end subroutine get_Pvsc_ad - + ! marsaglia and zaman random number generator. period is 2**43 with ! 900 million different sequences. the state of the generator (for restarts) subroutine init_random(s) - type (star_info), pointer :: s + type (star_info), pointer :: s integer :: ijkl,ij,kl,i,j,k,l,ii,jj,m real(dp) :: x,t ijkl = 54217137 @@ -3326,9 +3326,9 @@ subroutine init_random(s) s% rand_j97 = 33 end subroutine init_random - + real(dp) function rand(s) - type (star_info), pointer :: s + type (star_info), pointer :: s real(dp) :: uni uni = s% rand_u(s% rand_i97) - s% rand_u(s% rand_j97) if (uni < 0.0d0) uni = uni + 1.0d0 @@ -3368,7 +3368,7 @@ subroutine write_to_extra_terminal_output_file(s, str, advance) end if end subroutine write_to_extra_terminal_output_file - + subroutine write_eos_call_info(s,k) use chem_def type (star_info), pointer :: s @@ -3477,7 +3477,7 @@ real(dp) function center_avg_x(s,j) center_avg_x = sum_x/sum_dq end function center_avg_x - + subroutine get_area_info_opt_time_center(s, k, area, inv_R2, ierr) use auto_diff_support type (star_info), pointer :: s @@ -3497,7 +3497,7 @@ subroutine get_area_info_opt_time_center(s, k, area, inv_R2, ierr) end if end subroutine get_area_info_opt_time_center - + subroutine set_energy_eqn_scal(s, k, scal, ierr) ! 1/(erg g^-1 s^-1) type (star_info), pointer :: s integer, intent(in) :: k @@ -3513,13 +3513,13 @@ subroutine set_energy_eqn_scal(s, k, scal, ierr) ! 1/(erg g^-1 s^-1) end if if (s% dedt_eqn_r_scale > 0d0) then cell_energy_fraction_start = & - s% energy_start(k)*s% dm(k)/s% total_internal_energy_old - scal = min(scal, cell_energy_fraction_start*s% dedt_eqn_r_scale) + s% energy_start(k)*s% dm(k)/s% total_internal_energy_old + scal = min(scal, cell_energy_fraction_start*s% dedt_eqn_r_scale) end if scal = scal*s% dt/s% energy_start(k) end subroutine set_energy_eqn_scal - + real(dp) function conv_time_scale(s,k_in) result(tau_conv) type (star_info), pointer :: s integer, intent(in) :: k_in @@ -3550,7 +3550,7 @@ real(dp) function conv_time_scale(s,k_in) result(tau_conv) end if end function conv_time_scale - + subroutine set_conv_time_scales(s) type (star_info), pointer :: s integer :: k @@ -3571,9 +3571,9 @@ subroutine set_conv_time_scales(s) end do if (s% max_conv_time_scale == 0d0) s% max_conv_time_scale = 1d99 if (s% min_conv_time_scale == 1d99) s% min_conv_time_scale = 0d0 - end subroutine set_conv_time_scales + end subroutine set_conv_time_scales + - real(dp) function QHSE_time_scale(s,k) result(tau_qhse) type (star_info), pointer :: s integer, intent(in) :: k @@ -3588,16 +3588,16 @@ real(dp) function QHSE_time_scale(s,k) result(tau_qhse) tau_qhse = abs_dv/(s% cgrav(k)*s% m_grav(k)/pow2(s% r(k))) end function QHSE_time_scale - - + + real(dp) function eps_nuc_time_scale(s,k) result(tau_epsnuc) type (star_info), pointer :: s integer, intent(in) :: k tau_epsnuc = s% Cp(k)*s% T(k)/max(1d-10,abs(s% eps_nuc(k))) end function eps_nuc_time_scale - + real(dp) function cooling_time_scale(s,k) result(tau_cool) type (star_info), pointer :: s integer, intent(in) :: k @@ -3606,7 +3606,7 @@ real(dp) function cooling_time_scale(s,k) result(tau_cool) tau_cool = pow2(s% scale_height(k)) / thermal_conductivity end function cooling_time_scale - + function get_rho_face(s,k) result(rho_face) type (star_info), pointer :: s integer, intent(in) :: k @@ -3620,7 +3620,7 @@ function get_rho_face(s,k) result(rho_face) rho_face = alfa*wrap_d_00(s,k) + beta*wrap_d_m1(s,k) end function get_rho_face - + real(dp) function get_rho_face_val(s,k) result(rho_face) type (star_info), pointer :: s integer, intent(in) :: k @@ -3633,7 +3633,7 @@ real(dp) function get_rho_face_val(s,k) result(rho_face) rho_face = alfa*s% rho(k) + beta*s% rho(k-1) end function get_rho_face_val - + function get_T_face(s,k) result(T_face) type (star_info), pointer :: s integer, intent(in) :: k @@ -3647,7 +3647,7 @@ function get_T_face(s,k) result(T_face) T_face = alfa*wrap_T_00(s,k) + beta*wrap_T_m1(s,k) end function get_T_face - + function get_Prad_face(s,k) result(Prad_face) type (star_info), pointer :: s integer, intent(in) :: k @@ -3655,7 +3655,7 @@ function get_Prad_face(s,k) result(Prad_face) Prad_face = crad*pow4(get_T_face(s,k))/3d0 end function get_Prad_face - + function get_Peos_face(s,k) result(Peos_face) type (star_info), pointer :: s integer, intent(in) :: k @@ -3669,7 +3669,7 @@ function get_Peos_face(s,k) result(Peos_face) Peos_face = alfa*wrap_Peos_00(s,k) + beta*wrap_Peos_m1(s,k) end function get_Peos_face - + function get_Cp_face(s,k) result(Cp_face) type (star_info), pointer :: s integer, intent(in) :: k @@ -3683,7 +3683,7 @@ function get_Cp_face(s,k) result(Cp_face) Cp_face = alfa*wrap_Cp_00(s,k) + beta*wrap_Cp_m1(s,k) end function get_Cp_face - + function get_ChiRho_face(s,k) result(ChiRho_face) type (star_info), pointer :: s integer, intent(in) :: k @@ -3697,7 +3697,7 @@ function get_ChiRho_face(s,k) result(ChiRho_face) ChiRho_face = alfa*wrap_ChiRho_00(s,k) + beta*wrap_ChiRho_m1(s,k) end function get_ChiRho_face - + function get_ChiT_face(s,k) result(ChiT_face) type (star_info), pointer :: s integer, intent(in) :: k @@ -3711,7 +3711,7 @@ function get_ChiT_face(s,k) result(ChiT_face) ChiT_face = alfa*wrap_ChiT_00(s,k) + beta*wrap_ChiT_m1(s,k) end function get_ChiT_face - + function get_kap_face(s,k) result(kap_face) type (star_info), pointer :: s integer, intent(in) :: k @@ -3725,7 +3725,7 @@ function get_kap_face(s,k) result(kap_face) kap_face = alfa*wrap_kap_00(s,k) + beta*wrap_kap_m1(s,k) end function get_kap_face - + function get_grada_face(s,k) result(grada_face) type (star_info), pointer :: s integer, intent(in) :: k @@ -3739,7 +3739,7 @@ function get_grada_face(s,k) result(grada_face) grada_face = alfa*wrap_grad_ad_00(s,k) + beta*wrap_grad_ad_m1(s,k) end function get_grada_face - + function get_gradr_face(s,k) result(gradr) type (star_info), pointer :: s integer, intent(in) :: k @@ -3750,10 +3750,10 @@ function get_gradr_face(s,k) result(gradr) opacity = get_kap_face(s,k) L = wrap_L_00(s,k) Pr = get_Prad_face(s,k) - gradr = P*opacity*L/(16d0*pi*clight*s% m_grav(k)*s% cgrav(k)*Pr) + gradr = P*opacity*L/(16d0*pi*clight*s% m_grav(k)*s% cgrav(k)*Pr) end function get_gradr_face - + function get_scale_height_face(s,k) result(scale_height) type (star_info), pointer :: s integer, intent(in) :: k @@ -3776,7 +3776,7 @@ function get_scale_height_face(s,k) result(scale_height) end if end function get_scale_height_face - + real(dp) function get_scale_height_face_val(s,k) result(scale_height) type (star_info), pointer :: s integer, intent(in) :: k @@ -3806,14 +3806,14 @@ function get_QQ_cell(s,k) result(QQ_cell) type(auto_diff_real_star_order1) :: QQ_cell type(auto_diff_real_star_order1) :: & T_00, d_00, chiT_00, chiRho_00 - T_00 = wrap_T_00(s,k) - d_00 = wrap_d_00(s,k) + T_00 = wrap_T_00(s,k) + d_00 = wrap_d_00(s,k) chiT_00 = wrap_chiT_00(s,k) chiRho_00 = wrap_chiRho_00(s,k) QQ_cell = chiT_00/(d_00*T_00*chiRho_00) end function get_QQ_cell - + subroutine get_face_weights(s, k, alfa, beta) type (star_info), pointer :: s integer, intent(in) :: k diff --git a/star/private/starspots.f90 b/star/private/starspots.f90 index 12ed5c94c..556685b7c 100644 --- a/star/private/starspots.f90 +++ b/star/private/starspots.f90 @@ -102,7 +102,7 @@ subroutine starspot_restore_PT(s) ! ------------------------------------------------------------ type(star_info), pointer :: s - + s%Teff = pow(L_init/(pi4*pow2(s%r(1))*boltz_sigma), 0.25_dp) s%L(1) = L_init diff --git a/star/private/struct_burn_mix.f90 b/star/private/struct_burn_mix.f90 index 197b121cf..6d3ddb988 100644 --- a/star/private/struct_burn_mix.f90 +++ b/star/private/struct_burn_mix.f90 @@ -58,7 +58,7 @@ integer function do_struct_burn_mix(s, skip_global_corr_coeff_limit) dt = s% dt if (s% rsp_flag) then - do_struct_burn_mix = do_rsp_step(s,dt) + do_struct_burn_mix = do_rsp_step(s,dt) s% total_num_solver_iterations = & s% total_num_solver_iterations + s% num_solver_iterations s% total_num_solver_calls_made = s% total_num_solver_calls_made + 1 @@ -66,7 +66,7 @@ integer function do_struct_burn_mix(s, skip_global_corr_coeff_limit) s% total_num_solver_calls_converged = & s% total_num_solver_calls_converged + 1 return - end if + end if if (s% use_other_before_struct_burn_mix) then call s% other_before_struct_burn_mix(s% id, dt, do_struct_burn_mix) @@ -82,10 +82,10 @@ integer function do_struct_burn_mix(s, skip_global_corr_coeff_limit) s% num_solver_iterations = 0 do_struct_burn_mix = retry - + s% do_burn = (s% dxdt_nuc_factor > 0d0) s% do_mix = (s% mix_factor > 0d0) - + if (s% op_split_burn) then do k=1,nz s% burn_num_iters(k) = 0 @@ -103,7 +103,7 @@ integer function do_struct_burn_mix(s, skip_global_corr_coeff_limit) end if end do end if - + if (s% do_burn .and. s% op_split_burn) then total = 0 do k=1,s% nz @@ -115,16 +115,16 @@ integer function do_struct_burn_mix(s, skip_global_corr_coeff_limit) write(*,2) 'failed in do_burn', s% model_number call mesa_error(__FILE__,__LINE__,'do_struct_burn_mix') return - end if + end if call set_vars_if_needed(s, s% dt, 'after do_burn', ierr) - if (ierr /= 0) return + if (ierr /= 0) return do k=1,s% nz total = total + s% energy(k)*s% dm(k) end do s% non_epsnuc_energy_change_from_split_burn = total if (s% trace_evolve) write(*,*) 'done do_burn' end if - + if (s% doing_first_model_of_run) then if (s% i_lum /= 0) then s% L_phot_old = s% xh(s% i_lum,1)/Lsun @@ -157,7 +157,7 @@ integer function do_struct_burn_mix(s, skip_global_corr_coeff_limit) if (s% w_div_wc_flag) then s% xh(s% i_w_div_wc,:s% nz) = s% w_div_w_crit_roche(:s% nz) end if - + if (s% j_rot_flag) then s% xh(s% i_j_rot,:s% nz) = s% j_rot(:s% nz) s% j_rot_start(:s% nz) = s% j_rot(:s% nz) @@ -172,7 +172,7 @@ integer function do_struct_burn_mix(s, skip_global_corr_coeff_limit) if (s% report_ierr) write(*,*) 'save_start_values failed' return end if - + if (s% trace_evolve) write(*,*) 'call solver' do_struct_burn_mix = do_solver_converge( & s, nvar, skip_global_corr_coeff_limit, & @@ -214,9 +214,9 @@ integer function do_struct_burn_mix(s, skip_global_corr_coeff_limit) s% solver_iter = 0 ! to indicate that no longer doing solver iterations s% doing_struct_burn_mix = .false. if (s% doing_timing) call update_time(s, time0, total, s% time_struct_burn_mix) - + contains - + subroutine test(str) use chem_def, only: category_name character (len=*), intent(in) :: str @@ -334,7 +334,7 @@ subroutine save_start_values(s, ierr) s% opacity_start(k) = s% opacity(k) s% m_grav_start(k) = s% m_grav(k) end do - + if (s% RSP2_flag) then call set_etrb_start_vars(s,ierr) end if @@ -344,7 +344,7 @@ subroutine save_start_values(s, ierr) s% xh_start(j,k) = s% xh(j,k) end do end do - + do k=1,s% nz do j=1,s% species s% xa_start(j,k) = s% xa(j,k) @@ -358,7 +358,7 @@ subroutine save_start_values(s, ierr) s% total_rotational_kinetic_energy_start, & s% total_turbulent_energy_start, & s% total_energy_start) - + end subroutine save_start_values @@ -392,7 +392,7 @@ integer function do_solver_converge( & nz = s% nz n = nz*nvar - + s% solver_call_number = s% solver_call_number + 1 do_solver_converge = do_solver( & @@ -519,7 +519,7 @@ integer function do_solver( & do_solver = keep_going s% using_gold_tolerances = .false. gold_tolerances_level = 0 - + if ((s% use_gold2_tolerances .and. s% steps_before_use_gold2_tolerances < 0) .or. & (s% steps_before_use_gold2_tolerances >= 0 .and. & s% model_number > s% steps_before_use_gold2_tolerances + max(0,s% init_model_number))) then @@ -533,7 +533,7 @@ integer function do_solver( & else maxT = -1d0 end if - if (maxT > s% maxT_for_gold_tolerances) then + if (maxT > s% maxT_for_gold_tolerances) then !write(*,2) 'exceed maxT_for_gold_tolerances', & ! s% model_number, maxT, s% maxT_for_gold_tolerances else ! okay for maxT, so check if also ok for eosPC_frac @@ -793,7 +793,7 @@ subroutine newt(ierr) include 'formats' s% doing_solver_iterations = .true. save_warn_rates_flag = warn_rates_for_high_temp - warn_rates_for_high_temp = .false. + warn_rates_for_high_temp = .false. call solver( & s, nvar, skip_global_corr_coeff_limit, & gold_tolerances_level, tol_max_correction, tol_correction_norm, & @@ -827,7 +827,7 @@ integer function do_burn(s, dt) include 'formats' trace = .false. - + min_T_for_const_density_solver = s% op_split_burn_min_T_for_variable_T_solver do_burn = keep_going @@ -846,11 +846,11 @@ integer function do_burn(s, dt) end if if (dt <= 0d0) return - + max_num_iters_used = 0 max_num_iters_k = 0 k_bad = 0 - + screening_mode = get_screening_mode(s,ierr) if (ierr /= 0) then if (s% report_ierr) & @@ -865,7 +865,7 @@ integer function do_burn(s, dt) do k=1,nz if (s% T_start(k) < s% op_split_burn_min_T) then ! We get here if we have an off center ignition, - ! the arrays wont have been initialised earlier as they stop at the + ! the arrays wont have been initialised earlier as they stop at the ! first temperature that exceeds op_split_burn_min_T s% burn_num_iters(k) = 0 s% burn_avg_epsnuc(k) = 0d0 @@ -874,7 +874,7 @@ integer function do_burn(s, dt) kmin = k exit end do - + if (kmin > nz) return !skip_burn = s% fe_core_infall > s% op_split_burn_eps_nuc_infall_limit @@ -887,7 +887,7 @@ integer function do_burn(s, dt) if (k_bad /= 0) cycle if (s% T_start(k) < s% op_split_burn_min_T) then ! We get here if we have an off center ignition, - ! the arrays wont have been initialised earlier as they stop at the + ! the arrays wont have been initialised earlier as they stop at the ! first temperature that exceeds op_split_burn_min_T s% burn_num_iters(k) = 0 s% burn_avg_epsnuc(k) = 0d0 @@ -910,7 +910,7 @@ integer function do_burn(s, dt) ierr = -1 k_bad = k cycle - end if + end if !write(*,3) 'num_iters', k, num_iters s% burn_num_iters(k) = num_iters s% burn_avg_epsnuc(k) = avg_epsnuc @@ -920,18 +920,18 @@ integer function do_burn(s, dt) end if end do !$OMP END PARALLEL DO - + s% need_to_setvars = .true. - + if (s% doing_timing) & call update_time(s, time0, total, s% time_solve_burn) - + if (ierr /= 0) then if (s% report_ierr) write(*,2) 'do_burn failed', k_bad return call mesa_error(__FILE__,__LINE__,'do_burn') - - + + do_burn = retry if (trace .or. s% report_ierr) then write(*,*) 'do_burn ierr' @@ -973,10 +973,10 @@ subroutine burn1_zone( & logical, intent(in) :: skip_burn, dbg_in real(dp), intent(out) :: avg_epsnuc integer, intent(out) :: num_iters_out, ierr - + real(dp), target :: xa_start_ary(species) real(dp), pointer :: xa_start(:) - + real(dp) :: stptry, eps, odescal, & starting_log10T, ending_log10T, ending_eps_neu_total, & Cv0, eta0, substep_start_time @@ -986,12 +986,12 @@ subroutine burn1_zone( & real(dp), pointer, dimension(:) :: log10Ts_f1, log10Rhos_f1, etas_f1, & dxdt_source_term, times logical :: use_pivoting, trace, burn_dbg - + include 'formats' ierr = 0 num_iters_out = 0 - + if (skip_burn) then avg_epsnuc = 0d0 s% eps_nuc(k) = 0d0 @@ -1006,30 +1006,30 @@ subroutine burn1_zone( & s% eps_nuc_neu_total(k) = 0d0 return end if - + log10Ts_f1 => log10Ts_ary log10Rhos_f1 => log10Rhos_ary etas_f1 => etas_ary - + nullify(dxdt_source_term, times) - + xa_start => xa_start_ary stptry = 0d0 eps = s% op_split_burn_eps - odescal = s% op_split_burn_odescal - max_steps = s% burn_steps_hard_limit + odescal = s% op_split_burn_odescal + max_steps = s% burn_steps_hard_limit use_pivoting = .false. ! .true. trace = .false. burn_dbg = .false. starting_log10T = s% lnT(k)/ln10 - + do i=1,species xa_start(i) = s% xa(i,k) end do - + substep_start_time = 0d0 - + if (s% use_other_split_burn) then log10Ts_f1 => log10Ts_ary log10Rhos_f1 => log10Rhos_ary @@ -1055,7 +1055,7 @@ subroutine burn1_zone( & return call mesa_error(__FILE__,__LINE__,'burn1_zone') end if - + else if (s% T(k) >= min_T_for_const_density_solver) then Cv0 = s% Cv(k) eta0 = s% eta(k) @@ -1106,14 +1106,14 @@ subroutine burn1_zone( & call mesa_error(__FILE__,__LINE__,'burn1_zone') end if end if - + s% raw_rate(:,k) = 0d0 s% screened_rate(:,k) = 0d0 s% eps_nuc_rate(:,k) = 0d0 s% eps_neu_rate(:,k) = 0d0 num_iters_out = naccpt - + ! make extra call to get eps_nuc_categories call do1_net(s, k, s% species, s% num_reactions, .false., ierr) if (ierr /= 0) then @@ -1122,7 +1122,7 @@ subroutine burn1_zone( & return call mesa_error(__FILE__,__LINE__,'burn1_zone') end if - + s% eps_nuc(k) = 0d0 s% d_epsnuc_dlnd(k) = 0d0 s% d_epsnuc_dlnT(k) = 0d0 @@ -1133,14 +1133,14 @@ subroutine burn1_zone( & s% d_dxdt_nuc_dT(:,k) = 0d0 s% d_dxdt_nuc_dx(:,:,k) = 0d0 ! below, restore eps_nuc_neu to op_split zones. - s% eps_nuc_neu_total(k) = ending_eps_neu_total - + s% eps_nuc_neu_total(k) = ending_eps_neu_total + do i=1,species ! for use by dX_nuc_drop timestep limiter s% dxdt_nuc(i,k) = (s% xa(i,k)-xa_start(i))/dt end do - + contains - + subroutine get_eos_info_for_burn_at_const_density( & eos_handle, species, chem_id, net_iso, xa, & Rho, logRho, T, logT, & @@ -1161,7 +1161,7 @@ subroutine get_eos_info_for_burn_at_const_density( & include 'formats' ierr = 0 - + call eosDT_get( & eos_handle, species, chem_id, net_iso, xa, & Rho, logRho, T, logT, & @@ -1177,7 +1177,7 @@ subroutine get_eos_info_for_burn_at_const_density( & eta = res(i_eta) d_eta_dlnT = d_dlnT(i_eta) - + end subroutine get_eos_info_for_burn_at_const_density diff --git a/star/private/timestep.f90 b/star/private/timestep.f90 index 10b6753a4..1f34aed35 100644 --- a/star/private/timestep.f90 +++ b/star/private/timestep.f90 @@ -51,7 +51,7 @@ integer function timestep_controller(s, max_timestep) timestep_controller = do_timestep_limits(s, s% dt) if (timestep_controller /= keep_going) s% result_reason = timestep_limits - + if (s% force_timestep > 0) then s% dt_next = s% force_timestep s% why_Tlim = Tlim_force_timestep @@ -136,7 +136,7 @@ integer function do_timestep_limits(s, dt) if (return_now(Tlim_struc)) return if (.not. s% doing_first_model_of_run) then - + if (s% use_other_timestep_limit) then do_timestep_limits = s% other_timestep_limit( & s% id, skip_hard_limit, dt, dt_limit_ratio(Tlim_other_timestep_limit)) @@ -336,16 +336,16 @@ integer function do_timestep_limits(s, dt) end if i_limit = maxloc(dt_limit_ratio(1:numTlim), dim=1) - + order = 1 call filter_dt_next(s, order, dt_limit_ratio(i_limit)) ! sets s% dt_next - + if (s% log_max_temperature > s% min_logT_for_max_timestep_factor_at_high_T) then max_timestep_factor = s% max_timestep_factor_at_high_T else max_timestep_factor = s% max_timestep_factor end if - + if (max_timestep_factor > 0 .and. s% dt_next > max_timestep_factor*s% dt) then s% dt_next = max_timestep_factor*s% dt if (s% report_solver_dt_info) then @@ -422,7 +422,7 @@ integer function check_burn_steps_limit(s, skip_hard_limit, dt, dt_limit_ratio) integer :: max_steps check_burn_steps_limit = keep_going if (.not. s% op_split_burn .or. maxval(s% T_start(1:s%nz)) < s% op_split_burn_min_T) return - + max_steps = maxval(s% burn_num_iters(1:s% nz),mask=s% T(1:s%nz)>s% op_split_burn_min_T) check_burn_steps_limit = check_integer_limit( & s, s% burn_steps_limit, s% burn_steps_hard_limit, max_steps, & @@ -513,10 +513,10 @@ integer function check_dX(s, skip_hard_limit, dt, & s% dX_div_X_hard_limit(i) >= 1) then cycle ! go to next end if - + dX_limit = s% dX_limit(i) * s% time_delta_coeff dX_hard_limit = s% dX_hard_limit(i) * s% time_delta_coeff - + if (s% log_max_temperature > s% dX_div_X_at_high_T_limit_lgT_min(i)) then dX_div_X_limit = s% dX_div_X_at_high_T_limit(i) dX_div_X_hard_limit = s% dX_div_X_at_high_T_hard_limit(i) @@ -524,27 +524,27 @@ integer function check_dX(s, skip_hard_limit, dt, & dX_div_X_limit = s% dX_div_X_limit(i) dX_div_X_hard_limit = s% dX_div_X_hard_limit(i) end if - + dX_div_X_limit = dX_div_X_limit * s% time_delta_coeff dX_div_X_hard_limit = dX_div_X_hard_limit * s% time_delta_coeff - + max_dX = -1; max_dX_j = -1; max_dX_k = -1 max_dX_div_X = -1; max_dX_div_X_j = -1; max_dX_div_X_k = -1 bdy = 0 max_dX_bdy_dist_dm = 0 max_dX_div_X_bdy_dist_dm = 0 cz_dist_limit = s% dX_mix_dist_limit*Msun - + if (s% set_min_D_mix .and. s% ye(s% nz) >= s% min_center_Ye_for_min_D_mix) then D_mix_cutoff = s% min_D_mix else D_mix_cutoff = 0 end if - + sp = s% dX_limit_species(i) - + do k = 1, s% nz - + if (s% D_mix(k) > D_mix_cutoff) then cycle end if @@ -553,7 +553,7 @@ integer function check_dX(s, skip_hard_limit, dt, & cycle end if end if - + ! find the nearest mixing boundary bdy = binary_search(n_mix_bdy, mix_bdy_q, bdy, s% q(k)) ! don't check cells near a mixing boundary @@ -563,9 +563,9 @@ integer function check_dX(s, skip_hard_limit, dt, & else bdy_dist_dm = 0 end if - + do j = 1, s% species - + cid = s% chem_id(j) if (sp == 'X') then ! any hydrogen if (cid /= ih1 .or. cid /= ih2 .or. cid /= ih3) cycle @@ -576,13 +576,13 @@ integer function check_dX(s, skip_hard_limit, dt, & else ! single isotope if (trim(chem_isos% name(s% chem_id(j))) /= trim(sp)) cycle end if - + X = s% xa(j,k) X_old = s% xa_old(j,k) delta_X = X_old - X ! decrease in abundance - + if ((.not. s% dX_decreases_only(j)) .and. delta_X < 0) delta_X = -delta_X - + if (X >= s% dX_limit_min_X(i)) then ! any check for dX_limit_* < 1 is useless since X <= 1 anyway if ((.not. skip_hard_limit) .and. delta_X > dX_hard_limit(i)) then check_dX = retry @@ -636,7 +636,7 @@ integer function check_dX(s, skip_hard_limit, dt, & end if end do end do - + if (dX_limit(i) > 0) then ratio_tmp_dX = max_dX/dX_limit(i) if (ratio_tmp_dX > dX_dt_limit_ratio) then @@ -655,7 +655,7 @@ integer function check_dX(s, skip_hard_limit, dt, & end if end if end if - + if (dX_div_X_limit(i) > 0) then ratio_tmp_dX_div_X = max_dX_div_X/dX_div_X_limit(i) if (ratio_tmp_dX_div_X > dX_div_X_dt_limit_ratio) then ! pick out largest culprit only! @@ -688,7 +688,7 @@ integer function check_dL_div_L(s, skip_hard_limit, dt, dL_div_L_dt_ratio) real(dp) :: L, abs_dL, abs_dL_div_L, max_dL_div_L integer :: k, max_dL_div_L_k real(dp) :: dL_div_L_limit_min_L, dL_div_L_limit, dL_div_L_hard_limit - + include 'formats' check_dL_div_L = keep_going @@ -719,7 +719,7 @@ integer function check_dL_div_L(s, skip_hard_limit, dt, dL_div_L_dt_ratio) write(*,2) 'L_start', s% L_start(k) write(*,2) 'abs_dL_div_L', abs_dL_div_L write(*,2) 'dL_div_L_hard_limit', dL_div_L_hard_limit - end if + end if return end if if (abs_dL_div_L > max_dL_div_L) then @@ -787,7 +787,7 @@ subroutine get_dlgP_info(s, i, max_dlnP) do k=1,s% nz if (s% lnPeos(k) < lim) cycle dlnP = abs(s% lnPeos(k) - s% lnPeos_start(k)) - if (dlnP > max_dlnP) then + if (dlnP > max_dlnP) then max_dlnP = dlnP i = k end if @@ -1020,7 +1020,7 @@ integer function check_lgL( & integer :: iso include 'formats' check_lgL = keep_going - + iso = iso_in if (iso == iprot) then ! check_lgL_power_photo_change if (s% log_max_temperature < s% min_lgT_for_lgL_power_photo_limit) return @@ -1078,9 +1078,9 @@ integer function check_lgL( & else call mesa_error(__FILE__,__LINE__,'bad iso arg for check_lgL') end if - + if (old_L < 0d0) return - + lim = lim*s% time_delta_coeff hard_lim = hard_lim*s% time_delta_coeff @@ -2153,7 +2153,7 @@ integer function check_dX_nuc_drop(s, skip_hard_limit, dt, dt_limit_ratio) s% Tlim_dXnuc_drop_cell = max_k s% Tlim_dXnuc_drop_species = max_j - + hard_limit = s% dX_nuc_drop_hard_limit*s% time_delta_coeff if (hard_limit > 0 .and. (.not. skip_hard_limit) .and. & max_dx_nuc_drop > hard_limit) then @@ -2167,7 +2167,7 @@ integer function check_dX_nuc_drop(s, skip_hard_limit, dt, dt_limit_ratio) check_dX_nuc_drop = retry return end if - + limit = s% dX_nuc_drop_limit*s% time_delta_coeff if (s% log_max_temperature >= 9.45d0 .and. s% dX_nuc_drop_limit_at_high_T > 0) & limit = s% dX_nuc_drop_limit_at_high_T @@ -2182,7 +2182,7 @@ integer function check_dX_nuc_drop(s, skip_hard_limit, dt, dt_limit_ratio) s% dX_nuc_drop_max_j = max_j s% dX_nuc_drop_max_k = max_k - + contains subroutine do1(k) @@ -2229,7 +2229,7 @@ subroutine do1(k) else sigp1 = 0 end if - + if (k > 1) then dx00 = s% xa(j,k-1) - s% xa(j,k) flux00 = -sig00*dx00 @@ -2245,7 +2245,7 @@ subroutine do1(k) end if dx_inflow = max(0d0, fluxp1, -flux00)*dt_dm - + dx_drop = -(dx_burning + dx_inflow) ! dx_burning < 0 for drop dx = s% xa_old(j,k) - s% xa(j,k) ! the actual drop @@ -2285,7 +2285,7 @@ integer function check_varcontrol_limit(s, dt_limit_ratio) s% result_reason = nonzero_ierr return end if - + if (s% varcontrol_target < s% min_allowed_varcontrol_target) then check_varcontrol_limit = terminate write(*, *) 'ERROR: timestep varcontrol_target < min_allowed_varcontrol_target' @@ -2365,11 +2365,11 @@ real(dp) function eval_varcontrol(s, ierr) result(varcontrol) sumterm(j) = sumterm(j) + sumj k = nz-1 sumj = abs(sum(s% xh(j,k-1:k+1)) - sum(s% xh_old(j,k-1:k+1)))/3 - + if (j == s% i_lnd) then sumterm(j) = sumterm(j)/3 ! Seems to help. from Eggleton. end if - + sumvar = sumvar + sumterm(j) sumscales = sumscales + max(xscale_min, abs(s% xh_old(j,1))) @@ -2398,7 +2398,7 @@ subroutine filter_dt_next(s, order, dt_limit_ratio_in) beta1 = 0.25d0/order beta2 = 0.25d0/order alpha2 = 0.25d0 - + dt_limit_ratio = max(1d-10, dt_limit_ratio_in) s% dt_limit_ratio = dt_limit_ratio dt_limit_ratio_target = 1d0 diff --git a/star/private/turb_info.f90 b/star/private/turb_info.f90 index 42a4889db..5731601e3 100644 --- a/star/private/turb_info.f90 +++ b/star/private/turb_info.f90 @@ -68,7 +68,7 @@ subroutine set_mlt_vars(s, nzlo, nzhi, ierr) (s% mlt_mixing_type(k) == no_mixing) end if end if - if (op_err /= 0) ierr = op_err + if (op_err /= 0) ierr = op_err end do !$OMP END PARALLEL DO if (s% doing_timing) call update_time(s, time0, total, s% time_mlt) @@ -105,14 +105,14 @@ subroutine do1_mlt_2(s, k, & ierr = 0 nz = s% nz - + if (k < 1 .or. k > nz) then write(*,3) 'bad k for do1_mlt', k, nz ierr = -1 return call mesa_error(__FILE__,__LINE__) end if - + if (present(mixing_length_alpha_in)) then mixing_length_alpha = mixing_length_alpha_in else @@ -120,7 +120,7 @@ subroutine do1_mlt_2(s, k, & end if if (present(gradL_composition_term_in)) then - gradL_composition_term = gradL_composition_term_in + gradL_composition_term = gradL_composition_term_in else if (s% use_Ledoux_criterion) then gradL_composition_term = s% gradL_composition_term(k) else @@ -141,9 +141,9 @@ subroutine do1_mlt_2(s, k, & return end if gradr_ad = gradr_ad*gradr_factor - + ! now can call set_no_mixing if necessary - + if (k == 1 .and. s% mlt_make_surface_no_mixing) then call set_no_mixing('surface_no_mixing') return @@ -166,7 +166,7 @@ subroutine do1_mlt_2(s, k, & s% mlt_mixing_type(k) = phase_separation_mixing return end if - + if (s% lnT_start(k)/ln10 > s% max_logT_for_mlt) then call set_no_mixing('max_logT') return @@ -201,7 +201,7 @@ subroutine do1_mlt_2(s, k, & no_mix = .true. else if ((abs(vel(k))) >= & s% csound_start(k)*s% max_v_div_cs_for_convection) then - no_mix = .true. + no_mix = .true. else if (s% u_flag) then if (k == 1) then abs_du_div_cs = 1d99 @@ -218,7 +218,7 @@ subroutine do1_mlt_2(s, k, & return end if end if - + make_gradr_sticky_in_solver_iters = s% make_gradr_sticky_in_solver_iters if (.not. make_gradr_sticky_in_solver_iters .and. & s% min_logT_for_make_gradr_sticky_in_solver_iters < 1d20) then @@ -230,7 +230,7 @@ subroutine do1_mlt_2(s, k, & call set_no_mixing('gradr_sticky') return end if - + call do1_mlt_eval(s, k, s% MLT_option, gradL_composition_term, & gradr_ad, grada_face_ad, scale_height_ad, mixing_length_alpha, & mixing_type, gradT_ad, Y_face_ad, mlt_vc_ad, D_ad, Gamma_ad, ierr) @@ -240,7 +240,7 @@ subroutine do1_mlt_2(s, k, & end if return end if - + call store_results if (s% mlt_gradT_fraction >= 0d0 .and. s% mlt_gradT_fraction <= 1d0) then @@ -249,95 +249,95 @@ subroutine do1_mlt_2(s, k, & f = s% adjust_mlt_gradT_fraction(k) end if call adjust_gradT_fraction(s, k, f) - + if (s% mlt_mixing_type(k) == no_mixing .or. abs(s% gradr(k)) < 1d-20) then s% L_conv(k) = 0d0 else - s% L_conv(k) = s% L(k) * (1d0 - s% gradT(k)/s% gradr(k)) ! C&G 14.109 + s% L_conv(k) = s% L(k) * (1d0 - s% gradT(k)/s% gradr(k)) ! C&G 14.109 end if - contains - + contains + subroutine store_results s% mlt_mixing_type(k) = mixing_type - + s% grada_face_ad(k) = grada_face_ad s% grada_face(k) = grada_face_ad%val - + s% gradT_ad(k) = gradT_ad s% gradT(k) = s% gradT_ad(k)%val s% mlt_gradT(k) = s% gradT(k) ! prior to adjustments - + s% Y_face_ad(k) = Y_face_ad s% Y_face(k) = s% Y_face_ad(k)%val - + s% mlt_vc_ad(k) = mlt_vc_ad - if (s% okay_to_set_mlt_vc) s% mlt_vc(k) = s% mlt_vc_ad(k)%val - + if (s% okay_to_set_mlt_vc) s% mlt_vc(k) = s% mlt_vc_ad(k)%val + s% mlt_D_ad(k) = D_ad s% mlt_D(k) = D_ad%val rho_face_ad = get_rho_face(s,k) s% mlt_cdc(k) = s% mlt_D(k)*pow2(pi4*pow2(s%r(k))*rho_face_ad%val) - + s% mlt_Gamma_ad(k) = Gamma_ad s% mlt_Gamma(k) = Gamma_ad%val - + s% gradr_ad(k) = gradr_ad s% gradr(k) = s% gradr_ad(k)%val - + s% gradL_ad(k) = s% grada_face_ad(k) + gradL_composition_term s% gradL(k) = s% gradL_ad(k)%val - + s% scale_height_ad(k) = scale_height_ad - s% scale_height(k) = scale_height_ad%val - + s% scale_height(k) = scale_height_ad%val + s% Lambda_ad(k) = mixing_length_alpha*scale_height_ad s% mlt_mixing_length(k) = s% Lambda_ad(k)%val - + end subroutine store_results subroutine set_no_mixing(str) character (len=*) :: str include 'formats' - + s% mlt_mixing_type(k) = no_mixing - + s% grada_face_ad(k) = grada_face_ad s% grada_face(k) = grada_face_ad%val - + gradT_ad = gradr_ad s% gradT_ad(k) = gradT_ad s% gradT(k) = s% gradT_ad(k)%val - + Y_face_ad = gradT_ad - grada_face_ad s% Y_face_ad(k) = Y_face_ad s% Y_face(k) = s% Y_face_ad(k)%val - + s% mlt_vc_ad(k) = 0d0 if (s% okay_to_set_mlt_vc) s% mlt_vc(k) = 0d0 - + s% mlt_D_ad(k) = 0d0 s% mlt_D(k) = 0d0 s% mlt_cdc(k) = 0d0 - + s% mlt_Gamma_ad(k) = 0d0 s% mlt_Gamma(k) = 0d0 - + s% gradr_ad(k) = gradr_ad s% gradr(k) = s% gradr_ad(k)%val - + s% gradL_ad(k) = 0d0 s% gradL(k) = 0d0 - + s% scale_height_ad(k) = scale_height_ad - s% scale_height(k) = scale_height_ad%val - + s% scale_height(k) = scale_height_ad%val + s% Lambda_ad(k) = mixing_length_alpha*scale_height_ad s% mlt_mixing_length(k) = s% Lambda_ad(k)%val s% L_conv(k) = 0d0 - + end subroutine set_no_mixing end subroutine do1_mlt_2 @@ -350,7 +350,7 @@ subroutine adjust_gradT_fraction(s,k,f) type (star_info), pointer :: s real(dp), intent(in) :: f integer, intent(in) :: k - include 'formats' + include 'formats' if (f >= 0.0 .and. f <= 1.0) then if (f == 0d0) then s% gradT_ad(k) = s% gradr_ad(k) @@ -359,7 +359,7 @@ subroutine adjust_gradT_fraction(s,k,f) end if s% gradT(k) = s% gradT_ad(k)%val end if - call adjust_gradT_excess(s, k) + call adjust_gradT_excess(s, k) s% gradT_sub_grada(k) = s% gradT(k) - s% grada_face(k) end subroutine adjust_gradT_fraction @@ -373,7 +373,7 @@ subroutine adjust_gradT_excess(s, k) !s% gradT_excess_alpha is calculated at start of step and held constant during iterations ! gradT_excess_alpha = 0 means no efficiency boost; = 1 means full efficiency boost gradT_excess_alpha = s% gradT_excess_alpha - s% gradT_excess_effect(k) = 0.0d0 + s% gradT_excess_effect(k) = 0.0d0 gradT_sub_grada = s% gradT(k) - s% grada_face(k) if (gradT_excess_alpha <= 0.0 .or. & gradT_sub_grada <= s% gradT_excess_f1) return @@ -556,7 +556,7 @@ subroutine check_for_redo_MLT(s, nzlo, nzhi, ierr) call end_of_convective_region end if else ! in non-convective region - if (s% mlt_mixing_type(k) == convective_mixing) then + if (s% mlt_mixing_type(k) == convective_mixing) then ! start of a convective region k_bot = k+1 in_convective_region = .true. diff --git a/star/private/turb_support.f90 b/star/private/turb_support.f90 index c99508b69..228b97158 100644 --- a/star/private/turb_support.f90 +++ b/star/private/turb_support.f90 @@ -71,7 +71,7 @@ subroutine get_gradT(s, MLT_option, & ! used to create models XH1, cgrav, m, gradL_composition_term, mixing_length_alpha integer, intent(in) :: iso real(dp), intent(out) :: gradT, Y_face, conv_vel, D, Gamma - integer, intent(out) :: mixing_type, ierr + integer, intent(out) :: mixing_type, ierr type(auto_diff_real_star_order1) :: & gradr_ad, grada_ad, scale_height_ad, gradT_ad, Y_face_ad, mlt_vc_ad, D_ad, & Gamma_ad, r_ad, L_ad, T_ad, P_ad, opacity_ad, rho_ad, dV_ad, chiRho_ad, chiT_ad, Cp_ad @@ -101,8 +101,8 @@ subroutine get_gradT(s, MLT_option, & ! used to create models D = D_ad%val Gamma = Gamma_ad%val end subroutine get_gradT - - + + subroutine do1_mlt_eval( & s, k, MLT_option, gradL_composition_term, & gradr_in, grada, scale_height, mixing_length_alpha, & @@ -117,8 +117,8 @@ subroutine do1_mlt_eval( & integer, intent(out) :: mixing_type type(auto_diff_real_star_order1), intent(out) :: & gradT, Y_face, mlt_vc, D, Gamma - integer, intent(out) :: ierr - + integer, intent(out) :: ierr + real(dp) :: cgrav, m, XH1 integer :: iso type(auto_diff_real_star_order1) :: gradr, r, L, T, P, opacity, rho, dV, chiRho, chiT, Cp @@ -126,7 +126,7 @@ subroutine do1_mlt_eval( & ierr = 0 gradr = gradr_in - + cgrav = s% cgrav(k) m = s% m_grav(k) L = wrap_L_00(s,k) @@ -141,7 +141,7 @@ subroutine do1_mlt_eval( & Cp = get_Cp_face(s,k) iso = s% dominant_iso_for_thermohaline(k) XH1 = s% xa(s% net_iso(ih1),k) - + if (s% use_other_mlt_results) then call s% other_mlt_results(s% id, k, MLT_option, & r, L, T, P, opacity, rho, chiRho, chiT, Cp, gradr, grada, scale_height, & @@ -182,7 +182,7 @@ subroutine Get_results(s, k, MLT_option, & ! NOTE: k=0 is a valid arg integer, intent(out) :: mixing_type type(auto_diff_real_star_order1), intent(out) :: gradT, Y_face, conv_vel, D, Gamma integer, intent(out) :: ierr - + type(auto_diff_real_star_order1) :: Pr, Pg, grav, Lambda, gradL, beta real(dp) :: conv_vel_start, scale @@ -190,17 +190,17 @@ subroutine Get_results(s, k, MLT_option, & ! NOTE: k=0 is a valid arg real(dp) :: Gamma_limit, scale_value1, scale_value2, diff_grads_limit, reduction_limit, lambda_limit type(auto_diff_real_star_order1) :: Lrad_div_Ledd, Gamma_inv_threshold, Gamma_factor, alfa0, & diff_grads_factor, Gamma_term, exp_limit, grad_scale, gradr_scaled - + logical :: test_partials, using_TDC logical, parameter :: report = .false. include 'formats' - ! Pre-calculate some things. + ! Pre-calculate some things. Pr = crad*pow4(T)/3d0 Pg = P - Pr beta = Pg / P Lambda = mixing_length_alpha*scale_height - grav = cgrav*m/pow2(r) + grav = cgrav*m/pow2(r) if (s% use_Ledoux_criterion) then gradL = grada + gradL_composition_term ! Ledoux temperature gradient else @@ -213,7 +213,7 @@ subroutine Get_results(s, k, MLT_option, & ! NOTE: k=0 is a valid arg Y_face = gradT - gradL conv_vel = 0d0 D = 0d0 - Gamma = 0d0 + Gamma = 0d0 if (k /= 0) s% superad_reduction_factor(k) = 1d0 ! Bail if we asked for no mixing, or if parameters are bad. @@ -344,7 +344,7 @@ subroutine Get_results(s, k, MLT_option, & ! NOTE: k=0 is a valid arg return end if end if - end if + end if ! If there's too-little mixing to bother, or we hit a bad value, fall back on no mixing. if (D%val < s% remove_small_D_limit .or. is_bad(D%val)) then @@ -403,7 +403,7 @@ subroutine set_superad_reduction() end if !Gamma_term = Gamma_term + scale_value2*pow2(Lrad_div_Ledd/Gamma_inv_threshold-1d0) end if - + if (Gamma_term > 0d0) then Gamma_factor = Gamma_term/pow(beta,0.5d0)*diff_grads_factor Gamma_factor = Gamma_factor + 1d0 @@ -414,7 +414,7 @@ subroutine set_superad_reduction() end if end if end if - end if + end if if (k /= 0) s% superad_reduction_factor(k) = Gamma_factor% val if (Gamma_factor > 1d0) then grad_scale = (gradr-gradL)/(Gamma_factor*gradr) + gradL/gradr diff --git a/star/private/write_model.f90 b/star/private/write_model.f90 index 36819d5f9..89e8c4b58 100644 --- a/star/private/write_model.f90 +++ b/star/private/write_model.f90 @@ -71,11 +71,11 @@ subroutine do_write_model(id, filename, ierr) RTI_flag = s% RTI_flag rotation_flag = s% rotation_flag RSP_flag = s% RSP_flag - RSP2_flag = s% RSP2_flag + RSP2_flag = s% RSP2_flag write_mlt_vc = s% have_mlt_vc - + species = s% species - + open(newunit=iounit, file=trim(filename), action='write', status='replace') write(iounit,'(a)') '! note: initial lines of file can contain comments' write(iounit,'(a)') '!' @@ -90,7 +90,7 @@ subroutine do_write_model(id, filename, ierr) if (RSP_flag) file_type = file_type + 2**bit_for_RSP if (RSP2_flag) file_type = file_type + 2**bit_for_RSP2 if (write_mlt_vc) file_type = file_type + 2**bit_for_mlt_vc - + write(iounit, '(i14)', advance='no') file_type write(iounit,'(a)',advance='no') ' -- model for mesa/star' if (BTEST(file_type, bit_for_velocity)) & @@ -181,7 +181,7 @@ subroutine do_write_model(id, filename, ierr) 'log_rel_run_E_err', & safe_log10(abs(s% cumulative_energy_error/s% total_energy)) write(iounit, 2) 'num_retries', s% num_retries - write(iounit, '(a)') ! blank line for end of property list + write(iounit, '(a)') ! blank line for end of property list call header do k=1, nz diff --git a/star/public/star_lib.f90 b/star/public/star_lib.f90 index 722b09bee..985dca06c 100644 --- a/star/public/star_lib.f90 +++ b/star/public/star_lib.f90 @@ -133,7 +133,7 @@ subroutine read_star_job_id(id, filename, ierr) if (ierr/=0) return call read_star_job(s, filename, ierr) end subroutine read_star_job_id - + subroutine write_star_job(s, filename, ierr) use star_private_def @@ -160,7 +160,7 @@ end subroutine write_star_job_id ! call this after read_star_job. ! this sets starlib parameters that apply to all stars. ! okay to do extra calls on this; only 1st call is used. - subroutine starlib_init(s, ierr) + subroutine starlib_init(s, ierr) type (star_info), pointer :: s integer, intent(out) :: ierr call do_starlib_init( & @@ -233,7 +233,7 @@ end subroutine starlib_shutdown - ! if you want direct access to the star data structure, + ! if you want direct access to the star data structure, ! then you need to convert the handle to a pointer. ! use the routine star_ptr defined in star_def. @@ -244,7 +244,7 @@ end subroutine starlib_shutdown ! (using star_load). - ! logs and profiles are by default written to the directory named "logs_and_profiles", + ! logs and profiles are by default written to the directory named "logs_and_profiles", ! but you can change that if you'd like by calling this routine before calling star_setup. subroutine set_dir_for_logs_and_profiles(id, dir_name, ierr) integer, intent(in) :: id @@ -271,7 +271,7 @@ integer function star_get_history_column_id(cname) ! returns id for the history column if there is a matching name ! returns 0 otherwise. use star_history_def, only: do_get_history_id - character (len=*), intent(in) :: cname + character (len=*), intent(in) :: cname star_get_history_column_id = do_get_history_id(cname) end function star_get_history_column_id @@ -356,7 +356,7 @@ end subroutine star_allocate_arrays ! as determined by initial_mass and initial_z in the star_info structure. ! reads prebuilt initial models from mesa/data/star_data/starting_models. ! when star_load returns, the variables in star_def will have been set. - ! in particular, model_number will be 0 for a fresh start, + ! in particular, model_number will be 0 for a fresh start, ! and it will be greater than 0 for a restart. subroutine star_load_zams(id, ierr) use init, only: load_zams_model @@ -384,21 +384,21 @@ subroutine star_create_pre_ms_model( & use init, only: create_pre_ms_model integer, intent(in) :: id - real(dp), intent(in) :: T_c + real(dp), intent(in) :: T_c ! optional initial center temperature ! set to 0 to use default - real(dp), intent(in) :: guess_rho_c + real(dp), intent(in) :: guess_rho_c ! optional initial guess for center density ! set to 0 to use default - real(dp), intent(in) :: d_log10_P + real(dp), intent(in) :: d_log10_P ! standard point spacing in initial model is d_log10_P ! set to 0 to use default ! model contruction is from inside out and stops when at either of the following. - real(dp), intent(in) :: logT_surf_limit + real(dp), intent(in) :: logT_surf_limit ! set to 0 to use default - real(dp), intent(in) :: logP_surf_limit + real(dp), intent(in) :: logP_surf_limit ! set to 0 to use default - integer, intent(in) :: pre_ms_initial_zfracs, pre_ms_relax_num_steps + integer, intent(in) :: pre_ms_initial_zfracs, pre_ms_relax_num_steps logical, intent(in) :: dump_missing_metals_into_heaviest, change_net character(len=*), intent(in) :: new_net_name integer, intent(out) :: ierr @@ -443,7 +443,7 @@ subroutine star_create_initial_model(id, & initial_zfracs, initial_model_relax_num_steps, max_tries_for_create_initial_model logical, intent(in) :: dump_missing_metals_into_heaviest, change_net character(len=*), intent(in) :: new_net_name - real(dp), intent(in) :: initial_model_eps + real(dp), intent(in) :: initial_model_eps integer, intent(out) :: ierr type (star_info), pointer :: s ierr = 0 @@ -469,7 +469,7 @@ subroutine star_create_initial_model(id, & call create_initial_model(id, ierr) if (ierr /= 0) return end subroutine star_create_initial_model - + logical function doing_a_restart(restart_filename) use init, only: doing_restart @@ -521,7 +521,7 @@ end subroutine star_read_model subroutine star_number_from_saved_model(fname, model_number, ierr) use read_model, only: do_read_saved_model_number character (len=*), intent(in) :: fname ! filename for the saved model - integer, intent(inout) :: model_number + integer, intent(inout) :: model_number ! set only if this property is present in file integer, intent(out) :: ierr call do_read_saved_model_number(fname, model_number, ierr) @@ -531,13 +531,13 @@ end subroutine star_number_from_saved_model subroutine star_age_from_saved_model(fname, star_age, ierr) use read_model, only: do_read_saved_model_age character (len=*), intent(in) :: fname ! filename for the saved model - real(dp), intent(inout) :: star_age + real(dp), intent(inout) :: star_age ! set only if this property is present in file integer, intent(out) :: ierr call do_read_saved_model_age(fname, star_age, ierr) end subroutine star_age_from_saved_model - + ! after you've created a starting model, you're ready to evolve it. @@ -552,7 +552,7 @@ integer function star_evolve_step(id, first_try) use star_def, only: terminate, keep_going use star_utils, only: start_time, update_time integer, intent(in) :: id - logical, intent(in) :: first_try + logical, intent(in) :: first_try ! true on the first try to take this step ! false if this is a repeat for a retry type (star_info), pointer :: s @@ -575,7 +575,7 @@ integer function star_evolve_step_part1(id, first_try) use star_def, only: keep_going, redo, retry, terminate use evolve, only: do_evolve_step_part1 integer, intent(in) :: id - logical, intent(in) :: first_try + logical, intent(in) :: first_try type (star_info), pointer :: s integer :: ierr star_evolve_step_part1 = terminate @@ -589,7 +589,7 @@ integer function star_evolve_step_part2(id, first_try) use star_def, only: keep_going, redo, retry, terminate use evolve, only: do_evolve_step_part2 integer, intent(in) :: id - logical, intent(in) :: first_try + logical, intent(in) :: first_try type (star_info), pointer :: s integer :: ierr star_evolve_step_part2 = terminate @@ -625,7 +625,7 @@ end function star_check_limits ! this routine inspects the new model and picks a new timestep. - ! if it decides that the changes in the new model are too great, + ! if it decides that the changes in the new model are too great, integer function star_pick_next_timestep(id) ! returns either keep_going, redo, retry, or terminate. use evolve, only: pick_next_timestep @@ -654,7 +654,7 @@ integer function star_prepare_to_redo(id) end function star_prepare_to_redo - ! once in a while an attempted step will fail, and you'll need to retry it + ! once in a while an attempted step will fail, and you'll need to retry it ! with a smaller timestep or resort to backing up to a previous model. @@ -666,7 +666,7 @@ integer function star_prepare_to_retry(id) star_prepare_to_retry = prepare_to_retry(id) end function star_prepare_to_retry - ! typically, after the namelist controls file has been read by the star setup routine, + ! typically, after the namelist controls file has been read by the star setup routine, ! you won't need to do anything else with it. But in case you want ! to read or write a control file at other times, here are the routines to do it. subroutine star_read_controls(id, filename, ierr) @@ -700,7 +700,7 @@ end subroutine star_build_atm ! normally, "snapshots" for restarts will be saved automatically according - ! to the value of the photo_interval parameter. but if you want to + ! to the value of the photo_interval parameter. but if you want to ! do it yourself, you can call the following routine. subroutine star_save_for_restart(id, filename, ierr) use evolve_support, only: output_to_file @@ -752,7 +752,7 @@ subroutine get_data_for_profile_columns(s, & names, vals, is_int, ierr) end subroutine get_data_for_profile_columns - + ! you may want to have some data automatically saved and restored along with ! the rest of the information in a snapshot. you can do it by using the following routines. @@ -991,7 +991,7 @@ subroutine star_set_standard_composition(id, h1, h2, he3, he4, & call set_standard_composition(s, s% species, h1, h2, he3, he4, & which_zfracs, dump_missing_metals_into_heaviest, ierr) end subroutine star_set_standard_composition - + subroutine star_uniform_xa_from_file(id, file_for_uniform_xa, ierr) use adjust_xyz, only: set_uniform_xa_from_file @@ -1167,7 +1167,7 @@ end subroutine replace_element_in_section subroutine star_set_abundance(id, chem_id, new_frac, ierr) ! set mass fraction of species to new_frac uniformly in cells nzlo to nzhi - ! + ! ! NOTE: this routine simply changes abundances; it doesn't reconverge the model. integer, intent(in) :: id integer, intent(in) :: chem_id ! a chem_id such as ihe4. see chem_def. @@ -1225,7 +1225,7 @@ subroutine uniform_mix_envelope_down_to_T(id, T, ierr) call do_uniform_mix_envelope_down_to_T(s, T, ierr) end subroutine uniform_mix_envelope_down_to_T - + ! access to the value of the next timestep subroutine get_dt_next(id, dt, ierr) @@ -1414,16 +1414,16 @@ subroutine star_relax_composition( & use relax, only: do_relax_composition integer, intent(in) :: id integer, intent(in) :: num_steps_to_use ! use this many steps to do conversion - integer, intent(in) :: num_pts + integer, intent(in) :: num_pts ! length of composition vector; need not equal nz for current model (will interpolate) - integer, intent(in) :: species + integer, intent(in) :: species ! must = number of species for current model real(dp), intent(in) :: xa(:,:) ! (species, num_pts) ! target composition profile real(dp), intent(in) :: xq(:) ! (num_pts) ! xq(i) = fraction of xmstar exterior to the point i ! where xmstar = mstar - M_center integer, intent(out) :: ierr - call do_relax_composition(id, num_steps_to_use, num_pts, species, xa, xq, ierr) + call do_relax_composition(id, num_steps_to_use, num_pts, species, xa, xq, ierr) end subroutine star_relax_composition subroutine star_relax_angular_momentum( & @@ -1433,14 +1433,14 @@ subroutine star_relax_angular_momentum( & use relax, only: do_relax_angular_momentum integer, intent(in) :: id integer, intent(in) :: max_steps_to_use ! use this many steps to do conversion - integer, intent(in) :: num_pts + integer, intent(in) :: num_pts ! length of angular momentum vector; need not equal nz for current model (will interpolate) real(dp), intent(in) :: angular_momentum(:) ! (num_pts) ! target am profile real(dp), intent(in) :: xq(:) ! (num_pts) ! xq(i) = fraction of xmstar exterior to the point i ! where xmstar = mstar - M_center integer, intent(out) :: ierr - call do_relax_angular_momentum(id, max_steps_to_use, num_pts, angular_momentum, xq, ierr) + call do_relax_angular_momentum(id, max_steps_to_use, num_pts, angular_momentum, xq, ierr) end subroutine star_relax_angular_momentum subroutine star_relax_entropy( & @@ -1450,14 +1450,14 @@ subroutine star_relax_entropy( & use relax, only: do_relax_entropy integer, intent(in) :: id integer, intent(in) :: max_steps_to_use ! use this many steps to do conversion - integer, intent(in) :: num_pts + integer, intent(in) :: num_pts ! length of entropy vector; need not equal nz for current model (will interpolate) real(dp), intent(in) :: entropy(:) ! (num_pts) ! target entropy profile real(dp), intent(in) :: xq(:) ! (num_pts) ! xq(i) = fraction of xmstar exterior to the point i ! where xmstar = mstar - M_center integer, intent(out) :: ierr - call do_relax_entropy(id, max_steps_to_use, num_pts, entropy, xq, ierr) + call do_relax_entropy(id, max_steps_to_use, num_pts, entropy, xq, ierr) end subroutine star_relax_entropy subroutine star_relax_to_xaccrete(id, num_steps_to_use, ierr) @@ -1467,7 +1467,7 @@ subroutine star_relax_to_xaccrete(id, num_steps_to_use, ierr) integer, intent(in) :: id integer, intent(in) :: num_steps_to_use ! use this many steps to do conversion integer, intent(out) :: ierr - call do_relax_to_xaccrete(id, num_steps_to_use, ierr) + call do_relax_to_xaccrete(id, num_steps_to_use, ierr) end subroutine star_relax_to_xaccrete @@ -1505,7 +1505,7 @@ subroutine star_relax_tau_factor(id, new_tau_factor, dlogtau_factor, ierr) ! change log10(tau_factor) by at most this amount per step integer, intent(out) :: ierr call do_relax_tau_factor(id, new_tau_factor, dlogtau_factor, ierr) - end subroutine star_relax_tau_factor + end subroutine star_relax_tau_factor ! for normal stellar evolution, opacity_factor = 1 @@ -1518,7 +1518,7 @@ subroutine star_relax_opacity_factor(id, new_opacity_factor, dopacity_factor, ie ! change opacity_factor by at most this amount per step integer, intent(out) :: ierr call do_relax_opacity_factor(id, new_opacity_factor, dopacity_factor, ierr) - end subroutine star_relax_opacity_factor + end subroutine star_relax_opacity_factor subroutine star_relax_Tsurf_factor(id, new_Tsurf_factor, dlogTsurf_factor, ierr) @@ -1530,11 +1530,11 @@ subroutine star_relax_Tsurf_factor(id, new_Tsurf_factor, dlogTsurf_factor, ierr) integer, intent(out) :: ierr call do_relax_Tsurf_factor(id, new_Tsurf_factor, dlogTsurf_factor, ierr) end subroutine star_relax_Tsurf_factor - - ! kind_of_relax = 0 => target = new_omega - ! kind_of_relax = 1 => target = new_omega_div_omega_crit - ! kind_of_relax = 2 => target = new_surface_rotation_v + + ! kind_of_relax = 0 => target = new_omega + ! kind_of_relax = 1 => target = new_omega_div_omega_crit + ! kind_of_relax = 2 => target = new_surface_rotation_v subroutine star_relax_uniform_omega(id, & kind_of_relax, target_value, num_steps_to_relax_rotation, & relax_omega_max_yrs_dt, ierr) @@ -1579,7 +1579,7 @@ subroutine star_relax_num_steps(id, num_steps, max_timestep, ierr) integer, intent(out) :: ierr call do_relax_num_steps(id, num_steps, max_timestep, ierr) end subroutine star_relax_num_steps - + ! evolve until star_check_limits returns terminate. subroutine star_evolve_to_limit(id, restore_at_end, ierr) @@ -1654,12 +1654,12 @@ subroutine star_special_test(id, ierr) if (ierr /= 0) return end subroutine star_special_test - + ! rotation - ! note: this applies to the current model only; - ! subsequenct models may evolve away from solid body rotation. + ! note: this applies to the current model only; + ! subsequenct models may evolve away from solid body rotation. subroutine star_set_uniform_omega(id, omega, ierr) use hydro_rotation, only: set_uniform_omega integer, intent(in) :: id @@ -1731,7 +1731,7 @@ subroutine save_profile(id, priority, ierr) use profile, only: do_save_profiles integer, intent(in) :: id integer, intent(in) :: priority - ! there is a limit to how many profiles are saved, + ! there is a limit to how many profiles are saved, ! and lower priority models are discarded if necessary ! to make room for higher priority ones. integer, intent(out) :: ierr @@ -1787,7 +1787,7 @@ real(dp) function val_for_profile(s, c, k) type (star_info), pointer :: s integer, intent(in) :: c ! one of the values like p_logL defined in star_def integer, intent(in) :: k ! the zone number - logical :: int_flag + logical :: int_flag integer :: int_val call getval_for_profile(s, c, k, val_for_profile, int_flag, int_val) if (int_flag) val_for_profile = dble(int_val) @@ -1966,7 +1966,7 @@ subroutine star_xa_for_standard_metals( & real(dp), intent(in) :: h1, h2, he3, he4 ! mass fractions logical, intent(in) :: dump_missing_metals_into_heaviest real(dp), intent(inout) :: xa(:) ! (species) - integer, intent(out) :: ierr + integer, intent(out) :: ierr call get_xa_for_standard_metals( & s, species, chem_id, net_iso, & h1, h2, he3, he4, which_zfracs, & @@ -2056,7 +2056,7 @@ end subroutine star_set_xqs subroutine star_get_eos( & id, k, xa, & - Rho, logRho, T, logT, & + Rho, logRho, T, logT, & res, dres_dlnRho, dres_dlnT, & dres_dxa, ierr) use eos_def, only: num_eos_basic_results @@ -2074,7 +2074,7 @@ subroutine star_get_eos( & if (ierr /= 0) return call get_eos( & s, k, xa, & - Rho, logRho, T, logT, & + Rho, logRho, T, logT, & res, dres_dlnRho, dres_dlnT, & dres_dxa, ierr) end subroutine star_get_eos @@ -2192,7 +2192,7 @@ subroutine star_get_kap( & eta, deta_dlnRho, deta_dlnT, & kap_fracs, kap, dlnkap_dlnRho, dlnkap_dlnT, ierr) end subroutine star_get_kap - + subroutine star_do_eos_for_cell(id, k, ierr) use micro, only: do_eos_for_cell integer, intent(in) :: id @@ -2205,7 +2205,7 @@ subroutine star_do_eos_for_cell(id, k, ierr) call do_eos_for_cell(s, k, ierr) end subroutine star_do_eos_for_cell - + subroutine star_do_kap_for_cell(id, k, ierr) use micro, only: do_kap_for_cell integer, intent(in) :: id @@ -2218,7 +2218,7 @@ subroutine star_do_kap_for_cell(id, k, ierr) call do_kap_for_cell(s, k, ierr) end subroutine star_do_kap_for_cell - + subroutine star_get_atm_PT( & id, tau_surf, L, R, M, cgrav, skip_partials, Teff, & lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, & @@ -2245,7 +2245,7 @@ subroutine star_get_atm_PT( & ierr) end subroutine star_get_atm_PT - + subroutine star_get_surf_PT( & id, skip_partials, need_atm_Psurf, need_atm_Tsurf, & lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, & @@ -2267,7 +2267,7 @@ subroutine star_get_surf_PT( & lnT_surf, dlnT_dL, dlnT_dlnR, dlnT_dlnM, dlnT_dlnkap, & lnP_surf, dlnP_dL, dlnP_dlnR, dlnP_dlnM, dlnP_dlnkap, & ierr) - end subroutine star_get_surf_PT + end subroutine star_get_surf_PT integer function get_result_reason(id, ierr) integer, intent(in) :: id @@ -2534,7 +2534,7 @@ subroutine star_zero_inner_v_by_mass_gm(id, m, ierr) integer, intent(out) :: ierr call do_zero_inner_v_by_mass_gm(id, m, ierr) end subroutine star_zero_inner_v_by_mass_gm - + subroutine star_relax_to_star_cut(& id, k_remove, do_jrot, do_entropy, turn_off_energy_sources_and_sinks, ierr) @@ -2774,7 +2774,7 @@ subroutine create_pgstar_file_name(s, dir, prefix, name) character (len=*), intent(out) :: name call do_create_file_name(s, dir, prefix, name) end subroutine create_pgstar_file_name - + subroutine pgstar_write_plot_to_file(s, p, filename, ierr) use star_pgstar, only: pgstar_win_file_data @@ -2824,7 +2824,7 @@ subroutine show_pgstar_annotations( & call do_show_pgstar_annotations( & s, show_annotation1, show_annotation2, show_annotation3) end subroutine show_pgstar_annotations - + subroutine pgstar_show_box(s, str1, str2) use pgstar, only: show_box_pgstar @@ -2928,7 +2928,7 @@ subroutine pgstar_show_age(s) type (star_info), pointer :: s call show_age_pgstar(s) end subroutine pgstar_show_age - + subroutine star_history_specs(s, num, names, specs, report) use history, only: get_history_specs @@ -3013,7 +3013,7 @@ logical function star_get1_history_value(s, name, val) real(dp), intent(out) :: val star_get1_history_value = get1_hist_value(s, name, val) end function star_get1_history_value - + real(dp) function star_get_history_output(s, name, ierr) ! If error return -huge(double) and ierr = 1, if provided @@ -3038,7 +3038,7 @@ real(dp) function star_get_history_output(s, name, ierr) return end if end if - if (is_int_value(1)) then + if (is_int_value(1)) then star_get_history_output=dble(int_values(num_rows)) else star_get_history_output=values(num_rows) @@ -3086,7 +3086,7 @@ subroutine star_mlt_gradT(id, MLT_option, & ! can be useful when creating models XH1, cgrav, m, gradL_composition_term, mixing_length_alpha integer, intent(in) :: iso real(dp), intent(out) :: gradT, Y_face, conv_vel, D, Gamma - integer, intent(out) :: mixing_type, ierr + integer, intent(out) :: mixing_type, ierr type (star_info), pointer :: s call star_ptr(id, s, ierr) if (ierr /= 0) return @@ -3145,7 +3145,7 @@ end subroutine star_do_garbage_collection subroutine star_shutdown_pgstar(id, ierr) use pgstar, only: shutdown_pgstar - integer, intent(in) :: id ! id for star + integer, intent(in) :: id ! id for star integer, intent(out) :: ierr type (star_info), pointer :: s ierr = 0 @@ -3262,14 +3262,14 @@ real(dp) function star_ejecta_mass(id) call star_ptr(id, s, ierr) star_ejecta_mass = get_ejecta_mass(s) end function star_ejecta_mass - + ! Returns the next available star id integer function star_find_next_star_id() use star_private_def, only : find_next_star_id star_find_next_star_id = find_next_star_id() end function star_find_next_star_id - + subroutine star_init_star_handles() use star_private_def, only: init_star_handles diff --git a/star/test_suite/1.3M_ms_high_Z/src/run.f90 b/star/test_suite/1.3M_ms_high_Z/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/1.3M_ms_high_Z/src/run.f90 +++ b/star/test_suite/1.3M_ms_high_Z/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/1.3M_ms_high_Z/src/run_star_extras.f90 b/star/test_suite/1.3M_ms_high_Z/src/run_star_extras.f90 index 7de7ebc67..3b8053c04 100644 --- a/star/test_suite/1.3M_ms_high_Z/src/run_star_extras.f90 +++ b/star/test_suite/1.3M_ms_high_Z/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -78,7 +78,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -88,7 +88,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -101,8 +101,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -114,7 +114,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -125,8 +125,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -140,7 +140,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -152,8 +152,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/1.4M_ms_op_mono/src/run.f90 b/star/test_suite/1.4M_ms_op_mono/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/1.4M_ms_op_mono/src/run.f90 +++ b/star/test_suite/1.4M_ms_op_mono/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/1.4M_ms_op_mono/src/run_star_extras.f90 b/star/test_suite/1.4M_ms_op_mono/src/run_star_extras.f90 index c626584b2..8f5b4c9cd 100644 --- a/star/test_suite/1.4M_ms_op_mono/src/run_star_extras.f90 +++ b/star/test_suite/1.4M_ms_op_mono/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) write(*,*) 'this test was intentionally skipped' write(*,*) 'pretend successfully used OP_mono opacities' end if - + s% extras_startup => extras_startup s% extras_start_step => extras_start_step s% extras_check_model => extras_check_model @@ -74,10 +74,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -88,8 +88,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -101,7 +101,7 @@ subroutine extras_after_evolve(id, ierr) ! running at all is the primary check write(*,*) 'successfully used OP_mono opacities' - + call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve @@ -125,7 +125,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -138,8 +138,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -151,7 +151,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -162,8 +162,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 2 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer, intent(in) :: id, n, nz character (len=maxlen_profile_column_name) :: names(n) @@ -190,7 +190,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end do end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -202,8 +202,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/1.5M_with_diffusion/src/run.f90 b/star/test_suite/1.5M_with_diffusion/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/1.5M_with_diffusion/src/run.f90 +++ b/star/test_suite/1.5M_with_diffusion/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/1.5M_with_diffusion/src/run_star_extras.f90 b/star/test_suite/1.5M_with_diffusion/src/run_star_extras.f90 index 89743ce76..e120db6be 100644 --- a/star/test_suite/1.5M_with_diffusion/src/run_star_extras.f90 +++ b/star/test_suite/1.5M_with_diffusion/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -78,7 +78,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -88,7 +88,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -101,8 +101,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -114,7 +114,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -125,8 +125,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -140,7 +140,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -152,8 +152,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/12M_pre_ms_to_core_collapse/src/run.f90 b/star/test_suite/12M_pre_ms_to_core_collapse/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/12M_pre_ms_to_core_collapse/src/run.f90 +++ b/star/test_suite/12M_pre_ms_to_core_collapse/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/12M_pre_ms_to_core_collapse/src/run_star_extras.f90 b/star/test_suite/12M_pre_ms_to_core_collapse/src/run_star_extras.f90 index eca52db75..fd52503e7 100644 --- a/star/test_suite/12M_pre_ms_to_core_collapse/src/run_star_extras.f90 +++ b/star/test_suite/12M_pre_ms_to_core_collapse/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,9 +27,9 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" ! here are the x controls used below @@ -42,8 +42,8 @@ module run_star_extras contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -58,8 +58,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine end subroutine extras_controls @@ -90,12 +90,12 @@ subroutine alpha_mlt_routine(id, ierr) else s% alpha_mlt(k) = alpha_other end if - !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), + !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), end do !stop end subroutine alpha_mlt_routine - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -105,12 +105,12 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (.not. s% x_logical_ctrl(37)) return - + end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use num_lib, only: find0 integer, intent(in) :: id @@ -142,7 +142,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) if (.not. s% x_logical_ctrl(37)) return end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -152,7 +152,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -165,8 +165,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -178,7 +178,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -189,8 +189,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -208,7 +208,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(k,1) = s% zbar(k)/s% abar(k) end do end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) integer, intent(in) :: id @@ -224,4 +224,4 @@ integer function extras_finish_step(id) end function extras_finish_step end module run_star_extras - + diff --git a/star/test_suite/15M_dynamo/src/run.f90 b/star/test_suite/15M_dynamo/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/15M_dynamo/src/run.f90 +++ b/star/test_suite/15M_dynamo/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/15M_dynamo/src/run_star_extras.f90 b/star/test_suite/15M_dynamo/src/run_star_extras.f90 index 7eaad328a..a416c7618 100644 --- a/star/test_suite/15M_dynamo/src/run_star_extras.f90 +++ b/star/test_suite/15M_dynamo/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use num_lib integer, intent(in) :: id @@ -77,18 +77,18 @@ subroutine extras_after_evolve(id, ierr) integer :: k, k_cntr, k_surf type (star_info), pointer :: s logical :: okay - + include 'formats' - + okay = .true. ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) - + if (.not. s% x_logical_ctrl(1)) return - + write(*,'(A)') call check('star_mass', s% star_mass, 12.5d0, 14.5d0) call check('log total_angular_momentum', safe_log10(s% total_angular_momentum), 50d0, 53.0d0) @@ -97,34 +97,34 @@ subroutine extras_after_evolve(id, ierr) call check('he_core_mass', s% he_core_mass, 2.0d0, 5.0d0) call check('surface j_rot', safe_log10(s% j_rot(1)), 17d0, 19d0) call check('surface v_rot', s% omega(1)*s% r(1)*1d-5, 0.01d0, 0.6d0) - + k_cntr = 0 k_surf = 0 do k = s% nz, 1, -1 if (s% m(k) > 3.0d0*Msun .and. k_cntr == 0) k_cntr = k if (s% m(k) > 3.4d0*Msun .and. k_surf == 0) k_surf = k end do - + write(*,'(A)') write(*,1) 'avg from 3.0 to 3.4 Msun' call check('logT', avg_val(s% lnT)/ln10, 7.2d0, 8.1d0) call check('logRho', avg_val(s% lnd)/ln10, 1d0, 3.0d0) call check('log j_rot', safe_log10(avg_val(s% j_rot)), 14.5d0, 15.5d0) - call check('D_ES', safe_log10(avg_val(s% D_ES)), 1d0, 5d0) + call check('D_ES', safe_log10(avg_val(s% D_ES)), 1d0, 5d0) call check('D_ST', safe_log10(avg_val(s% D_ST)), 0.12d0, 12.0d0) call check('nu_ST', safe_log10(avg_val(s% nu_ST)), 8.0d0, 12.0d0) write(*,'(A)') if (okay) write(*,'(a)') 'all values are within tolerances' write(*,'(A)') - - + + contains - + real(dp) function avg_val(v) real(dp) :: v(:) avg_val = dot_product(v(k_surf:k_cntr), s% dq(k_surf:k_cntr)) / sum(s% dq(k_surf:k_cntr)) end function avg_val - + subroutine check(str, val, low, hi) real(dp), intent(in) :: val, low, hi character (len=*) :: str @@ -136,10 +136,10 @@ subroutine check(str, val, low, hi) okay = .false. end if end subroutine check - - + + end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -149,7 +149,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -162,8 +162,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -175,7 +175,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -186,8 +186,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -201,7 +201,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -213,8 +213,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/16M_conv_premix/src/run.f90 b/star/test_suite/16M_conv_premix/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/16M_conv_premix/src/run.f90 +++ b/star/test_suite/16M_conv_premix/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/16M_conv_premix/src/run_star_extras.f90 b/star/test_suite/16M_conv_premix/src/run_star_extras.f90 index 60af6567d..3cfc79ae2 100644 --- a/star/test_suite/16M_conv_premix/src/run_star_extras.f90 +++ b/star/test_suite/16M_conv_premix/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -79,7 +79,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -89,7 +89,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -102,8 +102,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -115,7 +115,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -126,8 +126,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -141,7 +141,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going, retry, or terminate. integer function extras_finish_step(id) @@ -154,8 +154,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/16M_predictive_mix/src/run.f90 b/star/test_suite/16M_predictive_mix/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/16M_predictive_mix/src/run.f90 +++ b/star/test_suite/16M_predictive_mix/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/16M_predictive_mix/src/run_star_extras.f90 b/star/test_suite/16M_predictive_mix/src/run_star_extras.f90 index 60af6567d..3cfc79ae2 100644 --- a/star/test_suite/16M_predictive_mix/src/run_star_extras.f90 +++ b/star/test_suite/16M_predictive_mix/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -79,7 +79,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -89,7 +89,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -102,8 +102,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -115,7 +115,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -126,8 +126,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -141,7 +141,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going, retry, or terminate. integer function extras_finish_step(id) @@ -154,8 +154,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/1M_pre_ms_to_wd/src/run.f90 b/star/test_suite/1M_pre_ms_to_wd/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/1M_pre_ms_to_wd/src/run.f90 +++ b/star/test_suite/1M_pre_ms_to_wd/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/1M_pre_ms_to_wd/src/run_star_extras.f90 b/star/test_suite/1M_pre_ms_to_wd/src/run_star_extras.f90 index 94716d117..c80e219d7 100644 --- a/star/test_suite/1M_pre_ms_to_wd/src/run_star_extras.f90 +++ b/star/test_suite/1M_pre_ms_to_wd/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,21 +27,21 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none include 'test_suite_extras_def.inc' include 'xtra_coeff_os/xtra_coeff_os_def.inc' - + ! these routines are called by the standard run_star check_model - + contains include 'test_suite_extras.inc' include 'xtra_coeff_os/xtra_coeff_os.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -50,7 +50,7 @@ subroutine extras_controls(id, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return include 'xtra_coeff_os/xtra_coeff_os_controls.inc' - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -58,10 +58,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -72,8 +72,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -84,7 +84,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -94,7 +94,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -107,8 +107,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -120,7 +120,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -131,8 +131,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -146,7 +146,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going, retry, or terminate. integer function extras_finish_step(id) @@ -159,8 +159,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/1M_thermohaline/src/run.f90 b/star/test_suite/1M_thermohaline/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/1M_thermohaline/src/run.f90 +++ b/star/test_suite/1M_thermohaline/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/1M_thermohaline/src/run_star_extras.f90 b/star/test_suite/1M_thermohaline/src/run_star_extras.f90 index 878ddaf31..3a641e065 100644 --- a/star/test_suite/1M_thermohaline/src/run_star_extras.f90 +++ b/star/test_suite/1M_thermohaline/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,16 +27,16 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -44,7 +44,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,15 +66,15 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use num_lib integer, intent(in) :: id integer, intent(out) :: ierr real(dp) :: dt integer :: k, k_cntr, k_surf - + logical :: okay type (star_info), pointer :: s character (len=strlen) :: test @@ -91,14 +91,14 @@ subroutine extras_after_evolve(id, ierr) call check('log he_core_omega', safe_log10(s% he_core_omega), -6d0, -3d0) call check('surface j_rot', safe_log10(s% j_rot(1)), 5d0, 25d0) call check('surface v_rot', s% omega(1)*s% r(1)*1d-5, 0d0, 1d0) - + k_cntr = 0 k_surf = 0 do k = s% nz, 1, -1 if (s% m(k) > 0.24d0*Msun .and. k_cntr == 0) k_cntr = k if (s% m(k) > 0.25d0*Msun .and. k_surf == 0) k_surf = k end do - + if (k_surf >=1 .and. k_cntr <= s% nz) then write(*,'(A)') write(*,1) 'avg near 0.245 Msun' @@ -113,15 +113,15 @@ subroutine extras_after_evolve(id, ierr) if (okay) write(*,'(a)') 'all values are within tolerances' end if write(*,'(A)') - - + + contains - + real(dp) function avg_val(v) real(dp) :: v(:) avg_val = dot_product(v(k_surf:k_cntr), s% dq(k_surf:k_cntr)) / sum(s% dq(k_surf:k_cntr)) end function avg_val - + subroutine check(str, val, low, hi) real(dp), intent(in) :: val, low, hi character (len=*) :: str @@ -133,10 +133,10 @@ subroutine check(str, val, low, hi) okay = .false. end if end subroutine check - - + + end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -149,7 +149,7 @@ integer function extras_check_model(id) include 'formats' extras_check_model = keep_going - + end function extras_check_model @@ -162,8 +162,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -175,7 +175,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -186,8 +186,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -201,7 +201,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -213,8 +213,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/20M_pre_ms_to_core_collapse/src/run.f90 b/star/test_suite/20M_pre_ms_to_core_collapse/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/20M_pre_ms_to_core_collapse/src/run.f90 +++ b/star/test_suite/20M_pre_ms_to_core_collapse/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/20M_pre_ms_to_core_collapse/src/run_star_extras.f90 b/star/test_suite/20M_pre_ms_to_core_collapse/src/run_star_extras.f90 index 2cf66b188..dc9809b91 100644 --- a/star/test_suite/20M_pre_ms_to_core_collapse/src/run_star_extras.f90 +++ b/star/test_suite/20M_pre_ms_to_core_collapse/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,9 +27,9 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" ! here are the x controls used below @@ -42,8 +42,8 @@ module run_star_extras contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -58,8 +58,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine end subroutine extras_controls @@ -90,12 +90,12 @@ subroutine alpha_mlt_routine(id, ierr) else s% alpha_mlt(k) = alpha_other end if - !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), + !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), end do !stop end subroutine alpha_mlt_routine - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -105,12 +105,12 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (.not. s% x_logical_ctrl(37)) return - + end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use num_lib, only: find0 integer, intent(in) :: id @@ -142,7 +142,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) if (.not. s% x_logical_ctrl(37)) return end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -152,7 +152,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -165,8 +165,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -178,7 +178,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -189,8 +189,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -208,7 +208,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(k,1) = s% zbar(k)/s% abar(k) end do end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) integer, intent(in) :: id @@ -224,4 +224,4 @@ integer function extras_finish_step(id) end function extras_finish_step end module run_star_extras - + diff --git a/star/test_suite/20M_z2m2_high_rotation/src/run.f90 b/star/test_suite/20M_z2m2_high_rotation/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/20M_z2m2_high_rotation/src/run.f90 +++ b/star/test_suite/20M_z2m2_high_rotation/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/20M_z2m2_high_rotation/src/run_star_extras.f90 b/star/test_suite/20M_z2m2_high_rotation/src/run_star_extras.f90 index 2eaa73479..dfa1797a9 100644 --- a/star/test_suite/20M_z2m2_high_rotation/src/run_star_extras.f90 +++ b/star/test_suite/20M_z2m2_high_rotation/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -79,7 +79,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -89,7 +89,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -102,8 +102,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -115,7 +115,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -126,8 +126,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -145,7 +145,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(k,1) = s% zbar(k)/s% abar(k) end do end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -157,8 +157,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/5M_cepheid_blue_loop/src/run.f90 b/star/test_suite/5M_cepheid_blue_loop/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/5M_cepheid_blue_loop/src/run.f90 +++ b/star/test_suite/5M_cepheid_blue_loop/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/5M_cepheid_blue_loop/src/run_star_extras.f90 b/star/test_suite/5M_cepheid_blue_loop/src/run_star_extras.f90 index 9bd5a8093..655ea4b2e 100644 --- a/star/test_suite/5M_cepheid_blue_loop/src/run_star_extras.f90 +++ b/star/test_suite/5M_cepheid_blue_loop/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" logical :: have_crossed_red_edge, have_crossed_blue_edge - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -74,8 +74,8 @@ subroutine extras_startup(id, restart, ierr) call unpack_extra_info(s) end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -86,7 +86,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -98,7 +98,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going ! approx edges logT1 = s% x_ctrl(2) @@ -114,24 +114,24 @@ integer function extras_check_model(id) log_L = log10(s% L_surf) red_logT = get_red_logT(log_L) blue_logT = get_blue_logT(log_L) - + if (log_T > red_logT .and. .not. have_crossed_red_edge) then write(*,*) 'crossed red edge to start 2nd crossing', s% model_number have_crossed_red_edge = .true. end if - + if (log_T > blue_logT .and. .not. have_crossed_blue_edge) then write(*,*) 'crossed blue edge to end 2nd crossing', s% model_number have_crossed_blue_edge = .true. end if - + if (log_T < blue_logT .and. have_crossed_blue_edge) then write(*,*) 'crossed blue edge to start 3rd crossing', s% model_number extras_check_model = terminate end if - + contains - + real(dp) function get_blue_logT(log_L) real(dp), intent(in) :: log_L get_blue_logT = -1d99 @@ -142,7 +142,7 @@ real(dp) function get_blue_logT(log_L) end if end function get_blue_logT - + real(dp) function get_red_logT(log_L) real(dp), intent(in) :: log_L if (logL3 - logL4 > 0d0) then @@ -164,8 +164,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -177,7 +177,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -188,8 +188,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -203,7 +203,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -216,60 +216,60 @@ integer function extras_finish_step(id) extras_finish_step = keep_going call store_extra_info(s) end function extras_finish_step - - + + ! routines for saving and restoring extra data so can do restarts - + ! put these defs at the top and delete from the following routines !integer, parameter :: extra_info_alloc = 1 !integer, parameter :: extra_info_get = 2 !integer, parameter :: extra_info_put = 3 - - + + subroutine alloc_extra_info(s) integer, parameter :: extra_info_alloc = 1 type (star_info), pointer :: s call move_extra_info(s,extra_info_alloc) end subroutine alloc_extra_info - - + + subroutine unpack_extra_info(s) integer, parameter :: extra_info_get = 2 type (star_info), pointer :: s call move_extra_info(s,extra_info_get) end subroutine unpack_extra_info - - + + subroutine store_extra_info(s) integer, parameter :: extra_info_put = 3 type (star_info), pointer :: s call move_extra_info(s,extra_info_put) end subroutine store_extra_info - - + + subroutine move_extra_info(s,op) integer, parameter :: extra_info_alloc = 1 integer, parameter :: extra_info_get = 2 integer, parameter :: extra_info_put = 3 type (star_info), pointer :: s integer, intent(in) :: op - + integer :: i, j, num_ints, num_dbls, ierr - + i = 0 - ! call move_int or move_flg + ! call move_int or move_flg call move_flg(have_crossed_red_edge) call move_flg(have_crossed_blue_edge) num_ints = i - + i = 0 - ! call move_dbl - + ! call move_dbl + num_dbls = i - + if (op /= extra_info_alloc) return if (num_ints == 0 .and. num_dbls == 0) return - + ierr = 0 call star_alloc_extras(s% id, num_ints, num_dbls, ierr) if (ierr /= 0) then @@ -278,9 +278,9 @@ subroutine move_extra_info(s,op) write(*,*) 'alloc_extras num_dbls', num_dbls call mesa_error(__FILE__,__LINE__) end if - + contains - + subroutine move_dbl(dbl) real(dp) :: dbl i = i+1 @@ -291,7 +291,7 @@ subroutine move_dbl(dbl) s% extra_work(i) = dbl end select end subroutine move_dbl - + subroutine move_int(int) integer :: int i = i+1 @@ -302,7 +302,7 @@ subroutine move_int(int) s% extra_iwork(i) = int end select end subroutine move_int - + subroutine move_flg(flg) logical :: flg i = i+1 @@ -317,8 +317,8 @@ subroutine move_flg(flg) end if end select end subroutine move_flg - + end subroutine move_extra_info end module run_star_extras - + diff --git a/star/test_suite/7M_prems_to_AGB/src/run.f90 b/star/test_suite/7M_prems_to_AGB/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/7M_prems_to_AGB/src/run.f90 +++ b/star/test_suite/7M_prems_to_AGB/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/7M_prems_to_AGB/src/run_star_extras.f90 b/star/test_suite/7M_prems_to_AGB/src/run_star_extras.f90 index aae419c5a..b4bd860e1 100644 --- a/star/test_suite/7M_prems_to_AGB/src/run_star_extras.f90 +++ b/star/test_suite/7M_prems_to_AGB/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,18 +27,18 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -46,7 +46,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -54,10 +54,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -68,8 +68,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -81,7 +81,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -91,7 +91,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -104,8 +104,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -117,7 +117,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -128,8 +128,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -143,7 +143,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -155,8 +155,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/R_CrB_star/src/run.f90 b/star/test_suite/R_CrB_star/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/R_CrB_star/src/run.f90 +++ b/star/test_suite/R_CrB_star/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/R_CrB_star/src/run_star_extras.f90 b/star/test_suite/R_CrB_star/src/run_star_extras.f90 index ea63e4379..a88a0dc66 100644 --- a/star/test_suite/R_CrB_star/src/run_star_extras.f90 +++ b/star/test_suite/R_CrB_star/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -96,7 +96,7 @@ subroutine extras_after_evolve(id, ierr) close(iounit) end if - + end subroutine extras_after_evolve @@ -119,7 +119,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -132,8 +132,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -145,7 +145,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -156,8 +156,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -171,7 +171,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -183,8 +183,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/T_tau_gradr/src/run.f90 b/star/test_suite/T_tau_gradr/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/T_tau_gradr/src/run.f90 +++ b/star/test_suite/T_tau_gradr/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/T_tau_gradr/src/run_star_extras.f90 b/star/test_suite/T_tau_gradr/src/run_star_extras.f90 index 5eef2cd43..a7e42c992 100644 --- a/star/test_suite/T_tau_gradr/src/run_star_extras.f90 +++ b/star/test_suite/T_tau_gradr/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -28,17 +28,17 @@ module run_star_extras use math_lib use auto_diff use utils_lib, only: mesa_error - + implicit none logical :: failed - + include 'test_suite_extras_def.inc' - + contains include 'test_suite_extras.inc' - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -56,8 +56,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_profile_columns => how_many_extra_profile_columns s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -71,8 +71,8 @@ subroutine extras_startup(id, restart, ierr) failed = .false. end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -148,7 +148,7 @@ integer function extras_check_model(id) call mesa_error(__FILE__,__LINE__) end select end if - + end function extras_check_model @@ -161,8 +161,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -174,7 +174,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -185,8 +185,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -206,7 +206,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end do end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -218,7 +218,7 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - + real(dp) function q(name, tau) character(*), intent(in) :: name @@ -249,4 +249,4 @@ real(dp) function q(name, tau) end function q end module run_star_extras - + diff --git a/star/test_suite/accreted_material_j/src/run.f90 b/star/test_suite/accreted_material_j/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/accreted_material_j/src/run.f90 +++ b/star/test_suite/accreted_material_j/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/accreted_material_j/src/run_star_extras.f90 b/star/test_suite/accreted_material_j/src/run_star_extras.f90 index 32461989b..e86194dd1 100644 --- a/star/test_suite/accreted_material_j/src/run_star_extras.f90 +++ b/star/test_suite/accreted_material_j/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -29,14 +29,14 @@ module run_star_extras use auto_diff implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -44,14 +44,14 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + ! this is the place to set any procedure pointers you want to change ! e.g., other_wind, other_mixing, other_energy (see star_data.inc) s% other_adjust_mdot => accretor_adjust_mdot s% lxtra(1) = .false. s% lxtra(2) = .false. - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -59,8 +59,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - + s% data_for_extra_profile_columns => data_for_extra_profile_columns + end subroutine extras_controls subroutine accretor_adjust_mdot(id, ierr) @@ -75,7 +75,7 @@ subroutine accretor_adjust_mdot(id, ierr) s% mstar_dot = s% mstar_dot + pow(10d0, s% x_ctrl(2))*Msun/secyer end subroutine accretor_adjust_mdot - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -86,8 +86,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -98,7 +98,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -109,7 +109,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going ! Check accretion of angular momentum if (s% model_number > 1 .and. s% mstar_dot > 0) then @@ -170,8 +170,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -183,7 +183,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -194,8 +194,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -208,7 +208,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + !note: do NOT add these names to profile_columns.list ! the profile_columns.list is only for the built-in profile column options. ! it must not include the new column names you are adding here. @@ -219,9 +219,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) !do k = 1, nz ! vals(k,1) = s% Pgas(k)/s% P(k) !end do - + end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. @@ -236,7 +236,7 @@ integer function extras_finish_step(id) include 'formats' - ! to save a profile, + ! to save a profile, ! s% need_to_save_profiles_now = .true. ! to update the star log, ! s% need_to_update_history_now = .true. @@ -246,8 +246,8 @@ integer function extras_finish_step(id) if (extras_finish_step == terminate) s% termination_code = t_extras_finish_step end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/adjust_net/src/run.f90 b/star/test_suite/adjust_net/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/adjust_net/src/run.f90 +++ b/star/test_suite/adjust_net/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/adjust_net/src/run_star_extras.f90 b/star/test_suite/adjust_net/src/run_star_extras.f90 index 4ca36438e..fed53c106 100644 --- a/star/test_suite/adjust_net/src/run_star_extras.f90 +++ b/star/test_suite/adjust_net/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -79,7 +79,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return include 'formats' - select case (s% x_integer_ctrl(1)) + select case (s% x_integer_ctrl(1)) case(2) ! inlist_adjust_net if (s% species == 62) then write(*,'(a,i3)') 'finished with expected number of species', s% species @@ -93,7 +93,7 @@ subroutine extras_after_evolve(id, ierr) ierr = 0 call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -103,7 +103,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -116,8 +116,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -129,7 +129,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -140,8 +140,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -155,7 +155,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -170,10 +170,10 @@ integer function extras_finish_step(id) call star_ptr(id, s, ierr) if (ierr /= 0) return extras_finish_step = keep_going - + end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/c13_pocket/src/run.f90 b/star/test_suite/c13_pocket/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/c13_pocket/src/run.f90 +++ b/star/test_suite/c13_pocket/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/carbon_kh/src/run.f90 b/star/test_suite/carbon_kh/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/carbon_kh/src/run.f90 +++ b/star/test_suite/carbon_kh/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/carbon_kh/src/run_star_extras.f90 b/star/test_suite/carbon_kh/src/run_star_extras.f90 index 02500b6f4..8506c67b9 100644 --- a/star/test_suite/carbon_kh/src/run_star_extras.f90 +++ b/star/test_suite/carbon_kh/src/run_star_extras.f90 @@ -180,7 +180,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) names(6) = 'rel_e_eos_err_run_blend' vals(6) = e_eos_err_run_blend / s% total_energy_end - + end subroutine data_for_extra_history_columns @@ -273,8 +273,8 @@ logical function in_eos_blend(s, k) ((s% eos_frac_PC(k) .gt. 0) .and. (s% eos_frac_PC(k) .lt. 1)) .or. & ((s% eos_frac_CMS(k) .gt. 0) .and. (s% eos_frac_CMS(k) .lt. 1)) .or. & ((s% eos_frac_FreeEOS(k) .gt. 0) .and. (s% eos_frac_FreeEOS(k) .lt. 1)) - + end function in_eos_blend - + end module run_star_extras diff --git a/star/test_suite/cburn_inward/src/run.f90 b/star/test_suite/cburn_inward/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/cburn_inward/src/run.f90 +++ b/star/test_suite/cburn_inward/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/cburn_inward/src/run_star_extras.f90 b/star/test_suite/cburn_inward/src/run_star_extras.f90 index 93376d4f7..134e001d4 100644 --- a/star/test_suite/cburn_inward/src/run_star_extras.f90 +++ b/star/test_suite/cburn_inward/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,7 +27,7 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none ! Tracks quanties when the flame ignited @@ -35,12 +35,12 @@ module run_star_extras include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -48,7 +48,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -56,14 +56,14 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% other_photo_read => extras_photo_read s% other_photo_write => extras_photo_write end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -80,8 +80,8 @@ subroutine extras_startup(id, restart, ierr) flame_mass = -1 end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -92,7 +92,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return - select case (s% x_integer_ctrl(1)) + select case (s% x_integer_ctrl(1)) case(2) ! inlist_cburn_inward @@ -111,7 +111,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -121,7 +121,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -134,8 +134,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 4 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -155,7 +155,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) vals(4) = flame_mass/msun end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -166,8 +166,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -181,7 +181,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -194,17 +194,17 @@ integer function extras_finish_step(id) call star_ptr(id, s, ierr) if (ierr /= 0) return extras_finish_step = keep_going - - - ! Store initial flame location - select case (s% x_integer_ctrl(1)) + + + ! Store initial flame location + select case (s% x_integer_ctrl(1)) case(2) ! inlist_cburn_inward flame_cell = -1 ! Check to see if carbon has ignited do k=s%nz, 1, -1 - if (has_ignited(s, k)) then - flame_cell = k + if (has_ignited(s, k)) then + flame_cell = k exit end if end do @@ -222,7 +222,7 @@ integer function extras_finish_step(id) ! Final flame location if(ign_mass > 0d0 .and. s% m(flame_cell) < 0.5d0*ign_mass) then extras_finish_step = terminate - write(*,'(a)') "Terminate as flame reached half way" + write(*,'(a)') "Terminate as flame reached half way" s% termination_code = t_extras_finish_step end if end if @@ -230,8 +230,8 @@ integer function extras_finish_step(id) end select end function extras_finish_step - - + + logical function has_ignited(s, k) use net_def use chem_def @@ -241,12 +241,12 @@ logical function has_ignited(s, k) integer,intent(in) :: k real(dp) :: neAbun,naAbun,mgAbun,heAbun real(dp) :: netEng,ne_burn,o_burn - + has_ignited = .false. if(s% co_core_mass > 0d0) then if(s%m(k)/Msun < s%co_core_mass)THEN netEng = star_get_profile_output(s,'net_nuclear_energy',k) - + if(netEng >= 0.0)THEN neAbun = s%xa(s%net_iso(chem_get_iso_id('ne20')),k) naAbun = s%xa(s%net_iso(chem_get_iso_id('na23')),k) @@ -266,35 +266,35 @@ subroutine extras_photo_read(id, iounit, ierr) integer, intent(out) :: ierr type (star_info), pointer :: s ierr = 0 - + call star_ptr(id, s, ierr) if (ierr /= 0) return - + select case (s% x_integer_ctrl(1)) case(2) read(iounit,iostat=ierr) ign_mass, ign_density, ign_co_core_mass,flame_mass end select - + end subroutine extras_photo_read - + subroutine extras_photo_write(id, iounit) integer, intent(in) :: id, iounit integer :: ierr type (star_info), pointer :: s ierr = 0 - + call star_ptr(id, s, ierr) if (ierr /= 0) return - + select case (s% x_integer_ctrl(1)) case(2) write(iounit) ign_mass, ign_density, ign_co_core_mass,flame_mass end select - + end subroutine extras_photo_write end module run_star_extras - + diff --git a/star/test_suite/ccsn_IIp/src/run.f90 b/star/test_suite/ccsn_IIp/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/ccsn_IIp/src/run.f90 +++ b/star/test_suite/ccsn_IIp/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/ccsn_IIp/src/run_star_extras.f90 b/star/test_suite/ccsn_IIp/src/run_star_extras.f90 index 93384f3e8..84f9a9869 100644 --- a/star/test_suite/ccsn_IIp/src/run_star_extras.f90 +++ b/star/test_suite/ccsn_IIp/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -28,10 +28,10 @@ module run_star_extras use math_lib use auto_diff use utils_lib, only: mesa_error, is_bad - + implicit none - integer, parameter :: X_VEL_FRAC_C = 1 ! fraction of c to limit v_center to + integer, parameter :: X_VEL_FRAC_C = 1 ! fraction of c to limit v_center to integer, parameter :: X_STOP_M = 2 ! stop_m integer, parameter :: X_STOP_M_FRAC_HE = 7 !for setting stop_m in part2, fraction of He layer. @@ -43,7 +43,7 @@ module run_star_extras integer, parameter :: X_CSM_MDOT = 18 ! mass of csm to add if >0 - part 5 only integer, parameter :: X_CSM_MASS = 19 ! mass of csm to add if >0 - part 5 only - + integer, parameter :: X_MLT_ALPHA = 21 ! use this mlta_alpha when h1>x_ctrl(X_MLT_H_LIM) integer, parameter :: X_MLT_OTHER = 22 ! else use this mlt alpha integer, parameter :: X_MLT_H_LIM = 23 ! h limit to switch mlt alpha's @@ -54,12 +54,12 @@ module run_star_extras integer, parameter :: X_DELTA_LGL_AGE = 32 ! when to change delta_lgL options integer, parameter :: X_DELTA_LGL_LIM = 33 ! s% delta_lgL_limit integer, parameter :: X_DELTA_LGL_HARD_LIM = 34 ! s% delta_lgL_hard_limit - + integer, parameter :: X_NI_MASS_START = 35 ! where to put Ni above M_center - integer, parameter :: X_NI_MASS_END = 36 ! where to stop putting Ni56 above he core + integer, parameter :: X_NI_MASS_END = 36 ! where to stop putting Ni56 above he core integer, parameter :: X_STELLA_MIN_CNTR_U = 37 !min center velocity for stella. - + integer, parameter :: X_SMOOTH_XA_1_START = 45 ! boxcar smooth start mass above M_center integer, parameter :: X_SMOOTH_XA_1_END = 46 ! boxcar smooth end mass above he core integer, parameter :: X_SMOOTH_XA_1_BOXCAR_MASS = 47 ! boxcar smooth boxcar size @@ -69,10 +69,10 @@ module run_star_extras integer, parameter :: X_SMOOTH_XA_2_BOXCAR_MASS = 50 ! boxcar smooth boxcar size integer, parameter :: X_MAGNETAR_L_CNTR = 55 ! L_center - Magnetar is only enabled if this is greater than 0 - integer, parameter :: X_MAGNETAR_START_UP = 56 ! start ramping up magnetar at this time in days - integer, parameter :: X_MAGNETAR_END_UP = 57 ! stop ramping up magnetar at this time in days - integer, parameter :: X_MAGNETAR_START_DOWN = 58 ! start ramping down magnetar at this time in days - integer, parameter :: X_MAGNETAR_END_DOWN = 59 ! stop ramping down magnetar at this time in days + integer, parameter :: X_MAGNETAR_START_UP = 56 ! start ramping up magnetar at this time in days + integer, parameter :: X_MAGNETAR_END_UP = 57 ! stop ramping up magnetar at this time in days + integer, parameter :: X_MAGNETAR_START_DOWN = 58 ! start ramping down magnetar at this time in days + integer, parameter :: X_MAGNETAR_END_DOWN = 59 ! stop ramping down magnetar at this time in days integer, parameter :: X_FORCE_STOP_M = 98 integer, parameter :: X_DEFAULT_STOP_M = 99 @@ -91,12 +91,12 @@ module run_star_extras include "test_suite_extras_def.inc" include 'stella/stella_def.inc' - + real(dp) :: & initial_time, & initial_nico, initial_M_center, initial_he_core_mass, initial_mass, & start_m, stop_m - + real(dp), parameter :: h1_limit = 0.1 ! We use this to check that RTI mixing worked real(dp) :: max_mass_h ! Mass co-ordinate where h1< h1_limit @@ -112,11 +112,11 @@ subroutine extras_controls(id, ierr) include 'formats' ierr = 0 call star_ptr(id, s, ierr) - if (ierr /= 0) return - + if (ierr /= 0) return + include 'stella/stella_controls.inc' if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_start_step => extras_start_step @@ -191,8 +191,8 @@ subroutine low_density_wind_routine(id, Lsurf, Msurf, Rsurf, Tsurf, X, Y, Z, w, w = (msum/Msun)/(s% dt/secyer) write(*,1) 'low_density_wind_routine lg(Mdot) msum/Msun', safe_log10(w), msum/Msun end subroutine low_density_wind_routine - - + + subroutine set_nico_mass(s, i_ni56, i_co56, new_ni, final_call, mass_ni56, ierr) use chem_def, only: io16 type (star_info), pointer :: s @@ -201,7 +201,7 @@ subroutine set_nico_mass(s, i_ni56, i_co56, new_ni, final_call, mass_ni56, ierr) real(dp), intent(in) :: new_ni real(dp), intent(out) :: mass_ni56 integer, intent(out) :: ierr - + integer :: i_o16, k, j, n, nz, species, jmax, kcut real(dp) :: old_nico, nico_change, & old_o16, new_o16, alfa_o16, alfa_nico, sum_dm, & @@ -229,10 +229,10 @@ subroutine set_nico_mass(s, i_ni56, i_co56, new_ni, final_call, mass_ni56, ierr) end do min_m = s% x_ctrl(X_NI_MASS_START)*Msun + s% M_center max_m = s% x_ctrl(X_NI_MASS_END)*Msun + s% he_core_mass*Msun - + if (s% u_flag) then do k=nz,1,-1 - if (s% u(k) > s% x_ctrl(X_STELLA_MIN_CNTR_U)) then + if (s% u(k) > s% x_ctrl(X_STELLA_MIN_CNTR_U)) then ! prepare for removal before give to Stella if (s% m(k) > min_m) then min_m = s% m(k) @@ -240,9 +240,9 @@ subroutine set_nico_mass(s, i_ni56, i_co56, new_ni, final_call, mass_ni56, ierr) exit end if end if - end do - end if - + end do + end if + write(*,1) 'max_m min_m he_core_mass new_ni', & max_m/Msun, min_m/Msun, s% he_core_mass, new_ni if (max_m > 0d0) then @@ -313,7 +313,7 @@ subroutine set_nico_mass(s, i_ni56, i_co56, new_ni, final_call, mass_ni56, ierr) !call mesa_error(__FILE__,__LINE__,'set_nico_mass') return end if - + write(*,*) 'rescale Ni profile' do k=1,nz do j=1,species @@ -326,7 +326,7 @@ subroutine set_nico_mass(s, i_ni56, i_co56, new_ni, final_call, mass_ni56, ierr) end do end if end do - + kcut = nz if (final_call .and. stella_skip_inner_dm > 0d0) then mcut = s% M_center + stella_skip_inner_dm*Msun @@ -382,7 +382,7 @@ subroutine set_nico_mass(s, i_ni56, i_co56, new_ni, final_call, mass_ni56, ierr) mass_ni56 = new_ni write(*,1) 'revised mass Ni56', check_ni56 end subroutine set_nico_mass - + subroutine extras_startup(id, restart, ierr) use chem_def, only: ini56, ico56, ih1, ihe4, io16 use interp_2d_lib_db, only: interp_mkbicub_db @@ -410,7 +410,7 @@ subroutine extras_startup(id, restart, ierr) he4 = s% net_iso(ihe4) h1 = s% net_iso(ih1) if (o16 <= 0 .or. he4 <= 0 .or. h1 <= 0) call mesa_error(__FILE__,__LINE__,'missing o16, he4, or h1') - + if (s% eos_rq% logRho_min_OPAL_SCVH_limit > -12d0) then write(*,'(A)') write(*,*)'FIX: have set_logRho_OPAL_SCVH_limits too large' @@ -418,7 +418,7 @@ subroutine extras_startup(id, restart, ierr) write(*,'(A)') call mesa_error(__FILE__,__LINE__,'extras_startup') end if - + if (.not. restart) then initial_nico = 0 stop_m = 0 @@ -427,7 +427,7 @@ subroutine extras_startup(id, restart, ierr) initial_time = s% time initial_he_core_mass = s% he_core_mass max_mass_h = -1 - + if (s% x_integer_ctrl(I_INLIST_PART) == INLIST_EDEP) then if (s% total_mass_for_inject_extra_ergs_sec > 0) then ! doing edep if (s% v_flag) then @@ -454,7 +454,7 @@ subroutine extras_startup(id, restart, ierr) if (s% x_integer_ctrl(I_INLIST_PART) == INLIST_SHOCK_PART5 .and. & s% x_ctrl(X_CSM_MASS) > 0) call add_csm ! part 5, add csm - + if (s% x_ctrl(X_SMOOTH_XA_1_BOXCAR_MASS) > 0d0 .and. s% x_integer_ctrl(I_SMOOTH_XA_1_NUM_ITERS) > 0) then min_mass = s% x_ctrl(X_SMOOTH_XA_1_START) + s% M_center/Msun max_mass = s% x_ctrl(X_SMOOTH_XA_1_END) + s% he_core_mass @@ -471,7 +471,7 @@ subroutine extras_startup(id, restart, ierr) end if initial_nico = xni56 end if - + if (s% x_ctrl(X_SMOOTH_XA_2_BOXCAR_MASS) > 0d0 .and. s% x_integer_ctrl(I_SMOOTH_XA_2_NUM_ITERS) > 0) then min_mass = s% x_ctrl(X_SMOOTH_XA_2_START) + s% M_center/Msun max_mass = s% x_ctrl(X_SMOOTH_XA_2_END) + s% he_core_mass @@ -480,10 +480,10 @@ subroutine extras_startup(id, restart, ierr) s% id, min_mass, max_mass, boxcar_mass, s% x_integer_ctrl(I_SMOOTH_XA_2_NUM_ITERS), ierr) if (ierr /= 0) return end if - + if (s% x_integer_ctrl(I_INLIST_PART) == INLIST_SHOCK_PART1) & s% cumulative_energy_error = 0d0 ! set to 0 at start of part1 - + start_m = s% shock_mass if (start_m == 0d0) then ! use max v k_max_v = maxloc(s% u(1:s% nz),dim=1) @@ -498,10 +498,10 @@ subroutine extras_startup(id, restart, ierr) write(*,2) 'use shock for start_m', s% shock_k, s% shock_mass end if write(*,2) 'M_center', s% nz, s% M_center/Msun - + write(*,1) 's% x_ctrl(X_FORCE_STOP_M)', s% x_ctrl(X_FORCE_STOP_M) write(*,2) 's% x_integer_ctrl(I_INLIST_PART)', s% x_integer_ctrl(I_INLIST_PART) - + if (s% x_ctrl(X_FORCE_STOP_M) > 0d0) then stop_m = s% x_ctrl(X_FORCE_STOP_M) else @@ -520,17 +520,17 @@ subroutine extras_startup(id, restart, ierr) stop_m = s% star_mass - s% x_ctrl(X_MASS_BELOW_SURF) end select end if - + end if ! not restart - + write(*,1) 's% x_ctrl(X_MASS_BELOW_SURF)', s% x_ctrl(X_MASS_BELOW_SURF) write(*,1) 's% star_mass', s% star_mass write(*,1) 'start_m', start_m write(*,1) 'stop_m', stop_m - + if (s% x_ctrl(X_MASS_BELOW_SURF) > 0d0) & stop_m = min(stop_m, s% star_mass - s% x_ctrl(X_MASS_BELOW_SURF)) - + if (start_m > stop_m .and. stop_m > 0d0) then write(*,1) 'start_m > stop_m', start_m, stop_m call mesa_error(__FILE__,__LINE__,'extras_startup') @@ -546,7 +546,7 @@ subroutine extras_startup(id, restart, ierr) write(*,'(A)') !stop end if - + contains subroutine find_inlist_part1_stop_m() @@ -615,7 +615,7 @@ subroutine find_inlist_part3_stop_m() if (stop_m == 0d0) call mesa_error(__FILE__,__LINE__,'failed to find stop_m') end subroutine find_inlist_part3_stop_m - + subroutine add_csm real(dp) :: xni56, xmax, & logT, P_hse, Z, & @@ -651,7 +651,7 @@ subroutine add_csm write(*,1) 'old log(r(1)/Rsun), R/Rsun', log10(s% r(1)/Rsun), s% r(1)/Rsun write(*,2) 'rho0, T0, r0, csm mass, csm v', & kk, rho0, T0, r0/Rsun, (s% m(1) - s% m(kk))/Msun, windv - dm = sum(s% dm(1:kk-1))/(kk-1) + dm = sum(s% dm(1:kk-1))/(kk-1) dq = dm/s% xmstar do k = 1, kk-1 s% dq(k) = dq @@ -683,14 +683,14 @@ subroutine add_csm s% rho(k) = rho s% lnd(k) = log(s% rho(k)) s% xh(s% i_lnd,k) = s% lnd(k) - - + + s% u(k) = windv !* r/r0 - - + + s% xh(s% i_u,k) = s% u(k) - - + + if (.true.) then ! set T to give P for HSE r = s% r(k+1) P_hse = s% Peos(k+1) - & @@ -717,7 +717,7 @@ subroutine add_csm s% lnT(k) = log(s% T(k)) end if s% xh(s% i_lnT,k) = s% lnT(k) - + if (.true.) then ! set to black body L s% L(k) = atm_L(s% T(k), s% r(k)) else @@ -736,8 +736,8 @@ subroutine add_csm end subroutine add_csm end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use chem_def, only: ini56, ico56, ih1 integer, intent(in) :: id @@ -753,7 +753,7 @@ subroutine extras_after_evolve(id, ierr) call write_stella_data(s, ierr) if (ierr /= 0) return end if - + ! Check that RTI worked if (s% x_integer_ctrl(I_INLIST_PART) == INLIST_SHOCK_PART4 .and. s% rti_flag) then ! This is only needed for the test suite and can be removed if doing science @@ -793,7 +793,7 @@ end subroutine check_rti end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -819,8 +819,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -831,9 +831,9 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -847,8 +847,8 @@ integer function how_many_extra_profile_columns(id) if (s% x_integer_ctrl(I_INLIST_PART) == INLIST_SHOCK_PART3) & how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -874,7 +874,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) return end if end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_start_step(id) @@ -890,23 +890,23 @@ integer function extras_start_step(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% x_integer_ctrl(I_INLIST_PART) == INLIST_SHOCK_PART1 .and. s% model_number >= 1000) & s% max_timestep = 0 ! turn off limit - + age_days = s% star_age*365.25d0 - + if (s% x_ctrl(X_RTI_DAYS_OFF) > 0 .and. age_days >= s% x_ctrl(X_RTI_DAYS_OFF) .and. & s% RTI_C > 0d0) then call turn_off_rti() end if - + call enable_magnetar(s) - + if (age_days >= s% x_ctrl(X_DELTA_LGL_AGE)) then call adjust_delta_lgL() end if - + if (s% x_logical_ctrl(L_V_CNTR) .and. s% dt > 0d0) then call adjust_v_center() end if @@ -917,7 +917,7 @@ integer function extras_start_step(id) subroutine turn_off_rti() include 'formats' s% RTI_C = 0d0 - s% RTI_log_max_boost = 0d0 + s% RTI_log_max_boost = 0d0 s% RTI_m_full_boost = -1d0 s% RTI_m_no_boost = 0d0 s% dedt_RTI_diffusion_factor = 1d0 @@ -949,7 +949,7 @@ subroutine adjust_delta_lgL() end subroutine adjust_delta_lgL end function extras_start_step - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -964,7 +964,7 @@ integer function extras_finish_step(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% x_ctrl(X_STOP_M) <= 0) return shock_mass = s% shock_mass if (shock_mass >= s% x_ctrl(X_STOP_M)) then @@ -977,7 +977,7 @@ integer function extras_finish_step(id) write(*,1) 'shock has reached this fraction of target', & shock_mass/s% x_ctrl(X_STOP_M) end if - + if (s% x_integer_ctrl(I_INLIST_PART) == INLIST_SHOCK_PART5 .and. & s% model_number == save_stella_data_for_model_number) then call write_stella_data(s, ierr) @@ -1000,19 +1000,19 @@ subroutine restore_nico_mass() end subroutine restore_nico_mass - + end function extras_finish_step - + subroutine extras_photo_read(id, iounit, ierr) integer, intent(in) :: id, iounit integer, intent(out) :: ierr integer :: inlist_part type (star_info), pointer :: s ierr = 0 - + call star_ptr(id, s, ierr) if (ierr /= 0) return - + read(iounit,iostat=ierr) initial_nico, initial_M_center, initial_mass, initial_time, initial_he_core_mass read(iounit,iostat=ierr) start_m, stop_m, inlist_part, max_mass_h @@ -1023,19 +1023,19 @@ subroutine extras_photo_read(id, iounit, ierr) end if end subroutine extras_photo_read - + subroutine extras_photo_write(id, iounit) integer, intent(in) :: id, iounit integer :: ierr type (star_info), pointer :: s ierr = 0 - + call star_ptr(id, s, ierr) if (ierr /= 0) return - + write(iounit) initial_nico, initial_M_center, initial_mass, initial_time, initial_he_core_mass write(iounit) start_m, stop_m, s% x_integer_ctrl(I_INLIST_PART), max_mass_h - + end subroutine extras_photo_write @@ -1069,4 +1069,3 @@ subroutine enable_magnetar(s) end subroutine enable_magnetar end module run_star_extras - \ No newline at end of file diff --git a/star/test_suite/check_pulse_atm/src/run.f90 b/star/test_suite/check_pulse_atm/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/check_pulse_atm/src/run.f90 +++ b/star/test_suite/check_pulse_atm/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/check_pulse_atm/src/run_star_extras.f90 b/star/test_suite/check_pulse_atm/src/run_star_extras.f90 index b158e5557..11429dc9e 100644 --- a/star/test_suite/check_pulse_atm/src/run_star_extras.f90 +++ b/star/test_suite/check_pulse_atm/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -28,17 +28,17 @@ module run_star_extras use math_lib use auto_diff use utils_lib, only: mesa_error - + implicit none logical :: failed - + include 'test_suite_extras_def.inc' - + contains include 'test_suite_extras.inc' - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -56,8 +56,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_profile_columns => how_many_extra_profile_columns s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -71,8 +71,8 @@ subroutine extras_startup(id, restart, ierr) failed = .false. end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -132,7 +132,7 @@ integer function extras_check_model(id) write(*,*) 'failed to save '//filename call mesa_error(__FILE__,__LINE__) end if - + ! load pulse data and compare it to reference value open(newunit=iounit, file=filename, status='OLD', iostat=ierr) if (ierr /= 0) then @@ -153,7 +153,7 @@ integer function extras_check_model(id) end if read(iounit, *, iostat=ierr) row ! M, R, L, ... - read(iounit, *, iostat=ierr) row ! + read(iounit, *, iostat=ierr) row ! read(iounit, *, iostat=ierr) row ! ..., Teff, G Teff = row(4) @@ -225,7 +225,7 @@ integer function extras_check_model(id) call mesa_error(__FILE__,__LINE__) end select end if - + end function extras_check_model @@ -238,8 +238,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -251,7 +251,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -262,8 +262,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -283,7 +283,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end do end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -295,7 +295,7 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - + real(dp) function q(name, tau) character(*), intent(in) :: name @@ -326,4 +326,4 @@ real(dp) function q(name, tau) end function q end module run_star_extras - + diff --git a/star/test_suite/check_redo/src/run.f90 b/star/test_suite/check_redo/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/check_redo/src/run.f90 +++ b/star/test_suite/check_redo/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/check_redo/src/run_star_extras.f90 b/star/test_suite/check_redo/src/run_star_extras.f90 index 4c0be81a1..872cf4690 100644 --- a/star/test_suite/check_redo/src/run_star_extras.f90 +++ b/star/test_suite/check_redo/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" logical :: done_redo, doing_restart - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -74,8 +74,8 @@ subroutine extras_startup(id, restart, ierr) doing_restart = .true. end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -129,8 +129,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -142,7 +142,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -153,8 +153,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -168,7 +168,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -183,10 +183,10 @@ integer function extras_finish_step(id) done_redo = .false. end if write(*,*) "check radius", s% r(1)/Rsun - + end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/conductive_flame/src/run.f90 b/star/test_suite/conductive_flame/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/conductive_flame/src/run.f90 +++ b/star/test_suite/conductive_flame/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/conductive_flame/src/run_star_extras.f90 b/star/test_suite/conductive_flame/src/run_star_extras.f90 index 2229026f8..272d7dc9a 100644 --- a/star/test_suite/conductive_flame/src/run_star_extras.f90 +++ b/star/test_suite/conductive_flame/src/run_star_extras.f90 @@ -31,7 +31,7 @@ module run_star_extras implicit none include "test_suite_extras_def.inc" - + real(dp) :: constant_lnP, constant_lnT real(dp) :: flame_position, flame_width, flame_r0, flame_t0 diff --git a/star/test_suite/conserve_angular_momentum/src/run.f90 b/star/test_suite/conserve_angular_momentum/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/conserve_angular_momentum/src/run.f90 +++ b/star/test_suite/conserve_angular_momentum/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/conserve_angular_momentum/src/run_star_extras.f90 b/star/test_suite/conserve_angular_momentum/src/run_star_extras.f90 index e0f1076a3..fad5eca34 100644 --- a/star/test_suite/conserve_angular_momentum/src/run_star_extras.f90 +++ b/star/test_suite/conserve_angular_momentum/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,19 +27,19 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" real(dp) :: total_angular_momentum - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -55,10 +55,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -69,8 +69,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -88,7 +88,7 @@ subroutine extras_after_evolve(id, ierr) end if call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -126,8 +126,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -139,7 +139,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -150,8 +150,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -165,7 +165,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -177,8 +177,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/conv_core_cpm/src/run.f90 b/star/test_suite/conv_core_cpm/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/conv_core_cpm/src/run.f90 +++ b/star/test_suite/conv_core_cpm/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/conv_core_cpm/src/run_star_extras.f90 b/star/test_suite/conv_core_cpm/src/run_star_extras.f90 index c66854172..5168a3cd0 100644 --- a/star/test_suite/conv_core_cpm/src/run_star_extras.f90 +++ b/star/test_suite/conv_core_cpm/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,15 +27,15 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include 'test_suite_extras_def.inc' - + contains include 'test_suite_extras.inc' - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -51,7 +51,7 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% other_photo_read => extras_photo_read s% other_photo_write => extras_photo_write end subroutine extras_controls @@ -69,8 +69,8 @@ subroutine extras_photo_write(id, iounit) integer, intent(in) :: id, iounit !write(iounit) example_of_data_to_save_in_photos end subroutine extras_photo_write - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -81,8 +81,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -97,18 +97,18 @@ subroutine extras_after_evolve(id, ierr) max_mass_conv_core = s% x_ctrl(2) mass_conv_core = s% mass_conv_core - + if ((mass_conv_core .lt. min_mass_conv_core) & .or. (mass_conv_core .gt. max_mass_conv_core)) then write(*,*) 'bad value for mass_conv_core at termination' write(*,*) 'min allowed value', min_mass_conv_core write(*,*) 'mass_conv_core', mass_conv_core - write(*,*) 'max allowed value', max_mass_conv_core + write(*,*) 'max allowed value', max_mass_conv_core else write(*,*) 'Test passed: mass_conv_core within specified range' write(*,*) 'mass_conv_core', mass_conv_core endif - + call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve @@ -133,7 +133,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -146,8 +146,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -159,7 +159,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -170,8 +170,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -185,7 +185,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -197,7 +197,7 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - + end module run_star_extras - + diff --git a/star/test_suite/custom_colors/src/run.f90 b/star/test_suite/custom_colors/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/custom_colors/src/run.f90 +++ b/star/test_suite/custom_colors/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/custom_colors/src/run_star_extras.f90 b/star/test_suite/custom_colors/src/run_star_extras.f90 index 9d9747386..d666c532f 100644 --- a/star/test_suite/custom_colors/src/run_star_extras.f90 +++ b/star/test_suite/custom_colors/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -28,17 +28,17 @@ module run_star_extras use math_lib use auto_diff use colors_lib - + implicit none include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -46,7 +46,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -54,61 +54,61 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - + s% data_for_extra_profile_columns => data_for_extra_profile_columns + #ifdef USE_PGPLOT !Add custom decorator to pgplots s% color_magnitude1_pgstar_decorator => col_mag1_decorator #endif - + end subroutine extras_controls - + #ifdef USE_PGPLOT subroutine col_mag1_decorator(id, xmin, xmax, ymin, ymax, plot_num, ierr) integer, intent(in) :: id !Not dp - real,intent(in) :: xmin, xmax, ymin, ymax + real,intent(in) :: xmin, xmax, ymin, ymax real :: xcenter,ycenter,dx,dy,a integer, intent(in) :: plot_num integer, intent(out) :: ierr integer :: i type (star_info), pointer :: s character(len=20) :: temp - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + dx=(xmax-xmin) dy=(ymax-ymin) - + xcenter = xmin + dx*0.5d0 ycenter = ymin + dy*0.5d0 - + call pgsci(clr_Coral) - + !Add stuff to the top panel in color_magnitude1 - if(plot_num==1) Then + if(plot_num==1) Then a = 0.1d0 call pgline(5, (/xcenter-a*dx,xcenter-a*dx,xcenter+a*dx,xcenter+a*dx,xcenter-a*dx/),& (/ycenter-a*dy,ycenter+a*dy,ycenter+a*dy,ycenter-a*dy,ycenter-a*dy/)) - + else ! Second or higher panel, this function gets called once per panel for the color_magnitude1 plot, so ! num_panel distinguishes between each panel xcenter=xmin+dx*0.75d0 ycenter=ymin+dy*0.25d0 write(temp, '(f10.2)') log10(s%T(s%nz)) - + !xcenter, ycenter is the position, The 45 rotates the text, 0.0 is a padding number then the string follows that call PGPTXT(xcenter,ycenter,45.0d0,0.0d0, 'log T\dc\u='//trim(temp)) end if - - - end subroutine col_mag1_decorator -#endif - - + + + end subroutine col_mag1_decorator +#endif + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -119,8 +119,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -131,11 +131,11 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return write(*,'(a)') 'finished custom colors' - + call test_suite_after_evolve(s, ierr) - + end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -145,7 +145,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -158,8 +158,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 1 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -169,22 +169,22 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - - + + !Here we get the fake av data names(1)='av_v' ! Same name as used in the fake_av_v.txt file for the column - + vals(1)=get_bc_by_name(names(1),safe_log10(s% T(1)),& safe_log10(s% grav(1)),& - ! Normally we have the metalicity as the third parameter here, + ! Normally we have the metalicity as the third parameter here, ! but that is not required. We do not need the Teff or logg either, ! we could do the interpolation over three other parameters or inputs. s%job%extras_rpar(1),ierr) - - + + end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -195,8 +195,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -210,7 +210,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going, retry, or terminate. integer function extras_finish_step(id) @@ -223,8 +223,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/custom_rates/src/run.f90 b/star/test_suite/custom_rates/src/run.f90 index 525b59f92..76d423f1a 100644 --- a/star/test_suite/custom_rates/src/run.f90 +++ b/star/test_suite/custom_rates/src/run.f90 @@ -1,16 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - -end program - \ No newline at end of file + +end program run diff --git a/star/test_suite/custom_rates/src/run_star_extras.f90 b/star/test_suite/custom_rates/src/run_star_extras.f90 index 7de7ebc67..3b8053c04 100644 --- a/star/test_suite/custom_rates/src/run_star_extras.f90 +++ b/star/test_suite/custom_rates/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -78,7 +78,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -88,7 +88,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -101,8 +101,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -114,7 +114,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -125,8 +125,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -140,7 +140,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -152,8 +152,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/diffusion_smoothness/src/run.f90 b/star/test_suite/diffusion_smoothness/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/diffusion_smoothness/src/run.f90 +++ b/star/test_suite/diffusion_smoothness/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/diffusion_smoothness/src/run_star_extras.f90 b/star/test_suite/diffusion_smoothness/src/run_star_extras.f90 index 6e0b61c23..1f0bde6a4 100644 --- a/star/test_suite/diffusion_smoothness/src/run_star_extras.f90 +++ b/star/test_suite/diffusion_smoothness/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,18 +27,18 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -46,7 +46,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -54,10 +54,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -68,8 +68,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -99,10 +99,10 @@ subroutine extras_after_evolve(id, ierr) write(*,1) 'avg d2N2 is too large', sum_d2N2/n end if write(*,'(A)') - end if + end if call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -112,7 +112,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -125,8 +125,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -138,7 +138,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -149,8 +149,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -164,7 +164,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -176,8 +176,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/extended_convective_penetration/src/run.f90 b/star/test_suite/extended_convective_penetration/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/extended_convective_penetration/src/run.f90 +++ b/star/test_suite/extended_convective_penetration/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/extended_convective_penetration/src/run_star_extras.f90 b/star/test_suite/extended_convective_penetration/src/run_star_extras.f90 index 8bb969a5d..fea1bb821 100644 --- a/star/test_suite/extended_convective_penetration/src/run_star_extras.f90 +++ b/star/test_suite/extended_convective_penetration/src/run_star_extras.f90 @@ -53,13 +53,13 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - + s% data_for_extra_profile_columns => data_for_extra_profile_columns + if (s% job% create_pre_main_sequence_model) return - + s% other_adjust_mlt_gradT_fraction => other_adjust_mlt_gradT_fraction_Peclet s% other_overshooting_scheme => extended_convective_penetration - + end subroutine extras_controls subroutine extras_startup(id, restart, ierr) @@ -93,8 +93,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -106,7 +106,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -117,8 +117,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -132,7 +132,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + integer function extras_check_model(id) integer, intent(in) :: id @@ -141,10 +141,10 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model - - + + subroutine extras_after_evolve(id, ierr) use num_lib integer, intent(in) :: id @@ -164,7 +164,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) - + if (s% job% create_pre_main_sequence_model) return write(*,'(A)') @@ -172,7 +172,7 @@ subroutine extras_after_evolve(id, ierr) k2 = 0 k3 = 0 k4 = 0 - + do k = s% nz, 1, -1 if (s% m(k) > 0.8_dp*Msun .and. k1 == 0) k1 = k if (s% m(k) > 0.95_dp*Msun .and. k2 == 0) k2 = k @@ -231,7 +231,7 @@ subroutine check_int(str, val, low, hi) okay = .false. end if end subroutine check_int - + end subroutine extras_after_evolve diff --git a/star/test_suite/gyre_in_mesa_bcep/src/run.f90 b/star/test_suite/gyre_in_mesa_bcep/src/run.f90 index 112660f7c..e049d797a 100644 --- a/star/test_suite/gyre_in_mesa_bcep/src/run.f90 +++ b/star/test_suite/gyre_in_mesa_bcep/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/gyre_in_mesa_bcep/src/run_star_extras.f90 b/star/test_suite/gyre_in_mesa_bcep/src/run_star_extras.f90 index b60405fdf..996914540 100644 --- a/star/test_suite/gyre_in_mesa_bcep/src/run_star_extras.f90 +++ b/star/test_suite/gyre_in_mesa_bcep/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras ! Uses @@ -33,7 +33,7 @@ module run_star_extras use gyre_mesa_m ! No implicit typing - + implicit none include "test_suite_extras_def.inc" @@ -42,7 +42,7 @@ module run_star_extras contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id @@ -59,7 +59,7 @@ subroutine extras_controls(id, ierr) s% extras_finish_step => extras_finish_step s% extras_after_evolve => extras_after_evolve - s% job% warn_run_star_extras =.false. + s% job% warn_run_star_extras =.false. end subroutine extras_controls @@ -77,7 +77,7 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (s% job% create_pre_main_sequence_model) return ! Initialize GYRE @@ -99,28 +99,28 @@ subroutine extras_startup(id, restart, ierr) end subroutine extras_startup !**** - + include 'gyre_in_mesa_extras_finish_step.inc' integer function extras_finish_step(id) integer, intent(in) :: id - integer :: ierr - + integer :: ierr + type (star_info), pointer :: s - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + extras_finish_step = keep_going - + if (s% job% create_pre_main_sequence_model) return - + extras_finish_step = gyre_in_mesa_extras_finish_step(id) - + if (extras_finish_step == terminate) & s% termination_code = t_extras_finish_step - + end function extras_finish_step !**** @@ -129,7 +129,7 @@ subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - + type (star_info), pointer :: s ierr = 0 diff --git a/star/test_suite/gyre_in_mesa_bcep/src/run_star_extras_stub.f90 b/star/test_suite/gyre_in_mesa_bcep/src/run_star_extras_stub.f90 index c8166979f..5ba95be6d 100644 --- a/star/test_suite/gyre_in_mesa_bcep/src/run_star_extras_stub.f90 +++ b/star/test_suite/gyre_in_mesa_bcep/src/run_star_extras_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. diff --git a/star/test_suite/gyre_in_mesa_envelope/src/run.f90 b/star/test_suite/gyre_in_mesa_envelope/src/run.f90 index 112660f7c..e049d797a 100644 --- a/star/test_suite/gyre_in_mesa_envelope/src/run.f90 +++ b/star/test_suite/gyre_in_mesa_envelope/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/gyre_in_mesa_envelope/src/run_star_extras.f90 b/star/test_suite/gyre_in_mesa_envelope/src/run_star_extras.f90 index b60405fdf..996914540 100644 --- a/star/test_suite/gyre_in_mesa_envelope/src/run_star_extras.f90 +++ b/star/test_suite/gyre_in_mesa_envelope/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras ! Uses @@ -33,7 +33,7 @@ module run_star_extras use gyre_mesa_m ! No implicit typing - + implicit none include "test_suite_extras_def.inc" @@ -42,7 +42,7 @@ module run_star_extras contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id @@ -59,7 +59,7 @@ subroutine extras_controls(id, ierr) s% extras_finish_step => extras_finish_step s% extras_after_evolve => extras_after_evolve - s% job% warn_run_star_extras =.false. + s% job% warn_run_star_extras =.false. end subroutine extras_controls @@ -77,7 +77,7 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (s% job% create_pre_main_sequence_model) return ! Initialize GYRE @@ -99,28 +99,28 @@ subroutine extras_startup(id, restart, ierr) end subroutine extras_startup !**** - + include 'gyre_in_mesa_extras_finish_step.inc' integer function extras_finish_step(id) integer, intent(in) :: id - integer :: ierr - + integer :: ierr + type (star_info), pointer :: s - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + extras_finish_step = keep_going - + if (s% job% create_pre_main_sequence_model) return - + extras_finish_step = gyre_in_mesa_extras_finish_step(id) - + if (extras_finish_step == terminate) & s% termination_code = t_extras_finish_step - + end function extras_finish_step !**** @@ -129,7 +129,7 @@ subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - + type (star_info), pointer :: s ierr = 0 diff --git a/star/test_suite/gyre_in_mesa_envelope/src/run_star_extras_stub.f90 b/star/test_suite/gyre_in_mesa_envelope/src/run_star_extras_stub.f90 index c8166979f..5ba95be6d 100644 --- a/star/test_suite/gyre_in_mesa_envelope/src/run_star_extras_stub.f90 +++ b/star/test_suite/gyre_in_mesa_envelope/src/run_star_extras_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. diff --git a/star/test_suite/gyre_in_mesa_ms/src/run.f90 b/star/test_suite/gyre_in_mesa_ms/src/run.f90 index 112660f7c..e049d797a 100644 --- a/star/test_suite/gyre_in_mesa_ms/src/run.f90 +++ b/star/test_suite/gyre_in_mesa_ms/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/gyre_in_mesa_ms/src/run_star_extras.f90 b/star/test_suite/gyre_in_mesa_ms/src/run_star_extras.f90 index b60405fdf..996914540 100644 --- a/star/test_suite/gyre_in_mesa_ms/src/run_star_extras.f90 +++ b/star/test_suite/gyre_in_mesa_ms/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras ! Uses @@ -33,7 +33,7 @@ module run_star_extras use gyre_mesa_m ! No implicit typing - + implicit none include "test_suite_extras_def.inc" @@ -42,7 +42,7 @@ module run_star_extras contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id @@ -59,7 +59,7 @@ subroutine extras_controls(id, ierr) s% extras_finish_step => extras_finish_step s% extras_after_evolve => extras_after_evolve - s% job% warn_run_star_extras =.false. + s% job% warn_run_star_extras =.false. end subroutine extras_controls @@ -77,7 +77,7 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (s% job% create_pre_main_sequence_model) return ! Initialize GYRE @@ -99,28 +99,28 @@ subroutine extras_startup(id, restart, ierr) end subroutine extras_startup !**** - + include 'gyre_in_mesa_extras_finish_step.inc' integer function extras_finish_step(id) integer, intent(in) :: id - integer :: ierr - + integer :: ierr + type (star_info), pointer :: s - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + extras_finish_step = keep_going - + if (s% job% create_pre_main_sequence_model) return - + extras_finish_step = gyre_in_mesa_extras_finish_step(id) - + if (extras_finish_step == terminate) & s% termination_code = t_extras_finish_step - + end function extras_finish_step !**** @@ -129,7 +129,7 @@ subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - + type (star_info), pointer :: s ierr = 0 diff --git a/star/test_suite/gyre_in_mesa_ms/src/run_star_extras_stub.f90 b/star/test_suite/gyre_in_mesa_ms/src/run_star_extras_stub.f90 index c8166979f..5ba95be6d 100644 --- a/star/test_suite/gyre_in_mesa_ms/src/run_star_extras_stub.f90 +++ b/star/test_suite/gyre_in_mesa_ms/src/run_star_extras_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. diff --git a/star/test_suite/gyre_in_mesa_rsg/src/run.f90 b/star/test_suite/gyre_in_mesa_rsg/src/run.f90 index 112660f7c..e049d797a 100644 --- a/star/test_suite/gyre_in_mesa_rsg/src/run.f90 +++ b/star/test_suite/gyre_in_mesa_rsg/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/gyre_in_mesa_rsg/src/run_star_extras.f90 b/star/test_suite/gyre_in_mesa_rsg/src/run_star_extras.f90 index b60405fdf..996914540 100644 --- a/star/test_suite/gyre_in_mesa_rsg/src/run_star_extras.f90 +++ b/star/test_suite/gyre_in_mesa_rsg/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras ! Uses @@ -33,7 +33,7 @@ module run_star_extras use gyre_mesa_m ! No implicit typing - + implicit none include "test_suite_extras_def.inc" @@ -42,7 +42,7 @@ module run_star_extras contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id @@ -59,7 +59,7 @@ subroutine extras_controls(id, ierr) s% extras_finish_step => extras_finish_step s% extras_after_evolve => extras_after_evolve - s% job% warn_run_star_extras =.false. + s% job% warn_run_star_extras =.false. end subroutine extras_controls @@ -77,7 +77,7 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (s% job% create_pre_main_sequence_model) return ! Initialize GYRE @@ -99,28 +99,28 @@ subroutine extras_startup(id, restart, ierr) end subroutine extras_startup !**** - + include 'gyre_in_mesa_extras_finish_step.inc' integer function extras_finish_step(id) integer, intent(in) :: id - integer :: ierr - + integer :: ierr + type (star_info), pointer :: s - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + extras_finish_step = keep_going - + if (s% job% create_pre_main_sequence_model) return - + extras_finish_step = gyre_in_mesa_extras_finish_step(id) - + if (extras_finish_step == terminate) & s% termination_code = t_extras_finish_step - + end function extras_finish_step !**** @@ -129,7 +129,7 @@ subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - + type (star_info), pointer :: s ierr = 0 diff --git a/star/test_suite/gyre_in_mesa_rsg/src/run_star_extras_stub.f90 b/star/test_suite/gyre_in_mesa_rsg/src/run_star_extras_stub.f90 index c8166979f..5ba95be6d 100644 --- a/star/test_suite/gyre_in_mesa_rsg/src/run_star_extras_stub.f90 +++ b/star/test_suite/gyre_in_mesa_rsg/src/run_star_extras_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. diff --git a/star/test_suite/gyre_in_mesa_spb/src/run.f90 b/star/test_suite/gyre_in_mesa_spb/src/run.f90 index 112660f7c..e049d797a 100644 --- a/star/test_suite/gyre_in_mesa_spb/src/run.f90 +++ b/star/test_suite/gyre_in_mesa_spb/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/gyre_in_mesa_spb/src/run_star_extras.f90 b/star/test_suite/gyre_in_mesa_spb/src/run_star_extras.f90 index b60405fdf..996914540 100644 --- a/star/test_suite/gyre_in_mesa_spb/src/run_star_extras.f90 +++ b/star/test_suite/gyre_in_mesa_spb/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras ! Uses @@ -33,7 +33,7 @@ module run_star_extras use gyre_mesa_m ! No implicit typing - + implicit none include "test_suite_extras_def.inc" @@ -42,7 +42,7 @@ module run_star_extras contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id @@ -59,7 +59,7 @@ subroutine extras_controls(id, ierr) s% extras_finish_step => extras_finish_step s% extras_after_evolve => extras_after_evolve - s% job% warn_run_star_extras =.false. + s% job% warn_run_star_extras =.false. end subroutine extras_controls @@ -77,7 +77,7 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (s% job% create_pre_main_sequence_model) return ! Initialize GYRE @@ -99,28 +99,28 @@ subroutine extras_startup(id, restart, ierr) end subroutine extras_startup !**** - + include 'gyre_in_mesa_extras_finish_step.inc' integer function extras_finish_step(id) integer, intent(in) :: id - integer :: ierr - + integer :: ierr + type (star_info), pointer :: s - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + extras_finish_step = keep_going - + if (s% job% create_pre_main_sequence_model) return - + extras_finish_step = gyre_in_mesa_extras_finish_step(id) - + if (extras_finish_step == terminate) & s% termination_code = t_extras_finish_step - + end function extras_finish_step !**** @@ -129,7 +129,7 @@ subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - + type (star_info), pointer :: s ierr = 0 diff --git a/star/test_suite/gyre_in_mesa_spb/src/run_star_extras_stub.f90 b/star/test_suite/gyre_in_mesa_spb/src/run_star_extras_stub.f90 index c8166979f..5ba95be6d 100644 --- a/star/test_suite/gyre_in_mesa_spb/src/run_star_extras_stub.f90 +++ b/star/test_suite/gyre_in_mesa_spb/src/run_star_extras_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. diff --git a/star/test_suite/gyre_in_mesa_wd/src/run.f90 b/star/test_suite/gyre_in_mesa_wd/src/run.f90 index 112660f7c..e049d797a 100644 --- a/star/test_suite/gyre_in_mesa_wd/src/run.f90 +++ b/star/test_suite/gyre_in_mesa_wd/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/gyre_in_mesa_wd/src/run_star_extras.f90 b/star/test_suite/gyre_in_mesa_wd/src/run_star_extras.f90 index b60405fdf..996914540 100644 --- a/star/test_suite/gyre_in_mesa_wd/src/run_star_extras.f90 +++ b/star/test_suite/gyre_in_mesa_wd/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras ! Uses @@ -33,7 +33,7 @@ module run_star_extras use gyre_mesa_m ! No implicit typing - + implicit none include "test_suite_extras_def.inc" @@ -42,7 +42,7 @@ module run_star_extras contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id @@ -59,7 +59,7 @@ subroutine extras_controls(id, ierr) s% extras_finish_step => extras_finish_step s% extras_after_evolve => extras_after_evolve - s% job% warn_run_star_extras =.false. + s% job% warn_run_star_extras =.false. end subroutine extras_controls @@ -77,7 +77,7 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (s% job% create_pre_main_sequence_model) return ! Initialize GYRE @@ -99,28 +99,28 @@ subroutine extras_startup(id, restart, ierr) end subroutine extras_startup !**** - + include 'gyre_in_mesa_extras_finish_step.inc' integer function extras_finish_step(id) integer, intent(in) :: id - integer :: ierr - + integer :: ierr + type (star_info), pointer :: s - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + extras_finish_step = keep_going - + if (s% job% create_pre_main_sequence_model) return - + extras_finish_step = gyre_in_mesa_extras_finish_step(id) - + if (extras_finish_step == terminate) & s% termination_code = t_extras_finish_step - + end function extras_finish_step !**** @@ -129,7 +129,7 @@ subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - + type (star_info), pointer :: s ierr = 0 diff --git a/star/test_suite/gyre_in_mesa_wd/src/run_star_extras_stub.f90 b/star/test_suite/gyre_in_mesa_wd/src/run_star_extras_stub.f90 index c8166979f..5ba95be6d 100644 --- a/star/test_suite/gyre_in_mesa_wd/src/run_star_extras_stub.f90 +++ b/star/test_suite/gyre_in_mesa_wd/src/run_star_extras_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. diff --git a/star/test_suite/hb_2M/src/run.f90 b/star/test_suite/hb_2M/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/hb_2M/src/run.f90 +++ b/star/test_suite/hb_2M/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/hb_2M/src/run_star_extras.f90 b/star/test_suite/hb_2M/src/run_star_extras.f90 index bddf2b33a..716bd9c69 100644 --- a/star/test_suite/hb_2M/src/run_star_extras.f90 +++ b/star/test_suite/hb_2M/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,18 +27,18 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none real(dp) :: mass_conv_core_y050 - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_photo_read(id, iounit, ierr) integer, intent(in) :: id, iounit integer, intent(out) :: ierr @@ -82,7 +82,7 @@ subroutine extras_controls(id, ierr) s% other_photo_read => extras_photo_read s% other_photo_write => extras_photo_write - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -90,10 +90,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -110,8 +110,8 @@ subroutine extras_startup(id, restart, ierr) call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -151,7 +151,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -161,7 +161,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -174,8 +174,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 1 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -189,7 +189,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) names(1) = 'mass_conv_core_y050' end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -200,8 +200,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -219,7 +219,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(k,1) = s% zbar(k)/s% abar(k) end do end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -240,8 +240,8 @@ integer function extras_finish_step(id) end if end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/high_mass/src/run.f90 b/star/test_suite/high_mass/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/high_mass/src/run.f90 +++ b/star/test_suite/high_mass/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/high_mass/src/run_star_extras.f90 b/star/test_suite/high_mass/src/run_star_extras.f90 index c9d33225a..2406f9a01 100644 --- a/star/test_suite/high_mass/src/run_star_extras.f90 +++ b/star/test_suite/high_mass/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -79,7 +79,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -89,7 +89,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -102,8 +102,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -115,7 +115,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -126,8 +126,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -141,7 +141,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -153,8 +153,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/high_rot_darkening/src/run.f90 b/star/test_suite/high_rot_darkening/src/run.f90 index 112660f7c..e049d797a 100644 --- a/star/test_suite/high_rot_darkening/src/run.f90 +++ b/star/test_suite/high_rot_darkening/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/high_rot_darkening/src/run_star_extras.f90 b/star/test_suite/high_rot_darkening/src/run_star_extras.f90 index af36fba5c..6b79f8bce 100644 --- a/star/test_suite/high_rot_darkening/src/run_star_extras.f90 +++ b/star/test_suite/high_rot_darkening/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,8 +19,8 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - - module run_star_extras + + module run_star_extras use star_lib use star_def @@ -30,20 +30,20 @@ module run_star_extras use const_def use chem_def use num_lib - + implicit none - + include "test_suite_extras_def.inc" integer, parameter :: restart_info_alloc = 1 integer, parameter :: restart_info_get = 2 integer, parameter :: restart_info_put = 3 - - + + contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -51,10 +51,10 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + ! this is the place to set any procedure pointers you want to change ! e.g., other_wind, other_mixing, other_energy (see star_data.inc) - + s% extras_startup => extras_startup s% extras_start_step => extras_start_step s% extras_check_model => extras_check_model @@ -63,12 +63,12 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% job% warn_run_star_extras=.false. end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -81,7 +81,7 @@ subroutine extras_startup(id, restart, ierr) call test_suite_startup(s, restart, ierr) end subroutine extras_startup - + integer function extras_start_step(id) integer, intent(in) :: id integer :: ierr @@ -109,8 +109,8 @@ integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_profile_column_name) :: names(n) @@ -123,13 +123,13 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer, intent(in) :: id, n, nz character (len=maxlen_profile_column_name) :: names(n) @@ -141,7 +141,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + integer function extras_finish_step(id) integer, intent(in) :: id @@ -152,7 +152,7 @@ integer function extras_finish_step(id) call star_ptr(id, s, ierr) if (ierr /= 0) return extras_finish_step = keep_going - + if (s% job% create_pre_main_sequence_model) return write(*,*) "omega/omega_crit is:", s% w_div_w_crit_avg_surf,& @@ -170,7 +170,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + end module run_star_extras - + diff --git a/star/test_suite/high_z/src/run.f90 b/star/test_suite/high_z/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/high_z/src/run.f90 +++ b/star/test_suite/high_z/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/high_z/src/run_star_extras.f90 b/star/test_suite/high_z/src/run_star_extras.f90 index 53c1d7a32..b98eb72fa 100644 --- a/star/test_suite/high_z/src/run_star_extras.f90 +++ b/star/test_suite/high_z/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -80,7 +80,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -90,7 +90,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -103,8 +103,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -116,7 +116,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -127,8 +127,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -142,7 +142,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -154,8 +154,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/hot_cool_wind/src/run.f90 b/star/test_suite/hot_cool_wind/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/hot_cool_wind/src/run.f90 +++ b/star/test_suite/hot_cool_wind/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/hot_cool_wind/src/run_star_extras.f90 b/star/test_suite/hot_cool_wind/src/run_star_extras.f90 index ff487ba1d..15f3c9133 100644 --- a/star/test_suite/hot_cool_wind/src/run_star_extras.f90 +++ b/star/test_suite/hot_cool_wind/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -91,7 +91,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -101,7 +101,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -114,8 +114,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -127,7 +127,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -138,8 +138,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -153,7 +153,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -165,8 +165,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/hse_riemann/src/run.f90 b/star/test_suite/hse_riemann/src/run.f90 index 112660f7c..e049d797a 100644 --- a/star/test_suite/hse_riemann/src/run.f90 +++ b/star/test_suite/hse_riemann/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/hse_riemann/src/run_star_extras.f90 b/star/test_suite/hse_riemann/src/run_star_extras.f90 index 5d643c04d..91cb6a87f 100644 --- a/star/test_suite/hse_riemann/src/run_star_extras.f90 +++ b/star/test_suite/hse_riemann/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -28,16 +28,16 @@ module run_star_extras use math_lib use auto_diff use utils_lib, only: mesa_error - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - + s% data_for_extra_profile_columns => data_for_extra_profile_columns + end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -93,7 +93,7 @@ subroutine extras_after_evolve(id, ierr) end if call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -103,7 +103,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -116,8 +116,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -131,7 +131,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (n == 0) return call star_ptr(id, s, ierr) if (ierr /= 0) return - + names(1) = 'Pmax_P' names(2) = 'Pmax_r_1m13' names(3) = 'Pmax_v' @@ -144,13 +144,13 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) names(10) = 'log_Pmax_T' names(11) = 'Pmax_r_div_t' names(12) = 'Pmax_m_div_Msun' - + k = maxloc(s% Peos(1:s% nz), dim=1) if (k == s% nz) k = s% nz-1 t = s% time - + !write(*,2) 'Pmax k r*1d-13', k, 0.5d0*(s% r(k)+s% r(k+1))*1d-13 - + vals(1) = s% Peos(k) ! Pmax_P vals(2) = 0.5d0*(s% r(k)+s% r(k+1))*1d-13 ! Pmax_r_1m13 vals(3) = 0.5d0*(s% v(k)+s% v(k+1)) ! Pmax_v @@ -163,10 +163,10 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) vals(10) = log10(s% T(k)) ! Pmax_T vals(11) = 0.5d0*(s% r(k)+s% r(k+1))/s% time ! Pmax_r_div_t vals(12) = s% m(k)/Msun ! Pmax_m_div_Msun - + end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -177,8 +177,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp, avo, kerg @@ -194,7 +194,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. @@ -217,9 +217,9 @@ integer function extras_finish_step(id) end if end do end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/irradiated_planet/src/run.f90 b/star/test_suite/irradiated_planet/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/irradiated_planet/src/run.f90 +++ b/star/test_suite/irradiated_planet/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/irradiated_planet/src/run_star_extras.f90 b/star/test_suite/irradiated_planet/src/run_star_extras.f90 index c9d33225a..2406f9a01 100644 --- a/star/test_suite/irradiated_planet/src/run_star_extras.f90 +++ b/star/test_suite/irradiated_planet/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -79,7 +79,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -89,7 +89,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -102,8 +102,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -115,7 +115,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -126,8 +126,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -141,7 +141,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -153,8 +153,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/low_z/src/run.f90 b/star/test_suite/low_z/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/low_z/src/run.f90 +++ b/star/test_suite/low_z/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/low_z/src/run_star_extras.f90 b/star/test_suite/low_z/src/run_star_extras.f90 index 7b7dd0610..f27c4353b 100644 --- a/star/test_suite/low_z/src/run_star_extras.f90 +++ b/star/test_suite/low_z/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -61,8 +61,8 @@ subroutine extras_controls(id, ierr) s% data_for_extra_profile_header_items => data_for_extra_profile_header_items end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -73,8 +73,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -85,7 +85,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -95,7 +95,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model integer function how_many_extra_history_columns(id) @@ -107,7 +107,7 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - + integer function how_many_extra_history_header_items(id) integer, intent(in) :: id @@ -166,7 +166,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -177,8 +177,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -192,7 +192,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -204,8 +204,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/magnetic_braking/src/run.f90 b/star/test_suite/magnetic_braking/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/magnetic_braking/src/run.f90 +++ b/star/test_suite/magnetic_braking/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/magnetic_braking/src/run_star_extras.f90 b/star/test_suite/magnetic_braking/src/run_star_extras.f90 index 5720fcada..273a933a9 100644 --- a/star/test_suite/magnetic_braking/src/run_star_extras.f90 +++ b/star/test_suite/magnetic_braking/src/run_star_extras.f90 @@ -100,7 +100,7 @@ subroutine magnetic_braking(id, ierr) ! Calculate total angular momentum j_tot = dot_product(s% j_rot(1:s% nz),s% dm_bar(1:s% nz)) ! g cm^2/s Total Stellar Angular Momentum Content - + if ((s% mstar_dot /= 0) .and. (j_tot .gt. 1d50) .and. (v_rot .gt. 0.8d5)) then ! Only 'brake' when mass is lost and star has non-negligible amount of angular momentum write(*,*) 'j_tot: ', j_tot, s% omega(1), v_rot/1d5 !Calculate V_inf of stellar wind (e.g. Vinf = 1.92 Vesc, see Lamers & Cassinelli 2000) @@ -208,7 +208,7 @@ subroutine extras_after_evolve(id, ierr) end if call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. diff --git a/star/test_suite/make_brown_dwarf/src/run.f90 b/star/test_suite/make_brown_dwarf/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/make_brown_dwarf/src/run.f90 +++ b/star/test_suite/make_brown_dwarf/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/make_brown_dwarf/src/run_star_extras.f90 b/star/test_suite/make_brown_dwarf/src/run_star_extras.f90 index 7de7ebc67..3b8053c04 100644 --- a/star/test_suite/make_brown_dwarf/src/run_star_extras.f90 +++ b/star/test_suite/make_brown_dwarf/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -78,7 +78,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -88,7 +88,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -101,8 +101,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -114,7 +114,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -125,8 +125,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -140,7 +140,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -152,8 +152,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/make_co_wd/src/run.f90 b/star/test_suite/make_co_wd/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/make_co_wd/src/run.f90 +++ b/star/test_suite/make_co_wd/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/make_co_wd/src/run_star_extras.f90 b/star/test_suite/make_co_wd/src/run_star_extras.f90 index 67a4d8bf4..522b01520 100644 --- a/star/test_suite/make_co_wd/src/run_star_extras.f90 +++ b/star/test_suite/make_co_wd/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -80,8 +80,8 @@ subroutine extras_startup(id, restart, ierr) end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -92,28 +92,28 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) use chem_def, only: icc integer, intent(in) :: id integer :: ierr - + real(dp), parameter :: Blocker_scaling_factor_after_TP = 5d0 type (star_info), pointer :: s ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + include 'formats' - + extras_check_model = keep_going ! check for c12_c12 burning that will make an ONe WD. if(s% L_by_category(icc) > 1d4) then write(*,'(A)') - write(*,*) "This model is too massive." + write(*,*) "This model is too massive." write(*,*) "Carbon has ignited in the interior and will produce an ONe WD." write(*,'(A)') extras_check_model = terminate @@ -128,7 +128,7 @@ integer function extras_check_model(id) s% do_element_diffusion = .true. end if end if - + end function extras_check_model @@ -141,8 +141,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -154,7 +154,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -165,8 +165,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -179,7 +179,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -206,7 +206,7 @@ integer function extras_finish_step(id) end do do k = kbot, 1, -1 if (s% m(k) > bottom_mass + H_env_limit*Msun) then - + write(*,2) 'call star_remove_surface_at_cell_k', k, s% m(k)/Msun call star_remove_surface_at_cell_k(s% id, k, ierr) if (ierr /= 0) then @@ -214,20 +214,20 @@ integer function extras_finish_step(id) extras_finish_step = terminate return end if - + !call star_relax_to_star_cut(s% id, k, .false., .true., .true., ierr) - - + + s% lxtra(1) = .true. exit end if end do end if end if - + end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/make_env/src/run.f90 b/star/test_suite/make_env/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/make_env/src/run.f90 +++ b/star/test_suite/make_env/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/make_env/src/run_star_extras.f90 b/star/test_suite/make_env/src/run_star_extras.f90 index 131977dca..ab4b8f7ea 100644 --- a/star/test_suite/make_env/src/run_star_extras.f90 +++ b/star/test_suite/make_env/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,12 +27,12 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - - include "test_suite_extras_def.inc" - - + + include "test_suite_extras_def.inc" + + contains include "test_suite_extras.inc" @@ -43,7 +43,7 @@ subroutine extras_controls(id, ierr) type (star_info), pointer :: s ierr = 0 call star_ptr(id, s, ierr) - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -51,15 +51,15 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - + s% data_for_extra_profile_columns => data_for_extra_profile_columns + if (.not. s% x_logical_ctrl(1)) return - + call create_env(id, s, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in create_env') end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -70,8 +70,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -82,7 +82,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -106,8 +106,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -119,7 +119,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -130,8 +130,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -145,7 +145,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -157,15 +157,15 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + subroutine create_env(id, s, ierr) use eos_lib use eos_def, only: i_lnfree_e, num_eos_basic_results, num_eos_d_dxa_results use chem_lib, only: basic_composition_info use utils_lib, only: is_bad use atm_lib, only: atm_Teff - + integer, intent(in) :: id type (star_info), pointer :: s integer, intent(out) :: ierr @@ -191,15 +191,15 @@ subroutine create_env(id, s, ierr) real(dp), allocatable :: dres_dxa(:,:) real(dp), parameter :: LOGRHO_TOL = 1d-11 real(dp), parameter :: LOGPGAS_TOL = 1d-11 - + include 'formats' - + ierr = 0 - + nz = s% x_integer_ctrl(1) - s% nz = nz + s% nz = nz max_iters = 100 - + net_name = s% x_character_ctrl(1) s% mstar = s% x_ctrl(1)*Msun s% xmstar = s% x_ctrl(2)*s% mstar @@ -207,17 +207,17 @@ subroutine create_env(id, s, ierr) s% star_mass = s% mstar/Msun call star_set_net(id, net_name, ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_set_net') - + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_set_net') + call star_set_var_info(id, ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_set_var_info') - + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_set_var_info') + call star_set_chem_names(id, ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_set_chem_names') - + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_set_chem_names') + call star_allocate_arrays(id, ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_allocate_arrays') - + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_allocate_arrays') + s% m(1) = s% mstar s% m_grav(1) = s% mstar s% cgrav(1) = standard_cgrav @@ -226,7 +226,7 @@ subroutine create_env(id, s, ierr) species = s% species allocate(dres_dxa(num_eos_d_dxa_results, species)) - + if (s% x_logical_ctrl(2)) then ! R and L in cgs units s% r(1) = s% x_ctrl(3) s% L(1:nz) = s% x_ctrl(4) @@ -246,19 +246,19 @@ subroutine create_env(id, s, ierr) write(*,1) 's% r(1)/r_phot', s% r(1)/r_phot end if end if - + i_lnd = s% i_lnd i_lnR = s% i_lnR i_lnT = s% i_lnT i_lum = s% i_lum s% L_center = s% L(nz) - s% r_start(1) = s% r(1) - + s% r_start(1) = s% r(1) + ln_dq1 = s% x_ctrl(5)*ln10 dq1 = exp(ln_dq1) dq_factor = calc_dq_factor(nz,dq1) - + s% q(1) = 1d0 s% dq(1) = dq1 do k=2, nz @@ -267,19 +267,19 @@ subroutine create_env(id, s, ierr) end do call star_normalize_dqs(s% id, nz, s% dq, ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_normalize_dqs') + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_normalize_dqs') call star_set_qs(s% id, nz, s% q, s% dq, ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_set_qs') - + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_set_qs') + call star_set_m_and_dm(s% id, ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_set_qs') - + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_set_qs') + call star_set_dm_bar(s% id, ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_set_dm_bar') - + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_set_dm_bar') + call change_to_xa_for_accretion(s% id, 1, nz, ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in change_to_xa_for_accretion') + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in change_to_xa_for_accretion') do k=1,nz s% m_grav(k) = s% m(k) @@ -314,7 +314,7 @@ subroutine create_env(id, s, ierr) s% r(1) = s% r(1)*pow2(s% Teff/Teff) write(*,1) 'new r(1)', s% r(1) end if - + ! do cell k=1 and then redo the atm. T_m1 = T_surf P_m1 = P_surf @@ -344,7 +344,7 @@ subroutine create_env(id, s, ierr) T_m1 = T_surf P_m1 = P_surf logRho_m1 = logRho - + do k=1,nz call do1_cell(ierr) if (ierr /= 0) then @@ -355,14 +355,14 @@ subroutine create_env(id, s, ierr) P_m1 = P_00 logRho_m1 = logRho end do - + s% model_number = 0 s% star_age = 0 - s% crystal_core_boundary_mass = -1d0 - + s% crystal_core_boundary_mass = -1d0 + write(*,2) 'start.mod', nz call star_write_model(id, 'start.mod', ierr) - if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_write_model') + if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in star_write_model') write(*,'(A)') write(*,*) 'finished create_env' @@ -370,10 +370,10 @@ subroutine create_env(id, s, ierr) !stop deallocate(dres_dxa) - + contains - + subroutine get_initial_guess_for_atm(ierr) integer, intent(out) :: ierr skip_partials = .true. @@ -403,7 +403,7 @@ subroutine get_initial_guess_for_atm(ierr) end if end subroutine get_initial_guess_for_atm - + subroutine get_atm(ierr) integer, intent(out) :: ierr logical, parameter :: & @@ -440,8 +440,8 @@ subroutine get_atm(ierr) stop end if end subroutine get_atm - - + + subroutine do1_cell(ierr) ! uses r(k), T_m1, P_m1, logRho_m1 use eos_def, only: i_grad_ad integer, intent(out) :: ierr @@ -450,14 +450,14 @@ subroutine do1_cell(ierr) ! uses r(k), T_m1, P_m1, logRho_m1 r_00 = s% r(k) s% cgrav(k) = standard_cgrav grav = -s% cgrav(k)*s% m(k)/r_00**2 - + if (k > 1) then dm_face = 0.5d0*(s% dm(k) + s% dm(k-1)) else ! k == 1 dm_face = 0.5d0*s% dm(k) end if area = 4d0*pi*r_00**2 - + P_00 = P_m1 - grav*dm_face/area P_face = 0.5d0*(P_m1 + P_00) dlnP_face = (P_m1 - P_00)/P_face @@ -466,7 +466,7 @@ subroutine do1_cell(ierr) ! uses r(k), T_m1, P_m1, logRho_m1 Prad = one_third*crad*pow4(T_00) Pgas = P_00 - Prad logT = log10(T_00) - + call star_solve_eos_given_PgasT( & s% id, k, s% xa(:,k), & logT, log10(Pgas), logRho_m1, LOGRHO_TOL, LOGPGAS_TOL, & @@ -486,7 +486,7 @@ subroutine do1_cell(ierr) ! uses r(k), T_m1, P_m1, logRho_m1 write(*, *) 'Call star_do_eos_for_cell failed', k stop end if - + s% extra_opacity_factor(k) = 1d0 call star_do_kap_for_cell(s% id, k, ierr) if (ierr /= 0) then @@ -501,16 +501,16 @@ subroutine do1_cell(ierr) ! uses r(k), T_m1, P_m1, logRho_m1 s% mlt_gradT_fraction = -1d0 s% adjust_mlt_gradT_fraction(k) = -1d0 s% gradL_composition_term(k) = 0d0 - + ! skipping use_other_alpha_mlt and other_gradr_factor s% alpha_mlt(k) = s% mixing_length_alpha - s% gradr_factor(k) = 1d0 + s% gradr_factor(k) = 1d0 call star_set_mlt_vars(s% id, k, k, ierr) if (ierr /= 0) then write(*, *) 'Call set_mlt_vars failed', k stop end if - + gradT = s% gradT(k) d_gradT_dT = s% gradT_ad(k)%d1Array(i_lnT_00)/T_00 T_face = 0.5d0*(T_m1 + T_00) @@ -527,7 +527,7 @@ subroutine do1_cell(ierr) ! uses r(k), T_m1, P_m1, logRho_m1 end if T_00 = T_00 + dT end do - + rho_00 = exp10(logRho) vol = four_thirds*pi*pow3(r_00) - s% dm(k)/rho_00 r_p1 = pow(0.75d0*vol/pi, one_third) @@ -536,7 +536,7 @@ subroutine do1_cell(ierr) ! uses r(k), T_m1, P_m1, logRho_m1 else s% r(k+1) = r_p1 end if - + s% lnR(k) = log(r_00) s% xh(i_lnR, k) = s% lnR(k) s% lnd(k) = log(rho_00) @@ -544,10 +544,10 @@ subroutine do1_cell(ierr) ! uses r(k), T_m1, P_m1, logRho_m1 s% lnT(k) = log(T_00) s% xh(i_lnT, k) = s% lnT(k) s% xh(i_lum, k) = s% L(k) - + end subroutine do1_cell - - + + real(dp) function dq_f(r, dfdr, lrpar, rpar, lipar, ipar, ierr) ! returns with ierr = 0 if was able to evaluate f and df/dx at x ! if df/dx not available, it is okay to set it to 0 @@ -570,7 +570,7 @@ real(dp) function dq_f(r, dfdr, lrpar, rpar, lipar, ipar, ierr) ipar(2) = ipar(2) + 1 !write(*,*) ipar(2), 'r, dq_f, dfdr', r, dq_f, dfdr end function dq_f - + real(dp) function calc_dq_factor(n,dq1) result(dq_factor) use num_lib, only: safe_root_with_guess integer, intent(in) :: n @@ -581,7 +581,7 @@ real(dp) function calc_dq_factor(n,dq1) result(dq_factor) integer, target :: ipar_array(lipar) integer, pointer :: ipar(:) ! (lipar) real(dp), target :: rpar_array(lrpar) - real(dp), pointer :: rpar(:) ! (lrpar) + real(dp), pointer :: rpar(:) ! (lrpar) include 'formats' ierr = 0 ipar => ipar_array @@ -605,9 +605,9 @@ real(dp) function calc_dq_factor(n,dq1) result(dq_factor) !write(*,*) 'dq_factor', dq_factor !stop end function calc_dq_factor - + end subroutine create_env - + end module run_star_extras - + diff --git a/star/test_suite/make_he_wd/src/run.f90 b/star/test_suite/make_he_wd/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/make_he_wd/src/run.f90 +++ b/star/test_suite/make_he_wd/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/make_he_wd/src/run_star_extras.f90 b/star/test_suite/make_he_wd/src/run_star_extras.f90 index c9d33225a..2406f9a01 100644 --- a/star/test_suite/make_he_wd/src/run_star_extras.f90 +++ b/star/test_suite/make_he_wd/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -79,7 +79,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -89,7 +89,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -102,8 +102,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -115,7 +115,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -126,8 +126,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -141,7 +141,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -153,8 +153,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/make_metals/src/run.f90 b/star/test_suite/make_metals/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/make_metals/src/run.f90 +++ b/star/test_suite/make_metals/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/make_metals/src/run_star_extras.f90 b/star/test_suite/make_metals/src/run_star_extras.f90 index 38f09b7c2..ac04a441f 100644 --- a/star/test_suite/make_metals/src/run_star_extras.f90 +++ b/star/test_suite/make_metals/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,16 +27,16 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -44,7 +44,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -78,7 +78,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -88,7 +88,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -101,8 +101,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -114,7 +114,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -125,8 +125,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -140,7 +140,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -152,8 +152,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/make_o_ne_wd/src/run.f90 b/star/test_suite/make_o_ne_wd/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/make_o_ne_wd/src/run.f90 +++ b/star/test_suite/make_o_ne_wd/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/make_o_ne_wd/src/run_star_extras.f90 b/star/test_suite/make_o_ne_wd/src/run_star_extras.f90 index 7848c97fe..23b421562 100644 --- a/star/test_suite/make_o_ne_wd/src/run_star_extras.f90 +++ b/star/test_suite/make_o_ne_wd/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,16 +27,16 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -44,7 +44,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,8 +67,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -79,25 +79,25 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) integer, intent(in) :: id integer :: ierr - + real(dp), parameter :: Blocker_scaling_factor_after_TP = 5d0 type (star_info), pointer :: s ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + include 'formats' - + extras_check_model = keep_going - + !if (abs(s% Blocker_scaling_factor - Blocker_scaling_factor_after_TP) < 1d-8) return - + !if (s% center_he4 < 1d-4 .and. & ! any(s% burn_he_conv_region(1:s% num_conv_boundaries)) .and. & ! s% he_core_mass - s% c_core_mass <= s% TP_he_shell_max) then @@ -107,7 +107,7 @@ integer function extras_check_model(id) ! extras_check_model = terminate ! s% termination_code = t_extras_finish_step !end if - + end function extras_check_model @@ -120,8 +120,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -133,7 +133,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -144,8 +144,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -158,7 +158,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -182,8 +182,8 @@ integer function extras_finish_step(id) end if end if end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/make_planets/src/run.f90 b/star/test_suite/make_planets/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/make_planets/src/run.f90 +++ b/star/test_suite/make_planets/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/make_planets/src/run_star_extras.f90 b/star/test_suite/make_planets/src/run_star_extras.f90 index 31ee2dd86..add8ac2e1 100644 --- a/star/test_suite/make_planets/src/run_star_extras.f90 +++ b/star/test_suite/make_planets/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,15 +27,15 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -43,7 +43,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -51,10 +51,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -65,8 +65,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -77,7 +77,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -87,7 +87,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -100,8 +100,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -113,7 +113,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -124,8 +124,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -139,7 +139,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -151,8 +151,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/make_pre_ccsn_13bvn/src/run.f90 b/star/test_suite/make_pre_ccsn_13bvn/src/run.f90 index 5c29c6a80..916b29a68 100644 --- a/star/test_suite/make_pre_ccsn_13bvn/src/run.f90 +++ b/star/test_suite/make_pre_ccsn_13bvn/src/run.f90 @@ -1,18 +1,18 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr character (len=32) :: inlist_fname - + ierr = 0 inlist_fname = 'inlist' - + call do_read_star_job(inlist_fname, ierr) if (ierr /= 0) stop 1 - + call do_run_star(inlist_fname) - + end program diff --git a/star/test_suite/make_pre_ccsn_13bvn/src/run_star_extras.f90 b/star/test_suite/make_pre_ccsn_13bvn/src/run_star_extras.f90 index 3dba3ddf8..8960ff9a0 100644 --- a/star/test_suite/make_pre_ccsn_13bvn/src/run_star_extras.f90 +++ b/star/test_suite/make_pre_ccsn_13bvn/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,25 +19,25 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def use math_lib - + implicit none include "test_suite_extras_def.inc" - + integer, parameter :: I_INLIST_PART = 1 ! inlist part number contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,7 +53,7 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% other_alpha_mlt => alpha_mlt_routine end subroutine extras_controls @@ -86,12 +86,12 @@ subroutine alpha_mlt_routine(id, ierr) else s% alpha_mlt(k) = alpha_other end if - !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), + !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), end do !stop end subroutine alpha_mlt_routine - - + + !integer function extras_startup(id, restart, ierr) subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id @@ -103,8 +103,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -115,7 +115,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, backup, or terminate. integer function extras_check_model(id) @@ -138,8 +138,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 1 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -167,7 +167,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -178,8 +178,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 3 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -211,7 +211,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end if end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_start_step(id) integer, intent(in) :: id @@ -256,10 +256,10 @@ subroutine extras_photo_read(id, iounit, ierr) integer :: inlist_part type (star_info), pointer :: s ierr = 0 - + call star_ptr(id, s, ierr) if (ierr /= 0) return - + read(iounit,iostat=ierr) inlist_part if(inlist_part/= s% x_integer_ctrl(I_INLIST_PART)) then @@ -269,19 +269,19 @@ subroutine extras_photo_read(id, iounit, ierr) end if end subroutine extras_photo_read - + subroutine extras_photo_write(id, iounit) integer, intent(in) :: id, iounit integer :: ierr type (star_info), pointer :: s ierr = 0 - + call star_ptr(id, s, ierr) if (ierr /= 0) return - + write(iounit) s% x_integer_ctrl(I_INLIST_PART) - + end subroutine extras_photo_write end module run_star_extras - + diff --git a/star/test_suite/make_sdb/src/run.f90 b/star/test_suite/make_sdb/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/make_sdb/src/run.f90 +++ b/star/test_suite/make_sdb/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/make_sdb/src/run_star_extras.f90 b/star/test_suite/make_sdb/src/run_star_extras.f90 index 131e84f91..aea8d1eb2 100644 --- a/star/test_suite/make_sdb/src/run_star_extras.f90 +++ b/star/test_suite/make_sdb/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -75,10 +75,10 @@ subroutine extras_startup(id, restart, ierr) ! Turn off winds because already below specified threshold. s% Reimers_scaling_factor = 0d0 s% Blocker_scaling_factor = 0d0 - end if + end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -89,7 +89,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -103,7 +103,7 @@ integer function extras_check_model(id) h_upper_limit = s% x_ctrl(1) h_lower_limit = (1d0 - s% x_ctrl(2))*h_upper_limit - + h_env_mass = s% star_mass - s% he_core_mass if(h_env_mass > h_upper_limit) then @@ -129,8 +129,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -142,7 +142,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -153,8 +153,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -168,7 +168,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -180,8 +180,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/make_zams/src/run.f90 b/star/test_suite/make_zams/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/make_zams/src/run.f90 +++ b/star/test_suite/make_zams/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/make_zams/src/run_star_extras.f90 b/star/test_suite/make_zams/src/run_star_extras.f90 index f30dec564..b76b20ade 100644 --- a/star/test_suite/make_zams/src/run_star_extras.f90 +++ b/star/test_suite/make_zams/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,15 +27,15 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include 'test_suite_extras_def.inc' - + contains include 'test_suite_extras.inc' - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -51,10 +51,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -65,8 +65,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -98,7 +98,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -111,8 +111,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -124,7 +124,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -135,8 +135,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -150,7 +150,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -163,8 +163,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/make_zams_low_mass/src/run.f90 b/star/test_suite/make_zams_low_mass/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/make_zams_low_mass/src/run.f90 +++ b/star/test_suite/make_zams_low_mass/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/make_zams_low_mass/src/run_star_extras.f90 b/star/test_suite/make_zams_low_mass/src/run_star_extras.f90 index f30dec564..b76b20ade 100644 --- a/star/test_suite/make_zams_low_mass/src/run_star_extras.f90 +++ b/star/test_suite/make_zams_low_mass/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,15 +27,15 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include 'test_suite_extras_def.inc' - + contains include 'test_suite_extras.inc' - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -51,10 +51,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -65,8 +65,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -98,7 +98,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -111,8 +111,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -124,7 +124,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -135,8 +135,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -150,7 +150,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -163,8 +163,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/make_zams_ultra_high_mass/src/run.f90 b/star/test_suite/make_zams_ultra_high_mass/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/make_zams_ultra_high_mass/src/run.f90 +++ b/star/test_suite/make_zams_ultra_high_mass/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/make_zams_ultra_high_mass/src/run_star_extras.f90 b/star/test_suite/make_zams_ultra_high_mass/src/run_star_extras.f90 index f30dec564..b76b20ade 100644 --- a/star/test_suite/make_zams_ultra_high_mass/src/run_star_extras.f90 +++ b/star/test_suite/make_zams_ultra_high_mass/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,15 +27,15 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include 'test_suite_extras_def.inc' - + contains include 'test_suite_extras.inc' - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -51,10 +51,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -65,8 +65,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -98,7 +98,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -111,8 +111,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -124,7 +124,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -135,8 +135,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -150,7 +150,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -163,8 +163,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/ns_c/src/run.f90 b/star/test_suite/ns_c/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/ns_c/src/run.f90 +++ b/star/test_suite/ns_c/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/ns_c/src/run_star_extras.f90 b/star/test_suite/ns_c/src/run_star_extras.f90 index 33fd5d467..e74554833 100644 --- a/star/test_suite/ns_c/src/run_star_extras.f90 +++ b/star/test_suite/ns_c/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,16 +27,16 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - - include "test_suite_extras_def.inc" - - + + include "test_suite_extras_def.inc" + + contains include "test_suite_extras.inc" - include "other_cgrav.inc" + include "other_cgrav.inc" subroutine extras_controls(id, ierr) integer, intent(in) :: id @@ -44,7 +44,7 @@ subroutine extras_controls(id, ierr) type (star_info), pointer :: s ierr = 0 call star_ptr(id, s, ierr) - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% other_cgrav => my_other_cgrav end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -78,7 +78,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -102,8 +102,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -115,7 +115,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -126,8 +126,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -141,7 +141,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -153,7 +153,7 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - + end module run_star_extras - + diff --git a/star/test_suite/ns_h/src/run.f90 b/star/test_suite/ns_h/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/ns_h/src/run.f90 +++ b/star/test_suite/ns_h/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/ns_h/src/run_star_extras.f90 b/star/test_suite/ns_h/src/run_star_extras.f90 index 33fd5d467..e74554833 100644 --- a/star/test_suite/ns_h/src/run_star_extras.f90 +++ b/star/test_suite/ns_h/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,16 +27,16 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - - include "test_suite_extras_def.inc" - - + + include "test_suite_extras_def.inc" + + contains include "test_suite_extras.inc" - include "other_cgrav.inc" + include "other_cgrav.inc" subroutine extras_controls(id, ierr) integer, intent(in) :: id @@ -44,7 +44,7 @@ subroutine extras_controls(id, ierr) type (star_info), pointer :: s ierr = 0 call star_ptr(id, s, ierr) - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% other_cgrav => my_other_cgrav end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -78,7 +78,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -102,8 +102,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -115,7 +115,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -126,8 +126,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -141,7 +141,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -153,7 +153,7 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - + end module run_star_extras - + diff --git a/star/test_suite/ns_he/src/run.f90 b/star/test_suite/ns_he/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/ns_he/src/run.f90 +++ b/star/test_suite/ns_he/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/ns_he/src/run_star_extras.f90 b/star/test_suite/ns_he/src/run_star_extras.f90 index 33fd5d467..e74554833 100644 --- a/star/test_suite/ns_he/src/run_star_extras.f90 +++ b/star/test_suite/ns_he/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,16 +27,16 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - - include "test_suite_extras_def.inc" - - + + include "test_suite_extras_def.inc" + + contains include "test_suite_extras.inc" - include "other_cgrav.inc" + include "other_cgrav.inc" subroutine extras_controls(id, ierr) integer, intent(in) :: id @@ -44,7 +44,7 @@ subroutine extras_controls(id, ierr) type (star_info), pointer :: s ierr = 0 call star_ptr(id, s, ierr) - if (ierr /= 0) return + if (ierr /= 0) return s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% other_cgrav => my_other_cgrav end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -78,7 +78,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -102,8 +102,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -115,7 +115,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -126,8 +126,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -141,7 +141,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -153,7 +153,7 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - + end module run_star_extras - + diff --git a/star/test_suite/other_physics_hooks/src/run.f90 b/star/test_suite/other_physics_hooks/src/run.f90 index 112660f7c..e049d797a 100644 --- a/star/test_suite/other_physics_hooks/src/run.f90 +++ b/star/test_suite/other_physics_hooks/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/other_physics_hooks/src/run_star_extras.f90 b/star/test_suite/other_physics_hooks/src/run_star_extras.f90 index cc40ccee2..9a0e83e06 100644 --- a/star/test_suite/other_physics_hooks/src/run_star_extras.f90 +++ b/star/test_suite/other_physics_hooks/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,9 +27,9 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" @@ -37,14 +37,14 @@ module run_star_extras include 'timestep_limit/timestep_limit_def.inc' include 'other_winds/other_winds_def.inc' include 'xtrans_mesh_factor/xtrans_mesh_factor_def.inc' - - + + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -52,7 +52,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + include 'overshoot_dbl_exp/overshoot_dbl_exp_extras_controls.inc' if (ierr /= 0) return include 'timestep_limit/timestep_limit_extras_controls.inc' @@ -61,10 +61,10 @@ subroutine extras_controls(id, ierr) if (ierr /= 0) return include 'xtrans_mesh_factor/xtrans_mesh_factor_extras_controls.inc' if (ierr /= 0) return - + s% use_other_kap = .true. s% other_kap_get => my_kap_get - + s% eos_rq% use_other_eos_results = .true. s% eos_rq% other_eos_results => my_other_eos_results s% eos_rq% use_other_eos_component = .false. @@ -76,7 +76,7 @@ subroutine extras_controls(id, ierr) s% use_other_rate_get = .true. s% other_rate_get => my_rate_get - + s% use_other_close_gaps = .true. s% other_close_gaps => my_close_gaps @@ -90,8 +90,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - + s% data_for_extra_profile_columns => data_for_extra_profile_columns + end subroutine extras_controls @@ -99,8 +99,8 @@ end subroutine extras_controls include 'timestep_limit/timestep_limit.inc' include 'other_winds/other_winds.inc' include 'xtrans_mesh_factor/xtrans_mesh_factor.inc' - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -111,8 +111,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -123,7 +123,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -133,7 +133,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -146,8 +146,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -159,7 +159,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -170,8 +170,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -185,7 +185,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -197,7 +197,7 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - + ! eos hook routines @@ -306,8 +306,8 @@ subroutine my_other_eos_results( & res(i_lnPgas) = res(i_lnPgas) + 0 end subroutine my_other_eos_results - - + + subroutine my_kap_get( & id, k, handle, species, chem_id, net_iso, xa, & log10_rho, log10_T, & @@ -317,15 +317,15 @@ subroutine my_kap_get( & use kap_def, only: num_kap_fracs use kap_lib - + ! INPUT integer, intent(in) :: id ! star id if available; 0 otherwise - integer, intent(in) :: k ! cell number or 0 if not for a particular cell + integer, intent(in) :: k ! cell number or 0 if not for a particular cell integer, intent(in) :: handle ! from alloc_kap_handle integer, intent(in) :: species integer, pointer :: chem_id(:) ! maps species to chem id ! index from 1 to species - ! value is between 1 and num_chem_isos + ! value is between 1 and num_chem_isos integer, pointer :: net_iso(:) ! maps chem id to species number ! index from 1 to num_chem_isos (defined in chem_def) ! value is 0 if the iso is not in the current net @@ -345,7 +345,7 @@ subroutine my_kap_get( & real(dp), intent(out) :: dln_kap_dlnT ! partial derivative at constant Rho real(dp), intent(out) :: dln_kap_dxa(:) ! partial derivative w.r.t. to species integer, intent(out) :: ierr ! 0 means AOK. - + call kap_get( & handle, species, chem_id, net_iso, xa, log10_rho, log10_T, & lnfree_e, d_lnfree_e_dlnRho, d_lnfree_e_dlnT, & @@ -357,9 +357,9 @@ end subroutine my_kap_get subroutine my_screening(sc, z1, z2, a1, a2, screen, dscreendt, dscreendd, ierr) use rates_def - + implicit none - + type (Screen_Info) :: sc ! See rates_def ! This contains lots of useful things like temperature, density etc as well as some precomputed ! terms that are useful for screening calculations. The derived type is set in do_screen_set_context (screen.f90) @@ -369,7 +369,7 @@ subroutine my_screening(sc, z1, z2, a1, a2, screen, dscreendt, dscreendd, ierr) real(dp),intent(out) :: dscreendt !< on return, temperature derivative of the screening factor real(dp),intent(out) :: dscreendd !< on return, density derivative of the screening factor integer, intent(out) :: ierr - + screen = 1d0 dscreendt = 0d0 dscreendd = 0d0 @@ -381,22 +381,22 @@ subroutine my_rate_get(ir, temp, tf, raw_rate, ierr) use rates_def use rates_lib implicit none - + integer :: ir ! Rate id real(dp),intent(in) :: temp !< Temperature type (T_Factors) :: tf !< Various temperature factors real(dp),intent(inout) :: raw_rate !< Unscreened reaction_rate, note this will have the default mesa rate on entry integer, intent(out) :: ierr - + ierr = 0 - + if (.false. .and. trim(reaction_name(ir)) == 'r_he4_he4_he4_to_c12') then if(temp<1d8) then raw_rate = 0d0 end if - + end if - + end subroutine my_rate_get @@ -412,7 +412,7 @@ subroutine my_close_gaps(id, mix_type, min_gap, ierr) if (ierr /= 0) return do k=1, 10 - if (.false. .and. s% mixing_type(k) == mix_type) then + if (.false. .and. s% mixing_type(k) == mix_type) then write(*,*) k, s% D_mix(k), s% mixing_type(k) end if end do @@ -441,4 +441,4 @@ end subroutine my_other_pressure end module run_star_extras - + diff --git a/star/test_suite/pisn/src/run.f90 b/star/test_suite/pisn/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/pisn/src/run.f90 +++ b/star/test_suite/pisn/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/pisn/src/run_star_extras.f90 b/star/test_suite/pisn/src/run_star_extras.f90 index 56313e837..dd94b6a94 100644 --- a/star/test_suite/pisn/src/run_star_extras.f90 +++ b/star/test_suite/pisn/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,19 +27,19 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none ! (Gamma1 - 4/3) at the center when integral_gamma1-4/3 first drops below 0 - real(dp) :: gamma1_cntr_pulse_start + real(dp) :: gamma1_cntr_pulse_start include "test_suite_extras_def.inc" contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -55,7 +55,7 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% other_remove_surface => remove_ejecta_one_cell_per_step !s% use_other_remove_surface = .true. @@ -63,8 +63,8 @@ subroutine extras_controls(id, ierr) s% other_photo_write => extras_photo_write end subroutine extras_controls - - + + subroutine remove_ejecta_one_cell_per_step(id, ierr, j) integer, intent(in) :: id integer, intent(out) :: ierr, j @@ -72,14 +72,14 @@ subroutine remove_ejecta_one_cell_per_step(id, ierr, j) include 'formats' ierr = 0 call star_ptr(id, s, ierr) - if (ierr /= 0) return + if (ierr /= 0) return if (star_ejecta_mass(id) > 0.1d0*Msun) then call star_remove_surface_at_cell_k(id, 2, ierr) write(*,2) 'remove_ejecta_one_cell_per_step', s% model_number end if end subroutine remove_ejecta_one_cell_per_step - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -87,16 +87,16 @@ subroutine extras_startup(id, restart, ierr) type (star_info), pointer :: s ierr = 0 call star_ptr(id, s, ierr) - if (ierr /= 0) return - call test_suite_startup(s, restart, ierr) - + if (ierr /= 0) return + call test_suite_startup(s, restart, ierr) + if(.not.restart) then gamma1_cntr_pulse_start = HUGE(gamma1_cntr_pulse_start) end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use num_lib, only: find0 integer, intent(in) :: id @@ -116,9 +116,9 @@ subroutine extras_after_evolve(id, ierr) end select call test_suite_after_evolve(s, ierr) - if (ierr /= 0) return + if (ierr /= 0) return end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -128,7 +128,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -143,8 +143,8 @@ integer function how_many_extra_history_columns(id) how_many_extra_history_columns = 1 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -179,7 +179,7 @@ real(dp) function gamma1_integral(s) end function gamma1_integral - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -190,8 +190,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -209,7 +209,7 @@ end subroutine data_for_extra_profile_columns integer function extras_start_step(id) integer, intent(in) :: id - extras_start_step = keep_going + extras_start_step = keep_going end function extras_start_step ! returns either keep_going or terminate. @@ -246,34 +246,34 @@ subroutine extras_photo_read(id, iounit, ierr) integer, intent(out) :: ierr type (star_info), pointer :: s ierr = 0 - + call star_ptr(id, s, ierr) if (ierr /= 0) return - + select case (s% x_integer_ctrl(1)) case(7) read(iounit,iostat=ierr) gamma1_cntr_pulse_start end select - + end subroutine extras_photo_read - + subroutine extras_photo_write(id, iounit) integer, intent(in) :: id, iounit integer :: ierr type (star_info), pointer :: s ierr = 0 - + call star_ptr(id, s, ierr) if (ierr /= 0) return - + select case (s% x_integer_ctrl(1)) case(7) write(iounit) gamma1_cntr_pulse_start end select - + end subroutine extras_photo_write end module run_star_extras - + diff --git a/star/test_suite/ppisn/src/run.f90 b/star/test_suite/ppisn/src/run.f90 index 112660f7c..e049d797a 100644 --- a/star/test_suite/ppisn/src/run.f90 +++ b/star/test_suite/ppisn/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/ppisn/src/run_star_extras.f90 b/star/test_suite/ppisn/src/run_star_extras.f90 index 5b68e118a..8f94b11e6 100644 --- a/star/test_suite/ppisn/src/run_star_extras.f90 +++ b/star/test_suite/ppisn/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -33,9 +33,9 @@ module run_star_extras use interp_1d_def, only: pm_work_size use interp_1d_lib, only: interp_pm, interp_values, interp_value - + implicit none - + include "test_suite_extras_def.inc" logical :: dbg = .false. @@ -99,12 +99,12 @@ module run_star_extras real(dp) :: delta_lgRho_cntr_hard_limit, dt_div_min_dr_div_cs_limit real(dp) :: logT_for_v_flag, logLneu_for_v_flag logical :: stop_100d_after_pulse - + contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -112,7 +112,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_start_step => extras_start_step s% extras_check_model => extras_check_model @@ -121,7 +121,7 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns ! we turn pgstar on and off at some points, so we store the original setting pgstar_flag = s% job% pgstar_flag @@ -249,7 +249,7 @@ subroutine eval_Vink_wind(w) alfa = (T1 - (Teff_jump - dT)) / (2*dT) end if end if - + if (alfa > 0) then ! eval hot side wind (eqn 24) vinf_div_vesc = 2.6d0 ! this is the hot side galactic value vinf_div_vesc = vinf_div_vesc*pow(Z_div_Z_solar,0.13d0) ! corrected for Z @@ -265,7 +265,7 @@ subroutine eval_Vink_wind(w) else w1 = 0 end if - + if (alfa < 1) then ! eval cool side wind (eqn 25) vinf_div_vesc = 1.3d0 ! this is the cool side galactic value vinf_div_vesc = vinf_div_vesc*pow(Z_div_Z_solar,0.13d0) ! corrected for Z @@ -280,9 +280,9 @@ subroutine eval_Vink_wind(w) else w2 = 0 end if - + w = alfa*w1 + (1 - alfa)*w2 - + end subroutine eval_Vink_wind subroutine eval_Nieuwenhuijzen_wind(w) @@ -311,7 +311,7 @@ subroutine eval_Hamann_wind(w) end subroutine eval_Hamann_wind end subroutine brott_wind - + subroutine my_adjust_mdot(id, ierr) use star_def integer, intent(in) :: id @@ -414,15 +414,15 @@ subroutine my_other_kap_get( & use kap_def, only: num_kap_fracs use kap_lib - + ! INPUT integer, intent(in) :: id ! star id if available; 0 otherwise - integer, intent(in) :: k ! cell number or 0 if not for a particular cell + integer, intent(in) :: k ! cell number or 0 if not for a particular cell integer, intent(in) :: handle ! from alloc_kap_handle integer, intent(in) :: species integer, pointer :: chem_id(:) ! maps species to chem id ! index from 1 to species - ! value is between 1 and num_chem_isos + ! value is between 1 and num_chem_isos integer, pointer :: net_iso(:) ! maps chem id to species number ! index from 1 to num_chem_isos (defined in chem_def) ! value is 0 if the iso is not in the current net @@ -452,7 +452,7 @@ subroutine my_other_kap_get( & ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + kap = 0; dln_kap_dlnRho = 0; dln_kap_dlnT = 0; dln_kap_dxa = 0 velocity = 0 radius = 0 @@ -540,8 +540,8 @@ subroutine extras_startup(id, restart, ierr) end if end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -553,7 +553,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -565,7 +565,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -579,8 +579,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 22 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -655,7 +655,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) end if vals(h_yr_since_coll) = s% xtra(x_time_since_first_gamma_zero)/secyer - + vals(h_log_R_098) = -100 vals(h_log_R_095) = -100 vals(h_log_R_090) = -100 @@ -726,9 +726,9 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) vals(h_T_ejecta) = vals(h_T_ejecta) + 0.5d0*s% dm(k0)*s% u(k0)*s% u(k0) end if vals(h_Omega_ejecta) = vals(h_Omega_ejecta) - s% dm_bar(k0)*s% cgrav(k0)*s% m(k0)/s% r(k0) - end do + end do end if - + if (s% u_flag) then vals(h_u_flag) = 1d0 else @@ -737,7 +737,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -752,8 +752,8 @@ integer function how_many_extra_profile_columns(id) how_many_extra_profile_columns = 1 end if end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -776,8 +776,8 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) names(5) = "specific_thermal_e" names(6) = "total_specific_e" names(7) = "mlt_vc" - names(8) = "spin_parameter" - + names(8) = "spin_parameter" + do k = s% nz, 1, -1 vals(k,1) = sqrt(2*s% cgrav(k)*s% m(k)/(s% r(k))) vals(k,2) = s% u(k)/vals(k,1) @@ -795,7 +795,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end if end do else - names(1) = "spin_parameter" + names(1) = "spin_parameter" if (s% rotation_flag) then do k = s% nz, 1, -1 @@ -806,10 +806,10 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(:,1) = 0d0 end if end if - - + + end subroutine data_for_extra_profile_columns - + integer function extras_start_step(id) integer, intent(in) :: id @@ -901,9 +901,9 @@ integer function extras_start_step(id) 0.5d0*s% dm(k0)*s% u(k0)*s% u(k0) - s% dm(k0)*s% cgrav(k0)*s% m(k0)/s% r(k0) & +s% energy(k0)*s% dm(k0) end do - ! adjust location of boundary to remove by considering also + ! adjust location of boundary to remove by considering also ! material below the escape velocity that has a positive net - ! total specific energy. + ! total specific energy. if (energy_removed_layers > 0d0) then ! possible to eject material if(mod(s%model_number, s%terminal_interval) == 0) then write(*,*) "k, q, energy_removed_layers before adjustment is", k, s% q(k), energy_removed_layers @@ -920,7 +920,7 @@ integer function extras_start_step(id) avg_v_div_vesc = avg_v_div_vesc + & s% dm(k0)*s% u(k0)/sqrt(2*s% cgrav(k0)*s% m(k0)/(s% r(k0))) end if - end do + end do if(mod(s%model_number, s%terminal_interval) == 0) then write(*,*) "k, q, energy_removed_layers after adjustment is", k, s% q(k), energy_removed_layers end if @@ -962,7 +962,7 @@ integer function extras_start_step(id) exit end if end do - + if(mod(s%model_number, s%terminal_interval) == 0) then write(*,*) 'Layers above q=', s% q(k), 'will be removed' write(*,*) 'checking for conditions inside q=', q_for_relax_check, 'of material that will remain' @@ -998,7 +998,7 @@ integer function extras_start_step(id) end if else ! escape velocity reached within a tiny fraction of the - ! core. Before marking as PISN verify if any cell above + ! core. Before marking as PISN verify if any cell above ! this is below the escape velocity do k0 = k, 1, -1 v_esc = sqrt(2*s% cgrav(k0)*s% m(k0)/(s% r(k0))) @@ -1021,7 +1021,7 @@ integer function extras_start_step(id) write(*,*) "Relaxing model to lower mass!" s% ixtra(ix_num_relaxations) = s% ixtra(ix_num_relaxations) + 1 s% xtra(x_star_age_at_relax) = s% star_age - + !save a profile just before relaxation write(fname, fmt="(a18,i0.3,a5)") 'LOGS/prerelax_prof', s% ixtra(ix_num_relaxations), '.data' call star_write_profile_info(id, fname, ierr) @@ -1224,7 +1224,7 @@ integer function extras_start_step(id) extras_start_step = keep_going end function extras_start_step - + subroutine my_before_struct_burn_mix(id, dt, res) use const_def, only: dp use star_def @@ -1261,7 +1261,7 @@ subroutine my_before_struct_burn_mix(id, dt, res) !ignore L_nuc limit if L_phot is too high or if we just did a relax !(ixtra(ix_steps_since_relax) is set to zero right after a relax) - + !when L_phot exceeds max_Lphoto_for_lgLnuc_limit, the timestep limit is applied !to L_phot instead @@ -1314,7 +1314,7 @@ subroutine my_before_struct_burn_mix(id, dt, res) res = keep_going end subroutine my_before_struct_burn_mix - + subroutine null_binary_controls(id, binary_id, ierr) integer, intent(in) :: id, binary_id integer, intent(out) :: ierr @@ -1338,7 +1338,7 @@ integer function extras_finish_step(id) !count time since first collapse if (s% lxtra(lx_have_reached_gamma_limit)) then s% xtra(x_time_since_first_gamma_zero) = & - s% xtra(x_time_since_first_gamma_zero) + s% dt + s% xtra(x_time_since_first_gamma_zero) + s% dt end if s% ixtra(ix_steps_since_relax) = s% ixtra(ix_steps_since_relax) + 1 @@ -1356,6 +1356,6 @@ integer function extras_finish_step(id) if (extras_finish_step == terminate) s% termination_code = t_extras_finish_step end function extras_finish_step - + end module run_star_extras - + diff --git a/star/test_suite/radiative_levitation/src/run.f90 b/star/test_suite/radiative_levitation/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/radiative_levitation/src/run.f90 +++ b/star/test_suite/radiative_levitation/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/radiative_levitation/src/run_star_extras.f90 b/star/test_suite/radiative_levitation/src/run_star_extras.f90 index 97a3924eb..60ec2c6c4 100644 --- a/star/test_suite/radiative_levitation/src/run_star_extras.f90 +++ b/star/test_suite/radiative_levitation/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,18 +27,18 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - + subroutine set_op_mono_factors(id, ierr) use chem_def, only: ife56 integer, intent(in) :: id @@ -60,8 +60,8 @@ subroutine set_op_mono_factors(id, ierr) if (abs(1d0 - s% x_ctrl(1)) > 1d-6) write(*,1) & 'set_op_mono_factors -- increase fe56 opacity by factor ', s% x_ctrl(1) end subroutine set_op_mono_factors - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -71,7 +71,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% x_ctrl(1) > 0d0) then if (len_trim(s% op_mono_data_path) == 0) then ierr = -1 @@ -91,7 +91,7 @@ subroutine extras_controls(id, ierr) write(*,*) 'extras_controls set pointer to set_op_mono_factors' s% set_op_mono_factors => set_op_mono_factors end if - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -99,11 +99,11 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - + s% data_for_extra_profile_columns => data_for_extra_profile_columns + end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -114,8 +114,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use chem_lib, only: chem_get_iso_id integer, intent(in) :: id @@ -128,7 +128,7 @@ subroutine extras_after_evolve(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% x_ctrl(1) > 0d0) then if (s% star_age < s% max_age) then write(*,1) 'failed to reach max age', s% star_age, s% max_age @@ -143,13 +143,13 @@ subroutine extras_after_evolve(id, ierr) if (s% mixing_type(k) /= convective_mixing) then write(*,4) 'bad mixing type', k, s% mixing_type(k), convective_mixing return - end if + end if fe56 = s% net_iso(chem_get_iso_id('fe56')) ni58 = s% net_iso(chem_get_iso_id('ni58')) if (fe56 <= 0 .or. ni58 <= 0) then write(*,4) 'missing fe56 or ni58', k, fe56, ni58 return - end if + end if if (s% xa(fe56,k) < 2d-2 .or. s% xa(ni58,k) < 7d-3) then write(*,2) 'too little fe56 or ni58', k, s% xa(fe56,k), s% xa(ni58,k) return @@ -163,10 +163,10 @@ subroutine extras_after_evolve(id, ierr) write(*,*) 'found expected effects of radiative levitation' end if end if - + call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -176,7 +176,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -189,8 +189,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -202,7 +202,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -213,8 +213,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -228,7 +228,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -236,16 +236,16 @@ integer function extras_finish_step(id) integer :: ierr type (star_info), pointer :: s include 'formats' - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return extras_finish_step = keep_going - + end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/relax_composition_j_entropy/src/run.f90 b/star/test_suite/relax_composition_j_entropy/src/run.f90 index 112660f7c..e049d797a 100644 --- a/star/test_suite/relax_composition_j_entropy/src/run.f90 +++ b/star/test_suite/relax_composition_j_entropy/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/relax_composition_j_entropy/src/run_star_extras.f90 b/star/test_suite/relax_composition_j_entropy/src/run_star_extras.f90 index 4c3c205e9..8b636ac15 100644 --- a/star/test_suite/relax_composition_j_entropy/src/run_star_extras.f90 +++ b/star/test_suite/relax_composition_j_entropy/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -28,19 +28,19 @@ module run_star_extras use math_lib use auto_diff use utils_lib - + implicit none include "test_suite_extras_def.inc" real(dp) :: target_Teff real(dp) :: target_L - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -49,10 +49,10 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + ! this is the place to set any procedure pointers you want to change ! e.g., other_wind, other_mixing, other_energy (see star_data.inc) - + ! Uncomment these lines if you wish to use the functions in this file, ! otherwise we use a null_ version which does nothing. s% extras_startup => extras_startup @@ -62,12 +62,12 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns ! Once you have set the function pointers you want, ! then uncomment this (or set it in your star_job inlist) ! to disable the printed warning message, - s% job% warn_run_star_extras =.false. + s% job% warn_run_star_extras =.false. if (s% x_integer_ctrl(1) == 2) then !load initial mass and target values @@ -104,13 +104,13 @@ subroutine extras_controls(id, ierr) write(*,1) "Loading model with mass:", s% initial_mass write(*,1) "Target value for Teff and L:", target_Teff, target_L end if - + end subroutine extras_controls - + ! None of the following functions are called unless you set their ! function point in extras_control. - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -121,7 +121,7 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -131,7 +131,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going if (s% x_integer_ctrl(1) == 2) then s% termination_code = t_xtra1 @@ -171,8 +171,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -182,15 +182,15 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + !note: do NOT add the extras names to history_columns.list ! the history_columns.list is only for the built-in log column options. ! it must not include the new column names you are adding here. - + end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -201,8 +201,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -215,7 +215,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + !note: do NOT add the extra names to profile_columns.list ! the profile_columns.list is only for the built-in profile column options. ! it must not include the new column names you are adding here. @@ -226,9 +226,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) !do k = 1, nz ! vals(k,1) = s% Pgas(k)/s% P(k) !end do - + end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. @@ -236,15 +236,15 @@ integer function extras_finish_step(id) integer, intent(in) :: id integer :: ierr, k, iounit type (star_info), pointer :: s - + 99 format(99(1pd26.18)) - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return extras_finish_step = keep_going - ! to save a profile, + ! to save a profile, ! s% need_to_save_profiles_now = .true. ! to update the star log, ! s% need_to_update_history_now = .true. @@ -349,8 +349,8 @@ integer function extras_finish_step(id) ! by default, indicate where (in the code) MESA terminated if (extras_finish_step == terminate) s% termination_code = t_extras_finish_step end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -363,8 +363,8 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - - + + end module run_star_extras - + diff --git a/star/test_suite/rsp_BEP/src/run.f90 b/star/test_suite/rsp_BEP/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/rsp_BEP/src/run.f90 +++ b/star/test_suite/rsp_BEP/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/rsp_BEP/src/run_star_extras.f90 b/star/test_suite/rsp_BEP/src/run_star_extras.f90 index e5eddfa37..166c7b27a 100644 --- a/star/test_suite/rsp_BEP/src/run_star_extras.f90 +++ b/star/test_suite/rsp_BEP/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -29,7 +29,7 @@ module run_star_extras use auto_diff implicit none - + include "test_suite_extras_def.inc" logical :: need_to_write_LINA_data @@ -37,7 +37,7 @@ module run_star_extras include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -72,7 +72,7 @@ subroutine extras_startup(id, restart, ierr) need_to_write_LINA_data = .false. end if end subroutine extras_startup - + integer function extras_start_step(id) integer, intent(in) :: id @@ -92,7 +92,7 @@ integer function extras_start_step(id) need_to_write_LINA_data = .false. end if end function extras_start_step - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -127,8 +127,8 @@ integer function extras_finish_step(id) write(*,'(A)') extras_finish_step = terminate end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -139,7 +139,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -149,7 +149,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -162,8 +162,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 8 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,7 +185,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) names(i) = 'delta_Mag'; vals(i) = 0; i=i+1 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -196,8 +196,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -219,9 +219,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end if end do end subroutine data_for_extra_profile_columns - - + + end module run_star_extras - + diff --git a/star/test_suite/rsp_BLAP/src/run.f90 b/star/test_suite/rsp_BLAP/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/rsp_BLAP/src/run.f90 +++ b/star/test_suite/rsp_BLAP/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/rsp_BLAP/src/run_star_extras.f90 b/star/test_suite/rsp_BLAP/src/run_star_extras.f90 index e5eddfa37..166c7b27a 100644 --- a/star/test_suite/rsp_BLAP/src/run_star_extras.f90 +++ b/star/test_suite/rsp_BLAP/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -29,7 +29,7 @@ module run_star_extras use auto_diff implicit none - + include "test_suite_extras_def.inc" logical :: need_to_write_LINA_data @@ -37,7 +37,7 @@ module run_star_extras include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -72,7 +72,7 @@ subroutine extras_startup(id, restart, ierr) need_to_write_LINA_data = .false. end if end subroutine extras_startup - + integer function extras_start_step(id) integer, intent(in) :: id @@ -92,7 +92,7 @@ integer function extras_start_step(id) need_to_write_LINA_data = .false. end if end function extras_start_step - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -127,8 +127,8 @@ integer function extras_finish_step(id) write(*,'(A)') extras_finish_step = terminate end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -139,7 +139,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -149,7 +149,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -162,8 +162,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 8 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,7 +185,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) names(i) = 'delta_Mag'; vals(i) = 0; i=i+1 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -196,8 +196,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -219,9 +219,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end if end do end subroutine data_for_extra_profile_columns - - + + end module run_star_extras - + diff --git a/star/test_suite/rsp_Cepheid/src/run.f90 b/star/test_suite/rsp_Cepheid/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/rsp_Cepheid/src/run.f90 +++ b/star/test_suite/rsp_Cepheid/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/rsp_Cepheid/src/run_star_extras.f90 b/star/test_suite/rsp_Cepheid/src/run_star_extras.f90 index e5eddfa37..166c7b27a 100644 --- a/star/test_suite/rsp_Cepheid/src/run_star_extras.f90 +++ b/star/test_suite/rsp_Cepheid/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -29,7 +29,7 @@ module run_star_extras use auto_diff implicit none - + include "test_suite_extras_def.inc" logical :: need_to_write_LINA_data @@ -37,7 +37,7 @@ module run_star_extras include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -72,7 +72,7 @@ subroutine extras_startup(id, restart, ierr) need_to_write_LINA_data = .false. end if end subroutine extras_startup - + integer function extras_start_step(id) integer, intent(in) :: id @@ -92,7 +92,7 @@ integer function extras_start_step(id) need_to_write_LINA_data = .false. end if end function extras_start_step - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -127,8 +127,8 @@ integer function extras_finish_step(id) write(*,'(A)') extras_finish_step = terminate end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -139,7 +139,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -149,7 +149,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -162,8 +162,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 8 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,7 +185,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) names(i) = 'delta_Mag'; vals(i) = 0; i=i+1 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -196,8 +196,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -219,9 +219,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end if end do end subroutine data_for_extra_profile_columns - - + + end module run_star_extras - + diff --git a/star/test_suite/rsp_Cepheid_6M/src/run.f90 b/star/test_suite/rsp_Cepheid_6M/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/rsp_Cepheid_6M/src/run.f90 +++ b/star/test_suite/rsp_Cepheid_6M/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/rsp_Cepheid_6M/src/run_star_extras.f90 b/star/test_suite/rsp_Cepheid_6M/src/run_star_extras.f90 index e5eddfa37..166c7b27a 100644 --- a/star/test_suite/rsp_Cepheid_6M/src/run_star_extras.f90 +++ b/star/test_suite/rsp_Cepheid_6M/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -29,7 +29,7 @@ module run_star_extras use auto_diff implicit none - + include "test_suite_extras_def.inc" logical :: need_to_write_LINA_data @@ -37,7 +37,7 @@ module run_star_extras include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -72,7 +72,7 @@ subroutine extras_startup(id, restart, ierr) need_to_write_LINA_data = .false. end if end subroutine extras_startup - + integer function extras_start_step(id) integer, intent(in) :: id @@ -92,7 +92,7 @@ integer function extras_start_step(id) need_to_write_LINA_data = .false. end if end function extras_start_step - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -127,8 +127,8 @@ integer function extras_finish_step(id) write(*,'(A)') extras_finish_step = terminate end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -139,7 +139,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -149,7 +149,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -162,8 +162,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 8 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,7 +185,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) names(i) = 'delta_Mag'; vals(i) = 0; i=i+1 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -196,8 +196,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -219,9 +219,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end if end do end subroutine data_for_extra_profile_columns - - + + end module run_star_extras - + diff --git a/star/test_suite/rsp_Delta_Scuti/src/run.f90 b/star/test_suite/rsp_Delta_Scuti/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/rsp_Delta_Scuti/src/run.f90 +++ b/star/test_suite/rsp_Delta_Scuti/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/rsp_Delta_Scuti/src/run_star_extras.f90 b/star/test_suite/rsp_Delta_Scuti/src/run_star_extras.f90 index e5eddfa37..166c7b27a 100644 --- a/star/test_suite/rsp_Delta_Scuti/src/run_star_extras.f90 +++ b/star/test_suite/rsp_Delta_Scuti/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -29,7 +29,7 @@ module run_star_extras use auto_diff implicit none - + include "test_suite_extras_def.inc" logical :: need_to_write_LINA_data @@ -37,7 +37,7 @@ module run_star_extras include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -72,7 +72,7 @@ subroutine extras_startup(id, restart, ierr) need_to_write_LINA_data = .false. end if end subroutine extras_startup - + integer function extras_start_step(id) integer, intent(in) :: id @@ -92,7 +92,7 @@ integer function extras_start_step(id) need_to_write_LINA_data = .false. end if end function extras_start_step - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -127,8 +127,8 @@ integer function extras_finish_step(id) write(*,'(A)') extras_finish_step = terminate end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -139,7 +139,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -149,7 +149,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -162,8 +162,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 8 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,7 +185,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) names(i) = 'delta_Mag'; vals(i) = 0; i=i+1 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -196,8 +196,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -219,9 +219,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end if end do end subroutine data_for_extra_profile_columns - - + + end module run_star_extras - + diff --git a/star/test_suite/rsp_RR_Lyrae/src/run.f90 b/star/test_suite/rsp_RR_Lyrae/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/rsp_RR_Lyrae/src/run.f90 +++ b/star/test_suite/rsp_RR_Lyrae/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/rsp_RR_Lyrae/src/run_star_extras.f90 b/star/test_suite/rsp_RR_Lyrae/src/run_star_extras.f90 index 0b45167c4..c2f191861 100644 --- a/star/test_suite/rsp_RR_Lyrae/src/run_star_extras.f90 +++ b/star/test_suite/rsp_RR_Lyrae/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -29,7 +29,7 @@ module run_star_extras use auto_diff implicit none - + include "test_suite_extras_def.inc" logical :: need_to_write_LINA_data @@ -37,7 +37,7 @@ module run_star_extras include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -72,7 +72,7 @@ subroutine extras_startup(id, restart, ierr) need_to_write_LINA_data = .false. end if end subroutine extras_startup - + integer function extras_start_step(id) integer, intent(in) :: id @@ -92,7 +92,7 @@ integer function extras_start_step(id) need_to_write_LINA_data = .false. end if end function extras_start_step - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -127,8 +127,8 @@ integer function extras_finish_step(id) write(*,'(A)') extras_finish_step = terminate end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -139,7 +139,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -149,7 +149,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -162,8 +162,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -175,7 +175,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -186,8 +186,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -201,9 +201,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - - + + end module run_star_extras - + diff --git a/star/test_suite/rsp_Type_II_Cepheid/src/run.f90 b/star/test_suite/rsp_Type_II_Cepheid/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/rsp_Type_II_Cepheid/src/run.f90 +++ b/star/test_suite/rsp_Type_II_Cepheid/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/rsp_Type_II_Cepheid/src/run_star_extras.f90 b/star/test_suite/rsp_Type_II_Cepheid/src/run_star_extras.f90 index 2ab69f0fd..e95a382d1 100644 --- a/star/test_suite/rsp_Type_II_Cepheid/src/run_star_extras.f90 +++ b/star/test_suite/rsp_Type_II_Cepheid/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -29,7 +29,7 @@ module run_star_extras use auto_diff implicit none - + include "test_suite_extras_def.inc" logical :: need_to_write_LINA_data @@ -37,7 +37,7 @@ module run_star_extras include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -72,7 +72,7 @@ subroutine extras_startup(id, restart, ierr) need_to_write_LINA_data = .false. end if end subroutine extras_startup - + integer function extras_start_step(id) integer, intent(in) :: id @@ -92,7 +92,7 @@ integer function extras_start_step(id) need_to_write_LINA_data = .false. end if end function extras_start_step - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -127,8 +127,8 @@ integer function extras_finish_step(id) write(*,'(A)') extras_finish_step = terminate end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -139,7 +139,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -149,7 +149,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -162,8 +162,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 8 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -185,7 +185,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) names(i) = 'delta_Mag'; vals(i) = 0; i=i+1 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -196,8 +196,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -219,9 +219,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) end if end do end subroutine data_for_extra_profile_columns - - + + end module run_star_extras - + diff --git a/star/test_suite/rsp_check_2nd_crossing/src/run.f90 b/star/test_suite/rsp_check_2nd_crossing/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/rsp_check_2nd_crossing/src/run.f90 +++ b/star/test_suite/rsp_check_2nd_crossing/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/rsp_check_2nd_crossing/src/run_star_extras.f90 b/star/test_suite/rsp_check_2nd_crossing/src/run_star_extras.f90 index dfe89949d..d91d20c1a 100644 --- a/star/test_suite/rsp_check_2nd_crossing/src/run_star_extras.f90 +++ b/star/test_suite/rsp_check_2nd_crossing/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -29,14 +29,14 @@ module run_star_extras use auto_diff implicit none - + include "test_suite_extras_def.inc" contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -51,21 +51,21 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - + s% data_for_extra_profile_columns => data_for_extra_profile_columns + if (s% use_other_rsp_build_model) & s% other_rsp_build_model => rsp_check_2nd_crossing end subroutine extras_controls - + subroutine rsp_check_2nd_crossing(id, ierr) use interp_1d_def, only: pm_work_size use interp_1d_lib integer, intent(in) :: id - integer, intent(out) :: ierr + integer, intent(out) :: ierr type (star_info), pointer :: s - + integer, parameter :: io_in=34, io_out=35, max_n = 200, max_cnt = 9000 real(dp) :: logT1, logL1, logT2, logL2, logT3, logL3, logT4, logL4, & delta_Teff, mass, X, Z, log_Teff, log_L, prev_Teff, & @@ -80,14 +80,14 @@ subroutine rsp_check_2nd_crossing(id, ierr) real(dp), pointer, dimension(:) :: & f1, work1, x_old, v_old, x_new, v_new logical :: okay, finished_1st_crossing, have_first, in_2nd_crossing, just_failed - + include 'formats' - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return write(*,*) 'rsp_check_2nd_crossing' - + delta_Teff = s% x_ctrl(1) ! approx edges logT1 = s% x_ctrl(2) @@ -98,30 +98,30 @@ subroutine rsp_check_2nd_crossing(id, ierr) logL3 = s% x_ctrl(7) logT4 = s% x_ctrl(8) logL4 = s% x_ctrl(9) - + skip_cols = s% x_integer_ctrl(1) col_model_number = s% x_integer_ctrl(2) col_star_age = s% x_integer_ctrl(3) col_log_Teff = s% x_integer_ctrl(4) col_log_L = s% x_integer_ctrl(5) - + num_cols_to_read = max(col_model_number, col_star_age, col_log_Teff, col_log_L) allocate(vals(num_cols_to_read), & growth(max_cnt), period(max_cnt), temp(max_cnt), lum(max_cnt), & Ts(max_cnt), Ls(max_cnt), ages(max_cnt), modnums(max_cnt), model(max_cnt), & f1(4*max_cnt), work1(max_cnt*pm_work_size), & x_old(max_n), v_old(max_n), x_new(max_n), v_new(max_n)) - + open(unit=io_in, file=trim(s% x_character_ctrl(1)), status='old', action='read', iostat=ierr) if (ierr /= 0) then write(*,*) 'failed to open history data file ' // trim(s% x_character_ctrl(1)) return - end if - + end if + do i=1,skip_cols read(io_in,*) end do - + model_cnt = 0 read_loop: do read(io_in,fmt=*,iostat=ierr) vals(1:num_cols_to_read) @@ -131,11 +131,11 @@ subroutine rsp_check_2nd_crossing(id, ierr) modnums(model_cnt) = int(vals(col_model_number)) ages(model_cnt) = vals(col_star_age) Ts(model_cnt) = exp10(vals(col_log_Teff)) - Ls(model_cnt) = exp10(vals(col_log_L)) + Ls(model_cnt) = exp10(vals(col_log_L)) end do read_loop num_models = model_cnt close(io_in) - + open(unit=io_out, file=TRIM(s% x_character_ctrl(2)), status='REPLACE', iostat=ierr) if (ierr /= 0) then write(*,*) 'failed to open output data file ' // trim(s% x_character_ctrl(2)) @@ -145,7 +145,7 @@ subroutine rsp_check_2nd_crossing(id, ierr) mass = s% RSP_mass X = s% RSP_X Z = s% RSP_Z - + write(io_out,1) 'RSP_mass', s% RSP_mass write(io_out,1) 'RSP_X', s% RSP_X write(io_out,1) 'RSP_Z', s% RSP_Z @@ -154,7 +154,7 @@ subroutine rsp_check_2nd_crossing(id, ierr) write(io_out,1) 'RSP_alfat', s% RSP_alfat write(io_out,1) 'RSP_gammar', s% RSP_gammar write(io_out,*) - + write(io_out,'(99a20)') 'model_number', 'period(d)', 'growth', & 'Teff', 'L', 'star_age' @@ -182,8 +182,8 @@ subroutine rsp_check_2nd_crossing(id, ierr) prev_Teff = s% RSP_Teff cycle search_loop ! still going to lower Ts end if - max_T = exp10(get_blue_logT(log_L)) - min_T = exp10(get_red_logT(log_L)) + max_T = exp10(get_blue_logT(log_L)) + min_T = exp10(get_red_logT(log_L)) if (s% RSP_Teff < min_T - 4*delta_Teff) then !write(*,2) 'too far from red edge', modnums(model_cnt), s% RSP_Teff, min_T prev_Teff = s% RSP_Teff @@ -227,7 +227,7 @@ subroutine rsp_check_2nd_crossing(id, ierr) if (num_beyond_blue_edge == 2 .or. n == max_n) exit search_loop prev_Teff = s% RSP_Teff end do search_loop - + if (n == 0 .or. growth(1) >= 0d0 .or. num_beyond_blue_edge < 1) then write(*,2) 'n', n write(*,2) 'num_beyond_blue_edge', num_beyond_blue_edge @@ -235,7 +235,7 @@ subroutine rsp_check_2nd_crossing(id, ierr) ierr = -1 return end if - + Teff_red_edge = -1 if (growth(2) < 0d0) then do i=4,n @@ -249,7 +249,7 @@ subroutine rsp_check_2nd_crossing(id, ierr) !write(*,*) 'x_old', x_old(1:4) !write(*,*) 'v_old', v_old(1:4) call interpolate_vector_pm( & - 4, x_old, 1, x_new, v_old, v_new, work1, 'red edge', ierr) + 4, x_old, 1, x_new, v_old, v_new, work1, 'red edge', ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in interpolate_vector_pm red edge') Teff_red_edge = v_new(1) write(*,'(A)') @@ -269,7 +269,7 @@ subroutine rsp_check_2nd_crossing(id, ierr) !write(*,*) 'x_old', x_old(1:3) !write(*,*) 'v_old', v_old(1:3) call interpolate_vector_pm( & - 3, x_old, 1, x_new, v_old, v_new, work1, 'red edge', ierr) + 3, x_old, 1, x_new, v_old, v_new, work1, 'red edge', ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in interpolate_vector_pm red edge') Teff_red_edge = v_new(1) write(*,'(A)') @@ -278,7 +278,7 @@ subroutine rsp_check_2nd_crossing(id, ierr) write(io_out,'(a20,f20.10)') 'Teff_red_edge', Teff_red_edge end if if (Teff_red_edge < 0d0) call mesa_error(__FILE__,__LINE__,'failed to find red edge') - + Teff_blue_edge = -1 if (num_beyond_blue_edge == 2) then do i=n-3,1,-1 @@ -292,7 +292,7 @@ subroutine rsp_check_2nd_crossing(id, ierr) !write(*,*) 'x_old', x_old(1:4) !write(*,*) 'v_old', v_old(1:4) call interpolate_vector_pm( & - 4, x_old, 1, x_new, v_old, v_new, work1, 'blue edge', ierr) + 4, x_old, 1, x_new, v_old, v_new, work1, 'blue edge', ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in interpolate_vector_pm blue edge') Teff_blue_edge = v_new(1) write(*,'(a20,f20.10)') 'Teff_blue_edge', Teff_blue_edge @@ -311,7 +311,7 @@ subroutine rsp_check_2nd_crossing(id, ierr) !write(*,*) 'x_old', x_old(1:3) !write(*,*) 'v_old', v_old(1:3) call interpolate_vector_pm( & - 3, x_old, 1, x_new, v_old, v_new, work1, 'blue edge', ierr) + 3, x_old, 1, x_new, v_old, v_new, work1, 'blue edge', ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'failed in interpolate_vector_pm blue edge') Teff_blue_edge = v_new(1) write(*,'(a20,f20.10)') 'Teff_blue_edge', Teff_blue_edge @@ -321,10 +321,10 @@ subroutine rsp_check_2nd_crossing(id, ierr) write(*,'(A)') write(io_out,*) if (Teff_blue_edge < 0d0) then - write(*,*) 'failed to find blue edge' + write(*,*) 'failed to find blue edge' return end if - + f(1:4,1:n) => f1(1:4*n) do i=1,n f(1,i) = lum(i) @@ -334,11 +334,11 @@ subroutine rsp_check_2nd_crossing(id, ierr) write(*,*) 'failed in interp_pm Ts' return end if - + offset = 0d0 write(*,'(a10,2a20)') 'offset', 'Teff', 'L' write(io_out,'(a10,2a20)') 'offset', 'Teff', 'L' - do + do x_new(1) = Teff_blue_edge - offset if (x_new(1) < Teff_red_edge) x_new(1) = Teff_red_edge call interp_values(temp, n, f1, 1, x_new, v_new, ierr) @@ -350,31 +350,31 @@ subroutine rsp_check_2nd_crossing(id, ierr) end do write(io_out,*) write(*,'(A)') - + close(io_out) write(*,*) 'done rsp_check_2nd_crossing' write(*,*) TRIM(s% x_character_ctrl(2)) !deallocate(f1, work1, x_new, v_new) - + ierr = -1 ! to force termination of run - + contains - + real(dp) function get_blue_logT(log_L) real(dp), intent(in) :: log_L get_blue_logT = logT2 + (log_L - logL2)*(logT1 - logT2)/(logL1 - logL2) end function get_blue_logT - + real(dp) function get_red_logT(log_L) real(dp), intent(in) :: log_L get_red_logT = logT4 + (log_L - logL4)*(logT3 - logT4)/(logL3 - logL4) end function get_red_logT - + end subroutine rsp_check_2nd_crossing - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -385,7 +385,7 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -420,8 +420,8 @@ integer function extras_finish_step(id) write(*,'(A)') extras_finish_step = terminate end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -432,7 +432,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -442,7 +442,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -455,8 +455,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -468,7 +468,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -479,8 +479,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -494,9 +494,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - - - + + + end module run_star_extras - + diff --git a/star/test_suite/rsp_gyre/src/run.f90 b/star/test_suite/rsp_gyre/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/rsp_gyre/src/run.f90 +++ b/star/test_suite/rsp_gyre/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/rsp_gyre/src/run_star_extras.f90 b/star/test_suite/rsp_gyre/src/run_star_extras.f90 index b3f46b9c1..2d4c1bc05 100644 --- a/star/test_suite/rsp_gyre/src/run_star_extras.f90 +++ b/star/test_suite/rsp_gyre/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -30,17 +30,17 @@ module run_star_extras use gyre_mesa_m implicit none - + include "test_suite_extras_def.inc" contains include "test_suite_extras.inc" - - + + include 'run_star_extras.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -55,14 +55,14 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns if (.not. s% use_other_RSP_linear_analysis) return s% other_rsp_linear_analysis => rsp_set_gyre_linear_analysis end subroutine extras_controls - + subroutine rsp_set_gyre_linear_analysis(id,restart,ierr) use const_def @@ -72,24 +72,24 @@ subroutine rsp_set_gyre_linear_analysis(id,restart,ierr) logical, intent(in) :: restart integer, intent(out) :: ierr type (star_info), pointer :: s - + real(dp), allocatable :: global_data(:) real(dp), allocatable :: point_data(:,:) integer :: ipar(5), mode_l real(dp) :: rpar(1) - + integer, parameter :: modes = 3 integer :: npts(modes), nz, i, k real(dp), allocatable, dimension(:,:) :: r, v real(dp) :: velkm, v_surf, amix1, amix2, amixF, & period(modes) - + include 'formats' - + if (restart) return - + write(*,*) 'set gyre starting velocities' - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return @@ -108,17 +108,17 @@ subroutine rsp_set_gyre_linear_analysis(id,restart,ierr) call set_constant('L_SUN', Lsun) call set_constant('GYRE_DIR', TRIM(mesa_dir)//'/gyre/gyre') - + mode_l = 0 ! mode l (e.g. 0 for p modes, 1 for g modes) ! should match gyre.in mode l - + call star_get_pulse_data(s%id, 'GYRE', & .FALSE., .FALSE., .FALSE., global_data, point_data, ierr) if (ierr /= 0) then print *,'Failed when calling get_pulse_data' return end if - + call star_write_pulse_data(s%id, & 'GYRE', 'gyre.data', global_data, point_data, ierr) if (ierr /= 0) return @@ -139,16 +139,16 @@ subroutine rsp_set_gyre_linear_analysis(id,restart,ierr) call get_modes(mode_l, process_mode_, ipar, rpar) call final() - + amix1 = s% x_ctrl(4) ! s% RSP_fraction_1st_overtone amix2 = s% x_ctrl(5) ! s% RSP_fraction_2nd_overtone if((amix1+amix2) > 1d0) then - write(*,*) 'AMIX DO NOT ADD UP RIGHT' + write(*,*) 'AMIX DO NOT ADD UP RIGHT' call mesa_error(__FILE__,__LINE__,'set_gyre_linear_analysis') end if velkm = s% x_ctrl(6) ! s% RSP_kick_vsurf_km_per_sec amixF = 1d0 - (amix1 + amix2) - + if (amixF > 0d0 .and. npts(1) /= nz-1) then write(*,3) 'amixF > 0d0 .and. npts(1) /= nz-1', npts(1) write(*,*) 'cannot use fundamental for setting starting velocities' @@ -157,7 +157,7 @@ subroutine rsp_set_gyre_linear_analysis(id,restart,ierr) ierr = -1 return end if - + if (AMIX1 > 0d0 .and. npts(2) /= nz-1) then write(*,3) 'AMIX1 > 0d0 .and. npts(2) /= nz-1', npts(2) write(*,*) 'cannot use 1st overtone for setting starting velocities' @@ -166,7 +166,7 @@ subroutine rsp_set_gyre_linear_analysis(id,restart,ierr) ierr = -1 return end if - + if (AMIX2 > 0d0 .and. npts(2) /= nz-1) then write(*,3) 'AMIX2 > 0d0 .and. npts(3) /= nz-1', npts(3) write(*,*) 'cannot use 2nd overtone for setting starting velocities' @@ -175,7 +175,7 @@ subroutine rsp_set_gyre_linear_analysis(id,restart,ierr) ierr = -1 return end if - + v_surf = amixF*v(1,nz-1) + AMIX1*v(2,nz-1) + AMIX2*v(3,nz-1) do i=1,nz-1 @@ -185,13 +185,13 @@ subroutine rsp_set_gyre_linear_analysis(id,restart,ierr) end do s% v(1) = s% v(2) s% v_center = 0d0 - + do k=1,nz s% xh(s% i_v,k) = s% v(k) end do - + s% rsp_period = period(s% RSP_mode_for_setting_PERIODLIN + 1) - + !write(*,*) 'amix1 amix2 amixF velkm v_surf period', amix1, amix2, amixF, velkm, v_surf, s% rsp_period contains @@ -232,7 +232,7 @@ subroutine process_mode_ (md, ipar, rpar, retcode) write(*, 110) md%n_pg, freq, 1d0/freq, 1d0/(freq*60), 1d0/(freq*24*3600), 'stable' 110 format(I8,E16.4,F16.4,F14.4,F12.4,A16) end if - + if (md%n_pg > modes) return gr = md%grid() @@ -241,7 +241,7 @@ subroutine process_mode_ (md, ipar, rpar, retcode) npts(md%n_pg) = md%n do k = 1, md%n r(md%n_pg,k) = gr%pt(k)%x - v(md%n_pg,k) = md%xi_r(k) + v(md%n_pg,k) = md%xi_r(k) end do if (write_flag) then @@ -263,9 +263,9 @@ subroutine process_mode_ (md, ipar, rpar, retcode) retcode = 0 end subroutine process_mode_ - + end subroutine rsp_set_gyre_linear_analysis - + end module run_star_extras - + diff --git a/star/test_suite/rsp_gyre/src/run_star_extras_stub.f90 b/star/test_suite/rsp_gyre/src/run_star_extras_stub.f90 index 0428ba9e7..809330fc5 100644 --- a/star/test_suite/rsp_gyre/src/run_star_extras_stub.f90 +++ b/star/test_suite/rsp_gyre/src/run_star_extras_stub.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -29,26 +29,26 @@ module run_star_extras use math_lib implicit none - + include "test_suite_extras_def.inc" contains - + include "test_suite_extras.inc" - - + + include 'run_star_extras.inc' - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr type (star_info), pointer :: s - + write(*,*) 'cannot run rsp without gyre.' write(*,*) 'this test was intentionally skipped' write(*,*) 'good match for period', -1d0, -1d0 - + open(unit=30, file='final.mod', action='write', status='replace') write(30,*) 'fake final.mod' close(30) @@ -57,7 +57,7 @@ subroutine extras_controls(id, ierr) return end subroutine extras_controls - + end module run_star_extras - + diff --git a/star/test_suite/rsp_save_and_load_file/src/run.f90 b/star/test_suite/rsp_save_and_load_file/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/rsp_save_and_load_file/src/run.f90 +++ b/star/test_suite/rsp_save_and_load_file/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/rsp_save_and_load_file/src/run_star_extras.f90 b/star/test_suite/rsp_save_and_load_file/src/run_star_extras.f90 index 0b45167c4..c2f191861 100644 --- a/star/test_suite/rsp_save_and_load_file/src/run_star_extras.f90 +++ b/star/test_suite/rsp_save_and_load_file/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -29,7 +29,7 @@ module run_star_extras use auto_diff implicit none - + include "test_suite_extras_def.inc" logical :: need_to_write_LINA_data @@ -37,7 +37,7 @@ module run_star_extras include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -72,7 +72,7 @@ subroutine extras_startup(id, restart, ierr) need_to_write_LINA_data = .false. end if end subroutine extras_startup - + integer function extras_start_step(id) integer, intent(in) :: id @@ -92,7 +92,7 @@ integer function extras_start_step(id) need_to_write_LINA_data = .false. end if end function extras_start_step - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -127,8 +127,8 @@ integer function extras_finish_step(id) write(*,'(A)') extras_finish_step = terminate end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -139,7 +139,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -149,7 +149,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -162,8 +162,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -175,7 +175,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -186,8 +186,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -201,9 +201,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - - + + end module run_star_extras - + diff --git a/star/test_suite/semiconvection/src/run.f90 b/star/test_suite/semiconvection/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/semiconvection/src/run.f90 +++ b/star/test_suite/semiconvection/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/semiconvection/src/run_star_extras.f90 b/star/test_suite/semiconvection/src/run_star_extras.f90 index 7dad8da8b..1def9f2d7 100644 --- a/star/test_suite/semiconvection/src/run_star_extras.f90 +++ b/star/test_suite/semiconvection/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,16 +27,16 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -44,7 +44,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use num_lib integer, intent(in) :: id @@ -76,17 +76,17 @@ subroutine extras_after_evolve(id, ierr) integer :: k, k1, k2, k3, k4 type (star_info), pointer :: s logical :: okay - + include 'formats' - + okay = .true. ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) - + write(*,'(A)') k1 = 0 k2 = 0 @@ -109,15 +109,15 @@ subroutine extras_after_evolve(id, ierr) write(*,'(A)') if (okay) write(*,'(a)') 'all values are within tolerances' write(*,'(A)') - - + + contains - + real(dp) function avg_val(v) real(dp) :: v(:) avg_val = dot_product(v(k3:k2), s% dq(k3:k2)) / sum(s% dq(k3:k2)) end function avg_val - + subroutine check(str, val, low, hi) real(dp), intent(in) :: val, low, hi character (len=*) :: str @@ -129,10 +129,10 @@ subroutine check(str, val, low, hi) okay = .false. end if end subroutine check - - + + end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -142,7 +142,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -155,8 +155,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -168,7 +168,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -179,8 +179,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -194,7 +194,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -206,8 +206,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/simplex_solar_calibration/src/run_star_extras.f90 b/star/test_suite/simplex_solar_calibration/src/run_star_extras.f90 index c6d9619b2..0f184f5d0 100644 --- a/star/test_suite/simplex_solar_calibration/src/run_star_extras.f90 +++ b/star/test_suite/simplex_solar_calibration/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -28,9 +28,9 @@ module run_star_extras use math_lib use auto_diff use utils_lib - + implicit none - + include "test_suite_extras_def.inc" ! you can add your own data declarations here. @@ -39,8 +39,8 @@ module run_star_extras include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) use simplex_search_data integer, intent(in) :: id @@ -54,9 +54,9 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns star_simplex_procs% set_my_vars => set_my_vars - star_simplex_procs% will_set_my_param => will_set_my_param + star_simplex_procs% will_set_my_param => will_set_my_param star_simplex_procs% extras_check_model => extras_check_model star_simplex_procs% extras_finish_step => extras_finish_step star_simplex_procs% extras_after_evolve => extras_after_evolve @@ -64,8 +64,8 @@ subroutine extras_controls(id, ierr) s% how_many_other_mesh_fcns => how_many_mesh_fcns s% other_mesh_fcn_data => gradr_grada_mesh_fcn_data end subroutine extras_controls - - + + subroutine set_my_vars(id, ierr) ! called from star_simplex code use simplex_search_data, only: include_my_var1_in_chi2, my_var1 integer, intent(in) :: id @@ -82,8 +82,8 @@ subroutine set_my_vars(id, ierr) ! called from star_simplex code my_var1 = s% Teff end if end subroutine set_my_vars - - + + subroutine will_set_my_param(id, i, new_value, ierr) ! called from star_simplex code use simplex_search_data, only: vary_my_param1 integer, intent(in) :: id @@ -102,8 +102,8 @@ subroutine will_set_my_param(id, i, new_value, ierr) ! called from star_simplex s% mixing_length_alpha = new_value end if end subroutine will_set_my_param - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -114,7 +114,7 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -135,28 +135,28 @@ integer function how_many_extra_history_columns(id) integer, intent(in) :: id how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) real(dp) :: vals(n) integer, intent(out) :: ierr - + !note: do NOT add these names to history_columns.list ! the history_columns.list is only for the built-in log column options. ! it must not include the new column names you are adding here. - + ierr = 0 end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) integer, intent(in) :: id how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer, intent(in) :: id, n, nz character (len=maxlen_profile_column_name) :: names(n) @@ -164,7 +164,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) integer, intent(out) :: ierr integer :: k ierr = 0 - + !note: do NOT add these names to profile_columns.list ! the profile_columns.list is only for the built-in profile column options. ! it must not include the new column names you are adding here. @@ -174,9 +174,9 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) !names(1) = 'beta' !do k = 1, nz ! vals(k,1) = s% Pgas(k)/s% P(k) - !end do + !end do end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. ! note: cannot request retry; extras_check_model can do that. @@ -188,7 +188,7 @@ integer function extras_finish_step(id) call star_ptr(id, s, ierr) if (ierr /= 0) return extras_finish_step = keep_going - ! to save a profile, + ! to save a profile, ! s% need_to_save_profiles_now = .true. ! to update the star log, ! s% need_to_update_history_now = .true. @@ -196,8 +196,8 @@ integer function extras_finish_step(id) ! by default, indicate where (in the code) MESA terminated if (extras_finish_step == terminate) s% termination_code = t_extras_finish_step end function extras_finish_step - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -210,14 +210,14 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + subroutine how_many_mesh_fcns(id, n) integer, intent(in) :: id integer, intent(out) :: n n = 1 end subroutine how_many_mesh_fcns - - + + subroutine gradr_grada_mesh_fcn_data( & id, nfcns, names, gval_is_xa_function, vals1, ierr) integer, intent(in) :: id @@ -250,7 +250,7 @@ subroutine gradr_grada_mesh_fcn_data( & do k=1,nz vals(k,1) = weight*tanh(min(maxval,(s% gradr(k)-s% grada(k)-center)/width))*width end do - + end subroutine gradr_grada_mesh_fcn_data end module run_star_extras diff --git a/star/test_suite/simplex_solar_calibration/src/simplex_search_data.f90 b/star/test_suite/simplex_solar_calibration/src/simplex_search_data.f90 index 37e3c2136..fbacf0fda 100644 --- a/star/test_suite/simplex_solar_calibration/src/simplex_search_data.f90 +++ b/star/test_suite/simplex_solar_calibration/src/simplex_search_data.f90 @@ -27,9 +27,9 @@ module simplex_search_data use const_def, only: dp - - implicit none - + + implicit none + logical :: just_do_first_values, trace_chi2_info, & simplex_just_call_my_extras_check_model, & simplex_using_revised_max_yr_dt @@ -37,7 +37,7 @@ module simplex_search_data logical :: include_logg_in_chi2 real(dp) :: logg_target, logg_sigma - + logical :: include_logL_in_chi2 real(dp) :: logL_target, logL_sigma @@ -46,24 +46,24 @@ module simplex_search_data logical :: include_FeH_in_chi2 real(dp) :: FeH_target, FeH_sigma - + logical :: include_logR_in_chi2 real(dp) :: logR_target, logR_sigma - + logical :: include_age_in_chi2 real(dp) :: age_target, age_sigma integer :: num_smaller_steps_before_age_target real(dp) :: dt_for_smaller_steps_before_age_target - + logical :: include_surface_Z_div_X_in_chi2 real(dp) :: surface_Z_div_X_target, surface_Z_div_X_sigma - + logical :: include_surface_He_in_chi2 real(dp) :: surface_He_target, surface_He_sigma - + logical :: include_Rcz_in_chi2 real(dp) :: Rcz_target, Rcz_sigma - + logical :: include_solar_cs_rms_in_chi2, report_solar_cs_rms real(dp) :: solar_cs_rms_target, solar_cs_rms_sigma @@ -78,9 +78,9 @@ module simplex_search_data logical :: include_my_var3_in_chi2 real(dp) :: my_var3_target, my_var3_sigma character (len=32) :: my_var3_name - + real(dp) :: Z_div_X_solar - + logical :: eval_chi2_at_target_age_only real(dp) :: min_age_for_chi2, max_age_for_chi2 @@ -107,26 +107,26 @@ module simplex_search_data real(dp) :: first_FeH, first_Y, first_mass, first_alpha, first_f_ov real(dp) :: min_FeH, min_Y, min_mass, min_alpha, min_f_ov real(dp) :: max_FeH, max_Y, max_mass, max_alpha, max_f_ov - + logical :: vary_my_param1,vary_my_param2, vary_my_param3 real(dp) :: & first_my_param1, first_my_param2, first_my_param3, & min_my_param1, min_my_param2, min_my_param3, & max_my_param1, max_my_param2, max_my_param3 character (len=32) :: my_param1_name, my_param2_name, my_param3_name - + real(dp) :: f0_ov_div_f_ov, Lnuc_div_L_limit, chi2_limit - + real(dp) :: & max_yrs_dt_chi2_small_limit, chi2_limit_for_small_timesteps, & max_yrs_dt_chi2_smaller_limit, chi2_limit_for_smaller_timesteps, & max_yrs_dt_chi2_smallest_limit, chi2_limit_for_smallest_timesteps, & chi2_search_limit1, chi2_search_limit2, chi2_relative_increase_limit, & avg_age_sigma_limit, avg_model_number_sigma_limit - + integer :: min_num_samples_for_avg, max_num_samples_for_avg, & limit_num_chi2_too_big - + real(dp) :: min_age_limit, & sigmas_coeff_for_logg_limit, & sigmas_coeff_for_logL_limit, & @@ -139,100 +139,100 @@ module simplex_search_data sigmas_coeff_for_my_var1_limit, & sigmas_coeff_for_my_var2_limit, & sigmas_coeff_for_my_var3_limit - + ! output controls logical :: write_best_model_data_for_each_sample integer :: num_digits character (len=256) :: sample_results_dir, & sample_results_prefix, sample_results_postfix - + integer :: model_num_digits logical :: write_profile_for_best_model character (len=256) :: best_model_profile_filename - + logical :: save_model_for_best_model character (len=256) :: best_model_save_model_filename - + logical :: save_info_for_last_model character (len=256) :: last_model_save_info_filename - + ! miscellaneous logical :: trace_limits, save_controls character (len=256) :: save_controls_filename - + real(dp) :: Y_frac_he3 - + logical :: read_extra_simplex_search_inlist1 - character (len=256) :: extra_simplex_search_inlist1_name - + character (len=256) :: extra_simplex_search_inlist1_name + logical :: read_extra_simplex_search_inlist2 - character (len=256) :: extra_simplex_search_inlist2_name - + character (len=256) :: extra_simplex_search_inlist2_name + logical :: read_extra_simplex_search_inlist3 - character (len=256) :: extra_simplex_search_inlist3_name - + character (len=256) :: extra_simplex_search_inlist3_name + logical :: read_extra_simplex_search_inlist4 - character (len=256) :: extra_simplex_search_inlist4_name - + character (len=256) :: extra_simplex_search_inlist4_name + logical :: read_extra_simplex_search_inlist5 - character (len=256) :: extra_simplex_search_inlist5_name + character (len=256) :: extra_simplex_search_inlist5_name namelist /simplex_search_controls/ & just_do_first_values, & simplex_just_call_my_extras_check_model, & simplex_using_revised_max_yr_dt, & simplex_revised_max_yr_dt, & - - trace_chi2_info, & + + trace_chi2_info, & include_logg_in_chi2, & logg_target, logg_sigma, & - + include_logL_in_chi2, & logL_target, logL_sigma, & - + include_Teff_in_chi2, & Teff_target, Teff_sigma, & - + include_FeH_in_chi2, & FeH_target, FeH_sigma, & - + include_logR_in_chi2, & logR_target, logR_sigma, & - + include_age_in_chi2, & age_target, age_sigma, & num_smaller_steps_before_age_target, & dt_for_smaller_steps_before_age_target, & - + include_surface_Z_div_X_in_chi2, & surface_Z_div_X_target, surface_Z_div_X_sigma, & - + include_surface_He_in_chi2, & surface_He_target, surface_He_sigma, & - + include_Rcz_in_chi2, & Rcz_target, Rcz_sigma, & - + include_solar_cs_rms_in_chi2, & solar_cs_rms_target, solar_cs_rms_sigma, & report_solar_cs_rms, & - + include_my_var1_in_chi2, & my_var1_target, my_var1_sigma, my_var1_name, & - + include_my_var2_in_chi2, & my_var2_target, my_var2_sigma, my_var2_name, & - + include_my_var3_in_chi2, & my_var3_target, my_var3_sigma, my_var3_name, & - + Z_div_X_solar, & - + eval_chi2_at_target_age_only, & min_age_for_chi2, & max_age_for_chi2, & - + simplex_output_filename, & simplex_itermax, & simplex_fcn_calls_max, simplex_seed, & @@ -270,7 +270,7 @@ module simplex_search_data min_my_param1, min_my_param2, min_my_param3, & max_my_param1, max_my_param2, max_my_param3, & my_param1_name, my_param2_name, my_param3_name, & - + sigmas_coeff_for_logR_limit, & sigmas_coeff_for_surface_Z_div_X_limit, & sigmas_coeff_for_surface_He_limit, & @@ -283,7 +283,7 @@ module simplex_search_data write_best_model_data_for_each_sample, model_num_digits, & num_digits, sample_results_dir, & sample_results_prefix, sample_results_postfix, & - + write_profile_for_best_model, best_model_profile_filename, & save_model_for_best_model, best_model_save_model_filename, & save_info_for_last_model, last_model_save_info_filename, & @@ -300,17 +300,17 @@ module simplex_search_data extra_simplex_search_inlist4_name, & read_extra_simplex_search_inlist5, & extra_simplex_search_inlist5_name - + integer :: sample_number, nvar, num_chi2_too_big - + integer :: & i_Y, i_FeH, i_mass, i_alpha, i_f_ov, & i_my_param1, i_my_param2, i_my_param3 real(dp) :: & final_Y, final_FeH, final_mass, final_alpha, final_f_ov, & final_my_param1, final_my_param2, final_my_param3 - + real(dp) :: initial_max_years_for_timestep logical :: okay_to_restart @@ -346,11 +346,11 @@ module simplex_search_data best_my_param1, & best_my_param2, & best_my_param3 - + integer :: best_model_number integer :: max_num_samples integer :: scan_grid_skip_number - + real(dp), pointer, dimension(:) :: & sample_chi2, & sample_age, & @@ -379,14 +379,14 @@ module simplex_search_data sample_my_param1, & sample_my_param2, & sample_my_param3 - + integer, pointer, dimension(:) :: & sample_index_by_chi2, & sample_model_number, & sample_op_code - + real(dp) :: simplex_max_dt_next - + real(dp) :: avg_age_top_samples, avg_age_sigma, & avg_model_number_top_samples, avg_model_number_sigma @@ -397,7 +397,7 @@ module simplex_search_data integer :: star_id, star_model_number integer :: num_chi2_terms - + real(dp) :: & current_Y, & current_FeH, & @@ -413,7 +413,7 @@ module simplex_search_data logical :: have_sound_speed_data = .false. integer, parameter :: npts = 79 real(dp), dimension(npts) :: data_r, data_csound, data_width - + logical, parameter :: scale_simplex_params = .false. ! experimental @@ -441,7 +441,7 @@ end subroutine extras_controls_interface integer function extras_check_model_interface(id) integer, intent(in) :: id end function extras_check_model_interface - + integer function extras_finish_step_interface(id) integer, intent(in) :: id end function extras_finish_step_interface diff --git a/star/test_suite/simplex_solar_calibration/src/simplex_search_run_support.f90 b/star/test_suite/simplex_solar_calibration/src/simplex_search_run_support.f90 index 78b38c1c1..d46c98efa 100644 --- a/star/test_suite/simplex_solar_calibration/src/simplex_search_run_support.f90 +++ b/star/test_suite/simplex_solar_calibration/src/simplex_search_run_support.f90 @@ -33,13 +33,13 @@ module simplex_search_run_support use const_def use simplex_search_data - + implicit none - - - contains - + + contains + + subroutine do_run_star_simplex( & extras_controls, inlist_simplex_search_controls_fname) use run_star_support, only: do_read_star_job, id_from_read_star_job @@ -47,14 +47,14 @@ subroutine do_run_star_simplex( & subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr - end subroutine extras_controls + end subroutine extras_controls end interface character (len=256) :: inlist_simplex_search_controls_fname optional inlist_simplex_search_controls_fname integer :: id, ierr character (len=256) :: inlist_fname - + include 'formats' ierr = 0 @@ -67,10 +67,10 @@ end subroutine extras_controls star_id = id okay_to_restart = .true. - + call init_simplex_search_data(ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + star_simplex_procs% extras_controls => extras_controls if (present(inlist_simplex_search_controls_fname)) then @@ -84,7 +84,7 @@ end subroutine extras_controls write(*,*) 'failed in read_simplex_search_controls' call mesa_error(__FILE__,__LINE__) end if - + if (Y_depends_on_Z .and. vary_Y) then vary_Y = .false. write(*,*) & @@ -98,12 +98,12 @@ end subroutine extras_controls call mesa_error(__FILE__,__LINE__) end if end if - + next_Y_to_try = -1 next_FeH_to_try = -1 - next_mass_to_try = -1 + next_mass_to_try = -1 next_alpha_to_try = -1 - next_f_ov_to_try = -1 + next_f_ov_to_try = -1 sample_number = 0 max_num_samples = 0 num_chi2_too_big = 0 @@ -118,7 +118,7 @@ end subroutine extras_controls my_param1 = 0 my_param2 = 0 my_param3 = 0 - + call init_sample_ptrs if (just_do_first_values) then @@ -136,12 +136,12 @@ end subroutine extras_controls end if end subroutine do_run_star_simplex - - + + subroutine do_simplex(ierr) use num_lib integer, intent(out) :: ierr - + real(dp) :: final_mass, final_alpha, final_Y, final_FeH real(dp), dimension(:), pointer :: x_first, x_lower, x_upper, x_final real(dp), pointer :: simplex(:,:), f(:) @@ -153,11 +153,11 @@ subroutine do_simplex(ierr) num_fcn_calls_for_ars, num_accepted_for_ars integer :: seed, i, j, k, num_samples logical :: start_from_given_simplex_and_f - + include 'formats' - + ierr = 0 - + if (vary_mass) then nvar = nvar+1; i_mass = nvar if (min_mass >= max_mass) then @@ -174,7 +174,7 @@ subroutine do_simplex(ierr) ierr = -1 end if end if - + if (vary_FeH) then nvar = nvar+1; i_FeH = nvar if (min_FeH >= max_FeH) then @@ -183,7 +183,7 @@ subroutine do_simplex(ierr) ierr = -1 end if end if - + if (vary_alpha) then nvar = nvar+1; i_alpha = nvar if (min_alpha >= max_alpha) then @@ -192,7 +192,7 @@ subroutine do_simplex(ierr) ierr = -1 end if end if - + if (vary_f_ov) then nvar = nvar+1; i_f_ov = nvar if (min_f_ov >= max_f_ov) then @@ -201,7 +201,7 @@ subroutine do_simplex(ierr) ierr = -1 end if end if - + if (vary_my_param1) then nvar = nvar+1; i_my_param1 = nvar if (min_my_param1 >= max_my_param1) then @@ -210,7 +210,7 @@ subroutine do_simplex(ierr) ierr = -1 end if end if - + if (vary_my_param2) then nvar = nvar+1; i_my_param2 = nvar if (min_my_param2 >= max_my_param2) then @@ -219,7 +219,7 @@ subroutine do_simplex(ierr) ierr = -1 end if end if - + if (vary_my_param3) then nvar = nvar+1; i_my_param3 = nvar if (min_my_param3 >= max_my_param3) then @@ -230,13 +230,13 @@ subroutine do_simplex(ierr) end if if (ierr /= 0) return - + lrpar = 0; lipar = 0 allocate( & rpar(lrpar), ipar(lipar), simplex(nvar,nvar+1), f(nvar+1), & x_lower(nvar), x_upper(nvar), x_first(nvar), x_final(nvar)) - + if (.not. scale_simplex_params) then call set_xs else ! values are scaled to -1..1 with first at 0 @@ -244,7 +244,7 @@ subroutine do_simplex(ierr) x_upper(1:nvar) = 1 x_first(1:nvar) = 0 end if - + if (restart_simplex_from_file) then call read_samples_from_file(simplex_output_filename, ierr) if (ierr /= 0) return @@ -255,13 +255,13 @@ subroutine do_simplex(ierr) end if num_samples = sample_number call setup_simplex_and_f(ierr) - if (ierr /= 0) return + if (ierr /= 0) return start_from_given_simplex_and_f = .true. call set_sample_averages else start_from_given_simplex_and_f = .false. end if - + call NM_simplex( & nvar, x_lower, x_upper, x_first, x_final, f_final, & simplex, f, start_from_given_simplex_and_f, simplex_f, & @@ -274,7 +274,7 @@ subroutine do_simplex(ierr) lrpar, rpar, lipar, ipar, & num_iters, num_fcn_calls, & num_fcn_calls_for_ars, num_accepted_for_ars, ierr) - + if (vary_Y) & final_Y = simplex_param( & x_final(i_Y), first_Y, min_Y, max_Y) @@ -283,32 +283,32 @@ subroutine do_simplex(ierr) final_FeH = simplex_param( & x_final(i_FeH), first_FeH, & min_FeH, max_FeH) - + if (vary_mass) & final_mass = simplex_param( & x_final(i_mass), first_mass, & min_mass, max_mass) - + if (vary_alpha) & final_alpha = simplex_param( & x_final(i_alpha), first_alpha, & min_alpha, max_alpha) - + if (vary_f_ov) & final_f_ov = simplex_param( & x_final(i_f_ov), first_f_ov, & min_f_ov, max_f_ov) - + if (vary_my_param1) & final_my_param1 = simplex_param( & x_final(i_my_param1), first_my_param1, & min_my_param1, max_my_param1) - + if (vary_my_param2) & final_my_param2 = simplex_param( & x_final(i_my_param2), first_my_param2, & min_my_param2, max_my_param2) - + if (vary_my_param3) & final_my_param3 = simplex_param( & x_final(i_my_param3), first_my_param3, & @@ -316,11 +316,11 @@ subroutine do_simplex(ierr) deallocate( & rpar, ipar, simplex, f, x_lower, x_upper, x_first, x_final) - - + + contains - - + + subroutine set_xs ! x_first, x_lower, x_upper if (vary_Y) then x_first(i_Y) = first_Y @@ -346,35 +346,35 @@ subroutine set_xs ! x_first, x_lower, x_upper x_first(i_f_ov) = first_f_ov x_lower(i_f_ov) = min_f_ov x_upper(i_f_ov) = max_f_ov - end if + end if if (vary_my_param1) then x_first(i_my_param1) = first_my_param1 x_lower(i_my_param1) = min_my_param1 x_upper(i_my_param1) = max_my_param1 - end if + end if if (vary_my_param2) then x_first(i_my_param2) = first_my_param2 x_lower(i_my_param2) = min_my_param2 x_upper(i_my_param2) = max_my_param2 - end if + end if if (vary_my_param3) then x_first(i_my_param3) = first_my_param3 x_lower(i_my_param3) = min_my_param3 x_upper(i_my_param3) = max_my_param3 - end if + end if end subroutine set_xs - - + + subroutine setup_simplex_and_f(ierr) use num_lib, only: qsort integer, intent(out) :: ierr - + integer :: j, i, k, max_i, jj integer, pointer :: index(:) ! sort results by increasing sample_chi2 - + include 'formats' - + ierr = 0 allocate(index(num_samples), stat=ierr) if (ierr /= 0) then @@ -397,17 +397,17 @@ subroutine setup_simplex_and_f(ierr) simplex(i_FeH,j) = & simplex_inverse(sample_init_FeH(i), first_FeH, min_FeH, max_FeH) write(*,3) 'FeH', j, i, sample_init_FeH(i) - end if + end if if (vary_mass) then simplex(i_mass,j) = & simplex_inverse(sample_mass(i), first_mass, min_mass, max_mass) write(*,3) 'mass', j, i, sample_mass(i) - end if + end if if (vary_alpha) then simplex(i_alpha,j) = & simplex_inverse(sample_alpha(i), first_alpha, min_alpha, max_alpha) write(*,3) 'alpha', j, i, sample_alpha(i) - end if + end if if (vary_f_ov) then simplex(i_f_ov,j) = & simplex_inverse(sample_f_ov(i), first_f_ov, min_f_ov, max_f_ov) @@ -430,7 +430,7 @@ subroutine setup_simplex_and_f(ierr) end if write(*,'(A)') end do - + deallocate(index) write(*,2) 'num_samples', max_i @@ -458,9 +458,9 @@ subroutine setup_simplex_and_f(ierr) write(*,'(A)') write(*,'(A)') num_samples = max_i - + end subroutine setup_simplex_and_f - + end subroutine do_simplex @@ -475,15 +475,15 @@ real(dp) function simplex_f( & real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(in) :: op_code integer, intent(out) :: ierr - + integer :: prev_sample_number include 'formats' - + ierr = 0 - + write(*,'(A)') write(*,'(A)') - + if (vary_Y) then next_Y_to_try = simplex_param( & x(i_Y), first_Y, min_Y, max_Y) @@ -501,7 +501,7 @@ real(dp) function simplex_f( & write(*,1) 'next_FeH_to_try', & next_FeH_to_try, x(i_FeH) end if - + if (vary_mass) then next_mass_to_try = simplex_param(& x(i_mass), first_mass, min_mass, max_mass) @@ -513,7 +513,7 @@ real(dp) function simplex_f( & return end if end if - + if (vary_alpha) then next_alpha_to_try = simplex_param( & x(i_alpha), first_alpha, min_alpha, max_alpha) @@ -525,7 +525,7 @@ real(dp) function simplex_f( & return end if end if - + if (vary_f_ov) then next_f_ov_to_try = simplex_param( & x(i_f_ov), first_f_ov, min_f_ov, max_f_ov) @@ -537,7 +537,7 @@ real(dp) function simplex_f( & return end if end if - + if (vary_my_param1) then next_my_param1_to_try = simplex_param( & x(i_my_param1), first_my_param1, min_my_param1, max_my_param1) @@ -549,7 +549,7 @@ real(dp) function simplex_f( & return end if end if - + if (vary_my_param2) then next_my_param2_to_try = simplex_param( & x(i_my_param2), first_my_param2, min_my_param2, max_my_param2) @@ -561,7 +561,7 @@ real(dp) function simplex_f( & return end if end if - + if (vary_my_param3) then next_my_param3_to_try = simplex_param( & x(i_my_param3), first_my_param3, min_my_param3, max_my_param3) @@ -573,7 +573,7 @@ real(dp) function simplex_f( & return end if end if - + prev_sample_number = sample_number simplex_f = eval1(star_id, ierr) if (ierr /= 0) then @@ -582,13 +582,13 @@ real(dp) function simplex_f( & simplex_f = 1d99 return end if - + if (sample_number == prev_sample_number) then write(*,*) 'failed to get new chi^2 -- try again' simplex_f = 1d99 return end if - + call save_best_for_sample(sample_number, op_code) call save_sample_results_to_file(-1, simplex_output_filename, ierr) @@ -602,10 +602,10 @@ real(dp) function simplex_f( & ierr = -1 return endif - + end function simplex_f - + real(dp) function simplex_param(x, first, min, max) result(param) real(dp), intent(in) :: x, first, min, max if (.not. scale_simplex_params) then @@ -619,7 +619,7 @@ real(dp) function simplex_param(x, first, min, max) result(param) end if end function simplex_param - + real(dp) function simplex_inverse(param, first, min, max) result(x) real(dp), intent(in) :: param, first, min, max if (.not. scale_simplex_params) then @@ -641,11 +641,11 @@ real(dp) function simplex_inverse(param, first, min, max) result(x) end if end function simplex_inverse - + subroutine save_best_for_sample(i, op_code) integer, intent(in) :: i, op_code integer :: ierr - + if (i <= 0) return if (i > max_num_samples) then call alloc_sample_ptrs(ierr) @@ -655,10 +655,10 @@ subroutine save_best_for_sample(i, op_code) return end if end if - + sample_op_code(i) = op_code sample_chi2(i) = best_chi2 - + sample_age(i) = best_age sample_init_Y(i) = current_Y sample_init_FeH(i) = current_FeH @@ -676,7 +676,7 @@ subroutine save_best_for_sample(i, op_code) sample_Teff(i) = best_Teff sample_logg(i) = best_logg sample_FeH(i) = best_FeH - + sample_logR(i) = best_logR sample_surface_Z_div_X(i) = best_surface_Z_div_X sample_surface_He(i) = best_surface_He @@ -693,14 +693,14 @@ subroutine save_best_for_sample(i, op_code) call set_sample_averages end subroutine save_best_for_sample - - + + subroutine set_sample_averages integer :: ierr, jj, j, n real(dp) :: avg_age_top_samples2, avg_model_number_top_samples2 - + include 'formats' - + call set_sample_index_by_chi2 n = min(sample_number, max_num_samples_for_avg) if (n < max(2,min_num_samples_for_avg)) then @@ -738,7 +738,7 @@ subroutine set_sample_averages sqrt(max(0d0,(avg_model_number_top_samples2 - & avg_model_number_top_samples*avg_model_number_top_samples/n)/(n-1))) avg_model_number_top_samples = avg_model_number_top_samples/n - + write(*,'(A)') write(*,2) 'n for averages', n write(*,1) 'avg_age_top_samples', avg_age_top_samples @@ -751,10 +751,10 @@ subroutine set_sample_averages avg_model_number_sigma_limit*avg_model_number_sigma write(*,'(A)') !call mesa_error(__FILE__,__LINE__,'set_sample_averages') - + end subroutine set_sample_averages - - + + subroutine zero_best_info best_chi2 = 0 best_init_h1 = 0 @@ -780,36 +780,36 @@ subroutine zero_best_info best_my_param3 = 0 end subroutine zero_best_info - - real(dp) function eval1(id_in,ierr) + + real(dp) function eval1(id_in,ierr) use run_star_support, only: run1_star - + integer, intent(in) :: id_in integer, intent(out) :: ierr - + logical, parameter :: & do_alloc_star = .false., & do_free_star = .false. - + type (star_info), pointer :: s logical :: restart - integer :: id, i + integer :: id, i include 'formats' - + ierr = 0 id = id_in - - call star_ptr(id, s, ierr) + + call star_ptr(id, s, ierr) if (ierr /= 0) return eval1 = -1 - + ! init for start of run - best_chi2 = -1 - num_chi2_too_big = 0 + best_chi2 = -1 + num_chi2_too_big = 0 simplex_max_dt_next = 1d99 - + call run1_star( & do_alloc_star, do_free_star, & ! note that these are both false okay_to_restart, & @@ -817,33 +817,33 @@ real(dp) function eval1(id_in,ierr) simplex_extras_controls, & ierr) if (ierr /= 0) return - + s% max_years_for_timestep = initial_max_years_for_timestep simplex_using_revised_max_yr_dt = .false. simplex_revised_max_yr_dt = s% max_years_for_timestep - + okay_to_restart = .false. ! only allow restart on 1st call to run1_star - + eval1 = best_chi2 - + if (simplex_just_call_my_extras_check_model) return - + if (best_chi2 < 0) then write(*,*) 'failed to find chi^2 for this run' call zero_best_info best_chi2 = 999999d0 return end if - + sample_number = sample_number + 1 - write(*,*) + write(*,*) call show_best(6) - + if (write_best_model_data_for_each_sample) & call write_best(sample_number) - + end function eval1 - + subroutine simplex_extras_controls(id, ierr) integer, intent(in) :: id @@ -854,12 +854,12 @@ subroutine simplex_extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + call star_simplex_procs% extras_controls(id, ierr) if (ierr /= 0) return initial_max_years_for_timestep = s% max_years_for_timestep - + if (simplex_just_call_my_extras_check_model) return ! overwrite various inlist controls @@ -899,7 +899,7 @@ subroutine simplex_extras_controls(id, ierr) else f_ov = first_f_ov end if - + if (vary_FeH) then FeH = next_FeH_to_try else @@ -916,7 +916,7 @@ subroutine simplex_extras_controls(id, ierr) X = (1d0 - Y0)/c Y = (Y0 + a*(b + Y0))/c Z = 1d0 - (X + Y) - else + else if (vary_Y) then Y = next_Y_to_try else @@ -931,30 +931,30 @@ subroutine simplex_extras_controls(id, ierr) else s% job% new_mass = first_mass end if - + s% job% relax_initial_mass = .true. s% initial_mass = s% job% new_mass - + initial_Y = Y !s% initial_Z = Z << don't do this. it interferes with use of zams file. - + s% job% initial_h1 = X s% job% initial_h2 = 0 s% job% initial_he3 = Y_frac_he3*Y s% job% initial_he4 = Y - s% job% initial_he3 - s% job% set_uniform_initial_composition = .true. - + s% job% set_uniform_initial_composition = .true. + current_Y = Y current_FeH = FeH current_mass = s% job% new_mass current_alpha = s% mixing_length_alpha current_f_ov = f_ov - + current_h1 = X current_he3 = s% job% initial_he3 current_he4 = s% job% initial_he4 current_Z = Z - + if (f_ov /= 0d0) then s% overshoot_scheme(1) = 'exponential' s% overshoot_zone_type(1) = 'any' @@ -963,19 +963,19 @@ subroutine simplex_extras_controls(id, ierr) s% overshoot_f(1) = f_ov s% overshoot_f0(1) = f0_ov_div_f_ov*f_ov end if - + s% extras_check_model => simplex_extras_check_model s% extras_finish_step => simplex_extras_finish_step s% extras_after_evolve => simplex_extras_after_evolve - + end subroutine simplex_extras_controls - integer function simplex_extras_check_model(id) + integer function simplex_extras_check_model(id) integer, intent(in) :: id integer :: other_check, ierr type (star_info), pointer :: s - + include 'formats' ierr = 0 call star_ptr(id, s, ierr) @@ -991,24 +991,24 @@ integer function simplex_extras_check_model(id) if (other_check > simplex_extras_check_model) & simplex_extras_check_model = other_check end if - + star_model_number = s% model_number - + end function simplex_extras_check_model - + integer function simplex_extras_finish_step(id) integer, intent(in) :: id integer :: ierr type (star_info), pointer :: s ierr = 0 - simplex_extras_finish_step = star_simplex_procs% extras_finish_step(id) + simplex_extras_finish_step = star_simplex_procs% extras_finish_step(id) call star_ptr(id, s, ierr) if (ierr /= 0) return s% dt_next = min(s% dt_next, simplex_max_dt_next) end function simplex_extras_finish_step - + subroutine simplex_extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -1024,7 +1024,7 @@ subroutine simplex_extras_after_evolve(id, ierr) !write(*,*) 'call do_simplex_extras_check_model before terminate' ckm = do_simplex_extras_check_model(s, id) !write(*,*) 'done do_simplex_extras_check_model before terminate' - end if + end if call star_simplex_procs% extras_after_evolve(id, ierr) if (save_info_for_last_model) then write(*,1) 'chi2', chi2 @@ -1051,21 +1051,21 @@ integer function do_simplex_extras_check_model(s, id) type (star_info), pointer :: s integer, intent(in) :: id - + integer :: ierr, i, j, n logical :: store_model, checking_age real(dp) :: age_limit, model_limit, err, X, Y, Z, & surface_X, surface_Z, remaining_years, prev_max_years, min_max - + include 'formats' - + do_simplex_extras_check_model = keep_going simplex_max_dt_next = 1d99 chi2 = -1 FeH = -1 checking_age = & eval_chi2_at_target_age_only .or. include_age_in_chi2 - + if (checking_age) then if (num_smaller_steps_before_age_target <= 0 .or. & dt_for_smaller_steps_before_age_target <= 0) then @@ -1113,7 +1113,7 @@ integer function do_simplex_extras_check_model(s, id) i = floor(remaining_years/s% max_years_for_timestep + 1d-6) write(*,3) 'remaining steps and years until age target', & s% model_number, i, remaining_years - else + else write(*,2) 'remaining_years until age target', & s% model_number, remaining_years end if @@ -1141,16 +1141,16 @@ integer function do_simplex_extras_check_model(s, id) return end if - if (include_age_in_chi2 .and. s% star_age < min_age_for_chi2) return + if (include_age_in_chi2 .and. s% star_age < min_age_for_chi2) return if (eval_chi2_at_target_age_only .and. s% star_age < age_target) return if (s% L_nuc_burn_total < s% L_phot*Lnuc_div_L_limit .or. & s% star_age < min_age_limit) then return end if - + if (.not. checking_age) then - + age_limit = avg_age_top_samples + avg_age_sigma_limit*avg_age_sigma if (s% star_age > age_limit) then write(*,1) 'star age > limit from top samples', s% star_age, age_limit @@ -1160,7 +1160,7 @@ integer function do_simplex_extras_check_model(s, id) do_simplex_extras_check_model = terminate return end if - + model_limit = & avg_model_number_top_samples + & avg_model_number_sigma_limit*avg_model_number_sigma @@ -1175,7 +1175,7 @@ integer function do_simplex_extras_check_model(s, id) end if end if - + surface_X = max(s% surface_h1, 1d-10) surface_He = s% surface_he3 + s% surface_he4 surface_Z = max(1d-99, min(1d0, 1 - (surface_X + surface_He))) @@ -1201,10 +1201,10 @@ integer function do_simplex_extras_check_model(s, id) else solar_cs_rms = 0 end if - + call check_limits if (do_simplex_extras_check_model /= keep_going) return - + chi2 = get_chi2(s, .true., ierr) if (ierr /= 0) then write(*,'(a40,i6)') 'failed to calculate chi^2', s% model_number @@ -1234,11 +1234,11 @@ integer function do_simplex_extras_check_model(s, id) write(*,'(a50,i6,99f16.2)') 'chi^2', s% model_number, chi2 store_model = .true. - + if (checking_age) then ! leave max_years_for_timestep as is else if (chi2 <= chi2_limit_for_smallest_timesteps) then - s% max_years_for_timestep = max_yrs_dt_chi2_smallest_limit + s% max_years_for_timestep = max_yrs_dt_chi2_smallest_limit if (s% dt > max_yrs_dt_chi2_smallest_limit*secyer) then s% dt = max_yrs_dt_chi2_smallest_limit*secyer s% timestep_hold = s% model_number + 10 @@ -1247,9 +1247,9 @@ integer function do_simplex_extras_check_model(s, id) max_yrs_dt_chi2_smallest_limit do_simplex_extras_check_model = redo return - end if + end if else if (chi2 <= chi2_limit_for_smaller_timesteps) then - s% max_years_for_timestep = max_yrs_dt_chi2_smaller_limit + s% max_years_for_timestep = max_yrs_dt_chi2_smaller_limit if (s% dt > max_yrs_dt_chi2_smaller_limit*secyer) then s% dt = max_yrs_dt_chi2_smaller_limit*secyer s% timestep_hold = s% model_number + 10 @@ -1258,9 +1258,9 @@ integer function do_simplex_extras_check_model(s, id) max_yrs_dt_chi2_smaller_limit do_simplex_extras_check_model = redo return - end if + end if else if (chi2 <= chi2_limit_for_small_timesteps) then - s% max_years_for_timestep = max_yrs_dt_chi2_small_limit + s% max_years_for_timestep = max_yrs_dt_chi2_small_limit if (s% dt > max_yrs_dt_chi2_small_limit*secyer) then s% dt = max_yrs_dt_chi2_small_limit*secyer s% timestep_hold = s% model_number + 10 @@ -1269,19 +1269,19 @@ integer function do_simplex_extras_check_model(s, id) max_yrs_dt_chi2_small_limit do_simplex_extras_check_model = redo return - end if + end if end if - + if (best_chi2 <= 0 .or. chi2 < best_chi2) then call save_best_info(s) end if - + call final_checks - + contains - - + + subroutine check_too_many_bad if (best_chi2 > 0) then num_chi2_too_big = num_chi2_too_big + 1 @@ -1293,8 +1293,8 @@ subroutine check_too_many_bad end if num_chi2_too_big = 0 end subroutine check_too_many_bad - - + + subroutine final_checks if (include_age_in_chi2 .and. s% star_age >= max_age_for_chi2) then write(*,*) 'have reached max_age_for_chi2' @@ -1322,8 +1322,8 @@ subroutine final_checks num_chi2_too_big = 0 end if end subroutine final_checks - - + + subroutine check_limits real(dp) :: logg_limit, logL_limit, Teff_limit, & logR_limit, surface_Z_div_X_limit, surface_He_limit, solar_Rcz_limit, & @@ -1331,7 +1331,7 @@ subroutine check_limits integer :: nz include 'formats' nz = s% nz - + if (s% star_age >= max_age_for_chi2) then write(*,*) 'have reached max_age_for_chi2' do_simplex_extras_check_model = terminate @@ -1348,14 +1348,14 @@ subroutine check_limits write(*,'(A)') do_simplex_extras_check_model = terminate return - end if + end if if (trace_limits) then write(*,1) 'Teff', s% Teff write(*,1) 'Teff_limit', Teff_limit end if end if - - if (sigmas_coeff_for_logg_limit /= 0 .and. logg_sigma > 0) then + + if (sigmas_coeff_for_logg_limit /= 0 .and. logg_sigma > 0) then logg_limit = logg_target + logg_sigma*sigmas_coeff_for_logg_limit if ((sigmas_coeff_for_logg_limit > 0 .and. logg > logg_limit) .or. & (sigmas_coeff_for_logg_limit < 0 .and. logg < logg_limit)) then @@ -1371,7 +1371,7 @@ subroutine check_limits write(*,1) 'logg_limit', logg_limit end if end if - + if (sigmas_coeff_for_logL_limit /= 0 .and. logL_sigma > 0) then logL_limit = logL_target + logL_sigma*sigmas_coeff_for_logL_limit if ((sigmas_coeff_for_logL_limit > 0 .and. s% log_surface_luminosity > logL_limit) .or. & @@ -1388,7 +1388,7 @@ subroutine check_limits write(*,1) 'logL_limit', logL_limit end if end if - + if (sigmas_coeff_for_logR_limit /= 0 .and. logR_sigma > 0) then logR_limit = logR_target + logR_sigma*sigmas_coeff_for_logR_limit if ((sigmas_coeff_for_logR_limit > 0 .and. logR > logR_limit) .or. & @@ -1405,7 +1405,7 @@ subroutine check_limits write(*,1) 'logR_limit', logR_limit end if end if - + if (sigmas_coeff_for_surface_Z_div_X_limit /= 0 .and. surface_Z_div_X_sigma > 0) then surface_Z_div_X_limit = surface_Z_div_X_target + & surface_Z_div_X_sigma*sigmas_coeff_for_surface_Z_div_X_limit @@ -1425,7 +1425,7 @@ subroutine check_limits write(*,1) 'surface_Z_div_X_limit', surface_Z_div_X_limit end if end if - + if (sigmas_coeff_for_surface_He_limit /= 0 .and. surface_He_sigma > 0) then surface_He_limit = surface_He_target + & surface_He_sigma*sigmas_coeff_for_surface_He_limit @@ -1445,7 +1445,7 @@ subroutine check_limits write(*,1) 'surface_He_limit', surface_He_limit end if end if - + if (sigmas_coeff_for_solar_Rcz_limit /= 0 .and. Rcz_sigma > 0) then solar_Rcz_limit = Rcz_target + Rcz_sigma*sigmas_coeff_for_solar_Rcz_limit if ((sigmas_coeff_for_solar_Rcz_limit > 0 .and. Rcz > solar_Rcz_limit) .or. & @@ -1462,7 +1462,7 @@ subroutine check_limits write(*,1) 'solar_Rcz_limit', solar_Rcz_limit end if end if - + if (sigmas_coeff_for_solar_cs_rms_limit /= 0 .and. solar_cs_rms_sigma > 0) then solar_cs_rms_limit = solar_cs_rms_target + & solar_cs_rms_sigma*sigmas_coeff_for_solar_cs_rms_limit @@ -1482,7 +1482,7 @@ subroutine check_limits write(*,1) 'solar_cs_rms_limit', solar_cs_rms_limit end if end if - + if (sigmas_coeff_for_my_var1_limit /= 0 .and. my_var1_sigma > 0) then my_var1_limit = & my_var1_target + my_var1_sigma*sigmas_coeff_for_my_var1_limit @@ -1502,7 +1502,7 @@ subroutine check_limits write(*,1) 'my_var1_limit', my_var1_limit end if end if - + if (sigmas_coeff_for_my_var2_limit /= 0 .and. my_var2_sigma > 0) then my_var2_limit = & my_var2_target + my_var2_sigma*sigmas_coeff_for_my_var2_limit @@ -1522,7 +1522,7 @@ subroutine check_limits write(*,1) 'my_var2_limit', my_var2_limit end if end if - + if (sigmas_coeff_for_my_var3_limit /= 0 .and. my_var3_sigma > 0) then my_var3_limit = & my_var3_target + my_var3_sigma*sigmas_coeff_for_my_var3_limit @@ -1542,20 +1542,20 @@ subroutine check_limits write(*,1) 'my_var3_limit', my_var3_limit end if end if - + end subroutine check_limits subroutine setup_solar_data_for_calc_rms(ierr) use const_def, only: mesa_data_dir integer, intent(out) :: ierr - + integer, parameter :: lines_to_skip = 11 integer :: iounit, i, k real(dp) :: jnk - + character (len=256) :: fname - + have_sound_speed_data = .true. ierr = 0 iounit = alloc_iounit(ierr) @@ -1568,8 +1568,8 @@ subroutine setup_solar_data_for_calc_rms(ierr) write(*,*) 'failed to open ' // trim(fname) call free_iounit(iounit) return - end if - + end if + do i=1,lines_to_skip read(iounit,fmt=*,iostat=ierr) if (ierr /= 0) then @@ -1579,7 +1579,7 @@ subroutine setup_solar_data_for_calc_rms(ierr) return end if end do - + do i=1,npts read(iounit,fmt=*,iostat=ierr) & data_r(i), jnk, data_csound(i), jnk, jnk, jnk, data_width(i) @@ -1593,7 +1593,7 @@ subroutine setup_solar_data_for_calc_rms(ierr) close(iounit) call free_iounit(iounit) - + end subroutine setup_solar_data_for_calc_rms @@ -1602,7 +1602,7 @@ real(dp) function calc_current_rms(s, nz) ! dR weighted use interp_1d_def type (star_info), pointer :: s integer, intent(in) :: nz - + logical, parameter :: dbg = .false. real(dp), target :: calc_rms_f1_ary(4*nz) real(dp), pointer :: calc_rms_f1(:), calc_rms_f(:,:) @@ -1611,10 +1611,10 @@ real(dp) function calc_current_rms(s, nz) ! dR weighted real(dp), target :: pm_work_ary(nz*pm_work_size) real(dp), pointer :: pm_work(:) integer :: k, i, ierr - + include 'formats' - - calc_current_rms = -1 + + calc_current_rms = -1 pm_work => pm_work_ary calc_rms_f1 => calc_rms_f1_ary calc_rms_f(1:4,1:nz) => calc_rms_f1(1:4*nz) @@ -1627,7 +1627,7 @@ real(dp) function calc_current_rms(s, nz) ! dR weighted return end if end if - + do k=1,nz if (k == 1) then calc_rms_f(1,k) = s% csound(k) @@ -1661,19 +1661,19 @@ real(dp) function calc_current_rms(s, nz) ! dR weighted if (dr < 0) dr = -dr ! change to weigh by point rather than by dr dr = 1 - + sumdr = sumdr + dr y2 = dr*pow2((cs - data_csound(i))/data_csound(i)) sumy2 = sumy2 + y2 if (dbg) write(*,2) 'rms cs, data_cs, reldiff, y2, dr', i, cs, data_csound(i), & (cs - data_csound(i))/data_csound(i), y2, dr end do - + calc_current_rms = sqrt(sumy2/sumdr) if (dbg) write(*,1) 'calc_current_rms', calc_current_rms end function calc_current_rms - + end function do_simplex_extras_check_model @@ -1684,17 +1684,17 @@ real(dp) function get_chi2(s, trace_okay, ierr) integer :: i, n, chi2N real(dp) :: chi2term, Teff, logL, chi2sum - + ! calculate chi^2 following Brandao et al, 2011, eqn 11 include 'formats' - + ierr = 0 chi2sum = 0 chi2N = 0 - + call star_simplex_procs% set_my_vars(s% id, ierr) if (ierr /= 0) return - + if (Teff_sigma > 0 .and. include_Teff_in_chi2) then Teff = s% Teff chi2term = pow2((Teff - Teff_target)/Teff_sigma) @@ -1703,7 +1703,7 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2sum = chi2sum + chi2term chi2N = chi2N + 1 end if - + if (logL_sigma > 0 .and. include_logL_in_chi2) then logL = s% log_surface_luminosity chi2term = pow2((logL - logL_target)/logL_sigma) @@ -1712,7 +1712,7 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2sum = chi2sum + chi2term chi2N = chi2N + 1 end if - + if (logg_sigma > 0 .and. include_logg_in_chi2) then chi2term = pow2((logg - logg_target)/logg_sigma) if (trace_okay .and. trace_chi2_info) & @@ -1720,7 +1720,7 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2sum = chi2sum + chi2term chi2N = chi2N + 1 end if - + if (FeH_sigma > 0 .and. include_FeH_in_chi2) then chi2term = pow2((FeH - FeH_target)/FeH_sigma) if (trace_okay .and. trace_chi2_info) & @@ -1728,7 +1728,7 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2sum = chi2sum + chi2term chi2N = chi2N + 1 end if - + if (logR_sigma > 0 .and. include_logR_in_chi2) then chi2term = pow2((logR - logR_target)/logR_sigma) if (trace_okay .and. trace_chi2_info) & @@ -1736,7 +1736,7 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2sum = chi2sum + chi2term chi2N = chi2N + 1 end if - + if (age_sigma > 0 .and. include_age_in_chi2) then chi2term = pow2((s% star_age - age_target)/age_sigma) if (trace_okay .and. trace_chi2_info) & @@ -1744,7 +1744,7 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2sum = chi2sum + chi2term chi2N = chi2N + 1 end if - + if (surface_Z_div_X_sigma > 0 .and. include_surface_Z_div_X_in_chi2) then chi2term = pow2((surface_Z_div_X - surface_Z_div_X_target)/surface_Z_div_X_sigma) if (trace_okay .and. trace_chi2_info) & @@ -1752,7 +1752,7 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2sum = chi2sum + chi2term chi2N = chi2N + 1 end if - + if (surface_He_sigma > 0 .and. include_surface_He_in_chi2) then chi2term = pow2((surface_He - surface_He_target)/surface_He_sigma) if (trace_okay .and. trace_chi2_info) & @@ -1760,7 +1760,7 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2sum = chi2sum + chi2term chi2N = chi2N + 1 end if - + if (Rcz_sigma > 0 .and. include_Rcz_in_chi2) then chi2term = pow2((Rcz - Rcz_target)/Rcz_sigma) if (trace_okay .and. trace_chi2_info) & @@ -1768,7 +1768,7 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2sum = chi2sum + chi2term chi2N = chi2N + 1 end if - + if (solar_cs_rms_sigma > 0 .and. include_solar_cs_rms_in_chi2) then chi2term = pow2((solar_cs_rms - solar_cs_rms_target)/solar_cs_rms_sigma) if (trace_okay .and. trace_chi2_info) & @@ -1776,7 +1776,7 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2sum = chi2sum + chi2term chi2N = chi2N + 1 end if - + if (my_var1_sigma > 0 .and. include_my_var1_in_chi2) then chi2term = pow2((my_var1 - my_var1_target)/my_var1_sigma) if (trace_okay .and. trace_chi2_info) & @@ -1784,7 +1784,7 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2sum = chi2sum + chi2term chi2N = chi2N + 1 end if - + if (my_var2_sigma > 0 .and. include_my_var2_in_chi2) then chi2term = pow2((my_var2 - my_var2_target)/my_var2_sigma) if (trace_okay .and. trace_chi2_info) & @@ -1792,7 +1792,7 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2sum = chi2sum + chi2term chi2N = chi2N + 1 end if - + if (my_var3_sigma > 0 .and. include_my_var3_in_chi2) then chi2term = pow2((my_var3 - my_var3_target)/my_var3_sigma) if (trace_okay .and. trace_chi2_info) & @@ -1805,17 +1805,17 @@ real(dp) function get_chi2(s, trace_okay, ierr) chi2 = chi2sum/max(1,chi2N) get_chi2 = chi2 - + end function get_chi2 - - - subroutine save_best_info(s) + + + subroutine save_best_info(s) type (star_info), pointer :: s integer :: ierr logical :: write_controls_info_with_profile - + include 'formats' - + if (save_model_for_best_model) then ierr = 0 call star_write_model(s% id, best_model_save_model_filename, ierr) @@ -1841,13 +1841,13 @@ subroutine save_best_info(s) write(*,*) 'failed in save_profile' call mesa_error(__FILE__,__LINE__) end if - end if - + end if + call store_best_info(s) - + end subroutine save_best_info - - + + subroutine init_sample_ptrs nullify( & sample_chi2, & @@ -1877,14 +1877,14 @@ subroutine init_sample_ptrs sample_model_number, & sample_index_by_chi2) end subroutine init_sample_ptrs - - + + subroutine alloc_sample_ptrs(ierr) use utils_lib integer, intent(out) :: ierr ierr = 0 max_num_samples = 1.5*max_num_samples + 200 - + call realloc_double(sample_chi2,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_age,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_init_Y,max_num_samples,ierr); if (ierr /= 0) return @@ -1901,27 +1901,27 @@ subroutine alloc_sample_ptrs(ierr) call realloc_double(sample_Teff,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_logg,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_FeH,max_num_samples,ierr); if (ierr /= 0) return - + call realloc_double(sample_logR,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_surface_Z_div_X,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_surface_He,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_Rcz,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_solar_cs_rms,max_num_samples,ierr); if (ierr /= 0) return - + call realloc_double(sample_my_var1,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_my_var2,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_my_var3,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_my_param1,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_my_param2,max_num_samples,ierr); if (ierr /= 0) return call realloc_double(sample_my_param3,max_num_samples,ierr); if (ierr /= 0) return - + call realloc_integer(sample_index_by_chi2,max_num_samples,ierr); if (ierr /= 0) return call realloc_integer(sample_op_code,max_num_samples,ierr); if (ierr /= 0) return call realloc_integer(sample_model_number,max_num_samples,ierr); if (ierr /= 0) return end subroutine alloc_sample_ptrs - - + + subroutine read_simplex_search_controls(filename, ierr) character (len=*), intent(in) :: filename integer, intent(out) :: ierr @@ -1930,37 +1930,37 @@ subroutine read_simplex_search_controls(filename, ierr) ierr = 0 call read1_simplex_search_inlist(filename, 1, ierr) end subroutine read_simplex_search_controls - - + + subroutine set_simplex_search_defaults include 'simplex_solar.defaults' end subroutine set_simplex_search_defaults - + recursive subroutine read1_simplex_search_inlist(filename, level, ierr) character (len=*), intent(in) :: filename - integer, intent(in) :: level + integer, intent(in) :: level integer, intent(out) :: ierr - + logical :: read_extra1, read_extra2, read_extra3, read_extra4, read_extra5 character (len=256) :: message, extra1, extra2, extra3, extra4, extra5 integer :: unit - + if (level >= 10) then write(*,*) 'ERROR: too many levels of nested extra star_job inlist files' ierr = -1 return end if - + ierr = 0 unit=alloc_iounit(ierr) if (ierr /= 0) return - + open(unit=unit, file=trim(filename), action='read', delim='quote', iostat=ierr) if (ierr /= 0) then write(*, *) 'Failed to open simplex search inlist file ', trim(filename) else - read(unit, nml=simplex_search_controls, iostat=ierr) + read(unit, nml=simplex_search_controls, iostat=ierr) close(unit) if (ierr /= 0) then write(*, *) & @@ -1968,73 +1968,73 @@ recursive subroutine read1_simplex_search_inlist(filename, level, ierr) write(*, '(a)') trim(message) write(*, '(a)') & 'The following runtime error message might help you find the problem' - write(*, *) + write(*, *) open(unit=unit, file=trim(filename), & action='read', delim='quote', status='old', iostat=ierr) read(unit, nml=simplex_search_controls) close(unit) - end if + end if end if call free_iounit(unit) if (ierr /= 0) return - + ! recursive calls to read other inlists - + read_extra1 = read_extra_simplex_search_inlist1 read_extra_simplex_search_inlist1 = .false. extra1 = extra_simplex_search_inlist1_name extra_simplex_search_inlist1_name = 'undefined' - + read_extra2 = read_extra_simplex_search_inlist2 read_extra_simplex_search_inlist2 = .false. extra2 = extra_simplex_search_inlist2_name extra_simplex_search_inlist2_name = 'undefined' - + read_extra3 = read_extra_simplex_search_inlist3 read_extra_simplex_search_inlist3 = .false. extra3 = extra_simplex_search_inlist3_name extra_simplex_search_inlist3_name = 'undefined' - + read_extra4 = read_extra_simplex_search_inlist4 read_extra_simplex_search_inlist4 = .false. extra4 = extra_simplex_search_inlist4_name extra_simplex_search_inlist4_name = 'undefined' - + read_extra5 = read_extra_simplex_search_inlist5 read_extra_simplex_search_inlist5 = .false. extra5 = extra_simplex_search_inlist5_name extra_simplex_search_inlist5_name = 'undefined' - + if (read_extra1) then !write(*,*) 'read extra simplex_search inlist1 from ' // trim(extra1) call read1_simplex_search_inlist(extra1, level+1, ierr) if (ierr /= 0) return end if - + if (read_extra2) then !write(*,*) 'read extra simplex_search inlist2 from ' // trim(extra2) call read1_simplex_search_inlist(extra2, level+1, ierr) if (ierr /= 0) return end if - + if (read_extra3) then !write(*,*) 'read extra simplex_search inlist3 from ' // trim(extra3) call read1_simplex_search_inlist(extra3, level+1, ierr) if (ierr /= 0) return end if - + if (read_extra4) then !write(*,*) 'read extra simplex_search inlist4 from ' // trim(extra4) call read1_simplex_search_inlist(extra4, level+1, ierr) if (ierr /= 0) return end if - + if (read_extra5) then write(*,*) 'read extra simplex_search inlist5 from ' // trim(extra5) call read1_simplex_search_inlist(extra5, level+1, ierr) if (ierr /= 0) return end if - + end subroutine read1_simplex_search_inlist @@ -2061,7 +2061,7 @@ subroutine write_simplex_search_controls(filename_in, ierr) close(unit) end if call free_iounit(unit) - + write(*,'(A)') write(*,*) 'saved initial &simplex_search_controls to ' // trim(filename) write(*,'(A)') @@ -2083,10 +2083,10 @@ subroutine save_sample_results_to_file(i_total, results_fname, ierr) if (ierr /= 0) return call show_all_sample_results(iounit, i_total, ierr) close(iounit) - call free_iounit(iounit) + call free_iounit(iounit) end subroutine save_sample_results_to_file - - + + subroutine set_sample_index_by_chi2 use num_lib, only: qsort if (sample_number <= 0) return @@ -2096,17 +2096,17 @@ subroutine set_sample_index_by_chi2 end if call qsort(sample_index_by_chi2, sample_number, sample_chi2) end subroutine set_sample_index_by_chi2 - - + + subroutine show_sample_header(iounit) integer, intent(in) ::iounit - + integer :: j character (len=10) :: str - + write(iounit,'(2x,a6,7a26,a16,99a26)') & 'sample', & - + 'chi2', & 'mass', & 'init_Y', & @@ -2114,9 +2114,9 @@ subroutine show_sample_header(iounit) 'alpha', & 'f_ov', & 'age', & - + 'model_number', & - + 'init_h1', & 'init_he3', & 'init_he4', & @@ -2137,20 +2137,20 @@ subroutine show_sample_header(iounit) trim(my_param1_name), & trim(my_param2_name), & trim(my_param3_name) - + end subroutine show_sample_header - - + + subroutine show1_sample_results(i, iounit) use num_lib, only: simplex_info_str integer, intent(in) :: i, iounit - + integer :: j, k, op_code, ierr character (len=256) :: info_str - + ierr = 0 - op_code = sample_op_code(i) + op_code = sample_op_code(i) if (op_code <= 0) then info_str = '' else @@ -2160,7 +2160,7 @@ subroutine show1_sample_results(i, iounit) ierr = 0 end if end if - + write(iounit,'(3x,i5,7(1pd26.16),i16,99(1pd26.16))',advance='no') i, & sample_chi2(i), & sample_mass(i), & @@ -2190,15 +2190,15 @@ subroutine show1_sample_results(i, iounit) sample_my_param1(i), & sample_my_param2(i), & sample_my_param3(i) - + if (iounit == 6) return write(iounit,'(a12)') trim(info_str) - - + + end subroutine show1_sample_results - - + + subroutine show_all_sample_results(iounit, i_total, ierr) integer, intent(in) :: iounit, i_total integer, intent(out) :: ierr @@ -2225,10 +2225,10 @@ subroutine show_all_sample_results(iounit, i_total, ierr) end subroutine show_all_sample_results - + subroutine show_best(io) integer, intent(in) :: io - + real(dp) :: chi2term include 'formats' @@ -2240,7 +2240,7 @@ subroutine show_best(io) call write1('Teff_obs', Teff_target) call write1('Teff_sigma', Teff_sigma) end if - + if (logL_sigma > 0 .and. include_logL_in_chi2) then chi2term = pow2((best_logL - logL_target)/logL_sigma) write(io,'(A)') @@ -2249,7 +2249,7 @@ subroutine show_best(io) call write1('logL_obs', logL_target) call write1('logL_sigma', logL_sigma) end if - + if (logg_sigma > 0 .and. include_logg_in_chi2) then chi2term = pow2((best_logg - logg_target)/logg_sigma) write(io,'(A)') @@ -2258,7 +2258,7 @@ subroutine show_best(io) call write1('logg_obs', logg_target) call write1('logg_sigma', logg_sigma) end if - + if (FeH_sigma > 0 .and. include_FeH_in_chi2) then chi2term = pow2((best_FeH - FeH_target)/FeH_sigma) write(io,'(A)') @@ -2267,7 +2267,7 @@ subroutine show_best(io) call write1('FeH_obs', FeH_target) call write1('FeH_sigma', FeH_sigma) end if - + if (logR_sigma > 0 .and. include_logR_in_chi2) then chi2term = pow2((best_logR - logR_target)/logR_sigma) write(io,'(A)') @@ -2276,7 +2276,7 @@ subroutine show_best(io) call write1('logR_obs', logR_target) call write1('logR_sigma', logR_sigma) end if - + if (age_sigma > 0 .and. include_age_in_chi2) then chi2term = pow2((best_age - age_target)/age_sigma) write(io,'(A)') @@ -2285,7 +2285,7 @@ subroutine show_best(io) write(io,'(a40,1pd20.10)') 'age_target', age_target write(io,'(a40,1pd20.10)') 'age_sigma', age_sigma end if - + if (surface_Z_div_X_sigma > 0 .and. & include_surface_Z_div_X_in_chi2) then chi2term = & @@ -2296,7 +2296,7 @@ subroutine show_best(io) call write1('surface_Z_div_X_obs', surface_Z_div_X_target) call write1('surface_Z_div_X_sigma', surface_Z_div_X_sigma) end if - + if (surface_He_sigma > 0 .and. include_surface_He_in_chi2) then chi2term = pow2((best_surface_He - surface_He_target)/surface_He_sigma) write(io,'(A)') @@ -2305,7 +2305,7 @@ subroutine show_best(io) call write1('surface_He_obs', surface_He_target) call write1('surface_He_sigma', surface_He_sigma) end if - + if (Rcz_sigma > 0 .and. include_Rcz_in_chi2) then chi2term = pow2((best_Rcz - Rcz_target)/Rcz_sigma) write(io,'(A)') @@ -2314,7 +2314,7 @@ subroutine show_best(io) call write1('Rcz_obs', Rcz_target) call write1('Rcz_sigma', Rcz_sigma) end if - + if (solar_cs_rms_sigma > 0 .and. include_solar_cs_rms_in_chi2) then chi2term = pow2((best_solar_cs_rms - solar_cs_rms_target)/solar_cs_rms_sigma) write(io,'(A)') @@ -2323,7 +2323,7 @@ subroutine show_best(io) call write1('solar_cs_rms_obs', solar_cs_rms_target) call write1('solar_cs_rms_sigma', solar_cs_rms_sigma) end if - + if (my_var1_sigma > 0 .and. include_my_var1_in_chi2) then chi2term = pow2( & (best_my_var1 - my_var1_target)/my_var1_sigma) @@ -2333,7 +2333,7 @@ subroutine show_best(io) call write1(trim(my_var1_name) // '_obs', my_var1_target) call write1(trim(my_var1_name) // '_sigma', my_var1_sigma) end if - + if (my_var2_sigma > 0 .and. include_my_var2_in_chi2) then chi2term = pow2( & (best_my_var2 - my_var2_target)/my_var2_sigma) @@ -2343,7 +2343,7 @@ subroutine show_best(io) call write1(trim(my_var2_name) // '_obs', my_var2_target) call write1(trim(my_var2_name) // '_sigma', my_var2_sigma) end if - + if (my_var3_sigma > 0 .and. include_my_var3_in_chi2) then chi2term = pow2( & (best_my_var3 - my_var3_target)/my_var3_sigma) @@ -2353,7 +2353,7 @@ subroutine show_best(io) call write1(trim(my_var3_name) // '_obs', my_var3_target) call write1(trim(my_var3_name) // '_sigma', my_var3_sigma) end if - + write(io,'(A)') call write1('R/Rsun', best_radius) call write1('logL/Lsun', best_logL) @@ -2365,14 +2365,14 @@ subroutine show_best(io) call write1('surface_He', best_surface_He) call write1('Rcz', best_Rcz) call write1('solar_cs_rms', best_solar_cs_rms) - write(io,*) + write(io,*) call write1('initial h1', current_h1) call write1('initial he3', current_he3) call write1('initial he4', current_he4) call write1('initial Y', current_Y) call write1('initial Z', current_Z) call write1('initial FeH', current_FeH) - write(io,*) + write(io,*) call write1('mass/Msun', current_mass) call write1('alpha', current_alpha) call write1('f_ov', current_f_ov) @@ -2383,9 +2383,9 @@ subroutine show_best(io) write(io,'(a40,i16)') 'model number', best_model_number write(io,'(A)') write(io,'(A)') - + contains - + subroutine write1(str,x) character (len=*), intent(in) :: str real(dp), intent(in) :: x @@ -2398,13 +2398,13 @@ end subroutine write1 end subroutine show_best - + subroutine store_best_info(s) type (star_info), pointer :: s integer :: i - + best_chi2 = chi2 - + best_age = s% star_age best_model_number = s% model_number best_radius = s% photosphere_r @@ -2412,30 +2412,30 @@ subroutine store_best_info(s) best_Teff = s% Teff best_logg = logg best_FeH = FeH - + best_logR = logR best_surface_Z_div_X = surface_Z_div_X best_surface_He = surface_He best_Rcz = Rcz best_solar_cs_rms = solar_cs_rms - + best_my_var1 = my_var1 best_my_var2 = my_var2 best_my_var3 = my_var3 best_my_param1 = my_param1 best_my_param2 = my_param2 best_my_param3 = my_param3 - + end subroutine store_best_info - - + + subroutine write_best(num) use utils_lib, only: mkdir integer, intent(in) :: num integer :: ierr, iounit character (len=256) :: format_string, num_string, filename integer, parameter :: max_len_out = 2000 - character (len=max_len_out) :: script + character (len=max_len_out) :: script ierr = 0 iounit = alloc_iounit(ierr) if (ierr /= 0) return @@ -2462,30 +2462,30 @@ subroutine read_samples_from_file(results_fname, ierr) integer, intent(out) :: ierr integer :: iounit, num, i, j, model_number character (len=100) :: line - + include 'formats' - - ierr = 0 + + ierr = 0 write(*,*) 'read samples from file ' // trim(results_fname) - + iounit = alloc_iounit(ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__,'alloc_iounit failed') open(unit=iounit, file=trim(results_fname), action='read', status='old', iostat=ierr) if (ierr /= 0) then write(*,*) 'failed to open ' // trim(results_fname) - call free_iounit(iounit) + call free_iounit(iounit) return end if - + read(iounit, fmt=*, iostat=ierr) num if (ierr /= 0) then write(*,*) 'failed to read number of samples on 1st line of ' // trim(results_fname) call done return end if - + write(*,2) 'number of samples in file', num - + read(iounit, fmt='(a)', iostat=ierr) line if (ierr /= 0) then write(*,*) 'failed to read 2nd line of ' // trim(results_fname) @@ -2493,7 +2493,7 @@ subroutine read_samples_from_file(results_fname, ierr) call done return end if - + do while (max_num_samples < num) call alloc_sample_ptrs(ierr) if (ierr /= 0) then @@ -2502,7 +2502,7 @@ subroutine read_samples_from_file(results_fname, ierr) return end if end do - + do j = 1, num call read1_sample_from_file(j, iounit, ierr) if (ierr /= 0) then @@ -2511,36 +2511,36 @@ subroutine read_samples_from_file(results_fname, ierr) return end if end do - + sample_number = num write(*,2) 'number of samples read from file', num - + call done - + contains - - + + subroutine done close(iounit) - call free_iounit(iounit) + call free_iounit(iounit) end subroutine done - + end subroutine read_samples_from_file - - + + subroutine read1_sample_from_file(j, iounit, ierr) use num_lib, only: simplex_op_code integer, intent(in) :: j, iounit integer, intent(out) :: ierr - + integer :: i, k character (len=256) :: info_str real(dp) :: logR - + include 'formats' - + ierr = 0 read(iounit,fmt='(i8)',advance='no',iostat=ierr) i if (ierr /= 0) return @@ -2549,7 +2549,7 @@ subroutine read1_sample_from_file(j, iounit, ierr) ierr = -1 return end if - + read(iounit,'(7(1pd26.16),i16,99(1pd26.16))',advance='no',iostat=ierr) & sample_chi2(i), & sample_mass(i), & @@ -2580,7 +2580,7 @@ subroutine read1_sample_from_file(j, iounit, ierr) sample_my_param2(i), & sample_my_param3(i) if (failed('results')) return - + sample_radius(i) = exp10(logR) read(iounit,'(a12)',iostat=ierr) info_str @@ -2589,7 +2589,7 @@ subroutine read1_sample_from_file(j, iounit, ierr) sample_op_code(i) = 0 return end if - + if (len_trim(info_str) == 0) then sample_op_code(i) = 0 else @@ -2600,11 +2600,11 @@ subroutine read1_sample_from_file(j, iounit, ierr) return end if end if - - + + contains - - + + logical function failed(str) character (len=*), intent(in) :: str include 'formats' @@ -2613,10 +2613,10 @@ logical function failed(str) write(*,2) 'failed reading ' // trim(str) // ' data for sample number', i failed = .true. end function failed - - + + end subroutine read1_sample_from_file - + end module simplex_search_run_support diff --git a/star/test_suite/split_burn_big_net/src/run.f90 b/star/test_suite/split_burn_big_net/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/split_burn_big_net/src/run.f90 +++ b/star/test_suite/split_burn_big_net/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/split_burn_big_net/src/run_star_extras.f90 b/star/test_suite/split_burn_big_net/src/run_star_extras.f90 index 619d11f61..a9dc294f5 100644 --- a/star/test_suite/split_burn_big_net/src/run_star_extras.f90 +++ b/star/test_suite/split_burn_big_net/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,9 +27,9 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" ! here are the x controls used below @@ -38,7 +38,7 @@ module run_star_extras !alpha_H = s% x_ctrl(21) !alpha_other = s% x_ctrl(22) !H_limit = s% x_ctrl(23) - + ! test suite ! s% x_integer_ctrl(1) part number (set to 0 to disable test suite checks) @@ -46,8 +46,8 @@ module run_star_extras contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -62,8 +62,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine end subroutine extras_controls @@ -94,12 +94,12 @@ subroutine alpha_mlt_routine(id, ierr) else s% alpha_mlt(k) = alpha_other end if - !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), + !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), end do !stop end subroutine alpha_mlt_routine - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -109,10 +109,10 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use num_lib, only: find0 integer, intent(in) :: id @@ -125,7 +125,7 @@ subroutine extras_after_evolve(id, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return - select case (s% x_integer_ctrl(1)) + select case (s% x_integer_ctrl(1)) case(1) ! inlist_big_net @@ -139,7 +139,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -149,7 +149,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -162,8 +162,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -175,7 +175,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -186,8 +186,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -205,7 +205,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(k,1) = s% zbar(k)/s% abar(k) end do end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) integer, intent(in) :: id @@ -219,8 +219,8 @@ integer function extras_finish_step(id) if (extras_finish_step == terminate) & s% termination_code = t_extras_finish_step end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/starspots/src/run.f90 b/star/test_suite/starspots/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/starspots/src/run.f90 +++ b/star/test_suite/starspots/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/starspots/src/run_star_extras.f90 b/star/test_suite/starspots/src/run_star_extras.f90 index 89743ce76..e120db6be 100644 --- a/star/test_suite/starspots/src/run_star_extras.f90 +++ b/star/test_suite/starspots/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -78,7 +78,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -88,7 +88,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -101,8 +101,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -114,7 +114,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -125,8 +125,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -140,7 +140,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -152,8 +152,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/test_case_template/src/run.f90 b/star/test_suite/test_case_template/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/test_case_template/src/run.f90 +++ b/star/test_suite/test_case_template/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/test_case_template/src/run_star_extras.f90 b/star/test_suite/test_case_template/src/run_star_extras.f90 index b5f93b9bf..f91dddf91 100644 --- a/star/test_suite/test_case_template/src/run_star_extras.f90 +++ b/star/test_suite/test_case_template/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include 'test_suite_extras_def.inc' - + !real(dp) :: example_of_data_to_save_in_photos - + contains include 'test_suite_extras.inc' - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -53,7 +53,7 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% other_photo_read => extras_photo_read s% other_photo_write => extras_photo_write end subroutine extras_controls @@ -71,8 +71,8 @@ subroutine extras_photo_write(id, iounit) integer, intent(in) :: id, iounit !write(iounit) example_of_data_to_save_in_photos end subroutine extras_photo_write - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -83,8 +83,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -116,7 +116,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -129,8 +129,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -142,7 +142,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -153,8 +153,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -168,7 +168,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -180,8 +180,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/timing/src/run.f90 b/star/test_suite/timing/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/timing/src/run.f90 +++ b/star/test_suite/timing/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/timing/src/run_star_extras.f90 b/star/test_suite/timing/src/run_star_extras.f90 index 58c006244..ec4b24425 100644 --- a/star/test_suite/timing/src/run_star_extras.f90 +++ b/star/test_suite/timing/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,16 +27,16 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -44,7 +44,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -87,7 +87,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -100,8 +100,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -113,7 +113,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -124,8 +124,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -139,7 +139,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -151,8 +151,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/twin_studies/src/run.f90 b/star/test_suite/twin_studies/src/run.f90 index 0755aeea0..18fbdda1a 100644 --- a/star/test_suite/twin_studies/src/run.f90 +++ b/star/test_suite/twin_studies/src/run.f90 @@ -1,6 +1,6 @@ program run use run_star_extras, only: do_run_multi_stars - + call do_run_multi_stars - + end program diff --git a/star/test_suite/twin_studies/src/run_star_extras.f90 b/star/test_suite/twin_studies/src/run_star_extras.f90 index 661ca75cf..ecf9d46f6 100644 --- a/star/test_suite/twin_studies/src/run_star_extras.f90 +++ b/star/test_suite/twin_studies/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -28,18 +28,18 @@ module run_star_extras use math_lib use auto_diff use run_star_support - + implicit none include 'test_suite_extras_def.inc' include 'multi_stars_extras_def.inc' - + contains include 'test_suite_extras.inc' include 'multi_stars_extras.inc' - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -55,10 +55,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -69,8 +69,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -102,7 +102,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -115,8 +115,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -128,7 +128,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -139,8 +139,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -154,7 +154,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -192,4 +192,4 @@ end function extras_finish_step end module run_star_extras - + diff --git a/star/test_suite/tzo/src/run.f90 b/star/test_suite/tzo/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/tzo/src/run.f90 +++ b/star/test_suite/tzo/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/tzo/src/run_star_extras.f90 b/star/test_suite/tzo/src/run_star_extras.f90 index 186675b56..e08d07f92 100644 --- a/star/test_suite/tzo/src/run_star_extras.f90 +++ b/star/test_suite/tzo/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,19 +27,19 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include 'test_suite_extras_def.inc' - + logical :: use_hydro integer :: inlist_part real(dp) :: eta_ledd, eta_medd,target_mass - + contains include 'test_suite_extras.inc' - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -55,7 +55,7 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns s% other_cgrav => my_other_cgrav @@ -70,8 +70,8 @@ subroutine extras_controls(id, ierr) end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -82,8 +82,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -114,18 +114,18 @@ integer function extras_start_step(id) call star_set_v_flag(s% id, .true., ierr) if(ierr/=0) return end if - + ! Eddington L l_center = (4d0 * pi * standard_cgrav * s% m_center * clight)/s% opacity(s% nz) - + ! eddington limited accretion m_center = eta_medd * l_center / (clight*clight) - + s% m_center = s% m_center + m_center * s% dt s% xmstar = s% mstar - s% M_center - + s% L_center = eta_ledd * l_center - + end select @@ -140,8 +140,8 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going - + extras_check_model = keep_going + if(s% m_center/msun > target_mass .and. inlist_part == 4) then termination_code_str(t_xtra1) = 'PASS: Have reached requested NS mass' s% termination_code = t_xtra1 @@ -160,8 +160,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -173,7 +173,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -184,8 +184,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -199,7 +199,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -211,10 +211,10 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - ! use the Tolman–Oppenheimer–Volkoff (TOV) equation. - ! See first equation in https://en.wikipedia.org/wiki/Tolman%E2%80%93Oppenheimer%E2%80%93Volkoff_equation. + + ! use the Tolman–Oppenheimer–Volkoff (TOV) equation. + ! See first equation in https://en.wikipedia.org/wiki/Tolman%E2%80%93Oppenheimer%E2%80%93Volkoff_equation. ! want to replace -G*m/r^2 by -G*m/r^2*(1 + P/(rho c^2))(1 + 4 pi r^3 P /(m c^2))/(1 - 2 G m/(r c^2)) subroutine my_other_cgrav(id, ierr) use star_def @@ -260,7 +260,7 @@ subroutine my_other_cgrav(id, ierr) end do !write(*,*) 'done my_other_cgrav', s% model_number end subroutine my_other_cgrav - + end module run_star_extras - + diff --git a/star/test_suite/wd_acc_small_dm/src/run.f90 b/star/test_suite/wd_acc_small_dm/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/wd_acc_small_dm/src/run.f90 +++ b/star/test_suite/wd_acc_small_dm/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/wd_acc_small_dm/src/run_star_extras.f90 b/star/test_suite/wd_acc_small_dm/src/run_star_extras.f90 index 9a7e0a5a0..3d07dae0c 100644 --- a/star/test_suite/wd_acc_small_dm/src/run_star_extras.f90 +++ b/star/test_suite/wd_acc_small_dm/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,19 +27,19 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" integer :: h1_index real(dp) :: initial_h1_mass, h1_acc_abund, h1_init_surf_abund logical :: all_ok = .true. - + contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -47,7 +47,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -76,7 +76,7 @@ subroutine extras_photo_write(id, iounit) write(iounit) initial_h1_mass, h1_init_surf_abund end subroutine extras_photo_write - + subroutine extras_startup(id, restart, ierr) use chem_def, only: ih1 ! use adjust_xyz, only: get_xa_for_accretion @@ -107,12 +107,12 @@ subroutine extras_startup(id, restart, ierr) ! initial surface abundance (for testing profile) h1_init_surf_abund = s%xa( h1_index, 1) - + end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -135,7 +135,7 @@ subroutine extras_after_evolve(id, ierr) end if end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -145,7 +145,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -158,8 +158,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 1 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -186,7 +186,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -197,8 +197,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -216,7 +216,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(k,1) = s% zbar(k)/s% abar(k) end do end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -237,7 +237,7 @@ integer function extras_finish_step(id) extras_finish_step = keep_going end function extras_finish_step - + logical function check_initial_accretion_ok( nz, species, dm, xa, accreted_mass ) integer, intent(in) :: nz, species @@ -270,7 +270,7 @@ logical function check_initial_accretion_ok( nz, species, dm, xa, accreted_mass check_initial_accretion_ok = .true. end if - + return end function check_initial_accretion_ok @@ -318,11 +318,11 @@ logical function check_accretion_profile_ok( nz, species, dm, xa, accreted_mass write(*,*) 'with accreted mass of ', accreted_mass, ' Msun' write(*,*) 'abundance profile has clean transition from accreted to underlying abundances' end if - + check_accretion_profile_ok = prof_all_ok - + return end function check_accretion_profile_ok end module run_star_extras - + diff --git a/star/test_suite/wd_aic/src/run.f90 b/star/test_suite/wd_aic/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/wd_aic/src/run.f90 +++ b/star/test_suite/wd_aic/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/wd_aic/src/run_star_extras.f90 b/star/test_suite/wd_aic/src/run_star_extras.f90 index 323b43bd8..95ce97a78 100644 --- a/star/test_suite/wd_aic/src/run_star_extras.f90 +++ b/star/test_suite/wd_aic/src/run_star_extras.f90 @@ -67,7 +67,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -75,7 +75,7 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls @@ -110,7 +110,7 @@ integer function extras_check_model(id) use rates_def integer, intent(in) :: id - + integer :: mg24, na24, ne20, ierr real(dp) :: center_mg24, center_na24, center_ne20 type (star_info), pointer :: s @@ -212,8 +212,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp diff --git a/star/test_suite/wd_c_core_ignition/src/run.f90 b/star/test_suite/wd_c_core_ignition/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/wd_c_core_ignition/src/run.f90 +++ b/star/test_suite/wd_c_core_ignition/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/wd_c_core_ignition/src/run_star_extras.f90 b/star/test_suite/wd_c_core_ignition/src/run_star_extras.f90 index 66ea8aacd..7a0de1f37 100644 --- a/star/test_suite/wd_c_core_ignition/src/run_star_extras.f90 +++ b/star/test_suite/wd_c_core_ignition/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,16 +27,16 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -44,7 +44,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -52,9 +52,9 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -65,8 +65,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -78,7 +78,7 @@ subroutine extras_after_evolve(id, ierr) ierr = 0 call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -88,7 +88,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -101,8 +101,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -114,7 +114,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -125,8 +125,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -140,7 +140,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -152,8 +152,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/wd_cool_0.6M/src/run.f90 b/star/test_suite/wd_cool_0.6M/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/wd_cool_0.6M/src/run.f90 +++ b/star/test_suite/wd_cool_0.6M/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/wd_cool_0.6M/src/run_star_extras.f90 b/star/test_suite/wd_cool_0.6M/src/run_star_extras.f90 index ee4a87bca..ceff2b8fa 100644 --- a/star/test_suite/wd_cool_0.6M/src/run_star_extras.f90 +++ b/star/test_suite/wd_cool_0.6M/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,12 +27,12 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains @@ -46,7 +46,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -57,8 +57,8 @@ subroutine extras_controls(id, ierr) s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -69,8 +69,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -81,7 +81,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -91,7 +91,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -104,8 +104,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -117,7 +117,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -128,8 +128,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 2 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -161,7 +161,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) s% lnd(kmax)/ln10, s% lnT(kmax)/ln10, & 1d0 - (s% x(kmax) + s% y(kmax)), s% abar(kmax), s% zbar(kmax) end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -173,8 +173,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/wd_diffusion/src/run.f90 b/star/test_suite/wd_diffusion/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/wd_diffusion/src/run.f90 +++ b/star/test_suite/wd_diffusion/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/wd_diffusion/src/run_star_extras.f90 b/star/test_suite/wd_diffusion/src/run_star_extras.f90 index 0b3ed9383..7ef536a6d 100644 --- a/star/test_suite/wd_diffusion/src/run_star_extras.f90 +++ b/star/test_suite/wd_diffusion/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,17 +27,17 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + ! these routines are called by the standard run_star check_model contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -45,7 +45,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -53,10 +53,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -67,25 +67,25 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr type (star_info), pointer :: s real(dp) :: dt, eEmg integer :: k, k0 - + ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + if (s% Teff > s% Teff_lower_limit) then write(*,*) 'failed to reach target for Teff' ierr = -1 return end if - + ! Find a zone at mass coordinate 0.5 do k=1,s%nz @@ -95,17 +95,17 @@ subroutine extras_after_evolve(id, ierr) end if end do eEmg = qe * s% E_field(k0)/(amu * s% g_field_element_diffusion(k0)) - + write(*,*) 'Core eE/mg = ', eEmg if (eEmg > 1.95d0 .and. eEmg < 2.05d0) then write(*,*) 'passed test for electric field in the core' else write(*,*) 'failed test for electric field in the core' - end if - + end if + call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -115,7 +115,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -128,8 +128,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -141,7 +141,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -152,8 +152,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -167,7 +167,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -179,8 +179,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/wd_he_shell_ignition/src/run.f90 b/star/test_suite/wd_he_shell_ignition/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/wd_he_shell_ignition/src/run.f90 +++ b/star/test_suite/wd_he_shell_ignition/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/wd_he_shell_ignition/src/run_star_extras.f90 b/star/test_suite/wd_he_shell_ignition/src/run_star_extras.f90 index 38f09b7c2..ac04a441f 100644 --- a/star/test_suite/wd_he_shell_ignition/src/run_star_extras.f90 +++ b/star/test_suite/wd_he_shell_ignition/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,16 +27,16 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -44,7 +44,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -78,7 +78,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -88,7 +88,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -101,8 +101,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -114,7 +114,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -125,8 +125,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -140,7 +140,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -152,8 +152,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/wd_nova_burst/src/run.f90 b/star/test_suite/wd_nova_burst/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/wd_nova_burst/src/run.f90 +++ b/star/test_suite/wd_nova_burst/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/wd_nova_burst/src/run_star_extras.f90 b/star/test_suite/wd_nova_burst/src/run_star_extras.f90 index cae622bad..719ff5b87 100644 --- a/star/test_suite/wd_nova_burst/src/run_star_extras.f90 +++ b/star/test_suite/wd_nova_burst/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,16 +27,16 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - - include "test_suite_extras_def.inc" - + + include "test_suite_extras_def.inc" + integer :: num_bursts logical :: waiting_for_burst real(dp) :: L_burst = 1d4, L_between = 1d3 ! Lsun units - - + + contains include "test_suite_extras.inc" @@ -65,7 +65,7 @@ subroutine extras_controls(id, ierr) s% other_photo_read => extras_photo_read s% other_photo_write => extras_photo_write - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -73,10 +73,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -91,8 +91,8 @@ subroutine extras_startup(id, restart, ierr) waiting_for_burst = .true. end if end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -103,7 +103,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -141,8 +141,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -154,7 +154,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -165,8 +165,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -184,7 +184,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(k,1) = s% zbar(k)/s% abar(k) end do end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -196,7 +196,7 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - + end module run_star_extras - + diff --git a/star/test_suite/wd_stable_h_burn/src/run.f90 b/star/test_suite/wd_stable_h_burn/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/wd_stable_h_burn/src/run.f90 +++ b/star/test_suite/wd_stable_h_burn/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/wd_stable_h_burn/src/run_star_extras.f90 b/star/test_suite/wd_stable_h_burn/src/run_star_extras.f90 index 38f09b7c2..ac04a441f 100644 --- a/star/test_suite/wd_stable_h_burn/src/run_star_extras.f90 +++ b/star/test_suite/wd_stable_h_burn/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,16 +27,16 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" - + contains include "test_suite_extras.inc" - + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -44,7 +44,7 @@ subroutine extras_controls(id, ierr) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - + s% extras_startup => extras_startup s% extras_check_model => extras_check_model s% extras_finish_step => extras_finish_step @@ -52,10 +52,10 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% data_for_extra_profile_columns => data_for_extra_profile_columns end subroutine extras_controls - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -66,8 +66,8 @@ subroutine extras_startup(id, restart, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -78,7 +78,7 @@ subroutine extras_after_evolve(id, ierr) if (ierr /= 0) return call test_suite_after_evolve(s, ierr) end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -88,7 +88,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -101,8 +101,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -114,7 +114,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -125,8 +125,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 0 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -140,7 +140,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) @@ -152,8 +152,8 @@ integer function extras_finish_step(id) if (ierr /= 0) return extras_finish_step = keep_going end function extras_finish_step - - + + end module run_star_extras - + diff --git a/star/test_suite/zams_to_cc_80/src/run.f90 b/star/test_suite/zams_to_cc_80/src/run.f90 index 815cbeabd..9d32c6be1 100644 --- a/star/test_suite/zams_to_cc_80/src/run.f90 +++ b/star/test_suite/zams_to_cc_80/src/run.f90 @@ -1,15 +1,15 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr - + ierr = 0 call do_read_star_job('inlist', ierr) if (ierr /= 0) stop 1 - + call do_run_star - + end program diff --git a/star/test_suite/zams_to_cc_80/src/run_star_extras.f90 b/star/test_suite/zams_to_cc_80/src/run_star_extras.f90 index 2cf66b188..dc9809b91 100644 --- a/star/test_suite/zams_to_cc_80/src/run_star_extras.f90 +++ b/star/test_suite/zams_to_cc_80/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,7 +19,7 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib @@ -27,9 +27,9 @@ module run_star_extras use const_def use math_lib use auto_diff - + implicit none - + include "test_suite_extras_def.inc" ! here are the x controls used below @@ -42,8 +42,8 @@ module run_star_extras contains include "test_suite_extras.inc" - - + + subroutine extras_controls(id, ierr) integer, intent(in) :: id integer, intent(out) :: ierr @@ -58,8 +58,8 @@ subroutine extras_controls(id, ierr) s% how_many_extra_history_columns => how_many_extra_history_columns s% data_for_extra_history_columns => data_for_extra_history_columns s% how_many_extra_profile_columns => how_many_extra_profile_columns - s% data_for_extra_profile_columns => data_for_extra_profile_columns - s% other_alpha_mlt => alpha_mlt_routine + s% data_for_extra_profile_columns => data_for_extra_profile_columns + s% other_alpha_mlt => alpha_mlt_routine end subroutine extras_controls @@ -90,12 +90,12 @@ subroutine alpha_mlt_routine(id, ierr) else s% alpha_mlt(k) = alpha_other end if - !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), + !write(*,2) 'alpha_mlt', k, s% alpha_mlt(k), end do !stop end subroutine alpha_mlt_routine - - + + subroutine extras_startup(id, restart, ierr) integer, intent(in) :: id logical, intent(in) :: restart @@ -105,12 +105,12 @@ subroutine extras_startup(id, restart, ierr) call star_ptr(id, s, ierr) if (ierr /= 0) return call test_suite_startup(s, restart, ierr) - + if (.not. s% x_logical_ctrl(37)) return - + end subroutine extras_startup - - + + subroutine extras_after_evolve(id, ierr) use num_lib, only: find0 integer, intent(in) :: id @@ -142,7 +142,7 @@ subroutine extras_after_evolve(id, ierr) call test_suite_after_evolve(s, ierr) if (.not. s% x_logical_ctrl(37)) return end subroutine extras_after_evolve - + ! returns either keep_going, retry, or terminate. integer function extras_check_model(id) @@ -152,7 +152,7 @@ integer function extras_check_model(id) ierr = 0 call star_ptr(id, s, ierr) if (ierr /= 0) return - extras_check_model = keep_going + extras_check_model = keep_going end function extras_check_model @@ -165,8 +165,8 @@ integer function how_many_extra_history_columns(id) if (ierr /= 0) return how_many_extra_history_columns = 0 end function how_many_extra_history_columns - - + + subroutine data_for_extra_history_columns(id, n, names, vals, ierr) integer, intent(in) :: id, n character (len=maxlen_history_column_name) :: names(n) @@ -178,7 +178,7 @@ subroutine data_for_extra_history_columns(id, n, names, vals, ierr) if (ierr /= 0) return end subroutine data_for_extra_history_columns - + integer function how_many_extra_profile_columns(id) use star_def, only: star_info integer, intent(in) :: id @@ -189,8 +189,8 @@ integer function how_many_extra_profile_columns(id) if (ierr /= 0) return how_many_extra_profile_columns = 1 end function how_many_extra_profile_columns - - + + subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) use star_def, only: star_info, maxlen_profile_column_name use const_def, only: dp @@ -208,7 +208,7 @@ subroutine data_for_extra_profile_columns(id, n, nz, names, vals, ierr) vals(k,1) = s% zbar(k)/s% abar(k) end do end subroutine data_for_extra_profile_columns - + ! returns either keep_going or terminate. integer function extras_finish_step(id) integer, intent(in) :: id @@ -224,4 +224,4 @@ integer function extras_finish_step(id) end function extras_finish_step end module run_star_extras - + diff --git a/star/work/src/run.f90 b/star/work/src/run.f90 index 5c29c6a80..916b29a68 100644 --- a/star/work/src/run.f90 +++ b/star/work/src/run.f90 @@ -1,18 +1,18 @@ program run use run_star_support, only: do_read_star_job use run_star, only: do_run_star - + implicit none - + integer :: ierr character (len=32) :: inlist_fname - + ierr = 0 inlist_fname = 'inlist' - + call do_read_star_job(inlist_fname, ierr) if (ierr /= 0) stop 1 - + call do_run_star(inlist_fname) - + end program diff --git a/star/work/src/run_star_extras.f90 b/star/work/src/run_star_extras.f90 index ef7aca062..52053a390 100644 --- a/star/work/src/run_star_extras.f90 +++ b/star/work/src/run_star_extras.f90 @@ -9,7 +9,7 @@ ! by the free software foundation; either version 2 of the license, or ! (at your option) any later version. ! -! mesa is distributed in the hope that it will be useful, +! mesa is distributed in the hope that it will be useful, ! but without any warranty; without even the implied warranty of ! merchantability or fitness for a particular purpose. see the ! gnu library general public license for more details. @@ -19,20 +19,20 @@ ! foundation, inc., 59 temple place, suite 330, boston, ma 02111-1307 usa ! ! *********************************************************************** - + module run_star_extras use star_lib use star_def use const_def use math_lib - + implicit none - + ! these routines are called by the standard run_star check_model contains - + include 'standard_run_star_extras.inc' end module run_star_extras - + diff --git a/star_data/public/star_data_def.f90 b/star_data/public/star_data_def.f90 index 14d3b692b..e868c1412 100644 --- a/star_data/public/star_data_def.f90 +++ b/star_data/public/star_data_def.f90 @@ -37,9 +37,9 @@ module star_data_def use colors_def, only: max_num_color_files, max_num_bcs_per_file use auto_diff, only: auto_diff_real_star_order1 use star_pgstar, only: pgstar_controls - - implicit none - + + implicit none + include "star_data_def.inc" include "star_job_controls_params.inc" type star_job_controls @@ -51,22 +51,22 @@ module star_data_def check_step_loop_timing, check_after_step_timing, check_before_step_timing integer(8) :: time0, time1, clock_rate, time0_extra, time1_extra, time0_initial end type star_job_controls - + type star_info - + include "star_data.inc" - + ! handles integer :: eos_handle integer :: kap_handle integer :: net_handle - + ! star id integer :: id ! unique identifier for each star_info instance - + ! Name of the main inlist used character (len=strlen) :: inlist_fname - + ! private logical :: in_use logical :: do_burn, do_mix @@ -75,47 +75,47 @@ module star_data_def type (EoS_General_Info), pointer :: eos_rq ! from call eos_ptr(s% eos_handle,s% eos_rq,ierr) type (Kap_General_Info), pointer :: kap_rq ! from call kap_ptr(s% kap_handle,s% kap_rq,ierr) type (Net_General_Info), pointer :: net_rq ! from call net_ptr(s% net_handle,s% net_rq, ierr) - + ! parameters for create pre ms -- set in run_star before calling star_create_pre_ms_model real(dp) :: pre_ms_T_c, pre_ms_guess_rho_c, & pre_ms_d_log10_P, pre_ms_logT_surf_limit, pre_ms_logP_surf_limit integer :: pre_ms_initial_zfracs, pre_ms_relax_num_steps logical :: pre_ms_change_net, pre_ms_dump_missing_heaviest character (len=net_name_len) :: pre_ms_new_net_name - + ! parameters for create initial model - real(dp) :: & + real(dp) :: & radius_in_cm_for_create_initial_model, & mass_in_gm_for_create_initial_model, & center_logP_1st_try_for_create_initial_model, & entropy_1st_try_for_create_initial_model, & abs_e01_tolerance_for_create_initial_model, & - abs_e02_tolerance_for_create_initial_model + abs_e02_tolerance_for_create_initial_model integer :: initial_zfracs_for_create_initial_model, & max_tries_for_create_initial_model integer :: initial_model_relax_num_steps real(dp) :: initial_model_eps logical :: initial_model_change_net, initial_dump_missing_heaviest character (len=net_name_len) :: initial_model_new_net_name - + ! extra profile entries for developer debugging real(dp), dimension(:,:), pointer :: profile_extra ! (nz,max_num_profile_extras) character (len=64) :: profile_extra_name(max_num_profile_extras) - + ! controls type (star_job_controls) :: job ! separate type to avoid name clashes include "star_controls.inc" include "star_controls_dev.inc" type(pgstar_controls) :: pg - + end type star_info logical :: have_initialized_star_handles = .false. integer, parameter :: max_star_handles = 10 ! this can be increased as necessary - type (star_info), target, save :: star_handles(max_star_handles) + type (star_info), target, save :: star_handles(max_star_handles) ! gfortran seems to require "save" here. at least it did once upon a time. @@ -133,7 +133,7 @@ end subroutine star_ptr subroutine get_star_ptr(id,s,ierr) integer, intent(in) :: id type (star_info), pointer :: s - integer, intent(out) :: ierr + integer, intent(out) :: ierr if (id < 1 .or. id > max_star_handles) then ierr = -1 return @@ -141,9 +141,9 @@ subroutine get_star_ptr(id,s,ierr) s => star_handles(id) ierr = 0 end subroutine get_star_ptr - - - subroutine result_reason_init + + + subroutine result_reason_init result_reason_str(result_reason_normal) = 'normal' result_reason_str(dt_is_zero) = 'dt_is_zero' result_reason_str(nonzero_ierr) = 'nonzero_ierr' @@ -163,7 +163,7 @@ subroutine result_reason_init result_reason_str(forced_stop) = 'forced_stop' end subroutine result_reason_init - + subroutine do_star_def_init(mesa_dir_init, ierr) character (len=*), intent(in) :: mesa_dir_init integer, intent(out) :: ierr diff --git a/star_data/public/star_data_lib.f90 b/star_data/public/star_data_lib.f90 index 0498e0530..d5710a257 100644 --- a/star_data/public/star_data_lib.f90 +++ b/star_data/public/star_data_lib.f90 @@ -25,11 +25,11 @@ ! *********************************************************************** module star_data_lib - + implicit none - contains - + contains + subroutine star_data_init(mesa_dir_init,ierr) use star_data_def, only: do_star_def_init character (len=*), intent(in) :: mesa_dir_init diff --git a/star_data/public/star_pgstar.f90 b/star_data/public/star_pgstar.f90 index 4db603342..d1115090b 100644 --- a/star_data/public/star_pgstar.f90 +++ b/star_data/public/star_pgstar.f90 @@ -34,7 +34,7 @@ module star_pgstar ! pgstar data abstract interface - + subroutine pgstar_plot_interface(id, device_id, ierr) integer, intent(in) :: id, device_id integer, intent(out) :: ierr @@ -50,7 +50,7 @@ end subroutine other_do_plot_in_grid_interface subroutine pgstar_decorator_interface(id, xmin, xmax, ymin, ymax, plot_num, ierr) integer, intent(in) :: id !Not doubles - real, intent(in) :: xmin, xmax, ymin, ymax + real, intent(in) :: xmin, xmax, ymin, ymax integer, intent(in) :: plot_num integer, intent(out) :: ierr end subroutine pgstar_decorator_interface @@ -81,7 +81,7 @@ end subroutine pgstar_decorator_interface real(dp), pointer :: vals(:) => null() ! values of items in history_columns list type (pgstar_hist_node), pointer :: next => null() ! list kept in strictly decreasing order by age & step - end type pgstar_hist_node + end type pgstar_hist_node integer, parameter :: max_Abundance_num_isos_to_show = 1000 diff --git a/stella/res/stella_extras.f90 b/stella/res/stella_extras.f90 index c4b9939c3..1240aa7d4 100644 --- a/stella/res/stella_extras.f90 +++ b/stella/res/stella_extras.f90 @@ -44,11 +44,11 @@ program main integer :: nm, num_models, cnt, k_phot, iday my_mesa_dir = '../..' - call const_init(my_mesa_dir,ierr) + call const_init(my_mesa_dir,ierr) if (ierr /= 0) then write(*,*) 'const_init failed' call mesa_error(__FILE__,__LINE__) - end if + end if call math_init() @@ -130,7 +130,7 @@ program main else filestr = 'mesa' end if - + fname = '../modmake/'//trim(filestr)//'.hyd' open(25,file=fname, status='old') write(*,*) 'read ' // trim(filestr)//'.hyd' @@ -156,7 +156,7 @@ program main t0 = time_lbol(num_lbol) num_lbol_max = num_lbol end if - end do + end do 334 continue @@ -179,10 +179,10 @@ program main write(*,*) 'read ' // trim(filestr)//'.tt' fname = trim(filestr)//'.tt' open(21,file=fname, status='old') - + fname = trim(filestr)//'.lbol_lnuc.txt' open(24,file=fname, status='unknown') - + do i=1,1000 read(21,'(a)',end=335) line if (len_trim(line) < 7) cycle @@ -200,7 +200,7 @@ program main dum = interp_logLbol(time) write(24,'(99(1pe18.6,x))') time-t0, dum, log10(gdepos*1d50) end do - end do + end do 335 continue close(21) @@ -256,10 +256,10 @@ program main write(27,'(99(a13))') 't-t0', 'tau', 'rho', 'T', 'r', 'v' write(*,*) 'read ' // trim(filestr)//'.swd' - + ! read data open(20,file=trim(filestr)//'.res', status='old') - + do nm=1,num_models do j=1,zone @@ -279,7 +279,7 @@ program main end if den(j,nm)=10**den(j,nm)*1d-6 end do - + time = t(nm) if (time < 0.1d0) then iday = int(time*1d2 + 1d-6) @@ -314,12 +314,12 @@ program main end do exit end do - + end do - + close(20) close(21) - + ! write results do nm=1,num_models time = t(nm) @@ -330,7 +330,7 @@ program main sum_tau=sum_tau+kap(j,nm)*den(j,nm)*(r(j,nm)-r(j-1,nm)) tau(j-1,nm) = sum_tau end do - + write(27,'(99(1pd13.4))') time-t0, & tau(1,nm), den(1,nm), temp(1,nm), r(1,nm), v(1,nm) @@ -347,7 +347,7 @@ program main ! call mesa_error(__FILE__,__LINE__) !end if dum = interp_logLbol(time) - Lbol = exp10(dum) + Lbol = exp10(dum) L_div_Lsun = Lbol/Lsun rphot = alfa*r(j,nm)+beta*r(j-1,nm) mphot = star_mass-(alfa*xm(j,nm)+beta*xm(j-1,nm)) @@ -394,7 +394,7 @@ program main call mesa_error(__FILE__,__LINE__) end if logRho = log10(density) - logRho = min(logRhos(num_logRhos), max(logRhos(1), logRho)) + logRho = min(logRhos(num_logRhos), max(logRhos(1), logRho)) logT = log10(temp(k,nm)) logT = min(logTs(num_logTs), max(logTs(1), logT)) ierr = 0 @@ -414,7 +414,7 @@ program main end if time_sec = time*secday tau_sob = pi*qe*qe/(me*clight)*n_Fe*eta*f*time_sec*lambda0 - + if ((tau_sob > tau_sob_lo .or. k==2) .and. v_sob_lo_tau == 0d0) then alfa = (tau_sob_lo - tau_sob_prev)/(tau_sob - tau_sob_prev) beta = 1d0 - alfa @@ -422,7 +422,7 @@ program main m_sob_lo_tau = star_mass - (alfa*xm(k,nm) + beta*xm(k+1,nm)) r_sob_lo_tau = alfa*r(k,nm) + beta*r(k+1,nm) end if - + if ((tau_sob > tau_sob_med .or. k==2) .and. v_sob_med_tau == 0d0) then alfa = (tau_sob_med - tau_sob_prev)/(tau_sob - tau_sob_prev) beta = 1d0 - alfa @@ -430,7 +430,7 @@ program main m_sob_med_tau = star_mass - (alfa*xm(k,nm) + beta*xm(k+1,nm)) r_sob_med_tau = alfa*r(k,nm) + beta*r(k+1,nm) end if - + if (tau_sob > tau_sob_hi .or. k==2) then alfa = (tau_sob_hi - tau_sob_prev)/(tau_sob - tau_sob_prev) beta = 1d0 - alfa @@ -445,9 +445,9 @@ program main m_sob_med_tau, r_sob_med_tau, & m_sob_hi_tau, r_sob_hi_tau exit - end if - - tau_sob_prev = tau_sob + end if + + tau_sob_prev = tau_sob end do end do @@ -468,7 +468,7 @@ program main call save_day_post_Lbol_max(3d0,t0,zone,star_mass,mass_IB,'003') call save_day_post_Lbol_max(4d0,t0,zone,star_mass,mass_IB,'004') call save_day_post_Lbol_max(5d0,t0,zone,star_mass,mass_IB,'005') - + call save_day_post_Lbol_max(10d0,t0,zone,star_mass,mass_IB,'010') call save_day_post_Lbol_max(20d0,t0,zone,star_mass,mass_IB,'020') call save_day_post_Lbol_max(30d0,t0,zone,star_mass,mass_IB,'030') @@ -508,7 +508,7 @@ real(dp) function interp_logLbol(time) end do interp_logLbol = logL_lbol(num_lbol) end function interp_logLbol - + real(dp) function get1_synthetic_color_abs_mag(name) result(mag) character (len=*) :: name mag = get_abs_mag_by_name(name, logT, log_g, Fe_H, L_div_Lsun, ierr) @@ -523,15 +523,15 @@ subroutine save_day_post_Lbol_max(day, t0, zone, star_mass, mass_IB, daystr) real(dp), intent(in) :: day, t0, star_mass, mass_IB integer, intent(in) :: zone character (len=*), intent(in) :: daystr - + integer, parameter :: io = 26, ncol = 36 real(dp) :: tnm, t1, t2, alfa, beta, data1(ncol), data2(ncol) integer :: k, i, nm1, nm2 character (len=132) :: fname include 'formats' - + if (t0 < 0d0) return - + tnm = day + t0 ! this is the desired run time nm1 = 0 nm2 = 0 @@ -542,7 +542,7 @@ subroutine save_day_post_Lbol_max(day, t0, zone, star_mass, mass_IB, daystr) exit end if end do - + if (nm1 == 0 .or. nm2 == 0) then write(*,*) 'save_day_post_Lbol_max failed to find models for', day return @@ -550,12 +550,12 @@ subroutine save_day_post_Lbol_max(day, t0, zone, star_mass, mass_IB, daystr) alfa = (t2 - tnm)/(t2 - t1) ! fraction from 1st time beta = 1d0 - alfa - + if (alfa > 1d0 .or. alfa < 0d0) then write(*,*) 'save_day_post_Lbol_max failed for', day return end if - + write(fname,'(a)') trim(filestr)// '.day' // trim(daystr) // '_post_Lbol_max.data' open(io,file=trim(fname), status='unknown') @@ -565,44 +565,44 @@ subroutine save_day_post_Lbol_max(day, t0, zone, star_mass, mass_IB, daystr) write(io,'(a20,2(1p,e25.15))') 'total mass', star_mass*msun, star_mass write(io,'(A)') write(io,'(99a25)') '', & - 'mass of cell (g)', & - 'cell center m (g)', & - 'cell center R (cm)', & + 'mass of cell (g)', & + 'cell center m (g)', & + 'cell center R (cm)', & 'cell center v (cm/s)', & - 'avg density', & - 'radiation pressure', & - 'avg temperature', & - 'radiation temperature', & - 'avg opacity', & - 'tau', & - 'outer edge m (g)', & - 'outer edge r (cm)', & - 'h1', & - 'he3', & - 'he4', & - 'c12', & - 'n14', & - 'o16', & - 'ne20', & - 'na23', & - 'mg24', & - 'si28', & - 's32', & - 'ar36', & - 'ca40', & - 'ti44', & - 'cr48', & - 'cr60', & - 'fe52', & - 'fe54', & - 'fe56', & - 'co56', & + 'avg density', & + 'radiation pressure', & + 'avg temperature', & + 'radiation temperature', & + 'avg opacity', & + 'tau', & + 'outer edge m (g)', & + 'outer edge r (cm)', & + 'h1', & + 'he3', & + 'he4', & + 'c12', & + 'n14', & + 'o16', & + 'ne20', & + 'na23', & + 'mg24', & + 'si28', & + 's32', & + 'ar36', & + 'ca40', & + 'ti44', & + 'cr48', & + 'cr60', & + 'fe52', & + 'fe54', & + 'fe56', & + 'co56', & 'ni56', & 'luminosity', & 'n_bar', & - 'n_e' + 'n_e' write(io,'(A)') - do j=1,zone + do j=1,zone !read(io1,*) i1, data1(1:ncol) !read(io2,*) i2, data2(1:ncol) call get1_data(j,nm1,data1) @@ -628,9 +628,9 @@ subroutine save_day_post_Lbol_max(day, t0, zone, star_mass, mass_IB, daystr) 333 continue write(*,*) 'failed in save_day_post_Lbol_max' call mesa_error(__FILE__,__LINE__) - + end subroutine save_day_post_Lbol_max - + subroutine get1_data(j,nm,d) integer, parameter :: ncol = 36 integer, intent(in) :: j,nm diff --git a/stella/src/stl/math_constants.f90 b/stella/src/stl/math_constants.f90 index 8678df1a3..6d8c2ff69 100644 --- a/stella/src/stl/math_constants.f90 +++ b/stella/src/stl/math_constants.f90 @@ -17,7 +17,7 @@ !! Adapted for use in CP2K (JGH) !! JGH (16-06-2002) : Added Gamma functions !! JGH (10-08-2004) : Added Euler constant (gamma) -!! Baklanov (13-07-2006) : change module name +!! Baklanov (13-07-2006) : change module name !! SOURCE !****************************************************************************** @@ -32,7 +32,7 @@ module math_constants p_zero, p_one, p_half, p_degree, p_radians public :: deq,dgt,dne,dle,dlt,dge public :: dNeqZero, dEqZero, dLtZero, dGtZero - + real(kind=dp), parameter, public :: one=1.0_dp, eps=2*epsilon(one) real (kind=dp), parameter :: p_pi = 3.14159265358979323846264338_dp @@ -85,30 +85,30 @@ function dge(x,y) result (test) logical :: test test = dgt(x,y) .or. deq(x,y) end function dge - -! compare with 0 + +! compare with 0 logical function dGtZero(x) real(kind=dp), intent(in) :: x dGtZero = dgt(x, 0._dp) end function dGtZero - + logical function dLtZero(x) real(kind=dp), intent(in) :: x dLtZero = dlt(x, 0._dp) end function dLtZero - + logical function dEqZero(x) real(kind=dp), intent(in) :: x write(*,*) ' eps=',eps dEqZero = deq(x, 0._dp) end function dEqZero - + logical function dNeqZero(x) real(kind=dp), intent(in) :: x dNeqZero = dne(x, 0._dp) end function dNeqZero - - + + end module math_constants !****************************************************************************** diff --git a/stella/src/stl/phys_constants.f90 b/stella/src/stl/phys_constants.f90 index 962ae50bf..a7ce85e1e 100644 --- a/stella/src/stl/phys_constants.f90 +++ b/stella/src/stl/phys_constants.f90 @@ -1,17 +1,17 @@ module phys_constants use kinds, only: dp - use math_constants, only: p_pi + use math_constants, only: p_pi implicit none private - + ! public :: p_h_bar, p_hplanc, p_c_light, p_boltzk, p_avogar, p_atom_m, p_m_e, p_echarg, & ! p_cg, p_cms, p_rsol, p_Rgas, & ! p_carad, p_csigm, p_ergev, p_gradev, p_radc, p_ctomp, p_ccaps, p_ccapz, p_a_fine - - public :: write_phys_constants - + + public :: write_phys_constants + ! *** Planck constant [J*s] *** real (kind=dp), parameter, public :: p_h_bar = 1.0545715960e-27_dp @@ -68,8 +68,8 @@ module phys_constants ! *** T [K] to eV *** real (kind=dp), parameter, public :: p_T2ev = p_k * p_erg2ev ! p_T2ev = 8.61734229583e-5 ! *** eV to T [K] *** - real (kind=dp), parameter, public :: p_ev2T = 1._dp / p_T2ev ! p_ev2T = 11604.5059563 - + real (kind=dp), parameter, public :: p_ev2T = 1._dp / p_T2ev ! p_ev2T = 11604.5059563 + contains SUBROUTINE write_phys_constants(output_unit) @@ -108,7 +108,7 @@ SUBROUTINE write_phys_constants(output_unit) END SUBROUTINE write_phys_constants ! ***************************************************************************** - + end module phys_constants !****************************************************************************** diff --git a/stella/src/stl/rad_photo_cross_section.f90 b/stella/src/stl/rad_photo_cross_section.f90 index 926ba7d9e..408d6b5d7 100644 --- a/stella/src/stl/rad_photo_cross_section.f90 +++ b/stella/src/stl/rad_photo_cross_section.f90 @@ -1,18 +1,18 @@ module rad_photo_cross_section use kinds, only: sp, dp - + implicit none - + public :: photoCross private - - character(len=*), parameter, private :: mdl_name = 'rad_photo_cross_section' - + + character(len=*), parameter, private :: mdl_name = 'rad_photo_cross_section' + interface photoCross module procedure photoCrossVerner, ics_full end interface - + real (kind=sp), parameter, private :: p_e_max = 5.d4 integer i integer, dimension(7) :: L, IS2Ne @@ -26,13 +26,13 @@ module rad_photo_cross_section ! COMMON/NTOT/NTOT(30) ! COMMON/PH1/PH1(6,30,30,7) ! COMMON/PH2/PH2(7,30,30) - + DATA (L(i),i=1,7) /0,0,1,0,1,2,0/ DATA (IS2Ne(i),i=1,7) /2,4,10,12,18,28,30/ DATA (NINN(i),i=1,30) /0,0,1,1,1,1,1,1,1,1,3,3,3,3,3,3,3,3,5,5,5,5,5,5,5,5,5,5,5,5/ DATA (NTOT(i),i=1,30) /1,1,2,2,3,3,3,3,3,3,4,4,5,5,5,5,5,5,6,6,6,6,6,6,6,6,6,6,7,7/ DATA (NFULL(i),i=1,30) /1,1,2,2,3,3,3,3,3,3,4,4,5,5,5,5,5,5,7,7,7,7,7,7,7,7,7,7,7,7/ - + DATA (PH1(i, 1, 1, 1),i=1,6) /1.360E+01, 4.298E-01, 5.475E+04, 3.288E+01, 2.963E+00, 0.000E+00/ DATA (PH1(i, 2, 1, 1),i=1,6) /5.442E+01, 1.720E+00, 1.369E+04, 3.288E+01, 2.963E+00, 0.000E+00/ DATA (PH1(i, 2, 2, 1),i=1,6) /2.459E+01, 5.996E+00, 4.470E+03, 2.199E+00, 6.098E+00, 0.000E+00/ @@ -3192,7 +3192,7 @@ module rad_photo_cross_section 1.017E+04, 5.288E+00, 1.736E+01, 4.667E-01/ DATA (PH1(i,30,30, 7),i=1,6) /9.394E+00, 1.673E+01,& 1.236E+00, 1.029E+03, 4.259E+00, 3.962E-02/ - + DATA (PH2(i, 1, 1),i=1,7) /4.298E-01, 5.475E+04, 3.288E+01, 2.963E+00, 0.000E+00, 0.000E+00, 0.000E+00/ DATA (PH2(i, 2, 1),i=1,7) /1.720E+00, 1.369E+04,3.288E+01, 2.963E+00, 0.000E+00, 0.000E+00, 0.000E+00/ DATA (PH2(i, 2, 2),i=1,7) /1.361E+01, 9.492E+02,1.469E+00, 3.188E+00, 2.039E+00, 4.434E-01, 2.136E+00/ @@ -3718,7 +3718,7 @@ module rad_photo_cross_section ! ! Written by D. A. Verner, verner@pa.uky.edu ! ! Modified by D. A. Badjin, June 15, 2008 ! ! Inner-shell ionization energies of some low-ionized species are slightly -! ! improved to fit smoothly the experimental inner-shell ionization energies +! ! improved to fit smoothly the experimental inner-shell ionization energies ! ! of neutral atoms. ! ! ****************************************************************************** ! ! This subroutine calculates partial photoionization cross sections @@ -3731,29 +3731,29 @@ module rad_photo_cross_section ! ! Verner and Yakovlev, 1995, A&AS, 109, 125 ("old" fit) !! !! ARGUMENTS -!! nz - atomic number from 1 to 30 (integer) +!! nz - atomic number from 1 to 30 (integer) !! ne - number of electrons from 1 to iz (integer) !! npts - the number of points in frequences and sigma. !! fr(npts) - contains the frequency grid at which the cross sections should be computed -!! +!! !! Output !! sigma(npts) - array of cross sections, in cm^2 !! !! AUTHOR !! D. A. Verner -!! +!! !! !! SOURCE !!*************************************************************************** subroutine ics_full(nz,ne,npts,fr,sigma) integer, intent(in) :: nz,ne, npts - real*8, dimension(npts), intent(in) :: fr + real(dp), dimension(npts), intent(in) :: fr real (kind=dp), dimension(npts), intent(out) :: sigma character(len=*), parameter :: subrtn_name = 'ics_full'& , fullPathSubrtn = mdl_name//'.'//subrtn_name integer k, is, nint, nout - real*8 a,b,e,einn,p1,q,s,x,y,z + real(dp) a,b,e,einn,p1,q,s,x,y,z ! common/l/l(7) ! common/ninn/ninn(30) ! common/ntot/ntot(30) @@ -3762,16 +3762,16 @@ subroutine ics_full(nz,ne,npts,fr,sigma) ! *** Hertz to electron-Volt transition coefficient - real*8, parameter :: hztoev=4.13566727333d-15 + real(dp), parameter :: hztoev=4.13566727333d-15 -! *** creating null-filled sigma-array +! *** creating null-filled sigma-array sigma(:)=0.d+00 - + ! *** some test to find an error - if(nz.lt.1.or.nz.gt.30)return + if(nz.lt.1.or.nz.gt.30)return if(ne.lt.1.or.ne.gt.nz)return @@ -3781,13 +3781,13 @@ subroutine ics_full(nz,ne,npts,fr,sigma) if(nz.eq.ne.and.nz.gt.18) nout=7 if(nz.eq.(ne+1).and.(nz.eq.20.or.nz.eq.21.or.nz.eq.22.or. & nz.eq.25.or.nz.eq.26)) nout=7 - + ! *** do-cycle, over the frequency grid do k=1,npts - e=hztoev*fr(k) - + e=hztoev*fr(k) + ! *** do-cycle, over shells do is=1,nout @@ -3817,9 +3817,9 @@ subroutine ics_full(nz,ne,npts,fr,sigma) endif endif -! *** if the current shell is treated as inner one +! *** if the current shell is treated as inner one ! *** or the current energy is high enough, then use "old" fit - + if(is.le.nint.or.e.ge.einn)then p1=-ph1(5,nz,ne,is) y=e/ph1(2,nz,ne,is) @@ -3834,15 +3834,15 @@ subroutine ics_full(nz,ne,npts,fr,sigma) else ! *** else use "new" fit for outer shells and low energies -! *** also we have to take into account that +! *** also we have to take into account that ! *** 1) for systems with outer p-shells the "new" fit computes -! *** cross sections both for p- and s- shells; +! *** cross sections both for p- and s- shells; ! *** 2) the same thing is for FeI and FeII with (3d+4s); ! *** 3)calcium has no 3d electrons, i.e. has no shell with number is=6 if(((nout.eq.3).and.(is.eq.2)).or.((nout.eq.5) & .and.(is.eq.4)).or.(((nz.eq.26).and.((ne.eq.26).or.(ne.eq.25))) & - .and.(is.eq.6)).or.((nz.eq.20).and.(is.eq.6))) then + .and.(is.eq.6)).or.((nz.eq.20).and.(is.eq.6))) then s=0 ! *** after all this checkings we can finally use the "new" fit @@ -3866,7 +3866,7 @@ subroutine ics_full(nz,ne,npts,fr,sigma) end do end do - + sigma(:)=sigma(:)*1.d-18! *1.e-18 transform from Mb to sm^2 return @@ -3881,15 +3881,15 @@ end subroutine ics_full !! FUNCTION !! This subroutine finds shell number, using photon energy, and then !! calculates partial photoionization cross sections -!! for all ionization stages of all atoms from H to Zn (Z=30) by use of +!! for all ionization stages of all atoms from H to Zn (Z=30) by use of !! Verner's subroutine "phfit2" !! http://www.pa.uky.edu/~verner/photo.html !! !! ARGUMENTS -!! nz - atomic number from 1 to 30 (integer) +!! nz - atomic number from 1 to 30 (integer) !! ne - number of electrons from 1 to iz (integer) -!! e - photon energy, eV -!! +!! e - photon energy, eV +!! !! Output !! s - photoionization cross section, Mb !! @@ -3902,13 +3902,13 @@ end subroutine ics_full subroutine photoCrossVerner( nz,ne, e, s) ! subroutine photoCrossVerner( nz,ne, e, s) integer, intent(in) :: nz,ne - real*8, intent(in) :: e + real(dp), intent(in) :: e real (kind=dp), intent(out) :: s character(len=*), parameter :: subrtn_name = 'photoCrossVerner'& , fullPathSubrtn = mdl_name//'.'//subrtn_name integer i, is_max, nint,tmpne real (kind=dp) e_max, tmps - + if(nz < 1.or.nz > 30)return if(ne < 1.or.ne > nz)return is_max = NFULL(ne) @@ -3922,7 +3922,7 @@ subroutine photoCrossVerner( nz,ne, e, s) ! enddo ! if( e > p_e_max) return ! energy is to high for this fit -! +! ! write(*,*)'BEGIN: nz=', nz, 'ne=', ne; ! e_max = p_Emax(nz,ne) ! is = ntot(ne) @@ -3951,7 +3951,7 @@ end subroutine photoCrossVerner !! !! FUNCTION !! Inner-shell ionization energies of some low-ionized species are slightly -!! improved to fit smoothly the experimental inner-shell ionization energies +!! improved to fit smoothly the experimental inner-shell ionization energies !! of neutral atoms. !! ****************************************************************************** !! This subroutine calculates partial photoionization cross sections @@ -3964,17 +3964,17 @@ end subroutine photoCrossVerner !! !! ARGUMENTS -!! nz - atomic number from 1 to 30 (integer) +!! nz - atomic number from 1 to 30 (integer) !! ne - number of electrons from 1 to iz (integer) !! is - shell number (integer) -!! e - photon energy, eV -!! +!! e - photon energy, eV +!! !! Shell numbers: -!! 1 - 1s, 2 - 2s, 3 - 2p, 4 - 3s, 5 - 3p, 6 - 3d, 7 - 4s. +!! 1 - 1s, 2 - 2s, 3 - 2p, 4 - 3s, 5 - 3p, 6 - 3d, 7 - 4s. !! If a species in the ground state has no electrons on the given shell, !! the subroutine returns s=0. -!! +!! !! Output !! s - photoionization cross section, Mb !! @@ -3989,11 +3989,11 @@ end subroutine photoCrossVerner !!*************************************************************************** subroutine phfit2(nz,ne,is,e,s) integer, intent(in) :: nz,ne, is - real*8, intent(in) :: e + real(dp), intent(in) :: e real (kind=dp), intent(out) :: s character(len=*), parameter :: subrtn_name = 'phfit2'& , fullPathSubrtn = mdl_name//'.'//subrtn_name - + integer :: nout, nint real (kind=sp) :: p1, y, q,a, b, x, z, einn @@ -4035,4 +4035,4 @@ subroutine phfit2(nz,ne,is,e,s) return end subroutine phfit2 -end module rad_photo_cross_section +end module rad_photo_cross_section diff --git a/stella/src/util/epsilon.f90 b/stella/src/util/epsilon.f90 index 81d52a919..df6f62f12 100644 --- a/stella/src/util/epsilon.f90 +++ b/stella/src/util/epsilon.f90 @@ -1,8 +1,7 @@ - program test_epsilon +program test_epsilon real, parameter :: x = 3.143 real(8), parameter :: y = 2.33 print *, EPSILON(x) print *, EPSILON(y) end program test_epsilon - \ No newline at end of file diff --git a/stella/src/util/gnufor2.f90 b/stella/src/util/gnufor2.f90 index 030d1f9fd..b1498b478 100644 --- a/stella/src/util/gnufor2.f90 +++ b/stella/src/util/gnufor2.f90 @@ -3,7 +3,7 @@ ! this Fortran90 module contains a collection of subroutines for plotting data, ! including 2D, 3D plots, surfaces, polar coordinates, histograms ! it is a modification of the GNUFOR interface written by John Burkardt: -! http://orion.math.iastate.edu/burkardt/g_src/gnufor/gnufor.html +! http://orion.math.iastate.edu/burkardt/g_src/gnufor/gnufor.html !*********************************************************************************** module gnufor2 implicit none @@ -116,35 +116,35 @@ subroutine image_4(x,y,rgb,pause,terminal,filename,persist,input) !*********************************************************************************** if (present(input)) then data_file_name='data_file_'//input//'.txt' - command_file_name='command_file_'//input//'.txt' + command_file_name='command_file_'//input//'.txt' else data_file_name='data_file.txt' command_file_name='command_file.txt' end if !*********************************************************************************** - ierror=0 - call get_unit(file_unit) + ierror=0 + call get_unit(file_unit) if (file_unit==0) then ierror=1 print *,'write_vector_date - fatal error! Could not get a free FORTRAN unit.' stop end if - open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) + open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) if (ios/=0) then ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal data file.' stop end if -!*********************************************************************************** +!*********************************************************************************** ! here we write the date to the data_file - the gnuplot will read this data later -!*********************************************************************************** +!*********************************************************************************** do j=1,ny do i=1,nx write (file_unit,'(2E12.4,3I5)') x(i),y(j),rgb(1,i,j),rgb(2,i,j),rgb(3,i,j) end do write (file_unit,'(a)') end do -!*********************************************************************************** +!*********************************************************************************** close (unit=file_unit) !*********************************************************************************** ierror = 0 @@ -159,38 +159,38 @@ subroutine image_4(x,y,rgb,pause,terminal,filename,persist,input) ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal command file.' stop - end if + end if !*********************************************************************************** ! here we write the commands to the commands file which gnuplot will execute !*********************************************************************************** my_persist='persist ' if (present(persist).and.(persist=='no')) my_persist=' ' if (present(terminal)) then - write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) + write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) if (present(filename)) then - write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' + write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' else - write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' + write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' end if else write ( file_unit, '(a)' ) 'set terminal ' // trim(default_terminal) // ' ' & - & //trim(my_persist) // ' title "Gnuplot"' + & //trim(my_persist) // ' title "Gnuplot"' end if !*********************************************************************************** write ( file_unit, '(a)' ) 'set nokey' write ( file_unit, '(a)' ) 'set xrange ['// trim(xrange1) // ':'// trim(xrange2) //']' write ( file_unit, '(a)' ) 'set yrange ['// trim(yrange1) // ':'// trim(yrange2) //']' write ( file_unit, '(a)' ) 'unset colorbox' -!*********************************************************************************** +!*********************************************************************************** write ( file_unit, '(a)' ) 'plot "' // trim ( data_file_name ) // & & '" with rgbimage' !*********************************************************************************** if (present(pause)) then if (pause<0.0) then write ( file_unit, '(a)' ) 'pause -1 "press RETURN to continue"' - else + else write ( my_pause,'(e9.3)') pause - write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) + write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) end if else write ( file_unit, '(a)' ) 'pause 0' @@ -231,35 +231,35 @@ subroutine image_3(rgb,pause,terminal,filename,persist,input) !*********************************************************************************** if (present(input)) then data_file_name='data_file_'//input//'.txt' - command_file_name='command_file_'//input//'.txt' + command_file_name='command_file_'//input//'.txt' else data_file_name='data_file.txt' command_file_name='command_file.txt' end if !*********************************************************************************** - ierror=0 - call get_unit(file_unit) + ierror=0 + call get_unit(file_unit) if (file_unit==0) then ierror=1 print *,'write_vector_date - fatal error! Could not get a free FORTRAN unit.' stop end if - open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) + open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) if (ios/=0) then ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal data file.' stop end if -!*********************************************************************************** +!*********************************************************************************** ! here we write the date to the data_file - the gnuplot will read this data later -!*********************************************************************************** +!*********************************************************************************** do j=1,ny do i=1,nx write (file_unit,'(5I5)') i,j,rgb(1,i,j),rgb(2,i,j),rgb(3,i,j) end do write (file_unit,'(a)') end do -!*********************************************************************************** +!*********************************************************************************** close (unit=file_unit) !*********************************************************************************** ierror = 0 @@ -274,22 +274,22 @@ subroutine image_3(rgb,pause,terminal,filename,persist,input) ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal command file.' stop - end if + end if !*********************************************************************************** ! here we write the commands to the commands file which gnuplot will execute !*********************************************************************************** my_persist='persist ' if (present(persist).and.(persist=='no')) my_persist=' ' if (present(terminal)) then - write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) + write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) if (present(filename)) then - write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' + write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' else - write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' + write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' end if else write ( file_unit, '(a)' ) 'set terminal ' // trim(default_terminal) // ' ' & - & //trim(my_persist) // ' title "Gnuplot"' + & //trim(my_persist) // ' title "Gnuplot"' end if !*********************************************************************************** write ( file_unit, '(a)' ) 'set nokey' @@ -297,16 +297,16 @@ subroutine image_3(rgb,pause,terminal,filename,persist,input) write ( file_unit, '(a)' ) 'unset xtics' write ( file_unit, '(a)' ) 'unset ytics' write ( file_unit, '(a)' ) 'unset colorbox' -!*********************************************************************************** +!*********************************************************************************** write ( file_unit, '(a)' ) 'plot "' // trim ( data_file_name ) // & & '" with rgbimage' !*********************************************************************************** if (present(pause)) then if (pause<0.0) then write ( file_unit, '(a)' ) 'pause -1 "press RETURN to continue"' - else + else write ( my_pause,'(e9.3)') pause - write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) + write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) end if else write ( file_unit, '(a)' ) 'pause 0' @@ -349,35 +349,35 @@ subroutine image_2(x,y,gray,pause,palette,terminal,filename,persist,input) !*********************************************************************************** if (present(input)) then data_file_name='data_file_'//input//'.txt' - command_file_name='command_file_'//input//'.txt' + command_file_name='command_file_'//input//'.txt' else data_file_name='data_file.txt' command_file_name='command_file.txt' end if !*********************************************************************************** - ierror=0 - call get_unit(file_unit) + ierror=0 + call get_unit(file_unit) if (file_unit==0) then ierror=1 print *,'write_vector_date - fatal error! Could not get a free FORTRAN unit.' stop end if - open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) + open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) if (ios/=0) then ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal data file.' stop end if -!*********************************************************************************** +!*********************************************************************************** ! here we write the date to the data_file - the gnuplot will read this data later -!*********************************************************************************** +!*********************************************************************************** do j=1,ny do i=1,nx write (file_unit,'(3E12.4)') x(i), y(j), gray(i,j) end do write (file_unit,'(a)') end do -!*********************************************************************************** +!*********************************************************************************** close (unit=file_unit) !*********************************************************************************** ierror = 0 @@ -392,22 +392,22 @@ subroutine image_2(x,y,gray,pause,palette,terminal,filename,persist,input) ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal command file.' stop - end if + end if !*********************************************************************************** ! here we write the commands to the commands file which gnuplot will execute !*********************************************************************************** my_persist='persist ' if (present(persist).and.(persist=='no')) my_persist=' ' if (present(terminal)) then - write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) + write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) if (present(filename)) then - write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' + write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' else - write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' + write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' end if else write ( file_unit, '(a)' ) 'set terminal ' // trim(default_terminal) // ' ' & - & //trim(my_persist) // ' title "Gnuplot"' + & //trim(my_persist) // ' title "Gnuplot"' end if !*********************************************************************************** write ( file_unit, '(a)' ) 'set nokey' @@ -424,16 +424,16 @@ subroutine image_2(x,y,gray,pause,palette,terminal,filename,persist,input) else write ( file_unit, '(a)' ) 'set palette model '// trim(default_palette) end if -!*********************************************************************************** +!*********************************************************************************** write ( file_unit, '(a)' ) 'plot "' // trim ( data_file_name ) // & & '" with image' !*********************************************************************************** if (present(pause)) then if (pause<0.0) then write ( file_unit, '(a)' ) 'pause -1 "press RETURN to continue"' - else + else write ( my_pause,'(e9.3)') pause - write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) + write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) end if else write ( file_unit, '(a)' ) 'pause 0' @@ -466,35 +466,35 @@ subroutine image_1(gray,pause,palette,terminal,filename,persist,input) !*********************************************************************************** if (present(input)) then data_file_name='data_file_'//input//'.txt' - command_file_name='command_file_'//input//'.txt' + command_file_name='command_file_'//input//'.txt' else data_file_name='data_file.txt' command_file_name='command_file.txt' end if !*********************************************************************************** - ierror=0 - call get_unit(file_unit) + ierror=0 + call get_unit(file_unit) if (file_unit==0) then ierror=1 print *,'write_vector_date - fatal error! Could not get a free FORTRAN unit.' stop end if - open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) + open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) if (ios/=0) then ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal data file.' stop end if -!*********************************************************************************** +!*********************************************************************************** ! here we write the date to the data_file - the gnuplot will read this data later -!*********************************************************************************** +!*********************************************************************************** do j=1,ny do i=1,nx write (file_unit,'(I5,I5,E15.7)') i,j,gray(i,j) end do write (file_unit,'(a)') end do -!*********************************************************************************** +!*********************************************************************************** close (unit=file_unit) !*********************************************************************************** ierror = 0 @@ -509,22 +509,22 @@ subroutine image_1(gray,pause,palette,terminal,filename,persist,input) ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal command file.' stop - end if + end if !*********************************************************************************** ! here we write the commands to the commands file which gnuplot will execute !*********************************************************************************** my_persist='persist ' if (present(persist).and.(persist=='no')) my_persist=' ' if (present(terminal)) then - write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) + write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) if (present(filename)) then - write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' + write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' else - write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' + write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' end if else write ( file_unit, '(a)' ) 'set terminal ' // trim(default_terminal) // ' ' & - & //trim(my_persist) // ' title "Gnuplot"' + & //trim(my_persist) // ' title "Gnuplot"' end if !*********************************************************************************** write ( file_unit, '(a)' ) 'set nokey' @@ -542,16 +542,16 @@ subroutine image_1(gray,pause,palette,terminal,filename,persist,input) else write ( file_unit, '(a)' ) 'set palette model '// trim(default_palette) end if -!*********************************************************************************** +!*********************************************************************************** write ( file_unit, '(a)' ) 'plot "' // trim ( data_file_name ) // & & '" with image' !*********************************************************************************** if (present(pause)) then if (pause<0.0) then write ( file_unit, '(a)' ) 'pause -1 "press RETURN to continue"' - else + else write ( my_pause,'(e9.3)') pause - write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) + write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) end if else write ( file_unit, '(a)' ) 'pause 0' @@ -586,32 +586,32 @@ subroutine plot3d(x,y,z,pause,color,terminal,filename,persist,input,linewidth) !*********************************************************************************** if (present(input)) then data_file_name='data_file_'//input//'.txt' - command_file_name='command_file_'//input//'.txt' + command_file_name='command_file_'//input//'.txt' else data_file_name='data_file.txt' command_file_name='command_file.txt' end if !*********************************************************************************** - ierror=0 - call get_unit(file_unit) + ierror=0 + call get_unit(file_unit) if (file_unit==0) then ierror=1 print *,'write_vector_date - fatal error! Could not get a free FORTRAN unit.' stop end if - open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) + open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) if (ios/=0) then ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal data file.' stop end if -!*********************************************************************************** +!*********************************************************************************** ! here we write the date to the data_file - the gnuplot will read this data later -!*********************************************************************************** +!*********************************************************************************** do i=1,nx write (file_unit,'(3E15.7)') x(i), y(i), z(i) end do -!*********************************************************************************** +!*********************************************************************************** close (unit=file_unit) !*********************************************************************************** ierror = 0 @@ -626,22 +626,22 @@ subroutine plot3d(x,y,z,pause,color,terminal,filename,persist,input,linewidth) ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal command file.' stop - end if + end if !*********************************************************************************** ! here we write the commands to the commands file which gnuplot will execute !*********************************************************************************** my_persist='persist' if (present(persist).and.(persist=='no')) my_persist=' ' if (present(terminal)) then - write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) + write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) if (present(filename)) then - write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' + write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' else - write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' + write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' end if else write ( file_unit, '(a)' ) 'set terminal ' // trim(default_terminal) // ' ' & - &// trim(my_persist) // ' title "Gnuplot"' + &// trim(my_persist) // ' title "Gnuplot"' end if !*********************************************************************************** write ( file_unit, '(a)' ) 'set nokey' @@ -650,21 +650,21 @@ subroutine plot3d(x,y,z,pause,color,terminal,filename,persist,input,linewidth) write ( my_linewidth,'(e9.3)') linewidth else my_linewidth=trim(default_linewidth) - end if + end if if (present(color)) then my_color='"'//trim(color)//'"' else my_color='"'//trim(default_color1)//'"' - end if + end if write ( file_unit, '(a)' ) 'splot "' // trim ( data_file_name ) // & '" using 1:2:3 with lines linecolor rgb' // my_color //' linewidth ' // my_linewidth !*********************************************************************************** if (present(pause)) then if (pause<0.0) then write ( file_unit, '(a)' ) 'pause -1 "press RETURN to continue"' - else + else write ( my_pause,'(e9.3)') pause - write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) + write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) end if else write ( file_unit, '(a)' ) 'pause 0' @@ -716,32 +716,32 @@ subroutine hist(x,n,pause,color,terminal,filename,persist,input) !*********************************************************************************** if (present(input)) then data_file_name='data_file_'//input//'.txt' - command_file_name='command_file_'//input//'.txt' + command_file_name='command_file_'//input//'.txt' else data_file_name='data_file.txt' command_file_name='command_file.txt' end if !*********************************************************************************** - ierror=0 - call get_unit(file_unit) + ierror=0 + call get_unit(file_unit) if (file_unit==0) then ierror=1 print *,'write_vector_date - fatal error! Could not get a free FORTRAN unit.' stop end if - open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) + open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) if (ios/=0) then ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal data file.' stop end if -!*********************************************************************************** +!*********************************************************************************** ! here we write the date to the data_file - the gnuplot will read this data later -!*********************************************************************************** +!*********************************************************************************** do i=1,n write (file_unit,'(2E15.7)') (xhist(i-1)+0.5*dx), yhist(i) end do -!*********************************************************************************** +!*********************************************************************************** close (unit=file_unit) !*********************************************************************************** ierror = 0 @@ -756,22 +756,22 @@ subroutine hist(x,n,pause,color,terminal,filename,persist,input) ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal command file.' stop - end if + end if !*********************************************************************************** ! here we write the commands to the commands file which gnuplot will execute !*********************************************************************************** my_persist='persist' if (present(persist).and.(persist=='no')) my_persist=' ' if (present(terminal)) then - write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) + write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) if (present(filename)) then - write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' + write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' else - write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' + write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' end if else write ( file_unit, '(a)' ) 'set terminal ' // trim(default_terminal) // ' ' & - & //trim(my_persist) // ' title "Gnuplot"' + & //trim(my_persist) // ' title "Gnuplot"' end if !*********************************************************************************** write ( file_unit, '(a)' ) 'set nokey' @@ -786,16 +786,16 @@ subroutine hist(x,n,pause,color,terminal,filename,persist,input) my_color='"'//color//'"' else my_color='"'//trim(default_color1)//'"' - end if + end if write ( file_unit, '(a)' ) 'plot "' // trim ( data_file_name ) // & '" using 1:2 with boxes linecolor rgb' // trim(my_color) !*********************************************************************************** if (present(pause)) then if (pause<0.0) then write ( file_unit, '(a)' ) 'pause -1 "press RETURN to continue"' - else + else write ( my_pause,'(e9.3)') pause - write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) + write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) end if else write ( file_unit, '(a)' ) 'pause 0' @@ -828,7 +828,7 @@ subroutine surf_3(x,y,z,pause,palette,terminal,filename,pm3d,contour,persist,inp if ((size(x).ne.nx).or.(size(y).ne.ny)) then print *,'subroutine surf_3 ERROR: sizes of x(:),y(:), and z(:,:) are incompatible' stop - end if + end if !*********************************************************************************** do i=1,nx do j=1,ny @@ -838,14 +838,14 @@ subroutine surf_3(x,y,z,pause,palette,terminal,filename,pm3d,contour,persist,inp end do end do call surf_1(xyz,pause,palette,terminal,filename,pm3d,contour,persist,input) -!*********************************************************************************** +!*********************************************************************************** end subroutine surf_3 !*********************************************************************************** !*********************************************************************************** !*********************************************************************************** subroutine surf_2(z,pause,palette,terminal,filename,pm3d,contour,persist,input) !*********************************************************************************** -! this subroutine plots a surface. The only input is a 2D array z(:,:), the x-y grid +! this subroutine plots a surface. The only input is a 2D array z(:,:), the x-y grid ! is generated automatically !*********************************************************************************** implicit none @@ -866,7 +866,7 @@ subroutine surf_2(z,pause,palette,terminal,filename,pm3d,contour,persist,input) end do end do call surf_1(xyz,pause,palette,terminal,filename,pm3d,contour,persist,input) -!*********************************************************************************** +!*********************************************************************************** end subroutine surf_2 !*********************************************************************************** !*********************************************************************************** @@ -890,35 +890,35 @@ subroutine surf_1(xyz,pause,palette,terminal,filename,pm3d,contour,persist,input !*********************************************************************************** if (present(input)) then data_file_name='data_file_'//input//'.txt' - command_file_name='command_file_'//input//'.txt' + command_file_name='command_file_'//input//'.txt' else data_file_name='data_file.txt' command_file_name='command_file.txt' end if !*********************************************************************************** - ierror=0 - call get_unit(file_unit) + ierror=0 + call get_unit(file_unit) if (file_unit==0) then ierror=1 print *,'write_vector_date - fatal error! Could not get a free FORTRAN unit.' stop end if - open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) + open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) if (ios/=0) then ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal data file.' stop end if -!*********************************************************************************** +!*********************************************************************************** ! here we write the date to the data_file - the gnuplot will read this data later -!*********************************************************************************** +!*********************************************************************************** do j=1,ny do i=1,nx write (file_unit,'(3E15.7)') xyz(1:3,i,j) end do write (file_unit,'(a)') end do -!*********************************************************************************** +!*********************************************************************************** close (unit=file_unit) !*********************************************************************************** ierror = 0 @@ -933,22 +933,22 @@ subroutine surf_1(xyz,pause,palette,terminal,filename,pm3d,contour,persist,input ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal command file.' stop - end if + end if !*********************************************************************************** ! here we write the commands to the commands file which gnuplot will execute !*********************************************************************************** my_persist='persist ' if (present(persist).and.(persist=='no')) my_persist=' ' if (present(terminal)) then - write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) + write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) if (present(filename)) then - write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' + write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' else - write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' + write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' end if else write ( file_unit, '(a)' ) 'set terminal ' // trim(default_terminal) // ' ' & - & //trim(my_persist) // ' title "Gnuplot"' + & //trim(my_persist) // ' title "Gnuplot"' end if !*********************************************************************************** write ( file_unit, '(a)' ) 'set nokey' @@ -964,31 +964,31 @@ subroutine surf_1(xyz,pause,palette,terminal,filename,pm3d,contour,persist,input end if !*********************************************************************************** if (present(pm3d)) then - write ( file_unit, '(a)' ) 'set '// pm3d + write ( file_unit, '(a)' ) 'set '// pm3d else write ( file_unit, '(a)' ) 'set surface' if (present(contour)) then - if (contour=='surface') then + if (contour=='surface') then write ( file_unit, '(a)' ) 'set contour surface' elseif (contour=='both') then write ( file_unit, '(a)' ) 'set contour both' - else + else write ( file_unit, '(a)' ) 'set contour' end if end if end if write ( file_unit, '(a)' ) 'set hidden3d' write ( file_unit, '(a)' ) 'set parametric' -!*********************************************************************************** +!*********************************************************************************** write ( file_unit, '(a)' ) 'splot "' // trim ( data_file_name ) // & & '" using 1:2:3 with lines palette' !*********************************************************************************** if (present(pause)) then if (pause<0.0) then write ( file_unit, '(a)' ) 'pause -1 "press RETURN to continue"' - else + else write ( my_pause,'(e9.3)') pause - write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) + write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) end if else write ( file_unit, '(a)' ) 'pause 0' @@ -1021,7 +1021,7 @@ subroutine plot_4(x1,y1,x2,y2,x3,y3,x4,y4,style,pause,color1,color2,color3,color !*********************************************************************************** if (present(input)) then data_file_name='data_file_'//input//'.txt' - command_file_name='command_file_'//input//'.txt' + command_file_name='command_file_'//input//'.txt' else data_file_name='data_file.txt' command_file_name='command_file.txt' @@ -1040,28 +1040,28 @@ subroutine plot_4(x1,y1,x2,y2,x3,y3,x4,y4,style,pause,color1,color2,color3,color stop end if !*********************************************************************************** - ierror=0 - call get_unit(file_unit) + ierror=0 + call get_unit(file_unit) if (file_unit==0) then ierror=1 print *,'write_vector_data - fatal error! Could not get a free FORTRAN unit.' stop end if - open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) + open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) if (ios/=0) then ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal data file.' stop end if -!*********************************************************************************** +!*********************************************************************************** ! here we write the date to the data_file - the gnuplot will read this data later !*********************************************************************************** - Nmax=max(Nx1,Nx2,Nx3,Nx4) + Nmax=max(Nx1,Nx2,Nx3,Nx4) do i=1,Nmax write (file_unit,'(8E15.7)') x1(min(i,Nx1)), y1(min(i,Nx1)), x2(min(i,Nx2)), y2(min(i,Nx2)), & & x3(min(i,Nx3)), y3(min(i,Nx3)), x4(min(i,Nx4)), y4(min(i,Nx4)) end do -!*********************************************************************************** +!*********************************************************************************** close (unit=file_unit) !*********************************************************************************** ierror = 0 @@ -1076,7 +1076,7 @@ subroutine plot_4(x1,y1,x2,y2,x3,y3,x4,y4,style,pause,color1,color2,color3,color ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal command file.' stop - end if + end if !*********************************************************************************** ! here we write the commands to the commands file which gnuplot will execute !*********************************************************************************** @@ -1116,7 +1116,7 @@ subroutine plot_4(x1,y1,x2,y2,x3,y3,x4,y4,style,pause,color1,color2,color3,color write ( my_linewidth,'(e9.3)') linewidth else my_linewidth=trim(default_linewidth) - end if + end if if (present(color1)) then my_color1='"'//trim(color1)//'"' else @@ -1141,15 +1141,15 @@ subroutine plot_4(x1,y1,x2,y2,x3,y3,x4,y4,style,pause,color1,color2,color3,color my_persist='persist ' if (present(persist).and.(persist=='no')) my_persist=' ' if (present(terminal)) then - write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) + write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) if (present(filename)) then - write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' + write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' else - write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' + write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' end if else write ( file_unit, '(a)' ) 'set terminal ' // trim(default_terminal) // ' ' & - & //trim(my_persist) // ' title "Gnuplot"' + & //trim(my_persist) // ' title "Gnuplot"' end if !*********************************************************************************** write ( file_unit, '(a)' ) 'unset key' @@ -1167,37 +1167,37 @@ subroutine plot_4(x1,y1,x2,y2,x3,y3,x4,y4,style,pause,color1,color2,color3,color if (present(style)) then write ( file_unit, '(a,i2,a)' ) 'plot "' // trim (data_file_name) & &//'" using 1:2 with ' // trim(my_line_type1) // ' pointtype ' // & - & style(1:2) // ' linecolor rgb ' // trim(my_color1) // ' linewidth '// trim(my_linewidth) // ',\' + & style(1:2) // ' linecolor rgb ' // trim(my_color1) // ' linewidth '// trim(my_linewidth) // ',\' write ( file_unit, '(a,i2,a)' ) ' "'// trim (data_file_name) & &//'" using 3:4 with ' // trim(my_line_type2) // ' pointtype ' & - &// style(4:5) // ' linecolor rgb ' // trim(my_color2) // ' linewidth '// trim(my_linewidth) //',\' + &// style(4:5) // ' linecolor rgb ' // trim(my_color2) // ' linewidth '// trim(my_linewidth) //',\' write ( file_unit, '(a,i2,a)' ) ' "'// trim (data_file_name) & &//'" using 5:6 with ' // trim(my_line_type3) // ' pointtype ' & - &// style(7:8) // ' linecolor rgb ' // trim(my_color3) // ' linewidth '// trim(my_linewidth) // ',\' + &// style(7:8) // ' linecolor rgb ' // trim(my_color3) // ' linewidth '// trim(my_linewidth) // ',\' write ( file_unit, '(a,i2,a)' ) ' "'// trim (data_file_name) & &//'" using 7:8 with ' // trim(my_line_type4) // ' pointtype ' & - &// style(10:11) // ' linecolor rgb '// trim(my_color4)// ' linewidth '// trim(my_linewidth) - else + &// style(10:11) // ' linecolor rgb '// trim(my_color4)// ' linewidth '// trim(my_linewidth) + else write ( file_unit, '(a,i2,a)' ) 'plot "' // trim (data_file_name) & & //'" using 1:2 with ' // trim(my_line_type1) // ' linecolor rgb '& - & // trim(my_color1) // ' linewidth '// trim(my_linewidth) // ',\' + & // trim(my_color1) // ' linewidth '// trim(my_linewidth) // ',\' write ( file_unit, '(a,i2,a)' ) ' "'// trim (data_file_name) & & //'" using 3:4 with ' // trim(my_line_type2) // ' linecolor rgb '& - & // trim(my_color2) // ' linewidth '// trim(my_linewidth) // ',\' + & // trim(my_color2) // ' linewidth '// trim(my_linewidth) // ',\' write ( file_unit, '(a,i2,a)' ) ' "'// trim (data_file_name) & & //'" using 5:6 with ' // trim(my_line_type3) // ' linecolor rgb '& - & // trim(my_color3) // ' linewidth '// trim(my_linewidth) // ',\' + & // trim(my_color3) // ' linewidth '// trim(my_linewidth) // ',\' write ( file_unit, '(a,i2,a)' ) ' "'// trim (data_file_name) & & //'" using 7:8 with ' // trim(my_line_type4) // ' linecolor rgb '& - & // trim(my_color4) // ' linewidth '// trim(my_linewidth) + & // trim(my_color4) // ' linewidth '// trim(my_linewidth) end if !*********************************************************************************** if (present(pause)) then if (pause<0.0) then write ( file_unit, '(a)' ) 'pause -1 "press RETURN to continue"' - else + else write ( my_pause,'(e9.3)') pause - write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) + write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) end if else write ( file_unit, '(a)' ) 'pause 0' @@ -1228,7 +1228,7 @@ subroutine plot_3(x1,y1,x2,y2,x3,y3,style,pause,color1,color2,color3,terminal,fi !*********************************************************************************** if (present(input)) then data_file_name='data_file_'//input//'.txt' - command_file_name='command_file_'//input//'.txt' + command_file_name='command_file_'//input//'.txt' else data_file_name='data_file.txt' command_file_name='command_file.txt' @@ -1246,28 +1246,28 @@ subroutine plot_3(x1,y1,x2,y2,x3,y3,style,pause,color1,color2,color3,terminal,fi stop end if !*********************************************************************************** - ierror=0 - call get_unit(file_unit) + ierror=0 + call get_unit(file_unit) if (file_unit==0) then ierror=1 print *,'write_vector_data - fatal error! Could not get a free FORTRAN unit.' stop end if - open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) + open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) if (ios/=0) then ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal data file.' stop end if -!*********************************************************************************** +!*********************************************************************************** ! here we write the date to the data_file - the gnuplot will read this data later !*********************************************************************************** - Nmax=max(Nx1,Nx2,Nx3) + Nmax=max(Nx1,Nx2,Nx3) do i=1,Nmax write (file_unit,'(6E15.7)') x1(min(i,Nx1)), y1(min(i,Nx1)), x2(min(i,Nx2)), y2(min(i,Nx2)), & & x3(min(i,Nx3)), y3(min(i,Nx3)) end do -!*********************************************************************************** +!*********************************************************************************** close (unit=file_unit) !*********************************************************************************** ierror = 0 @@ -1282,7 +1282,7 @@ subroutine plot_3(x1,y1,x2,y2,x3,y3,style,pause,color1,color2,color3,terminal,fi ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal command file.' stop - end if + end if !*********************************************************************************** ! here we write the commands to the commands file which gnuplot will execute !*********************************************************************************** @@ -1314,7 +1314,7 @@ subroutine plot_3(x1,y1,x2,y2,x3,y3,style,pause,color1,color2,color3,terminal,fi write ( my_linewidth,'(e9.3)') linewidth else my_linewidth=trim(default_linewidth) - end if + end if if (present(color1)) then my_color1='"'//trim(color1)//'"' else @@ -1334,15 +1334,15 @@ subroutine plot_3(x1,y1,x2,y2,x3,y3,style,pause,color1,color2,color3,terminal,fi my_persist='persist ' if (present(persist).and.(persist=='no')) my_persist=' ' if (present(terminal)) then - write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) + write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) if (present(filename)) then - write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' + write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' else - write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' + write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' end if else - write ( file_unit, '(a)' ) 'set terminal ' // trim(default_terminal) // ' ' & - &//trim(my_persist) // ' title "Gnuplot"' + write ( file_unit, '(a)' ) 'set terminal ' // trim(default_terminal) // ' ' & + &//trim(my_persist) // ' title "Gnuplot"' end if !*********************************************************************************** @@ -1356,36 +1356,36 @@ subroutine plot_3(x1,y1,x2,y2,x3,y3,style,pause,color1,color2,color3,terminal,fi write ( file_unit, '(a)' ) 'set grid polar' else write ( file_unit, '(a)' ) 'set grid' - end if + end if !*********************************************************************************** if (present(style)) then write ( file_unit, '(a,i2,a)' ) 'plot "' // trim (data_file_name) & &//'" using 1:2 with ' // trim(my_line_type1) // ' pointtype ' // & - & style(1:2) // ' linecolor rgb ' // trim(my_color1) // ' linewidth '// trim(my_linewidth) // ',\' + & style(1:2) // ' linecolor rgb ' // trim(my_color1) // ' linewidth '// trim(my_linewidth) // ',\' write ( file_unit, '(a,i2,a)' ) ' "'// trim (data_file_name) & &//'" using 3:4 with ' // trim(my_line_type2) // ' pointtype ' & - &// style(4:5) // ' linecolor rgb ' // trim(my_color2) // ' linewidth '// trim(my_linewidth) //',\' + &// style(4:5) // ' linecolor rgb ' // trim(my_color2) // ' linewidth '// trim(my_linewidth) //',\' write ( file_unit, '(a,i2,a)' ) ' "'// trim (data_file_name) & &//'" using 5:6 with ' // trim(my_line_type3) // ' pointtype ' & - &// style(7:8) // ' linecolor rgb ' // trim(my_color3) // ' linewidth '// trim(my_linewidth) - else + &// style(7:8) // ' linecolor rgb ' // trim(my_color3) // ' linewidth '// trim(my_linewidth) + else write ( file_unit, '(a,i2,a)' ) 'plot "' // trim (data_file_name) & & //'" using 1:2 with ' // trim(my_line_type1) // ' linecolor rgb '& - & // trim(my_color1) // ' linewidth '// trim(my_linewidth) // ',\' + & // trim(my_color1) // ' linewidth '// trim(my_linewidth) // ',\' write ( file_unit, '(a,i2,a)' ) ' "'// trim (data_file_name) & & //'" using 3:4 with ' // trim(my_line_type2) // ' linecolor rgb '& - & // trim(my_color2) // ' linewidth '// trim(my_linewidth) // ',\' + & // trim(my_color2) // ' linewidth '// trim(my_linewidth) // ',\' write ( file_unit, '(a,i2,a)' ) ' "'// trim (data_file_name) & & //'" using 5:6 with ' // trim(my_line_type3) // ' linecolor rgb '& - & // trim(my_color3) // ' linewidth '// trim(my_linewidth) + & // trim(my_color3) // ' linewidth '// trim(my_linewidth) end if !*********************************************************************************** if (present(pause)) then if (pause<0.0) then write ( file_unit, '(a)' ) 'pause -1 "press RETURN to continue"' - else + else write ( my_pause,'(e9.3)') pause - write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) + write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) end if else write ( file_unit, '(a)' ) 'pause 0' @@ -1415,7 +1415,7 @@ subroutine plot_2(x1,y1,x2,y2,style,pause,color1,color2,terminal,filename,polar, !*********************************************************************************** if (present(input)) then data_file_name='data_file_'//input//'.txt' - command_file_name='command_file_'//input//'.txt' + command_file_name='command_file_'//input//'.txt' else data_file_name='data_file.txt' command_file_name='command_file.txt' @@ -1432,27 +1432,27 @@ subroutine plot_2(x1,y1,x2,y2,style,pause,color1,color2,terminal,filename,polar, stop end if !*********************************************************************************** - ierror=0 - call get_unit(file_unit) + ierror=0 + call get_unit(file_unit) if (file_unit==0) then ierror=1 print *,'write_vector_data - fatal error! Could not get a free FORTRAN unit.' stop end if - open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) + open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) if (ios/=0) then ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal data file.' stop end if -!*********************************************************************************** +!*********************************************************************************** ! here we write the date to the data_file - the gnuplot will read this data later !*********************************************************************************** - Nmax=max(Nx1,Nx2) + Nmax=max(Nx1,Nx2) do i=1,Nmax write (file_unit,'(4E15.7)') x1(min(i,Nx1)), y1(min(i,Nx1)), x2(min(i,Nx2)), y2(min(i,Nx2)) end do -!*********************************************************************************** +!*********************************************************************************** close (unit=file_unit) !*********************************************************************************** ierror = 0 @@ -1467,7 +1467,7 @@ subroutine plot_2(x1,y1,x2,y2,style,pause,color1,color2,terminal,filename,polar, ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal command file.' stop - end if + end if !*********************************************************************************** ! here we write the commands to the commands file which gnuplot will execute !*********************************************************************************** @@ -1491,7 +1491,7 @@ subroutine plot_2(x1,y1,x2,y2,style,pause,color1,color2,terminal,filename,polar, write ( my_linewidth,'(e9.3)') linewidth else my_linewidth=trim(default_linewidth) - end if + end if if (present(color1)) then my_color1='"'//trim(color1)//'"' else @@ -1506,15 +1506,15 @@ subroutine plot_2(x1,y1,x2,y2,style,pause,color1,color2,terminal,filename,polar, my_persist='persist ' if (present(persist).and.(persist=='no')) my_persist=' ' if (present(terminal)) then - write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) + write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) if (present(filename)) then - write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' + write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' else - write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' + write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' end if else write ( file_unit, '(a)' ) 'set terminal ' // trim(default_terminal) // ' ' & - & //trim(my_persist) // ' title "Gnuplot"' + & //trim(my_persist) // ' title "Gnuplot"' end if !*********************************************************************************** @@ -1529,30 +1529,30 @@ subroutine plot_2(x1,y1,x2,y2,style,pause,color1,color2,terminal,filename,polar, write ( file_unit, '(a)' ) 'set grid polar' else write ( file_unit, '(a)' ) 'set grid' - end if + end if !*********************************************************************************** if (present(style)) then write ( file_unit, '(a,i2,a)' ) 'plot "' // trim (data_file_name) & &//'" using 1:2 with ' // trim(my_line_type1) // ' pointtype ' // & - & style(1:2) // ' linecolor rgb ' // trim(my_color1) // ' linewidth '// trim(my_linewidth) // ',\' + & style(1:2) // ' linecolor rgb ' // trim(my_color1) // ' linewidth '// trim(my_linewidth) // ',\' write ( file_unit, '(a,i2,a)' ) ' "'// trim (data_file_name) & &//'" using 3:4 with ' // trim(my_line_type2) // ' pointtype ' & - &// style(4:5) // ' linecolor rgb ' // trim(my_color2) // ' linewidth '// trim(my_linewidth) - else + &// style(4:5) // ' linecolor rgb ' // trim(my_color2) // ' linewidth '// trim(my_linewidth) + else write ( file_unit, '(a,i2,a)' ) 'plot "' // trim (data_file_name) & & //'" using 1:2 with ' // trim(my_line_type1) // ' linecolor rgb '& - & // trim(my_color1) // ' linewidth '// trim(my_linewidth) // ',\' + & // trim(my_color1) // ' linewidth '// trim(my_linewidth) // ',\' write ( file_unit, '(a,i2,a)' ) ' "'// trim (data_file_name) & & //'" using 3:4 with ' // trim(my_line_type2) // ' linecolor rgb '& - & // trim(my_color2) // ' linewidth '// trim(my_linewidth) + & // trim(my_color2) // ' linewidth '// trim(my_linewidth) end if !*********************************************************************************** if (present(pause)) then if (pause<0.0) then write ( file_unit, '(a)' ) 'pause -1 "press RETURN to continue"' - else + else write ( my_pause,'(e9.3)') pause - write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) + write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) end if else write ( file_unit, '(a)' ) 'pause 0' @@ -1582,7 +1582,7 @@ subroutine plot_1(x1,y1,style,pause,color1,terminal,filename,polar,persist,input !*********************************************************************************** if (present(input)) then data_file_name='data_file_'//input//'.txt' - command_file_name='command_file_'//input//'.txt' + command_file_name='command_file_'//input//'.txt' else data_file_name='data_file.txt' command_file_name='command_file.txt' @@ -1598,26 +1598,26 @@ subroutine plot_1(x1,y1,style,pause,color1,terminal,filename,polar,persist,input stop end if !*********************************************************************************** - ierror=0 - call get_unit(file_unit) + ierror=0 + call get_unit(file_unit) if (file_unit==0) then ierror=1 print *,'write_vector_data - fatal error! Could not get a free FORTRAN unit.' stop end if - open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) + open (unit=file_unit, file=data_file_name, status='replace', iostat=ios) if (ios/=0) then ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal data file.' stop end if -!*********************************************************************************** +!*********************************************************************************** ! here we write the date to the data_file - the gnuplot will read this data later -!*********************************************************************************** +!*********************************************************************************** do i=1,Nx1 write (file_unit,'(2E15.7)') x1(i), y1(i) end do -!*********************************************************************************** +!*********************************************************************************** close (unit=file_unit) !*********************************************************************************** ierror = 0 @@ -1632,7 +1632,7 @@ subroutine plot_1(x1,y1,style,pause,color1,terminal,filename,polar,persist,input ierror=2 print *,'write_vector_data - fatal error! Could not open the terminal command file.' stop - end if + end if !*********************************************************************************** ! here we write the commands to the commands file which gnuplot will execute !*********************************************************************************** @@ -1648,7 +1648,7 @@ subroutine plot_1(x1,y1,style,pause,color1,terminal,filename,polar,persist,input write ( my_linewidth,'(e9.3)') linewidth else my_linewidth=trim(default_linewidth) - end if + end if if (present(color1)) then my_color1='"'//trim(color1)//'"' else @@ -1658,15 +1658,15 @@ subroutine plot_1(x1,y1,style,pause,color1,terminal,filename,polar,persist,input my_persist='persist ' if (present(persist).and.(persist=='no')) my_persist=' ' if (present(terminal)) then - write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) + write ( file_unit, '(a)' ) 'set terminal '// trim(output_terminal(terminal)) if (present(filename)) then - write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' + write ( file_unit, '(a)' ) 'set output "'// trim(filename) //'"' else - write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' + write ( file_unit, '(a)' ) 'set output "'//my_date_and_time()//'"' end if else write ( file_unit, '(a)' ) 'set terminal ' // trim(default_terminal) // ' ' & - & //trim(my_persist) //' title "Gnuplot"' + & //trim(my_persist) //' title "Gnuplot"' end if !*********************************************************************************** write ( file_unit, '(a)' ) 'unset key' @@ -1679,24 +1679,24 @@ subroutine plot_1(x1,y1,style,pause,color1,terminal,filename,polar,persist,input write ( file_unit, '(a)' ) 'set grid polar' else write ( file_unit, '(a)' ) 'set grid' - end if + end if !*********************************************************************************** if (present(style)) then write ( file_unit, '(a,i2,a)' ) 'plot "' // trim (data_file_name) & &//'" using 1:2 with ' // trim(my_line_type1) // ' pointtype ' // & - & style(1:2) // ' linecolor rgb ' // trim(my_color1) // ' linewidth '// trim(my_linewidth) - else + & style(1:2) // ' linecolor rgb ' // trim(my_color1) // ' linewidth '// trim(my_linewidth) + else write ( file_unit, '(a,i2,a)' ) 'plot "' // trim (data_file_name) & & //'" using 1:2 with ' // trim(my_line_type1) // ' linecolor rgb '& - & // trim(my_color1) // ' linewidth '// trim(my_linewidth) + & // trim(my_color1) // ' linewidth '// trim(my_linewidth) end if !*********************************************************************************** if (present(pause)) then if (pause<0.0) then write ( file_unit, '(a)' ) 'pause -1 "press RETURN to continue"' - else + else write ( my_pause,'(e9.3)') pause - write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) + write ( file_unit, '(a)' ) 'pause ' // trim(my_pause) end if else write ( file_unit, '(a)' ) 'pause 0' @@ -1705,7 +1705,7 @@ subroutine plot_1(x1,y1,style,pause,color1,terminal,filename,polar,persist,input write ( file_unit, '(a)' ) 'q' close ( unit = file_unit ) !*********************************************************************************** - call run_gnuplot (command_file_name) + call run_gnuplot (command_file_name) !*********************************************************************************** end subroutine plot_1 !*********************************************************************************** @@ -1722,12 +1722,12 @@ subroutine run_gnuplot(command_file_name) ! Issue a command to the system that will startup GNUPLOT, using ! the file we just wrote as input. !*********************************************************************************** - write (command, *) 'gnuplot ' // trim (command_file_name) - status=system(trim(command)) + write (command, *) 'gnuplot ' // trim (command_file_name) + status=system(trim(command)) if (status.ne.0) then print *,'RUN_GNUPLOT - Fatal error!' stop - end if + end if return !*********************************************************************************** end subroutine run_gnuplot @@ -1741,10 +1741,10 @@ subroutine get_unit(iunit) integer ios integer iunit logical lopen -!*********************************************************************************** +!*********************************************************************************** iunit=0 do i=1,99 - if (i/= 5 .and. i/=6) then + if (i/= 5 .and. i/=6) then inquire (unit=i, opened=lopen, iostat=ios) if (ios==0) then if (.not.lopen) then @@ -1752,9 +1752,9 @@ subroutine get_unit(iunit) return end if end if - + end if - end do + end do return end subroutine get_unit !*********************************************************************************** diff --git a/stella/src/util/nag_sub.F90 b/stella/src/util/nag_sub.F90 index 257de791a..8354f59f9 100644 --- a/stella/src/util/nag_sub.F90 +++ b/stella/src/util/nag_sub.F90 @@ -20,12 +20,7 @@ module nag_sub implicit none private - - character(len=*), parameter, private :: mdl_name = 'lnag_sub' - - public :: nag_d01gaf - -contains + character(len=*), parameter, private :: mdl_name = 'lnag_sub' public :: nag_d01gaf contains !!****** !! @@ -45,19 +40,14 @@ module nag_sub !! see SUBROUTINE D01GAF in NAG !! !! OUTPUT -!! - -!! SOURCE +!! -!! SOURCE !! !!*** ********************************************************************** subroutine nag_d01gaf (X,y,N,ans,err) - real (kind=dp), dimension(:), intent(in) :: X - real (kind=dp), dimension(:), intent(in) :: y - integer, intent(in) :: N - real (kind=dp), intent(out) :: ans, err + real (kind=dp), dimension(:), intent(in) :: X real (kind=dp), dimension(:), intent(in) :: y integer, intent(in) :: N real (kind=dp), intent(out) :: ans, err character(len=*), parameter :: subrtn_name = 'd01gaf' & , fullPathSubrtn = mdl_name//'.'//subrtn_name integer :: ifail - call d01gaf(X,y,N,ans,err,ifail) if(ifail > 0) then diff --git a/turb/private/mlt.f90 b/turb/private/mlt.f90 index 7c22f183c..9a3381623 100644 --- a/turb/private/mlt.f90 +++ b/turb/private/mlt.f90 @@ -76,7 +76,7 @@ subroutine calc_MLT(MLT_option, mixing_length_alpha, Henyey_MLT_nu_param, Henyey Q, omega, a0, ff4_omega2_plus_1, A_1, A_2, & A_numerator, A_denom, A, Bcubed, delta, Zeta, & f, f0, f1, f2, radiative_conductivity, convective_conductivity - include 'formats' + include 'formats' if (gradr > gradL) then ! Convection zone @@ -92,12 +92,12 @@ subroutine calc_MLT(MLT_option, mixing_length_alpha, Henyey_MLT_nu_param, Henyey select case(trim(MLT_option)) case ('Henyey') ff1=1.0d0/Henyey_MLT_nu_param - ff2=0.5d0 + ff2=0.5d0 ff3=8.0d0/Henyey_MLT_y_param ff4=1.0d0/Henyey_MLT_y_param case ('ML1') - ff1=0.125d0 - ff2=0.5d0 + ff1=0.125d0 + ff2=0.5d0 ff3=24.0d0 ff4=0.0d0 case ('ML2') @@ -106,8 +106,8 @@ subroutine calc_MLT(MLT_option, mixing_length_alpha, Henyey_MLT_nu_param, Henyey ff3=16.0d0 ff4=0.0d0 case ('Mihalas') - ff1=0.125d0 - ff2=0.5d0 + ff1=0.125d0 + ff2=0.5d0 ff3=16.0d0 ff4=2.0d0 case default @@ -122,16 +122,16 @@ subroutine calc_MLT(MLT_option, mixing_length_alpha, Henyey_MLT_nu_param, Henyey A_2 = mixing_length_alpha*omega*ff4_omega2_plus_1 A_numerator = A_1*A_2 A_denom = ff3*crad*clight*pow3(T) - A = A_numerator/A_denom - end if + A = A_numerator/A_denom + end if ! 'B' param C&G 14.81 - Bcubed = (pow2(A)/a0)*(gradr - gradL) + Bcubed = (pow2(A)/a0)*(gradr - gradL) ! now solve cubic equation for convective efficiency, Gamma ! a0*Gamma^3 + Gamma^2 + Gamma - a0*Bcubed == 0 C&G 14.82, - ! leave it to Mathematica to find an expression for the root we want - delta = a0*Bcubed + ! leave it to Mathematica to find an expression for the root we want + delta = a0*Bcubed f = -2d0 + 9d0*a0 + 27d0*a0*a0*delta if (f > 1d100) then f0 = f @@ -140,13 +140,13 @@ subroutine calc_MLT(MLT_option, mixing_length_alpha, Henyey_MLT_nu_param, Henyey if (f0 <= 0d0) then f0 = f else - f0 = sqrt(f0) + f0 = sqrt(f0) end if end if - f1 = -2d0 + 9d0*a0 + 27d0*a0*a0*delta + f0 + f1 = -2d0 + 9d0*a0 + 27d0*a0*a0*delta + f0 if (f1 <= 0d0) return - f1 = pow(f1,one_third) - f2 = 2d0*two_13*(1d0 - 3d0*a0) / f1 + f1 = pow(f1,one_third) + f2 = 2d0*two_13*(1d0 - 3d0*a0) / f1 Gamma = (four_13*f1 + f2 - 2d0) / (6d0*a0) if (Gamma <= 0d0) return @@ -172,15 +172,15 @@ subroutine calc_MLT(MLT_option, mixing_length_alpha, Henyey_MLT_nu_param, Henyey if (is_bad(Zeta%val)) return if (Zeta > 1d0) then Zeta = 1d0 - end if - - gradT = (1d0 - Zeta)*gradr + Zeta*gradL ! C&G 14.79 + end if + + gradT = (1d0 - Zeta)*gradr + Zeta*gradL ! C&G 14.79 Y_face = gradT - gradL - + if (Y_face > 0d0) then mixing_type = convective_mixing end if - end subroutine calc_MLT + end subroutine calc_MLT end module MLT diff --git a/turb/private/semiconvection.f90 b/turb/private/semiconvection.f90 index a6928f4a8..f2d5911ac 100644 --- a/turb/private/semiconvection.f90 +++ b/turb/private/semiconvection.f90 @@ -75,7 +75,7 @@ subroutine calc_semiconvection(L, Lambda, m, T, P, Pr, beta, opacity, rho, alpha type(auto_diff_real_star_order1) :: bc, LG, & radiative_conductivity, a0, a1, a2, a3, a4, a5, a6, a, & - b1, b2, b3, b4, b5, b6, b7, b, div, bsq + b1, b2, b3, b4, b5, b6, b7, b, div, bsq real(dp) :: alpha include 'formats' @@ -84,8 +84,8 @@ subroutine calc_semiconvection(L, Lambda, m, T, P, Pr, beta, opacity, rho, alpha (4d0/3d0*crad*clight)*pow3(T)/(opacity*rho) ! erg / (K cm sec) D = alpha_semiconvection*radiative_conductivity/(6d0*Cp*rho) & *(gradr - grada)/(gradL - gradr) - if (D%val <= 0) return - conv_vel = 3d0*D/Lambda + if (D%val <= 0) return + conv_vel = 3d0*D/Lambda if (semiconvection_option == 'Langer_85 mixing; gradT = gradr') then gradT = gradr @@ -94,36 +94,36 @@ subroutine calc_semiconvection(L, Lambda, m, T, P, Pr, beta, opacity, rho, alpha return else if (semiconvection_option == 'Langer_85') then ! Solve[{ - ! L/Lrad - Lsc/Lrad - 1 == 0, - ! Lrad == grad LG, + ! L/Lrad - Lsc/Lrad - 1 == 0, + ! Lrad == grad LG, ! gradMu == (4 - 3*beta)/beta*gradL_composition_term, ! Lsc/Lrad == alpha (grad - gradA)/(2 grad (gradL - grad)) - ! (grad - gradA - (beta (8 - 3 beta))/bc gradMu)}, + ! (grad - gradA - (beta (8 - 3 beta))/bc gradMu)}, ! grad, {Lsc, Lrad, gradMu}] // Simplify alpha = min(1d0, alpha_semiconvection) - bc = 32d0 - 24d0*beta - beta*beta - LG = (16d0*pi*clight*m*cgrav*Pr)/(P*opacity) - a0 = alpha*gradL_composition_term*LG - a1 = -2d0*bc*L - a2 = 2d0*alpha*bc*grada*LG - a3 = -2d0*bc*gradL*LG - a4 = 32d0*a0 - a5 = -36d0*beta*a0 - a6 = 9d0*beta*beta*a0 - a = a1 + a2 + a3 + a4 + a5 + a6 - b1 = 32d0 - 36d0*beta + 9d0*beta*beta - b2 = b1*a0 - b3 = -2d0*gradL*L + alpha*grada*grada*LG - b4 = (-alpha*gradA + gradL)*LG - b5 = -b2 + 2d0*bc*(L + b4) - b6 = b2*grada + bc*b3 - b7 = -4d0*(alpha - 2d0)*bc*LG*b6 - b = b7 + b5*b5 + bc = 32d0 - 24d0*beta - beta*beta + LG = (16d0*pi*clight*m*cgrav*Pr)/(P*opacity) + a0 = alpha*gradL_composition_term*LG + a1 = -2d0*bc*L + a2 = 2d0*alpha*bc*grada*LG + a3 = -2d0*bc*gradL*LG + a4 = 32d0*a0 + a5 = -36d0*beta*a0 + a6 = 9d0*beta*beta*a0 + a = a1 + a2 + a3 + a4 + a5 + a6 + b1 = 32d0 - 36d0*beta + 9d0*beta*beta + b2 = b1*a0 + b3 = -2d0*gradL*L + alpha*grada*grada*LG + b4 = (-alpha*gradA + gradL)*LG + b5 = -b2 + 2d0*bc*(L + b4) + b6 = b2*grada + bc*b3 + b7 = -4d0*(alpha - 2d0)*bc*LG*b6 + b = b7 + b5*b5 div = 2d0*(alpha - 2d0)*bc*LG bsq = sqrt(b) gradT = (a + bsq)/div Y_face = gradT - grada - conv_vel = 3d0*D/Lambda + conv_vel = 3d0*D/Lambda mixing_type = semiconvective_mixing else write(*,*) 'turb: unknown values for semiconvection_option ' // & diff --git a/turb/private/tdc.f90 b/turb/private/tdc.f90 index f91ec10da..1a8dbf824 100644 --- a/turb/private/tdc.f90 +++ b/turb/private/tdc.f90 @@ -60,7 +60,7 @@ subroutine get_TDC_solution(info, scale, Zlb, Zub, conv_vel, Y_face, tdc_num_ite type(auto_diff_real_tdc), intent(in) :: Zlb, Zub type(auto_diff_real_star_order1),intent(out) :: conv_vel, Y_face integer, intent(out) :: tdc_num_iters, ierr - + logical :: Y_is_positive type(auto_diff_real_tdc) :: Af, Y, Y0, Y1, Z0, Z1, radY type(auto_diff_real_tdc) :: Q, Q0 @@ -71,7 +71,7 @@ subroutine get_TDC_solution(info, scale, Zlb, Zub, conv_vel, Y_face, tdc_num_ite ierr = 0 if (info%mixing_length_alpha == 0d0 .or. info%dt <= 0d0) then call mesa_error(__FILE__,__LINE__,'bad call to TDC get_TDC_solution') - end if + end if ! Determine the sign of the solution. ! @@ -165,7 +165,7 @@ subroutine get_TDC_solution(info, scale, Zlb, Zub, conv_vel, Y_face, tdc_num_ite ! ierr /= 0 should be impossible, because we checked the necessary conditions ! for the bisection search above. Nonetheless, bugs can crop up, so we leave this ! check in here and leave the checks in Af_bisection_search. - if (ierr /= 0) return + if (ierr /= 0) return Y0 = set_Y(.false., Z0) call compute_Q(info, Y0, Q, Af) if (info%report) write(*,*) 'Bisected Af. Y0=',Y0%val,'Af(Y0)=',Af%val @@ -218,7 +218,7 @@ subroutine get_TDC_solution(info, scale, Zlb, Zub, conv_vel, Y_face, tdc_num_ite ! Process Y into the various outputs. call compute_Q(info, Y, Q, Af) Y_face = unconvert(Y) - conv_vel = sqrt_2_div_3*unconvert(Af) + conv_vel = sqrt_2_div_3*unconvert(Af) end subroutine get_TDC_solution @@ -243,7 +243,7 @@ subroutine bracket_plus_Newton_search(info, scale, Y_is_positive, Zlb, Zub, Y_fa type(auto_diff_real_tdc), intent(out) :: Af integer, intent(out) :: tdc_num_iters integer, intent(out) :: ierr - + type(auto_diff_real_tdc) :: Y, Z, Q, Qc, Z_new, correction, lower_bound_Z, upper_bound_Z type(auto_diff_real_tdc) :: dQdZ integer :: iter, line_iter @@ -382,7 +382,7 @@ subroutine bracket_plus_Newton_search(info, scale, Y_is_positive, Zlb, Zub, Y_fa ! Unpack output Y_face = unconvert(Y) - tdc_num_iters = iter + tdc_num_iters = iter end subroutine bracket_plus_Newton_search end module tdc diff --git a/turb/private/tdc_support.f90 b/turb/private/tdc_support.f90 index efce8837f..0f3692b40 100644 --- a/turb/private/tdc_support.f90 +++ b/turb/private/tdc_support.f90 @@ -91,7 +91,7 @@ end function set_Y !! The search continues until the domain is narrowed to less than a width of bracket_tolerance, !! or until more than max_iter iterations have been taken. Because this is just used to get us in !! the right ballpark, bracket_tolerance is set quite wide, to 1. - !! + !! !! There is a check at the start to verify that Q takes on opposite signs on either end of the !! domain. This is allows us to bail early if there is no root in the domain. !! @@ -188,7 +188,7 @@ end subroutine Q_bisection_search !! !! The search continues until the domain is narrowed to less than a width of bracket_tolerance (1d-4), !! or until more than max_iter iterations have been taken. - !! + !! !! There is a check at the start to verify that dQ/dZ takes on opposite signs on either end of the !! domain. This is allows us to bail early if there is no root in the domain. !! @@ -296,7 +296,7 @@ subroutine dQdZ_bisection_search(info, lower_bound_Z_in, upper_bound_Z_in, Z, ha if (upper_bound_Z - lower_bound_Z < bracket_tolerance) then Z = (upper_bound_Z + lower_bound_Z) / 2d0 call compute_Q(info, Y, Q, Af) - return + return end if end do @@ -313,7 +313,7 @@ end subroutine dQdZ_bisection_search !! !! The search continues until the domain is narrowed to less than a width of bracket_tolerance (1d-4), !! or until more than max_iter iterations have been taken. - !! + !! !! There is a check at the start to verify that Af == 0 at the most-negative end of the domain. !! This is allows us to bail early if there is no root in the domain. !! @@ -437,7 +437,7 @@ end function convert !! no longer needed. This allows the output of the TDC solver to be passed back to the star solver. !! !! @param K_in, input, an auto_diff_real_tdc variable - !! @param K, output, an auto_diff_real_star_order1 variable. + !! @param K, output, an auto_diff_real_star_order1 variable. type(auto_diff_real_star_order1) function unconvert(K_in) result(K) type(auto_diff_real_tdc), intent(in) :: K_in K%val = K_in%val @@ -474,7 +474,7 @@ subroutine compute_Q(info, Y, Q, Af) end if ! Y_env sets the acceleration of blobs. - call eval_xis(info, Y_env, xi0, xi1, xi2) + call eval_xis(info, Y_env, xi0, xi1, xi2) Af = eval_Af(info%dt, info%A0, xi0, xi1, xi2) ! Y_env sets the convective flux but not the radiative flux. @@ -507,7 +507,7 @@ end subroutine compute_Q !! @param xi0 Output, the constant term in the convective velocity equation. !! @param xi1 Output, the prefactor of the linear term in the convective velocity equation. !! @param xi2 Output, the prefactor of the quadratic term in the convective velocity equation. - subroutine eval_xis(info, Y, xi0, xi1, xi2) + subroutine eval_xis(info, Y, xi0, xi1, xi2) ! eval_xis sets up Y with partial wrt Z ! so results come back with partials wrt Z type(tdc_info), intent(in) :: info @@ -542,7 +542,7 @@ end subroutine eval_xis !! The xi0/1/2 variables are constants for purposes of solving this equation. !! !! An important related parameter is J: - !! + !! !! J^2 = xi1^2 - 4 * xi0 * xi2 !! !! When J^2 > 0 the solution for w is hyperbolic in time. @@ -559,13 +559,13 @@ end subroutine eval_xis !! @param A0 convection speed from the start of the step (cm/s) !! @param xi0 The constant term in the convective velocity equation. !! @param xi1 The prefactor of the linear term in the convective velocity equation. - !! @param xi2 The prefactor of the quadratic term in the convective velocity equation. + !! @param xi2 The prefactor of the quadratic term in the convective velocity equation. !! @param Af Output, the convection speed at the end of the step (cm/s) function eval_Af(dt, A0, xi0, xi1, xi2) result(Af) - real(dp), intent(in) :: dt + real(dp), intent(in) :: dt type(auto_diff_real_tdc), intent(in) :: A0, xi0, xi1, xi2 type(auto_diff_real_tdc) :: Af ! output - type(auto_diff_real_tdc) :: J2, J, Jt4, num, den, y_for_atan, root + type(auto_diff_real_tdc) :: J2, J, Jt4, num, den, y_for_atan, root J2 = pow2(xi1) - 4d0 * xi0 * xi2 @@ -574,7 +574,7 @@ function eval_Af(dt, A0, xi0, xi1, xi2) result(Af) Jt4 = 0.25d0 * dt * J num = safe_tanh(Jt4) * (2d0 * xi0 + A0 * xi1) + A0 * J den = safe_tanh(Jt4) * (xi1 + 2d0 * A0 * xi2) - J - Af = num / den + Af = num / den if (Af < 0d0) then Af = -Af end if @@ -601,14 +601,14 @@ function eval_Af(dt, A0, xi0, xi1, xi2) result(Af) end if if (Jt4 < root) then - num = -xi1 + J * tan(Jt4 + atan(y_for_atan / J)) + num = -xi1 + J * tan(Jt4 + atan(y_for_atan / J)) den = 2d0 * xi2 Af = num / den else Af = 0d0 end if - else ! if (J2 == 0d0) then - Af = A0 + else ! if (J2 == 0d0) then + Af = A0 end if end function eval_Af diff --git a/turb/private/thermohaline.f90 b/turb/private/thermohaline.f90 index 3aa70ecbb..0862b839c 100644 --- a/turb/private/thermohaline.f90 +++ b/turb/private/thermohaline.f90 @@ -61,12 +61,12 @@ subroutine get_D_thermohaline(thermohaline_option, & real(dp), intent(in) :: & grada, gradr, T, opacity, rho, Cp, gradL_composition_term, XH1, & thermohaline_coeff - integer, intent(in) :: iso + integer, intent(in) :: iso real(dp), intent(out) :: D_thrm integer, intent(out) :: ierr - real(dp) :: dgrad, K_therm, K_T, K_mu, nu, R0, Pr, tau, r_th - include 'formats' - dgrad = max(1d-40, grada - gradr) ! positive since Schwarzschild stable + real(dp) :: dgrad, K_therm, K_T, K_mu, nu, R0, Pr, tau, r_th + include 'formats' + dgrad = max(1d-40, grada - gradr) ! positive since Schwarzschild stable K_therm = 4d0*crad*clight*pow3(T)/(3d0*opacity*rho) ! thermal conductivity if (thermohaline_option == 'Kippenhahn') then ! Kippenhahn, R., Ruschenplatt, G., & Thomas, H.-C. 1980, A&A, 91, 175 @@ -83,7 +83,7 @@ subroutine get_D_thermohaline(thermohaline_option, & else if (Pr < 0d0) then ! Bad results from get_diff_coeffs will just result in NaNs from thermohaline options, so skip D_thrm = 0d0 - else if (thermohaline_option == 'Traxler_Garaud_Stellmach_11') then + else if (thermohaline_option == 'Traxler_Garaud_Stellmach_11') then ! Traxler, Garaud, & Stellmach, ApJ Letters, 728:L29 (2011). ! also see Denissenkov. ApJ 723:563–579, 2010. D_thrm = 101d0*sqrt(K_mu*nu)*exp(-3.6d0*r_th)*pow(1d0 - r_th,1.1d0) ! eqn 24 @@ -102,20 +102,20 @@ end subroutine get_D_thermohaline subroutine get_diff_coeffs(K_therm, Cp, rho, T, opacity, iso, XH1, kt, kmu, vis) use chem_def, only: chem_isos real(dp), intent(in) :: K_therm, Cp, rho, T, opacity, XH1 - integer, intent(in) :: iso + integer, intent(in) :: iso real(dp), intent(out) :: kt, kmu, vis real(dp) :: loglambdah, loglambdacx, loglambdacy, ccx, ccy, qe4 - real(dp) :: Bcoeff, chemA, chemZ, acx, acy, nu_mol, nu_rad - real(dp), parameter :: sqrt5 = sqrt(5d0) + real(dp) :: Bcoeff, chemA, chemZ, acx, acy, nu_mol, nu_rad + real(dp), parameter :: sqrt5 = sqrt(5d0) kt = K_therm/(Cp*rho) ! thermal diffusivity (assumes radiatively dominated) qe4=pow4(qe) ! Log Lambda for pure H (equation 10 from Proffitt Michaud 93) - loglambdah = -19.26d0 - 0.5d0*log(rho) + 1.5d0*log(T) - 0.5d0*log(1d0 + 0.5d0*(1+XH1)) + loglambdah = -19.26d0 - 0.5d0*log(rho) + 1.5d0*log(T) - 0.5d0*log(1d0 + 0.5d0*(1+XH1)) nu_rad = 4d0*crad*pow4(T)/(15d0*clight*opacity*pow2(rho)) ! radiative viscosity - nu_mol = 0.406d0*sqrt(amu)*pow(boltzm*T,2.5d0)/(qe4*loglambdah*rho) + nu_mol = 0.406d0*sqrt(amu)*pow(boltzm*T,2.5d0)/(qe4*loglambdah*rho) ! From Spitzer "Physics of Fully Ionized Gases equation 5-54 - ! Assumes pure H. Still trying to work out what it would be for a mixture. + ! Assumes pure H. Still trying to work out what it would be for a mixture. vis = nu_mol + nu_rad ! total viscosity ! The following is from Proffitt & Michaud, 1993. @@ -128,7 +128,7 @@ subroutine get_diff_coeffs(K_therm, Cp, rho, T, opacity, iso, XH1, kt, kmu, vis) if(chemZ.gt.2) then ! This is if the driving chemical is NOT He. ! Log Lambda for H-dominant chem mixture (equation 10) - loglambdacx = loglambdah - log(chemz) + loglambdacx = loglambdah - log(chemz) ! Log Lambda for He-dominant chem mixture (equation 10) loglambdacy = loglambdah - log(2.d0*chemz) ! Calculation of C_ij coeffs (equation 12) @@ -144,12 +144,12 @@ subroutine get_diff_coeffs(K_therm, Cp, rho, T, opacity, iso, XH1, kt, kmu, vis) else ! Log Lambda for H-He mixture (equation 10) loglambdah = -19.26d0 - log(2d0) - 0.5d0*log(rho) + & - 1.5d0*log(T) - 0.5d0*log(1d0 + 0.5d0*(1+XH1)) + 1.5d0*log(T) - 0.5d0*log(1d0 + 0.5d0*(1+XH1)) ! Calculation of C_ij coeffs (equation 12) ccy = log(exp(1.2d0*loglambdah)+1d0)/1.2d0 ! My formula (see notes) based on Proffitt and Michaud 1993 kmu = (Bcoeff*pow(T,2.5d0)/(rho*ccy))*(3+XH1)/((1+XH1)*(3+5*XH1)*(0.7d0+0.3d0*XH1)) - + endif ! write(57,*) kt,kmu,vis,chemZ @@ -158,7 +158,7 @@ end subroutine get_diff_coeffs real(dp) function numu(R0,r_th,prandtl,diffratio) !Function calculates Nu_mu from input parameters, following Brown et al. 2013. - !Written by P. Garaud (2013). Please email pgaraud@ucsc.edu for troubleshooting. + !Written by P. Garaud (2013). Please email pgaraud@ucsc.edu for troubleshooting. real(dp), intent(in) :: R0,r_th,prandtl,diffratio real(dp) :: maxl2,maxl,lambdamax @@ -167,18 +167,18 @@ real(dp) function numu(R0,r_th,prandtl,diffratio) ! Initialize guess using estimates from Brown et al. 2013 call analytical_estimate_th(maxl,lambdamax,r_th,prandtl,diffratio) - + myvars(1) = maxl myvars(2) = lambdamax !Call Newton relaxation algorithm call NR(myvars,prandtl,diffratio,R0,ierr) - - !If the growth rate is negative, then try another set of parameters as first guess. + + !If the growth rate is negative, then try another set of parameters as first guess. !Repeat as many times as necessary until convergence is obtained. iter = 1 max_iters = 200 - do while(iter<=max_iters .and. ((myvars(2)<0).or.(ierr /= 0))) + do while(iter<=max_iters .and. ((myvars(2)<0).or.(ierr /= 0))) !write(*,*) 'Alternative', r_th,prandtl,diffratio,iter !Reset guess values myvars(1) = maxl @@ -189,9 +189,9 @@ real(dp) function numu(R0,r_th,prandtl,diffratio) if(ierr.eq.0) call NR(myvars,prandtl,diffratio,R0,ierr) !write(*,*) prandtl,diffratio,R0,myvars(1),myvars(2),ierr !Otherwise, increase counter and try again. - iter = iter + 1 + iter = iter + 1 enddo - + if((myvars(2)<0).or.(ierr /= 0)) then write(*,*) "WARNING: thermohaline Newton relaxation failed to converge, falling back to estimate" maxl2 = maxl*maxl @@ -206,7 +206,7 @@ real(dp) function numu(R0,r_th,prandtl,diffratio) numu = 1.d0 + 49.d0*lambdamax*lambdamax/(diffratio*maxl2*(lambdamax+diffratio*maxl2)) return - end function numu + end function numu subroutine thermohaline_rhs(myx,myf,myj,prandtl,diffratio,R0) @@ -215,7 +215,7 @@ subroutine thermohaline_rhs(myx,myf,myj,prandtl,diffratio,R0) ! lambda^3 + a_2 lambda^2 + a_1 lambda + a_0 = 0 (eq. 19 of Brown et al.) ! b_2 lambda^2 + b_1 lambda + b_0 = 0 (eq. 20 of Brown et al.) ! Inputs f, the equations, and j, their jacobian. - ! Written by P. Garaud (2013). Please email pgaraud@ucsc.edu for troubleshooting. + ! Written by P. Garaud (2013). Please email pgaraud@ucsc.edu for troubleshooting. real(dp), intent(in) :: myx(2), prandtl, diffratio, R0 real(dp), intent(out) :: myf(2), myj(2,2) @@ -248,7 +248,7 @@ subroutine thermohaline_rhs(myx,myf,myj,prandtl,diffratio,R0) myj(2,2) = 2*b_2*myx(2) + b_1 return - end subroutine thermohaline_rhs + end subroutine thermohaline_rhs subroutine analytical_estimate_th(maxl,lambdamax,r_th,prandtl,diffratio) @@ -260,13 +260,13 @@ subroutine analytical_estimate_th(maxl,lambdamax,r_th,prandtl,diffratio) if(r_th .lt. 0.5d0) then if(r_th .gt. prandtl) then - maxl = pow((1.d0/(1.d0+phi)) - 2.d0*dsqrt(r_th*phi)/pow(1d0+phi,2.5d0),0.25d0) + maxl = pow((1.d0/(1.d0+phi)) - 2.d0*dsqrt(r_th*phi)/pow(1d0+phi,2.5d0),0.25d0) ! Equation (B14) maxl4 = maxl*maxl*maxl*maxl maxl6 = maxl4*maxl*maxl lambdamax = 2*prandtl*phi*maxl6/(1d0-(1d0+phi)*maxl4) ! Equation (B11) else - maxl = dsqrt(dsqrt(1d0/(1d0+phi)) - dsqrt(prandtl)*(1d0+phi/((1d0+phi)*(1d0+phi)))) + maxl = dsqrt(dsqrt(1d0/(1d0+phi)) - dsqrt(prandtl)*(1d0+phi/((1d0+phi)*(1d0+phi)))) ! Equation (B5) lambdamax = dsqrt(prandtl) - prandtl*dsqrt(1d0+phi) !Equation (B5) endif @@ -288,7 +288,7 @@ end subroutine analytical_estimate_th subroutine NR(xrk,prandtl,diffratio,R0,ierr) ! Newton Relaxation routine used to solve cubic & quadratic in thermohaline case. - ! Written by P. Garaud (2013). Please email pgaraud@ucsc.edu for troubleshooting. + ! Written by P. Garaud (2013). Please email pgaraud@ucsc.edu for troubleshooting. real(dp), parameter :: acy = 1.d-13 ! accuracy of NR solution. integer, parameter :: niter = 20 ! max number of iterations allowed before giving up. @@ -301,7 +301,7 @@ subroutine NR(xrk,prandtl,diffratio,R0,ierr) ldx = n integer :: iter,ierr - real(dp) :: xrk(2), f(2) ! Functions f + real(dp) :: xrk(2), f(2) ! Functions f real(dp) :: j(2,2) ! Jacobian real(dp) :: err,errold ! Error at each iteration real(dp) :: x1_sav,x2_sav @@ -324,12 +324,12 @@ subroutine NR(xrk,prandtl,diffratio,R0,ierr) !While error is too large .and. decreasing, iterate. do while ((err.gt.acy).and.(ierr.eq.0).and.(iter.lt.niter)) - call thermohaline_rhs(xrk,f,j,prandtl,diffratio,R0) - + call thermohaline_rhs(xrk,f,j,prandtl,diffratio,R0) + fact = 'E' trans = 'N' equed = '' - + A = j B(1,1) = f(1) B(2,1) = f(2) @@ -349,19 +349,19 @@ subroutine NR(xrk,prandtl,diffratio,R0,ierr) err = dsqrt(f(1)*f(1)+f(2)*f(2)) ! Calculate the new error ! If, after a while, the error is still not decreasing, give up and exit NR. ! Otherwise, continue. - if((iter.gt.5).and.(err.gt.errold)) then + if((iter.gt.5).and.(err.gt.errold)) then ! Write(*,2) 'Error not decreasing at iter', iter, err, errold ierr = 1 ! Reset xs and exit loop. xrk(1) = x1_sav - xrk(2) = x2_sav + xrk(2) = x2_sav else - xrk = xrk - f ! The solution is now in f, so update x + xrk = xrk - f ! The solution is now in f, so update x errold = err endif endif enddo - + if(err<=acy) then ierr = 0 else diff --git a/turb/public/turb.f90 b/turb/public/turb.f90 index 4c4ab2dff..ab72d9b96 100644 --- a/turb/public/turb.f90 +++ b/turb/public/turb.f90 @@ -50,7 +50,7 @@ subroutine set_thermohaline(thermohaline_option, Lambda, grada, gradr, T, opacit gradT = gradr Y_face = gradT - grada conv_vel = 3d0*D/Lambda - mixing_type = thermohaline_mixing + mixing_type = thermohaline_mixing end subroutine set_thermohaline !> Computes the outputs of time-dependent convection theory following the model specified in diff --git a/utils/private/utils_dict.f90 b/utils/private/utils_dict.f90 index 5078ccada..97c38ef7f 100644 --- a/utils/private/utils_dict.f90 +++ b/utils/private/utils_dict.f90 @@ -25,12 +25,12 @@ module utils_dict use utils_def - - implicit none + + implicit none contains - - + + recursive subroutine do_integer_dict_map(dict, fcn, ierr) type (integer_dict), pointer :: dict interface @@ -51,26 +51,26 @@ end subroutine fcn if (ierr /= 0) return end if call fcn(node% key, node% value, ierr) - if (ierr /= 0) return + if (ierr /= 0) return if (.not. associated(node% right)) return node => node% right end do end subroutine do_integer_dict_map - - + + subroutine do_get_dict_entries(dict, keys, values) type (integer_dict), pointer :: dict character (len=maxlen_key_string), pointer :: keys(:) integer, pointer :: values(:) - + integer :: cnt, ierr, sz sz = size_integer_dict(dict) sz = min(sz, size(keys,dim=1), size(values,dim=1)) cnt = 0 call do_integer_dict_map(dict, fcn, ierr) - + contains - + subroutine fcn(key, value, ierr) character (len=*), intent(in) :: key integer, intent(in) :: value @@ -83,10 +83,10 @@ subroutine fcn(key, value, ierr) keys(cnt) = key values(cnt) = value end subroutine fcn - + end subroutine do_get_dict_entries - - + + recursive subroutine show_key_entries(dict) type (integer_dict), pointer :: dict type (integer_dict), pointer :: node @@ -101,8 +101,8 @@ recursive subroutine show_key_entries(dict) node => node% right end do end subroutine show_key_entries - - + + subroutine find_key_entry(dict, key, node) type (integer_dict), pointer :: dict character (len=*), intent(in) :: key @@ -142,20 +142,20 @@ subroutine find_key_entry(dict, key, node) end if node => node% right end if - end do + end do end subroutine find_key_entry - - + + recursive subroutine insert_node(node, root, duplicate) type (integer_dict), pointer :: node ! will be deallocated if a duplicate type (integer_dict), pointer :: root logical :: duplicate ! true if key was already defined - + integer :: height_left, height_right logical, parameter :: dbg = .false. if (dbg) write(*,*) 'insert ' // trim(node% key) // ' in ' // trim(root% key) - + if (node% key == root% key) then root% value = node% value deallocate(node) @@ -163,7 +163,7 @@ recursive subroutine insert_node(node, root, duplicate) duplicate = .true. return end if - + if (LGT(node% key, root% key)) then ! insert on left if (.not. associated(root% left)) then root% left => node @@ -195,17 +195,17 @@ recursive subroutine insert_node(node, root, duplicate) end if end if end if - + height_right = height_of_right_branch(root) height_left = height_of_left_branch(root) root% height = max(height_right, height_left) + 1 - + if (dbg) write(*,*) 'new root is ' // trim(root% key) - - + + contains - - + + integer function height_of_left_branch(n) type (integer_dict), pointer :: n if (.not. associated(n% left)) then @@ -214,8 +214,8 @@ integer function height_of_left_branch(n) height_of_left_branch = n% left% height end if end function height_of_left_branch - - + + integer function height_of_right_branch(n) type (integer_dict), pointer :: n if (.not. associated(n% right)) then @@ -224,8 +224,8 @@ integer function height_of_right_branch(n) height_of_right_branch = n% right% height end if end function height_of_right_branch - - + + subroutine single_rotate_with_left(k2) type (integer_dict), pointer :: k2 type (integer_dict), pointer :: k1 @@ -240,8 +240,8 @@ subroutine single_rotate_with_left(k2) k1% height = max(height_of_left_branch(k1), k2% height) + 1 k2 => k1 end subroutine single_rotate_with_left - - + + subroutine single_rotate_with_right(k1) type (integer_dict), pointer :: k1 type (integer_dict), pointer :: k2 @@ -256,25 +256,25 @@ subroutine single_rotate_with_right(k1) k2% height = max(height_of_right_branch(k2), k1% height) + 1 k1 => k2 end subroutine single_rotate_with_right - - + + subroutine double_rotate_with_left(k) type (integer_dict), pointer :: k call single_rotate_with_right(k% left) call single_rotate_with_left(k) end subroutine double_rotate_with_left - - + + subroutine double_rotate_with_right(k) type (integer_dict), pointer :: k call single_rotate_with_left(k% right) call single_rotate_with_right(k) end subroutine double_rotate_with_right - + end subroutine insert_node - - + + subroutine do_integer_dict_define(dict, key, value, duplicate, ierr) type (integer_dict), pointer :: dict ! pass null for empty dict character (len=*), intent(in) :: key @@ -313,24 +313,24 @@ subroutine do_integer_dict_define(dict, key, value, duplicate, ierr) write(*,*) 'done insert ' // trim(key) end if end subroutine do_integer_dict_define - - + + subroutine do_integer_dict_create_hash(dict, ierr) type (integer_dict), pointer :: dict integer, intent(out) :: ierr - + integer :: cnt, hash_size, i, collisions type (hash_entry), pointer :: hash(:) - + ierr = 0 if (.not. associated(dict)) then ierr = -1; return end if if (associated(dict% hash)) return - + !$omp critical (create_hash) if (.not. associated(dict% hash)) then - cnt = size_integer_dict(dict) ! number of entries + cnt = size_integer_dict(dict) ! number of entries if (cnt > 0) then hash_size = 4*cnt allocate(dict% hash(hash_size), stat=ierr) @@ -347,10 +347,10 @@ subroutine do_integer_dict_create_hash(dict, ierr) end if end if !$omp end critical (create_hash) - + end subroutine do_integer_dict_create_hash - + recursive subroutine check_dict(dict, ierr) type (integer_dict), pointer :: dict integer, intent(out) :: ierr @@ -387,8 +387,8 @@ recursive subroutine check_dict(dict, ierr) ierr = -1 end if end subroutine check_dict - - + + subroutine do_integer_dict_lookup(dict, key, value, ierr) type (integer_dict), pointer :: dict character (len=*), intent(in) :: key @@ -411,10 +411,10 @@ subroutine do_integer_dict_lookup(dict, key, value, ierr) value = node% value return end if - ierr = -1 + ierr = -1 end subroutine do_integer_dict_lookup - - + + recursive subroutine do_integer_dict_free(dict) type (integer_dict), pointer :: dict type (integer_dict), pointer :: node, next @@ -433,8 +433,8 @@ recursive subroutine do_integer_dict_free(dict) node => next end do end subroutine do_integer_dict_free - - + + recursive function size_integer_dict(dict) result(cnt) type (integer_dict), pointer :: dict type (integer_dict), pointer :: node, next @@ -450,8 +450,8 @@ recursive function size_integer_dict(dict) result(cnt) node => next end do end function size_integer_dict - - + + recursive subroutine do_enter_hash(dict, hash, hash_size, collisions) type (integer_dict), pointer :: dict type (hash_entry), pointer :: hash(:) @@ -478,7 +478,7 @@ recursive subroutine do_enter_hash(dict, hash, hash_size, collisions) end do if (.not. okay) then write(*,*) 'failed in do_enter_hash' - error stop 1 + error stop 1 end if if (associated(node% left)) & call do_enter_hash(node% left, hash, hash_size, collisions) @@ -487,8 +487,8 @@ recursive subroutine do_enter_hash(dict, hash, hash_size, collisions) node => next end do end subroutine do_enter_hash - - + + integer function dict_hashkey(key, hash_size) ! value between 1 and hash_size character (len=*) :: key integer, intent(in) :: hash_size diff --git a/utils/private/utils_idict.f90 b/utils/private/utils_idict.f90 index 7a9d14b5a..7da689d50 100644 --- a/utils/private/utils_idict.f90 +++ b/utils/private/utils_idict.f90 @@ -25,12 +25,12 @@ module utils_idict use utils_def - - implicit none + + implicit none contains - - + + recursive subroutine do_integer_idict_map(idict, fcn, ierr) type (integer_idict), pointer :: idict interface @@ -50,25 +50,25 @@ end subroutine fcn if (ierr /= 0) return end if call fcn(node% key1, node% key2, node% value, ierr) - if (ierr /= 0) return + if (ierr /= 0) return if (.not. associated(node% right)) return node => node% right end do end subroutine do_integer_idict_map - - + + subroutine do_get_idict_entries(idict, key1s, key2s, values) type (integer_idict), pointer :: idict integer, pointer, dimension(:) :: key1s, key2s, values - + integer :: cnt, ierr, sz sz = size_integer_idict(idict) sz = min(sz, size(key1s,dim=1), size(key2s,dim=1), size(values,dim=1)) cnt = 0 call do_integer_idict_map(idict, fcn, ierr) - + contains - + subroutine fcn(key1, key2, value, ierr) integer, intent(in) :: key1, key2, value integer, intent(out) :: ierr ! /= 0 means terminate map calls @@ -81,10 +81,10 @@ subroutine fcn(key1, key2, value, ierr) key2s(cnt) = key2 values(cnt) = value end subroutine fcn - + end subroutine do_get_idict_entries - - + + recursive subroutine show_key1_key2_entries(idict) type (integer_idict), pointer :: idict type (integer_idict), pointer :: node @@ -99,8 +99,8 @@ recursive subroutine show_key1_key2_entries(idict) node => node% right end do end subroutine show_key1_key2_entries - - + + subroutine find_key1_key2_entry(idict, key1, key2, node) type (integer_idict), pointer :: idict integer, intent(in) :: key1, key2 @@ -142,18 +142,18 @@ subroutine find_key1_key2_entry(idict, key1, key2, node) end if node => node% right end if - end do + end do end subroutine find_key1_key2_entry - - + + recursive subroutine insert_node(node, root, duplicate) type (integer_idict), pointer :: node ! will be deallocated if a duplicate type (integer_idict), pointer :: root logical :: duplicate ! true if key was already defined - + integer :: height_left, height_right logical, parameter :: dbg = .false. - + if (node% key1 == root% key1 .and. node% key2 == root% key2) then root% value = node% value deallocate(node) @@ -161,7 +161,7 @@ recursive subroutine insert_node(node, root, duplicate) duplicate = .true. return end if - + if (node% key1 > root% key1 .or. & (node% key1 == root% key1 .and. & node% key2 > root% key2)) then ! insert on left @@ -199,15 +199,15 @@ recursive subroutine insert_node(node, root, duplicate) end if end if end if - + height_right = height_of_right_branch(root) height_left = height_of_left_branch(root) root% height = max(height_right, height_left) + 1 - - + + contains - - + + integer function height_of_left_branch(n) type (integer_idict), pointer :: n if (.not. associated(n% left)) then @@ -216,8 +216,8 @@ integer function height_of_left_branch(n) height_of_left_branch = n% left% height end if end function height_of_left_branch - - + + integer function height_of_right_branch(n) type (integer_idict), pointer :: n if (.not. associated(n% right)) then @@ -226,8 +226,8 @@ integer function height_of_right_branch(n) height_of_right_branch = n% right% height end if end function height_of_right_branch - - + + subroutine single_rotate_with_left(k2) type (integer_idict), pointer :: k2 type (integer_idict), pointer :: k1 @@ -242,8 +242,8 @@ subroutine single_rotate_with_left(k2) k1% height = max(height_of_left_branch(k1), k2% height) + 1 k2 => k1 end subroutine single_rotate_with_left - - + + subroutine single_rotate_with_right(k1) type (integer_idict), pointer :: k1 type (integer_idict), pointer :: k2 @@ -258,25 +258,25 @@ subroutine single_rotate_with_right(k1) k2% height = max(height_of_right_branch(k2), k1% height) + 1 k1 => k2 end subroutine single_rotate_with_right - - + + subroutine double_rotate_with_left(k) type (integer_idict), pointer :: k call single_rotate_with_right(k% left) call single_rotate_with_left(k) end subroutine double_rotate_with_left - - + + subroutine double_rotate_with_right(k) type (integer_idict), pointer :: k call single_rotate_with_left(k% right) call single_rotate_with_right(k) end subroutine double_rotate_with_right - + end subroutine insert_node - - + + subroutine do_integer_idict_define(idict, key1, key2, value, duplicate, ierr) type (integer_idict), pointer :: idict ! pass null for empty idict integer, intent(in) :: key1, key2, value @@ -313,24 +313,24 @@ subroutine do_integer_idict_define(idict, key1, key2, value, duplicate, ierr) write(*,*) 'done insert', key1, key2 end if end subroutine do_integer_idict_define - - + + subroutine do_integer_idict_create_hash(idict, ierr) type (integer_idict), pointer :: idict integer, intent(out) :: ierr - + integer :: cnt, hash_size, i, collisions type (ihash_entry), pointer :: hash(:) - + ierr = 0 if (.not. associated(idict)) then ierr = -1; return end if if (associated(idict% hash)) return - + !$omp critical (create_hash) if (.not. associated(idict% hash)) then - cnt = size_integer_idict(idict) ! number of entries + cnt = size_integer_idict(idict) ! number of entries if (cnt > 0) then hash_size = 4*cnt allocate(idict% hash(hash_size), stat=ierr) @@ -347,10 +347,10 @@ subroutine do_integer_idict_create_hash(idict, ierr) end if end if !$omp end critical (create_hash) - + end subroutine do_integer_idict_create_hash - + recursive subroutine check_idict(idict, ierr) type (integer_idict), pointer :: idict integer, intent(out) :: ierr @@ -391,8 +391,8 @@ recursive subroutine check_idict(idict, ierr) ierr = -1 end if end subroutine check_idict - - + + subroutine do_integer_idict_lookup(idict, key1, key2, value, ierr) type (integer_idict), pointer :: idict integer, intent(in) :: key1, key2 @@ -415,10 +415,10 @@ subroutine do_integer_idict_lookup(idict, key1, key2, value, ierr) value = node% value return end if - ierr = -1 + ierr = -1 end subroutine do_integer_idict_lookup - - + + recursive subroutine do_integer_idict_free(idict) type (integer_idict), pointer :: idict type (integer_idict), pointer :: node, next @@ -436,8 +436,8 @@ recursive subroutine do_integer_idict_free(idict) node => next end do end subroutine do_integer_idict_free - - + + recursive function size_integer_idict(idict) result(cnt) type (integer_idict), pointer :: idict type (integer_idict), pointer :: node, next @@ -453,8 +453,8 @@ recursive function size_integer_idict(idict) result(cnt) node => next end do end function size_integer_idict - - + + recursive subroutine do_enter_hash(idict, hash, hash_size, collisions) type (integer_idict), pointer :: idict type (ihash_entry), pointer :: hash(:) @@ -490,8 +490,8 @@ recursive subroutine do_enter_hash(idict, hash, hash_size, collisions) node => next end do end subroutine do_enter_hash - - + + integer function idict_hashkey(key1, key2, hash_size) ! value between 1 and hash_size integer, intent(in) :: key1, key2, hash_size integer:: new, hash, c diff --git a/utils/private/utils_nan.f90 b/utils/private/utils_nan.f90 index 36a11fd1b..f4c0bc6b1 100644 --- a/utils/private/utils_nan.f90 +++ b/utils/private/utils_nan.f90 @@ -32,7 +32,7 @@ module utils_nan use utils_nan_qp ! No implicit typing - + implicit none ! Access specifiers diff --git a/utils/private/utils_nan_dp.f90 b/utils/private/utils_nan_dp.f90 index 3495667e1..bd70d8b38 100644 --- a/utils/private/utils_nan_dp.f90 +++ b/utils/private/utils_nan_dp.f90 @@ -33,7 +33,7 @@ module utils_nan_dp use ISO_C_BINDING ! No implicit typing - + implicit none ! Parameters @@ -76,7 +76,7 @@ module utils_nan_dp public :: set_nan ! Procedures - + contains elemental function is_nan_dp (x, signal) result (is_nan) @@ -95,7 +95,7 @@ elemental function is_nan_dp (x, signal) result (is_nan) ix = TRANSFER(x, ix) ! Split out IEEE fields - + frac = IBITS(ix, 0, FRAC_BITS_64) expn = IBITS(ix, FRAC_BITS_64, EXPN_BITS_64) sign = IBITS(ix, FRAC_BITS_64+EXPN_BITS_64, 1) @@ -131,7 +131,7 @@ elemental function is_inf_dp (x) result (is_inf) ix = TRANSFER(x, ix) ! Split out IEEE fields - + frac = IBITS(ix, 0, FRAC_BITS_64) expn = IBITS(ix, FRAC_BITS_64, EXPN_BITS_64) sign = IBITS(ix, FRAC_BITS_64+EXPN_BITS_64, 1) @@ -164,7 +164,7 @@ elemental function is_bad_dp (x) result (is_bad) end function is_bad_dp !**** - + subroutine set_nan_dp_0d (x, signal) real(dp), target, intent(out) :: x diff --git a/utils/private/utils_nan_qp.f90 b/utils/private/utils_nan_qp.f90 index 90daf2a9b..9ffeb1428 100644 --- a/utils/private/utils_nan_qp.f90 +++ b/utils/private/utils_nan_qp.f90 @@ -33,7 +33,7 @@ module utils_nan_qp use ISO_C_BINDING ! No implicit typing - + implicit none ! Parameters @@ -79,7 +79,7 @@ module utils_nan_qp public :: set_nan ! Procedures - + contains elemental function is_nan_qp (x, signal) result (is_nan) @@ -99,7 +99,7 @@ elemental function is_nan_qp (x, signal) result (is_nan) ix = TRANSFER(x, ix) ! Split out IEEE fields - + frac_l = IBITS(ix(1), 0, FRAC_BITS_128_L) frac_h = IBITS(ix(2), 0, FRAC_BITS_128_H) expn = IBITS(ix(2), FRAC_BITS_128_H, EXPN_BITS_128_H) @@ -171,7 +171,7 @@ elemental function is_bad_qp (x) result (is_bad) end function is_bad_qp !**** - + subroutine set_nan_qp_0d (x, signal) real(qp), target, intent(out) :: x diff --git a/utils/private/utils_nan_sp.f90 b/utils/private/utils_nan_sp.f90 index c370af308..84c13821a 100644 --- a/utils/private/utils_nan_sp.f90 +++ b/utils/private/utils_nan_sp.f90 @@ -33,7 +33,7 @@ module utils_nan_sp use ISO_C_BINDING ! No implicit typing - + implicit none ! Parameters @@ -76,7 +76,7 @@ module utils_nan_sp public :: set_nan ! Procedures - + contains elemental function is_nan_sp (x, signal) result (is_nan) @@ -95,7 +95,7 @@ elemental function is_nan_sp (x, signal) result (is_nan) ix = TRANSFER(x, ix) ! Split out IEEE fields - + frac = IBITS(ix, 0, FRAC_BITS_32) expn = IBITS(ix, FRAC_BITS_32, EXPN_BITS_32) sign = IBITS(ix, FRAC_BITS_32+EXPN_BITS_32, 1) @@ -131,7 +131,7 @@ elemental function is_inf_sp (x) result (is_inf) ix = TRANSFER(x, ix) ! Split out IEEE fields - + frac = IBITS(ix, 0, FRAC_BITS_32) expn = IBITS(ix, FRAC_BITS_32, EXPN_BITS_32) sign = IBITS(ix, FRAC_BITS_32+EXPN_BITS_32, 1) @@ -164,7 +164,7 @@ elemental function is_bad_sp (x) result (is_bad) end function is_bad_sp !**** - + subroutine set_nan_sp_0d (x, signal) real(sp), target, intent(out) :: x diff --git a/utils/private/utils_openmp.f90 b/utils/private/utils_openmp.f90 index 00cc2b077..04d802e19 100644 --- a/utils/private/utils_openmp.f90 +++ b/utils/private/utils_openmp.f90 @@ -24,34 +24,34 @@ ! *********************************************************************** module utils_openmp - + implicit none - + integer :: omp_max_threads = -1 contains - + integer function eval_OMP_GET_THREAD_NUM() use omp_lib, only: OMP_GET_THREAD_NUM eval_OMP_GET_THREAD_NUM = OMP_GET_THREAD_NUM() end function eval_OMP_GET_THREAD_NUM - + integer function eval_OMP_GET_MAX_THREADS() use omp_lib, only: OMP_GET_MAX_THREADS if (omp_max_threads < 0) & omp_max_threads = OMP_GET_MAX_THREADS() eval_OMP_GET_MAX_THREADS = omp_max_threads end function eval_OMP_GET_MAX_THREADS - + subroutine eval_OMP_SET_NUM_THREADS(threads) use omp_lib, only: OMP_SET_NUM_THREADS integer, intent(in) :: threads call OMP_SET_NUM_THREADS(threads) - end subroutine eval_OMP_SET_NUM_THREADS - - + end subroutine eval_OMP_SET_NUM_THREADS + + end module utils_openmp diff --git a/utils/private/utils_openmp_stub.f90 b/utils/private/utils_openmp_stub.f90 index 82a10abf6..835507fd5 100644 --- a/utils/private/utils_openmp_stub.f90 +++ b/utils/private/utils_openmp_stub.f90 @@ -24,26 +24,26 @@ ! *********************************************************************** module utils_openmp - + implicit none - + contains - - + + integer function eval_OMP_GET_THREAD_NUM() eval_OMP_GET_THREAD_NUM = 0 end function eval_OMP_GET_THREAD_NUM - - + + integer function eval_OMP_GET_MAX_THREADS() eval_OMP_GET_MAX_THREADS = 1 end function eval_OMP_GET_MAX_THREADS - + subroutine eval_OMP_SET_NUM_THREADS(threads) integer, intent(in) :: threads - end subroutine eval_OMP_SET_NUM_THREADS - + end subroutine eval_OMP_SET_NUM_THREADS + end module utils_openmp diff --git a/utils/private/utils_system.f90 b/utils/private/utils_system.f90 index b7e070811..ae66bbfd5 100644 --- a/utils/private/utils_system.f90 +++ b/utils/private/utils_system.f90 @@ -26,19 +26,19 @@ module utils_system implicit none - interface + interface function f_mkdir_p(folder) bind(C,name='c_mkdir_p') use, intrinsic :: ISO_C_BINDING, only: C_CHAR, C_INT integer(C_INT) :: f_mkdir_p character(kind=C_CHAR) :: folder(*) end function f_mkdir_p - + function f_mv(src, dest) bind(C,name='c_mv') use, intrinsic :: ISO_C_BINDING, only: C_CHAR, C_INT integer(C_INT) :: f_mv character(kind=C_CHAR) :: src(*), dest(*) end function f_mv - + function f_cp(src, dest) bind(C,name='c_cp') use, intrinsic :: ISO_C_BINDING, only: C_CHAR, C_INT integer(C_INT) :: f_cp @@ -53,51 +53,51 @@ end function f_is_dir end interface - private + private public :: mkdir_p, mv, cp, is_dir contains - - - ! Converts a fortran string to a NULL terminated string + + + ! Converts a fortran string to a NULL terminated string pure function f_c_string (f_str) result (c_str) use, intrinsic :: ISO_C_BINDING, only: C_CHAR, C_NULL_CHAR character(len=*), intent(in) :: f_str character(len=1,kind=C_CHAR) :: c_str(len_trim(f_str)+1) integer :: n, i - + n = len_trim(f_str) do i = 1, n c_str(i) = f_str(i:i) end do c_str(n + 1) = C_NULL_CHAR - - end function f_c_string - + + end function f_c_string + ! Makes a directory, potentially making any needed parent directories integer function mkdir_p(folder) character(len=*), intent(in) :: folder mkdir_p = f_mkdir_p(f_c_string(folder)) - + end function mkdir_p - + ! Moves src to dest, if dest is on a different filesystem, do a cp ! to the same filesystem then mv to dest integer function mv(src,dest) character(len=*), intent(in) :: src, dest - + mv = f_mv(f_c_string(src),f_c_string(dest)) - + end function mv - + ! Copies src to dest integer function cp(src,dest) character(len=*), intent(in) :: src, dest - + cp = f_cp(f_c_string(src),f_c_string(dest)) - + end function cp ! Checks if folder exists or not @@ -119,10 +119,10 @@ end module utils_system ! implicit none ! integer :: num, res ! character(len=256) :: f1, f2 - + ! num = command_argument_count() ! call get_command_argument(1,f1) - + ! if(num==1) then ! write(*,*) "Test mkdir_p ",trim(f1) ! res = mkdir_p(f1) @@ -133,7 +133,7 @@ end module utils_system ! write(*,*) "Test cp ",trim(f1)," * ",trim(f2) ! res = cp(f1,f2) ! end if - + ! write(*,*) "Result: ", res !end program sys diff --git a/utils/public/utils_def.f90 b/utils/public/utils_def.f90 index 49e426fc9..08a4995e4 100644 --- a/utils/public/utils_def.f90 +++ b/utils/public/utils_def.f90 @@ -25,20 +25,20 @@ module utils_def implicit none - + integer, parameter :: min_io_unit = 29 integer, parameter :: max_io_unit = 99 - - + + integer, parameter :: eof_token = 1 integer, parameter :: string_token = 2 integer, parameter :: name_token = 3 integer, parameter :: left_paren_token = 4 integer, parameter :: right_paren_token = 5 integer, parameter :: comma_token = 6 - + integer, parameter :: maxlen_key_string = 50 - + ! see http://en.wikipedia.org/wiki/AVL_tree type integer_dict character (len=maxlen_key_string) :: key @@ -52,8 +52,8 @@ module utils_def type hash_entry type (integer_dict), pointer :: ptr end type hash_entry - - + + type integer_idict integer :: key1, key2, value integer :: height @@ -65,10 +65,10 @@ module utils_def type ihash_entry type (integer_idict), pointer :: ptr end type ihash_entry - - - - - + + + + + end module utils_def diff --git a/utils/public/utils_lib.f90 b/utils/public/utils_lib.f90 index acdff16d6..b3b87bab4 100644 --- a/utils/public/utils_lib.f90 +++ b/utils/public/utils_lib.f90 @@ -26,7 +26,7 @@ module utils_lib ! Uses - + use utils_def, only: max_io_unit use const_def, only: dp, qp, strlen @@ -181,7 +181,7 @@ subroutine realloc_double(ptr,new_size,ierr) end subroutine realloc_double !**** - + subroutine realloc_double2(ptr,new_size1,new_size2,ierr) real(dp), pointer :: ptr(:,:) integer, intent(in) :: new_size1,new_size2 @@ -209,7 +209,7 @@ subroutine realloc_double2(ptr,new_size1,new_size2,ierr) end subroutine realloc_double2 !**** - + subroutine realloc_quad(ptr,new_size,ierr) real(qp), pointer :: ptr(:) integer, intent(in) :: new_size @@ -257,7 +257,7 @@ subroutine realloc_quad2(ptr,new_size1,new_size2,ierr) end subroutine realloc_quad2 !**** - + subroutine realloc_double3(ptr,new_size1,new_size2,new_size3,ierr) real(dp), pointer :: ptr(:,:,:) integer, intent(in) :: new_size1,new_size2,new_size3 @@ -483,7 +483,7 @@ subroutine alloc1(sz,a,ierr) end subroutine alloc1 !**** - + subroutine alloc2(sz1,sz2,a,ierr) real(dp), dimension(:,:), pointer :: a integer, intent(in) :: sz1,sz2 @@ -632,7 +632,7 @@ integer function token(iounit, n, i, buffer, string) read(iounit,fmt='(a)',iostat=info) buffer if (info /= 0) then token = eof_token - return + return end if n = len_trim(buffer) i = 0 @@ -690,11 +690,11 @@ integer function token(iounit, n, i, buffer, string) case default j1 = i; j2 = i name_loop: do - if (i+1 > n) exit - if (buffer(i+1:i+1) == ' ') exit - if (buffer(i+1:i+1) == '(') exit - if (buffer(i+1:i+1) == ')') exit - if (buffer(i+1:i+1) == ',') exit + if (i+1 > n) exit name_loop + if (buffer(i+1:i+1) == ' ') exit name_loop + if (buffer(i+1:i+1) == '(') exit name_loop + if (buffer(i+1:i+1) == ')') exit name_loop + if (buffer(i+1:i+1) == ',') exit name_loop i = i+1 j2 = i end do name_loop @@ -880,7 +880,7 @@ subroutine get_idict_entries(idict, key1s, key2s, values) end subroutine get_idict_entries !**** - + subroutine integer_idict_free(idict) use utils_idict type (integer_idict), pointer :: idict @@ -919,25 +919,25 @@ subroutine mkdir(folder) use utils_system, only : mkdir_p character(len=*), intent(in) :: folder integer :: res - + res = mkdir_p(folder) - + if(res/=0)then write(*,*) "mkdir failed for ",trim(folder) write(*,*) "error code ",res call mesa_error(__FILE__,__LINE__) end if - + end subroutine mkdir - + subroutine mv(file_in,file_out,skip_errors) use utils_system, only: mv_c => mv character(len=*),intent(in) :: file_in,file_out logical, optional, intent(in) :: skip_errors integer res - + res = mv_c(file_in,file_out) - + if(res/=0)then if (present(skip_errors))then if (skip_errors) then @@ -949,25 +949,25 @@ subroutine mv(file_in,file_out,skip_errors) call error() end if end if - - contains - + + contains + subroutine error() write(*,*) "mv failed for '"//trim(file_in)//"' '"//trim(file_out)//"'" write(*,*) "Error code: ",res call mesa_error(__FILE__,__LINE__) end subroutine error - + end subroutine mv - + subroutine cp_file(file_in,file_out,skip_errors) use utils_system, only: cp_c => cp character(len=*),intent(in) :: file_in,file_out logical, optional, intent(in) :: skip_errors integer res - + res = cp_c(file_in,file_out) - + if(res/=0)then if (present(skip_errors))then if (skip_errors) then @@ -979,15 +979,15 @@ subroutine cp_file(file_in,file_out,skip_errors) call error() end if end if - - contains - + + contains + subroutine error() write(*,*) "cp failed for '"//trim(file_in)//"' '"//trim(file_out)//"'" write(*,*) "Error code: ",res call mesa_error(__FILE__,__LINE__) end subroutine error - + end subroutine cp_file logical function folder_exists(folder) @@ -1159,17 +1159,17 @@ character(len=strlen) function switch_str(str1,str2,flag) character(len=*), intent(in) :: str1,str2 logical, intent(in) :: flag logical, parameter :: dbg=.false. - + if(flag) then switch_str=str1(1:min(len_trim(str1),strlen)) - if(len_trim(str1) > strlen .and. dbg) & + if(len_trim(str1) > strlen .and. dbg) & write(*,*) "Warning ",trim(str1), "truncated to ",switch_str else switch_str=str2(1:min(len_trim(str2),strlen)) if(len_trim(str2) > strlen .and. dbg) & write(*,*) "Warning ",trim(str2), "truncated to ",switch_str end if - + end function switch_str subroutine split_line(line, num, out) @@ -1208,55 +1208,55 @@ subroutine split_line(line, num, out) end subroutine split_line - + ! backward compatibility so Bill can debug older versions of files without changing these calls logical function is_bad_num(x) real(dp), intent(in) :: x is_bad_num = is_bad(x) end function is_bad_num - - + + logical function is_bad_real(x) real, intent(in) :: x is_bad_real = is_bad(x) end function is_bad_real - - + + logical function is_bad_quad(x) real(qp), intent(in) :: x is_bad_quad = is_bad(x) end function is_bad_quad - + subroutine fill_with_NaNs(ptr) real(dp) :: ptr(:) call set_nan(ptr) end subroutine fill_with_NaNs - - + + subroutine fill_with_NaNs_2D(ptr) real(dp) :: ptr(:,:) call set_nan(ptr) end subroutine fill_with_NaNs_2D - - + + subroutine fill_with_NaNs_3D(ptr) real(dp) :: ptr(:,:,:) call set_nan(ptr) end subroutine fill_with_NaNs_3D - - + + subroutine fill_with_NaNs_4D(ptr) real(dp) :: ptr(:,:,:,:) call set_nan(ptr) end subroutine fill_with_NaNs_4D - + subroutine set_to_NaN(x) real(dp) :: x real(dp) :: xa(1) call set_nan(xa) x = xa(1) end subroutine set_to_NaN - + end module utils_lib diff --git a/utils/test/src/test_utils.f90 b/utils/test/src/test_utils.f90 index 9f01d3c5b..27da76169 100644 --- a/utils/test/src/test_utils.f90 +++ b/utils/test/src/test_utils.f90 @@ -1,33 +1,33 @@ program test_utils - + use utils_def use utils_lib use const_def, only: dp - + implicit none - + call test_dict - + call test_idict - + call test_token_read - + contains - - + + subroutine test_dict type (integer_dict), pointer :: dict - + integer :: value, ierr logical :: duplicate write(*,'(A)') write(*,*) 'test_dict' - + nullify(dict) - + call integer_dict_define_and_report_duplicates(dict, 'c', 3, duplicate, ierr) if (ierr /= 0 .or. duplicate) call mesa_error(__FILE__,__LINE__) call integer_dict_define_and_report_duplicates(dict, 'a', 1, duplicate, ierr) @@ -43,53 +43,53 @@ subroutine test_dict if (ierr /= 0 .or. .not. duplicate) call mesa_error(__FILE__,__LINE__) call integer_dict_define_and_report_duplicates(dict, 'c', 3, duplicate, ierr) if (ierr /= 0 .or. .not. duplicate) call mesa_error(__FILE__,__LINE__) - + call integer_dict_create_hash(dict, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call integer_dict_lookup(dict, 'b', value, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) if (value /= 2) call mesa_error(__FILE__,__LINE__) - + call integer_dict_lookup(dict, 'a', value, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) if (value /= 1) call mesa_error(__FILE__,__LINE__) - + call integer_dict_lookup(dict, 'd', value, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) if (value /= 4) call mesa_error(__FILE__,__LINE__) - + call integer_dict_lookup(dict, 'bogus', value, ierr) if (ierr == 0) call mesa_error(__FILE__,__LINE__) ierr = 0 - + call integer_dict_free(dict) - + write(*,*) 'okay' write(*,'(A)') - - + + end subroutine test_dict - - + + subroutine test_idict type (integer_idict), pointer :: idict - + integer :: value, ierr logical :: duplicate write(*,'(A)') write(*,*) 'test_idict' - + nullify(idict) - + call integer_idict_define_and_report_duplicates(idict, 196, 48, 3, duplicate, ierr) if (ierr /= 0 .or. duplicate) call mesa_error(__FILE__,__LINE__) call integer_idict_define_and_report_duplicates(idict, 1547, 974, 1, duplicate, ierr) if (ierr /= 0 .or. duplicate) call mesa_error(__FILE__,__LINE__) call integer_idict_define_and_report_duplicates(idict, 592, 8, 4, duplicate, ierr) if (ierr /= 0 .or. duplicate) call mesa_error(__FILE__,__LINE__) - call integer_idict_define_and_report_duplicates(idict, -51, 885, 0, duplicate, ierr) + call integer_idict_define_and_report_duplicates(idict, -51, 885, 0, duplicate, ierr) if (ierr /= 0 .or. duplicate) call mesa_error(__FILE__,__LINE__) ! redefine some call integer_idict_define_and_report_duplicates(idict, -51, 885, 2, duplicate, ierr) @@ -98,35 +98,35 @@ subroutine test_idict if (ierr /= 0 .or. .not. duplicate) call mesa_error(__FILE__,__LINE__) call integer_idict_define_and_report_duplicates(idict, 196, 48, 3, duplicate, ierr) if (ierr /= 0 .or. .not. duplicate) call mesa_error(__FILE__,__LINE__) - + call integer_idict_create_hash(idict, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) - + call integer_idict_lookup(idict, -51, 885, value, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) if (value /= 2) call mesa_error(__FILE__,__LINE__) - + call integer_idict_lookup(idict, 1547, 974, value, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) if (value /= 1) call mesa_error(__FILE__,__LINE__) - + call integer_idict_lookup(idict, 592, 8, value, ierr) if (ierr /= 0) call mesa_error(__FILE__,__LINE__) if (value /= 4) call mesa_error(__FILE__,__LINE__) - + call integer_idict_lookup(idict, 0, 18888888, value, ierr) if (ierr == 0) call mesa_error(__FILE__,__LINE__) ierr = 0 - + call integer_idict_free(idict) - + write(*,*) 'okay' write(*,'(A)') - - + + end subroutine test_idict - - + + subroutine test_token_read integer :: iounit, n, i, t, ierr character (len=256) :: buffer, string, filename @@ -134,7 +134,7 @@ subroutine test_token_read write(*,'(A)') write(*,*) 'test_token_read' write(*,'(A)') - + filename = 'token.txt' ierr = 0 iounit = alloc_iounit(ierr) @@ -143,7 +143,7 @@ subroutine test_token_read if (ierr /= 0) call mesa_error(__FILE__,__LINE__) n = 0 i = 0 - + do t = token(iounit, n, i, buffer, string) select case(t) @@ -162,12 +162,12 @@ subroutine test_token_read exit case default end select - + end do - + close(iounit) call free_iounit(iounit) - + write(*,'(A)') write(*,*) 'done test_token_read' write(*,'(A)')