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 (http://www3.sympatico.ca/n.rieck) (mailto:n.rieck@sympatico.ca)
	! 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									!