OpenVMS Source Code Demos
POPULATION_SIM_1008.BAS
1000 %title "population_sim_xxx.bas" !
%ident "version 100.8" ! <<<---+---
declare string constant k_version = "100.8" , ! <<<---+ &
k_program = "population_sim" !
!==============================================================================================================
! title : population_sim_100.bas
! author : Neil Rieck (https://neilrieck.net) (mailto:n.rieck@bell.net)
! purpose: A population study written for OpenVMS BASIC
! notes : 1) this is an idealized society with no disease, congenital birth defects or accidental deaths
! : 2) everyone makes it to old age and dies in the same year
! : 3) everyone mates in a controlled fashion (no rape or infidelity)
! : 4) selected group(s) mate and give birth all in the same year
! : 5) selected group(s) only mate with themselves
! : 6) this society starts with an even population distribution
! : 7) RESULT 1: if every two people only produce two children, population will remain constant
! : 8) RESULT 2: if every two people only reproduce once, the population will shrink slowly
! : 9) all logic (except teen_fraction) is implemented with integers. I did this to make this sim more
! deterministic.
! history:
! ver who when what
! --- --- ------ ----------------------------------------------------------------------------------------------
! 100 NSR 090722 1. original work
! NSR 090723 2. added a second array to capture tallies for cross-generational analysis
! NSR 090726 3. a few final tweaks and cosmetic changes
! 4. added experimental fraction mode
! NSR 090801 5. introduced some simplifications to help you to understand the operation of this sim (these
! changes will make the code less efficient but more understandable)
! NSR 090803 6. now early teenage matings always happen at age 15 (this will allow me to have teenage
! matings while the first planned mating is delayed)
! 7. added support for fractional planned reproduction
! NSR 100402 8. max age was increased from 100,000 to 20 million (so we can model the world)
! changed LONG integers to XFLOAT
! changed DOUUBLE floats to XFLOAT
!==============================================================================================================
OPTION type = explicit , ! no kid stuff &
constant type = decimal , ! &
size = (decimal(20,6), integer long ) !
!
set no prompt !
!
declare long constant k_teenage_mating_year = 15 !
!
! variable declarations
!
declare long x
declare decimal(20,0) ! &
max_age , ! maximum age &
repro_age , ! repro age &
repro_num , ! repro num &
repro_gap , ! repro gap &
age_group , ! age group &
age_group_size , ! "initial" age group size &
max_year , ! maximum years &
year , ! year counter &
total , ! &
limit , ! &
mating , ! &
calc , ! &
string dump$ , ! &
junk$ , ! &
decimal(20,6) float1 , ! &
float2 , ! &
float_temp , ! &
teen_fraction , ! &
planned_fraction !
!====================================================================================================
! main
!====================================================================================================
2000 main:
on error goto common_trap
!
print "======================================================================="
print k_program +"_"+ k_version !
print "======================================================================="
print "Note: Decimal input is only allowed on two inputs." !
print " All others require integers" !
print " Most inputs default to the higher numerical value" !
!
! prompt for maximum age
!
input "maximum age (years) ? (eg 75) ";junk$ !
when error in !
max_age = integer(junk$) !
use !
end when !
select max_age !
case 0 !
max_age = 75 ! set default
case < 25 !
max_age = 25 !
print "Note: 'maximum age' was increased to 25" !
case > 99 !
max_age = 99 !
print "Note: 'maximum age' was decreased to 99" !
end select !
!
! prompt for age group size
!
input "age group size ? (eg 13157895) ";junk$ !
when error in !
age_group_size = integer(junk$) !
use !
end when !
select age_group_size !
case 0 !
age_group_size = 13157895 ! set default
case < 100 !
age_group_size = 100 !
print "Note: 'age group size' was increased to "+ str$(age_group_size)
case > 20000000 ! 20 million
age_group_size = 20000000 !
print "Note: 'age group size' was decreased to "+ str$(age_group_size)
end select !
!
! prompt for "reproduction events"
!
input "planned reproduction events ? (eg 1) ";junk$ !
when error in !
repro_num = integer(junk$) !
use !
repro_num = 0 !
end when !
select repro_num !
case 0 !
repro_num = 1 ! set default
case < 0 !
repro_num = 0 !
print "Note: 'reproduction number' was increased to 0" !
case > 10 !
repro_num = 10 !
print "Note: 'reproduction number' was decreased to 10" !
end select !
!
! prompt for "reproduction fraction"
!
input "planned reproduction fraction? (eg 0.1 - 1.0) ";junk$ !
when error in !
planned_fraction = decimal(junk$) !
use !
planned_fraction = 0 !
end when !
select planned_fraction !
case 0 !
planned_fraction = 1.0 ! set default
case < 0.1 !
planned_fraction = 0.1 !
print "Note: 'planned reproduction fraction' was increased to "+ str$(planned_fraction)
case > 1.0 !
planned_fraction = 1.0 !
print "Note: 'planned reproduction fraction' was decreased to "+ str$(planned_fraction)
end select !
!
! prompt for "reproduction age"
!
if repro_num > 0 then ! if we're going to reproduce
input "reproduction age (years) ? (eg 20) ";repro_age !
limit = max_age -1 !
select repro_age !
case 0 !
repro_age = 20 !
case > limit !
repro_age = limit !
case < 20 !
repro_age = 20 !
print "Note: 'reproduction age' was increased to 20" !
end select !
end if !
!
if repro_num > 1 then ! if more than one reproduction...
input "reproduction gap (years) ? (eg 2) ";repro_gap !
select repro_gap !
case 0 !
repro_gap = 2 !
case > 10 !
repro_gap = 10 !
print "Note: 'reproduction gap' was decreased to 10" !
end select !
end if !
!
if repro_num > 0 then ! if at least one reproduction...
print "Notes:"
print " 1) this next step deals with early teenage reproduction"
print " 2) this calc will be applied to age group "+ str$(k_teenage_mating_year)
print " 3) the default is 0.0 (off)"
input "early teenage mating fraction? (eg 0.0 - 1.0) "; junk$ !
when error in !
teen_fraction = decimal(junk$) !
use !
teen_fraction = 0 !
end when !
select teen_fraction !
case < 0.0 !
teen_fraction = 0.0 !
print "Note: 'early teenage reproduction fraction' was increased to "+ str$(teen_fraction)
case > 1.0 !
teen_fraction = 1.0 !
print "Note: 'early teenage reproduction fraction' was decreased to "+ str$(teen_fraction)
end select !
end if !
!
! make sure we have enough space for x reproductions
!
! given: repro_num 3
! repro_age 20
! repro_gap 1
!
! then: repro-1 20
! repor-2 21
! repor-3 22
!
select repro_num !
case 0 ! no reproductions so no age limit
limit = 0 !
case 1 !
limit = repro_age !
case else !
limit = repro_age + (repro_gap * (repro_num-1)) !
end select !
if max_age <= limit then !
max_age = limit +1 !
print "Note: 'maximum age' was raised to "+str$(max_age) !
end if !
!
! make sure we have enough years to view all events
!
limit = max_age !
print "maximum years to model ? (eg "+ str$(limit)+") "; !
input max_year !
max_year = limit if max_year < limit !
!------------------------------------------------------------------------
! init population
!------------------------------------------------------------------------
3000 print "======================================================================="
print "Initializing population age groups <<<" !
dim decimal(20,0) gen(max_age) ! reserve space for various ages
dim string mode$(max_age) ! reserve space for reproduction modes
dim decimal(20,0) gen_sum(max_year) ! bf_100.2
for age_group = 0 to max_age ! people will have ages 0 to max_age
gen(age_group) = age_group_size ! start with x people in each age group
next age_group !
if repro_num > 0 then ! if one, or more, matings have been selected
for mating = 0 to repro_num-1 !
calc = repro_age + (mating * repro_gap) !
mode$(calc) = "PR" ! flag this year for planned reproduction
next mating !
if teen_fraction > 0.0 then !
calc = k_teenage_mating_year !
mode$(calc) = "TF" ! flag this year for early teenaged reproduction
end if !
end if !
gosub print_total_pop !
gosub dump_population_details !
!------------------------------------------------------------------------
! let time take it's toll as the years ripple past
!------------------------------------------------------------------------
4000 print "running the sim" !
for year = 1 to max_year ! cycle through the years
for age_group = (max_age-1) to 0 step -1 ! people age by one year (last group dies)
gen(age_group+1) = gen(age_group) ! people age one year
next age_group !
gen(0) = 0 ! zap age_group zero (babies)
for age_group = 0 to max_age !
select mode$(age_group) !
case "PR" ! W/hole R/eprodction
calc = repro_age + (mating * repro_gap) !
float_temp = gen(calc) !
float_temp = float_temp * planned_fraction / 2.0 !
gen(0) = gen(0) + float_temp !
case "TF" ! F/ractional R/eprodction
calc = k_teenage_mating_year !
float_temp = gen(calc) !
float_temp = float_temp * teen_fraction / 2.0 !
gen(0) = gen(0) + float_temp !
end select !
next age_group !
gosub print_total_pop !
gosub dump_population_details !
next year !
goto fini !
!------------------------------------------------------------------------
! print total population
!------------------------------------------------------------------------
5000 print_total_pop: !
total = 0 ! init
for age_group = 0 to max_age !
total = total + gen(age_group) !
next age_group !
gen_sum(year) = total ! record the total number of people here
print using "Year: ### Population size: ############"; year; total; !
if year < 1 then !
print !
else !
float2 = gen_sum(year) !
float1 = gen_sum(year-1) !
if float1 >= 0.0 then !
float2 = float2/float1 !
else !
float2 = 0.0 !
end if
print using " growth rate: ##.######", float2 !
end if !
return !
!------------------------------------------------------------------------
! dump population details by age group
!------------------------------------------------------------------------
6000 dump_population_details: !
select dump$ !
case "YA" ! Yes All
goto dump_population_details_start !
case "NA" ! No All
goto dump_population_details_exit !
end select !
!
get_dump_option: !
input "view population details ? (Y/N/YA/NA) ";dump$ !
dump$ = edit$(dump$,32+2) !
select dump$ !
case "" !
dump$ = "Y" !
case "Y","YA" ! Yes, Yes All
case "N","NA" ! No, No All
goto dump_population_details_exit !
case else !
print "bad input" !
goto get_dump_option !
end select !
!
! start dump
!
7000 dump_population_details_start:
print using "Detail Report for Year ###", year; !
if year = 0 then !
print " (after initialize)" !
else !
print " (after running one pass)" !
end if !
for age_group = 0 to max_age !
print using "######## members of age group: ### ";gen(age_group); age_group;
print "repro code: "; mode$(age_group); !
select mode$(age_group) !
case "PR" !
print " ("+ format$(planned_fraction,"#.######") +")" !
case "TF" !
print " ("+ format$(teen_fraction , "#.######") +")" !
case else !
print !
end select !
next age_group !
print "Legend: PR = Planned Reproduction. TR = Teenage Reproduction" !
print "----------------------------------------------------------------------"
!
dump_population_details_exit: !
return !
!------------------------------------------------------------------------
! adios
!------------------------------------------------------------------------
8000 fini: !
print "======================================================================="
Print "The simulation has ended <<<"
print "Results:"
print " starting population : "+ str$( gen_sum(0 ) ) !
print " ending population : "+ str$( gen_sum(year) ) !
float2 = gen_sum(year) !
float1 = gen_sum(0 ) !
if float1 >= 0.0 then !
float2 = float2/float1 !
else !
float2 = 0.0 !
end if !
junk$ = format$(float2, "########.######") !
print " total change : "+ edit$(junk$,2) !
print "Parameters:" !
print " maximum years to model : "+ str$( max_year ) !
print " maximum age : "+ str$( max_age ) !
print " age group size : "+ str$( age_group_size ) !
print " planned reproduction events : "+ str$( repro_num ) !
print " planned reproduction fraction: "+ format$(planned_fraction, "#.######")
print " planned reproduction rate p/p: "; !
junk$ = format$(planned_fraction * repro_num / 2.0, "##.######") !
junk$ = edit$(junk$,2) ! remove white space
print junk$ !
print " reproduction age : "+ str$( repro_age ) !
print " reproduction gap : "+ str$( repro_gap ) !
print " early teenage mating fraction: "+ format$(teen_fraction, "#.######");
if teen_fraction = 0.0 then !
print " (disabled)" !
else !
print !
end if !
goto adios
!------------------------------------------------------------------------
! common error trap
!------------------------------------------------------------------------
common_trap:
print
print "=== common trap ==="
print "error ";str$(err)
print "line ";str$(erl)
print "text ";ert$(err)
resume adios
!------------------------------------------------------------------------
! that's all folks
!------------------------------------------------------------------------
adios:
end !