Skip to content

Commit

Permalink
fortitude part 2, modules outside star
Browse files Browse the repository at this point in the history
  • Loading branch information
@pmocz
pmocz committed Feb 10, 2025
1 parent aa6d30a commit abd39fb
Show file tree
Hide file tree
Showing 176 changed files with 4,346 additions and 4,346 deletions.
48 changes: 24 additions & 24 deletions astero/private/adipls_support.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -35,15 +35,15 @@ module adipls_support

! args for adipls
integer, save :: i_paramset, ierr_param, i_inout, nn
real(dp), save, pointer :: x(:) => null() ! (nn)
real(dp), save, pointer :: aa(:,:) => null() ! (iaa_arg,nn)
real(dp), save, pointer :: x(:) => null() ! (nn)
real(dp), save, pointer :: aa(:,:) => null() ! (iaa_arg,nn)
real(dp), save :: data(8)

integer, parameter :: ivarmd = 6, iaa_arg = 10

integer, save :: iounit_dev_null = -1

integer, save :: nn_redist ! set from redistrb.c input file
integer, save :: nn_redist ! set from redistrb.c input file


real(dp), save, pointer :: x_arg(:) => null(), aa_arg(:,:) => null()
Expand Down Expand Up @@ -136,28 +136,28 @@ subroutine do_adipls_get_one_el_info( &

if (.not. associated(l_order)) then
allocate(l_order(num_results))
else if (num_results >= size(l_order,dim=1)) then ! enlarge
else if (num_results >= size(l_order,dim=1)) then ! enlarge
call realloc_integer(l_order,num_results,ierr)
if (ierr /= 0) return
end if

if (.not. associated(l_em)) then
allocate(l_em(num_results))
else if (num_results >= size(l_em,dim=1)) then ! enlarge
else if (num_results >= size(l_em,dim=1)) then ! enlarge
call realloc_integer(l_em,num_results,ierr)
if (ierr /= 0) return
end if

if (.not. associated(l_freq)) then
allocate(l_freq(num_results))
else if (num_results >= size(l_freq,dim=1)) then ! enlarge
else if (num_results >= size(l_freq,dim=1)) then ! enlarge
call realloc_double(l_freq,num_results,ierr)
if (ierr /= 0) return
end if

if (.not. associated(l_inertia)) then
allocate(l_inertia(num_results))
else if (num_results >= size(l_inertia,dim=1)) then ! enlarge
else if (num_results >= size(l_inertia,dim=1)) then ! enlarge
call realloc_double(l_inertia,num_results,ierr)
if (ierr /= 0) return
end if
Expand Down Expand Up @@ -237,8 +237,8 @@ subroutine store_model_for_adipls (s, add_atmosphere, do_redistribute_mesh, ierr

integer :: iriche, iturpr
integer :: iconst, ivar, ivers, nn_in
real(dp), allocatable :: global_data(:) ! (iconst)
real(dp), allocatable :: point_data(:,:) ! (ivar,nn_in)
real(dp), allocatable :: global_data(:) ! (iconst)
real(dp), allocatable :: point_data(:,:) ! (ivar,nn_in)
character (len=2000) :: format_string, num_string, filename

ierr = 0
Expand Down Expand Up @@ -285,7 +285,7 @@ subroutine store_model_for_adipls (s, add_atmosphere, do_redistribute_mesh, ierr
ivar = SIZE(point_data, 1)
nn_in = SIZE(point_data, 2)

ivers = 0 ! It's not clear what this does in fgong_amdl
ivers = 0 ! It's not clear what this does in fgong_amdl

call fgong_amdl(cgrav, nn_in, iconst, ivar, ivers, global_data, point_data, data, aa, nn, ierr)
deallocate(global_data, point_data)
Expand Down Expand Up @@ -319,7 +319,7 @@ subroutine redist_amdl(ierr)
include 'formats'
ierr = 0
if (.not. do_redistribute_mesh) return
nn_new = nn_redist ! srdist uses nn from input file
nn_new = nn_redist ! srdist uses nn from input file
allocate(aa_new(iaa_arg,nn_new), x_new(nn_new))
ierr_param = 0
!write(*,2) 'call srdist: nn_redist', nn_new
Expand Down Expand Up @@ -668,10 +668,10 @@ subroutine read_and_store(iriche, iturpr, cgrav)
real(dp), intent(in) :: cgrav
character (len=64) :: fname
integer :: nn, nn_in, iconst, ivar, ivers, ierr
real(dp), pointer :: glob(:) ! (iconst) will be allocated
real(dp), pointer :: var(:,:) ! (ivar,nn_in) will be allocated
real(dp), pointer :: aa(:,:) ! (iaa_arg,nn) will be allocated
real(dp), pointer :: x(:) ! (nn) will be allocated
real(dp), pointer :: glob(:) ! (iconst) will be allocated
real(dp), pointer :: var(:,:) ! (ivar,nn_in) will be allocated
real(dp), pointer :: aa(:,:) ! (iaa_arg,nn) will be allocated
real(dp), pointer :: x(:) ! (nn) will be allocated
real(dp) :: data(8)

ierr = 0
Expand Down Expand Up @@ -702,7 +702,7 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr)
integer, intent(inout) :: iturpr
real(dp), intent(in) :: data(8)
real(dp), pointer :: aa(:,:)
real(dp), pointer :: x(:) ! (nn) will be allocated
real(dp), pointer :: x(:) ! (nn) will be allocated
! nn can be less than nn_in
integer, intent(out) :: nn, ierr

Expand Down Expand Up @@ -817,10 +817,10 @@ subroutine fgong_amdl(cgrav, nn_in, iconst, ivar, ivers, glob, var, data, aa, nn
! derived from fgong-amdl.d.f
real(dp), intent(in) :: cgrav
integer, intent(in) :: nn_in, iconst, ivar, ivers
real(dp), intent(inout) :: glob(:) ! (iconst)
real(dp), intent(inout) :: var(:,:) ! (ivar,nn_in)
real(dp), intent(inout) :: glob(:) ! (iconst)
real(dp), intent(inout) :: var(:,:) ! (ivar,nn_in)
real(dp), intent(inout) :: data(8)
real(dp), pointer :: aa(:,:) ! (iaa_arg,nn) will be allocated
real(dp), pointer :: aa(:,:) ! (iaa_arg,nn) will be allocated
integer, intent(out) :: nn, ierr

integer, parameter :: ireset(16) = &
Expand Down Expand Up @@ -922,8 +922,8 @@ end subroutine fgong_amdl
subroutine read_fgong_file(fin, nn, iconst, ivar, ivers, glob, var, ierr)
character (len=*), intent(in) :: fin
integer, intent(out) :: nn, iconst, ivar, ivers
real(dp), pointer :: glob(:) ! (iconst) will be allocated
real(dp), pointer :: var(:,:) ! (ivar,nn) will be allocated
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
Expand Down Expand Up @@ -986,8 +986,8 @@ end subroutine read_fgong_file
subroutine dump(filename_for_dump,nn,glob,var,ierr)
character (len=*), intent(in) :: filename_for_dump
integer, intent(in) :: nn
real(dp), pointer :: glob(:) ! (iconst)
real(dp), pointer :: var(:,:) ! (ivar,nn)
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
Expand All @@ -1010,7 +1010,7 @@ subroutine dump(filename_for_dump,nn,glob,var,ierr)

write(*,*) 'dump fgong data to ' // trim(filename_for_dump)

if (VAR(1,1) <= 1) then ! skip tny r
if (VAR(1,1) <= 1) then ! skip tny r
offset = 1
else
offset = 0
Expand Down
2 changes: 1 addition & 1 deletion astero/private/adipls_support_procs.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,7 +46,7 @@ subroutine spcout_adi(x,y,aa,data,nn,iy,iaa,ispcpr)
common/csumma/ csummm

integer :: icobs_st, nobs_st
real(dp) :: obs_st(10,100000) ! huge 2nd dimension to satisfy bounds checking
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
Expand Down
36 changes: 18 additions & 18 deletions astero/private/adipls_support_stub.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -34,15 +34,15 @@ module adipls_support

! args for adipls
integer :: i_paramset, ierr_param, i_inout, nn
real(dp), pointer :: x(:) ! (nn)
real(dp), pointer :: aa(:,:) ! (iaa_arg,nn)
real(dp), pointer :: x(:) ! (nn)
real(dp), pointer :: aa(:,:) ! (iaa_arg,nn)
real(dp) :: data(8)

integer, parameter :: ivarmd = 6, iaa_arg = 10

integer :: iounit_dev_null = -1

integer :: nn_redist ! set from redistrb.c input file
integer :: nn_redist ! set from redistrb.c input file


real(dp), pointer :: x_arg(:), aa_arg(:,:)
Expand Down Expand Up @@ -115,8 +115,8 @@ subroutine store_model_for_adipls (s, add_atmosphere, do_redistribute_mesh, ierr

integer :: i, iriche, iturpr
integer :: iconst, ivar, ivers
real(dp), allocatable :: global_data(:) ! (iconst)
real(dp), allocatable :: point_data(:,:) ! (ivar,nn)
real(dp), allocatable :: global_data(:) ! (iconst)
real(dp), allocatable :: point_data(:,:) ! (ivar,nn)
character (len=2000) :: format_string, num_string, filename

ierr = -1
Expand Down Expand Up @@ -185,10 +185,10 @@ subroutine read_and_store(iriche, iturpr, cgrav)
real(dp), intent(in) :: cgrav
character (len=64) :: fname
integer :: nn, iconst, ivar, ivers, ierr
real(dp), pointer :: glob(:) ! (iconst) will be allocated
real(dp), pointer :: var(:,:) ! (ivar,nn) will be allocated
real(dp), pointer :: aa(:,:) ! (iaa_arg,nn) will be allocated
real(dp), pointer :: x(:) ! (nn) will be allocated
real(dp), pointer :: glob(:) ! (iconst) will be allocated
real(dp), pointer :: var(:,:) ! (ivar,nn) will be allocated
real(dp), pointer :: aa(:,:) ! (iaa_arg,nn) will be allocated
real(dp), pointer :: x(:) ! (nn) will be allocated
real(dp) :: data(8)


Expand All @@ -201,7 +201,7 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr)
integer, intent(inout) :: iturpr
real(dp), intent(in) :: data(8)
real(dp), pointer :: aa(:,:)
real(dp), pointer :: x(:) ! (nn) will be allocated
real(dp), pointer :: x(:) ! (nn) will be allocated
! nn can be less than nn_in
integer, intent(out) :: nn, ierr

Expand All @@ -221,10 +221,10 @@ subroutine fgong_amdl( &
! derived from fgong-amdl.d.f
real(dp), intent(in) :: cgrav
integer, intent(in) :: nn_in, iconst, ivar, ivers
real(dp), intent(inout) :: glob(:) ! (iconst)
real(dp), intent(inout) :: var(:,:) ! (ivar,nn_in)
real(dp), intent(inout) :: glob(:) ! (iconst)
real(dp), intent(inout) :: var(:,:) ! (ivar,nn_in)
real(dp), intent(inout) :: data(8)
real(dp), pointer :: aa(:,:) ! (iaa_arg,nn) will be allocated
real(dp), pointer :: aa(:,:) ! (iaa_arg,nn) will be allocated
integer, intent(out) :: nn, ierr

integer, parameter :: ireset(16) = &
Expand All @@ -240,11 +240,11 @@ end subroutine fgong_amdl
subroutine read_fgong_file(fin, nn, iconst, ivar, ivers, glob, var, ierr)
character (len=*), intent(in) :: fin
integer, intent(out) :: nn, iconst, ivar, ivers
real(dp), pointer :: glob(:) ! (iconst) will be allocated
real(dp), pointer :: var(:,:) ! (ivar,nn) will be allocated
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)
real(dp), pointer :: var1(:,:) ! (ivar,nn)
integer :: ios, iounit, i, n, ir, nn1
character(80) :: head

Expand All @@ -257,8 +257,8 @@ end subroutine read_fgong_file
subroutine dump(filename_for_dump,nn,glob,var,ierr)
character (len=*), intent(in) :: filename_for_dump
integer, intent(in) :: nn
real(dp), pointer :: glob(:) ! (iconst)
real(dp), pointer :: var(:,:) ! (ivar,nn)
real(dp), pointer :: glob(:) ! (iconst)
real(dp), pointer :: var(:,:) ! (ivar,nn)
integer, intent(out) :: ierr

ierr = -1
Expand Down
26 changes: 13 additions & 13 deletions astero/private/astero_run_support.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -58,7 +58,7 @@ end subroutine extras_controls
include 'formats'

ierr = 0
call do_read_star_job('inlist', ierr) ! this does alloc_star
call do_read_star_job('inlist', ierr) ! this does alloc_star
! and saves the id in id_from_read_star_job
if (ierr /= 0) call mesa_error(__FILE__,__LINE__)

Expand Down Expand Up @@ -235,7 +235,7 @@ real(dp) function eval1(id_in,ierr)
s% astero_using_revised_max_yr_dt = .false.
s% astero_revised_max_yr_dt = s% max_years_for_timestep

okay_to_restart = .false. ! only allow restart on 1st call to run1_star
okay_to_restart = .false. ! only allow restart on 1st call to run1_star

eval1 = best_chi2

Expand Down Expand Up @@ -303,7 +303,7 @@ subroutine do_get_parameters_from_file(s, ierr)
write(*,*) 'reading ' // trim(filename_for_parameters)
write(*,2) 'max_num_from_file', max_num_from_file

read(iounit,*) ! skip 1st line
read(iounit,*) ! skip 1st line

do while (sample_number < max_num_from_file .or. max_num_from_file < 0)

Expand Down Expand Up @@ -608,12 +608,12 @@ subroutine bobyqa_or_newuoa_fun(n,x,f)
call mesa_error(__FILE__,__LINE__,'bobyqa_fun')
end if
if (sample_number == prev_sample_number) then
if (sample_number <= 0) then ! failed on 1st try
if (sample_number <= 0) then ! failed on 1st try
write(*,*) 'failed to find chi^2 on 1st try'
write(*,*) 'must give "first" values that yield a chi^2 result'
call mesa_error(__FILE__,__LINE__)
end if
return ! failed to get new chi^2
return ! failed to get new chi^2
end if

call save_best_for_sample(sample_number, 0)
Expand Down Expand Up @@ -715,10 +715,10 @@ real(dp) function simplex_f( &
n, x, lrpar, rpar, lipar, ipar, op_code, ierr)
use const_def, only: dp
integer, intent(in) :: n
real(dp), intent(in) :: x(:) ! (n)
real(dp), intent(in) :: x(:) ! (n)
integer, intent(in) :: lrpar, lipar
integer, intent(inout), pointer :: ipar(:) ! (lipar)
real(dp), intent(inout), pointer :: rpar(:) ! (lrpar)
integer, intent(inout), pointer :: ipar(:) ! (lipar)
real(dp), intent(inout), pointer :: rpar(:) ! (lrpar)
integer, intent(in) :: op_code
integer, intent(out) :: ierr

Expand Down Expand Up @@ -820,8 +820,8 @@ subroutine do_simplex(ierr)
real(dp), pointer :: simplex(:,:), f(:)
real(dp) :: f_final
integer :: lrpar, lipar
integer, pointer :: ipar(:) ! (lipar)
real(dp), pointer :: rpar(:) ! (lrpar)
integer, pointer :: ipar(:) ! (lipar)
real(dp), pointer :: rpar(:) ! (lrpar)
integer :: num_iters, num_fcn_calls, &
num_fcn_calls_for_ars, num_accepted_for_ars
integer :: i, num_samples
Expand Down Expand Up @@ -852,7 +852,7 @@ subroutine do_simplex(ierr)

if (.not. scale_simplex_params) then
call set_xs
else ! values are scaled to -1..1 with first at 0
else ! values are scaled to -1..1 with first at 0
x_lower(1:nvar) = -1
x_upper(1:nvar) = 1
x_first(1:nvar) = 0
Expand Down Expand Up @@ -904,7 +904,7 @@ subroutine do_simplex(ierr)
contains


subroutine set_xs ! x_first, x_lower, x_upper
subroutine set_xs ! x_first, x_lower, x_upper

do i = 1, max_parameters
if (vary_param(i)) then
Expand Down Expand Up @@ -936,7 +936,7 @@ subroutine setup_simplex_and_f(ierr)
max_i = 0
do j=1,nvar+1
i = index(j)
if (i > max_i) max_i = i ! max sample restored
if (i > max_i) max_i = i ! max sample restored
write(*,3) 'restore simplex', j, i
f(j) = sample_chi2(i)
write(*,3) 'chi2', j, i, f(j)
Expand Down
Loading

0 comments on commit abd39fb

Please sign in to comment.